diff options
| -rw-r--r-- | erebos.cabal | 1 | ||||
| -rw-r--r-- | main/Test.hs | 1 | ||||
| -rw-r--r-- | src/Erebos/Attach.hs | 2 | ||||
| -rw-r--r-- | src/Erebos/Chatroom.hs | 3 | ||||
| -rw-r--r-- | src/Erebos/Contact.hs | 2 | ||||
| -rw-r--r-- | src/Erebos/Conversation.hs | 2 | ||||
| -rw-r--r-- | src/Erebos/Discovery.hs | 3 | ||||
| -rw-r--r-- | src/Erebos/ICE.chs | 4 | ||||
| -rw-r--r-- | src/Erebos/Identity.hs | 2 | ||||
| -rw-r--r-- | src/Erebos/Message.hs | 3 | ||||
| -rw-r--r-- | src/Erebos/Network.hs | 1 | ||||
| -rw-r--r-- | src/Erebos/Network/Channel.hs | 2 | ||||
| -rw-r--r-- | src/Erebos/Network/Protocol.hs | 4 | ||||
| -rw-r--r-- | src/Erebos/Object/Internal.hs | 203 | ||||
| -rw-r--r-- | src/Erebos/Pairing.hs | 3 | ||||
| -rw-r--r-- | src/Erebos/PubKey.hs | 2 | ||||
| -rw-r--r-- | src/Erebos/Service.hs | 3 | ||||
| -rw-r--r-- | src/Erebos/Set.hs | 3 | ||||
| -rw-r--r-- | src/Erebos/State.hs | 4 | ||||
| -rw-r--r-- | src/Erebos/Storable.hs | 2 | ||||
| -rw-r--r-- | src/Erebos/Storage.hs | 6 | ||||
| -rw-r--r-- | src/Erebos/Storage/Head.hs | 348 | ||||
| -rw-r--r-- | src/Erebos/Storage/Internal.hs | 5 | ||||
| -rw-r--r-- | src/Erebos/Storage/Key.hs | 2 | ||||
| -rw-r--r-- | src/Erebos/Storage/Merge.hs | 3 | ||||
| -rw-r--r-- | src/Erebos/Sync.hs | 2 |
26 files changed, 389 insertions, 227 deletions
diff --git a/erebos.cabal b/erebos.cabal index 3f6bb67..c76224d 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -110,6 +110,7 @@ library Erebos.State Erebos.Storable Erebos.Storage + Erebos.Storage.Head Erebos.Storage.Key Erebos.Storage.Merge Erebos.Sync diff --git a/main/Test.hs b/main/Test.hs index 4c23453..9c68165 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -45,6 +45,7 @@ import Erebos.Set import Erebos.State import Erebos.Storable import Erebos.Storage +import Erebos.Storage.Head import Erebos.Storage.Internal (unsafeStoreRawBytes) import Erebos.Storage.Merge import Erebos.Sync diff --git a/src/Erebos/Attach.hs b/src/Erebos/Attach.hs index e0a240e..aac7297 100644 --- a/src/Erebos/Attach.hs +++ b/src/Erebos/Attach.hs @@ -16,11 +16,11 @@ import qualified Data.Text as T import Erebos.Identity import Erebos.Network -import Erebos.Object.Internal import Erebos.Pairing import Erebos.PubKey import Erebos.Service import Erebos.State +import Erebos.Storable import Erebos.Storage.Key type AttachService = PairingService AttachIdentity diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs index 25c8c17..814e1af 100644 --- a/src/Erebos/Chatroom.hs +++ b/src/Erebos/Chatroom.hs @@ -49,11 +49,12 @@ import Data.Text (Text) import Data.Time import Erebos.Identity -import Erebos.Object.Internal import Erebos.PubKey import Erebos.Service import Erebos.Set import Erebos.State +import Erebos.Storable +import Erebos.Storage.Head import Erebos.Storage.Merge import Erebos.Util diff --git a/src/Erebos/Contact.hs b/src/Erebos/Contact.hs index 0af434f..0e92e41 100644 --- a/src/Erebos/Contact.hs +++ b/src/Erebos/Contact.hs @@ -23,12 +23,12 @@ import qualified Data.Text as T import Erebos.Identity import Erebos.Network -import Erebos.Object.Internal import Erebos.Pairing import Erebos.PubKey import Erebos.Service import Erebos.Set import Erebos.State +import Erebos.Storable import Erebos.Storage.Merge data Contact = Contact diff --git a/src/Erebos/Conversation.hs b/src/Erebos/Conversation.hs index 4c68830..68d15ce 100644 --- a/src/Erebos/Conversation.hs +++ b/src/Erebos/Conversation.hs @@ -32,8 +32,8 @@ import Data.Time.LocalTime import Erebos.Chatroom import Erebos.Identity import Erebos.Message hiding (formatMessage) -import Erebos.Object.Internal import Erebos.State +import Erebos.Storable data Message = DirectMessageMessage DirectMessage Bool diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs index d89a7fa..459af71 100644 --- a/src/Erebos/Discovery.hs +++ b/src/Erebos/Discovery.hs @@ -19,8 +19,9 @@ import Network.Socket import Erebos.ICE import Erebos.Identity import Erebos.Network -import Erebos.Object.Internal +import Erebos.Object import Erebos.Service +import Erebos.Storable keepaliveSeconds :: Int diff --git a/src/Erebos/ICE.chs b/src/Erebos/ICE.chs index 787ce51..2d3177d 100644 --- a/src/Erebos/ICE.chs +++ b/src/Erebos/ICE.chs @@ -40,7 +40,9 @@ import Foreign.Ptr import Foreign.StablePtr import Erebos.Flow -import Erebos.Object.Internal +import Erebos.Object +import Erebos.Storable +import Erebos.Storage #include "pjproject.h" diff --git a/src/Erebos/Identity.hs b/src/Erebos/Identity.hs index fdfacfc..e75999d 100644 --- a/src/Erebos/Identity.hs +++ b/src/Erebos/Identity.hs @@ -40,8 +40,8 @@ import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T -import Erebos.Object.Internal import Erebos.PubKey +import Erebos.Storable import Erebos.Storage.Merge import Erebos.Util diff --git a/src/Erebos/Message.hs b/src/Erebos/Message.hs index a558d1a..a81e795 100644 --- a/src/Erebos/Message.hs +++ b/src/Erebos/Message.hs @@ -31,9 +31,10 @@ import Data.Time.LocalTime import Erebos.Identity import Erebos.Network -import Erebos.Object.Internal import Erebos.Service import Erebos.State +import Erebos.Storable +import Erebos.Storage.Head import Erebos.Storage.Merge data DirectMessage = DirectMessage diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs index 9572c40..364597f 100644 --- a/src/Erebos/Network.hs +++ b/src/Erebos/Network.hs @@ -67,6 +67,7 @@ import Erebos.Object.Internal import Erebos.PubKey import Erebos.Service import Erebos.State +import Erebos.Storage import Erebos.Storage.Key import Erebos.Storage.Merge diff --git a/src/Erebos/Network/Channel.hs b/src/Erebos/Network/Channel.hs index a6bab79..17e1a37 100644 --- a/src/Erebos/Network/Channel.hs +++ b/src/Erebos/Network/Channel.hs @@ -26,8 +26,8 @@ import Data.ByteString.Lazy qualified as BL import Data.List import Erebos.Identity -import Erebos.Object.Internal import Erebos.PubKey +import Erebos.Storable data Channel = Channel { chPeers :: [Stored (Signed IdentityData)] diff --git a/src/Erebos/Network/Protocol.hs b/src/Erebos/Network/Protocol.hs index 832be0b..c657759 100644 --- a/src/Erebos/Network/Protocol.hs +++ b/src/Erebos/Network/Protocol.hs @@ -67,8 +67,10 @@ import System.Clock import Erebos.Flow import Erebos.Identity import Erebos.Network.Channel -import Erebos.Object.Internal +import Erebos.Object import Erebos.Service +import Erebos.Storable +import Erebos.Storage protocolVersion :: Text diff --git a/src/Erebos/Object/Internal.hs b/src/Erebos/Object/Internal.hs index 312c3af..03ee83c 100644 --- a/src/Erebos/Object/Internal.hs +++ b/src/Erebos/Object/Internal.hs @@ -16,17 +16,6 @@ module Erebos.Object.Internal ( storeObject, collectObjects, collectStoredObjects, - Head, HeadType(..), - HeadTypeID, mkHeadTypeID, - headId, headStorage, headRef, headObject, headStoredObject, - loadHeads, loadHead, reloadHead, - storeHead, replaceHead, updateHead, updateHead_, - loadHeadRaw, storeHeadRaw, replaceHeadRaw, - - WatchedHead, - watchHead, watchHeadWith, unwatchHead, - watchHeadRaw, - MonadStorage(..), Storable(..), ZeroStorable(..), @@ -84,7 +73,6 @@ import qualified Data.ByteString.Lazy.Char8 as BLC import Data.Char import Data.Function import qualified Data.HashTable.IO as HT -import Data.List import qualified Data.Map as M import Data.Maybe import Data.Ratio @@ -98,13 +86,10 @@ import Data.Time.Calendar import Data.Time.Clock import Data.Time.Format import Data.Time.LocalTime -import Data.Typeable import Data.UUID (UUID) import qualified Data.UUID as U -import qualified Data.UUID.V4 as U import System.Directory -import System.FSNotify import System.FilePath import System.IO.Error import System.IO.Unsafe @@ -404,194 +389,9 @@ collectOtherStored seen (Rec items) = foldr helper ([], seen) $ map snd items collectOtherStored seen _ = ([], seen) -type Head = Head' Complete - -headId :: Head a -> HeadID -headId (Head uuid _) = uuid - -headStorage :: Head a -> Storage -headStorage = refStorage . headRef - -headRef :: Head a -> Ref -headRef (Head _ sx) = storedRef sx - -headObject :: Head a -> a -headObject (Head _ sx) = fromStored sx - -headStoredObject :: Head a -> Stored a -headStoredObject (Head _ sx) = sx - deriving instance StorableUUID HeadID deriving instance StorableUUID HeadTypeID -mkHeadTypeID :: String -> HeadTypeID -mkHeadTypeID = maybe (error "Invalid head type ID") HeadTypeID . U.fromString - -class Storable a => HeadType a where - headTypeID :: proxy a -> HeadTypeID - - -headTypePath :: FilePath -> HeadTypeID -> FilePath -headTypePath spath (HeadTypeID tid) = spath </> "heads" </> U.toString tid - -headPath :: FilePath -> HeadTypeID -> HeadID -> FilePath -headPath spath tid (HeadID hid) = headTypePath spath tid </> U.toString hid - -loadHeads :: forall a m. MonadIO m => HeadType a => Storage -> m [Head a] -loadHeads s@(Storage { stBacking = StorageDir { dirPath = spath }}) = liftIO $ do - let hpath = headTypePath spath $ headTypeID @a Proxy - - files <- filterM (doesFileExist . (hpath </>)) =<< - handleJust (\e -> guard (isDoesNotExistError e)) (const $ return []) - (getDirectoryContents hpath) - fmap catMaybes $ forM files $ \hname -> do - case U.fromString hname of - Just hid -> do - (h:_) <- BC.lines <$> B.readFile (hpath </> hname) - Just ref <- readRef s h - return $ Just $ Head (HeadID hid) $ wrappedLoad ref - Nothing -> return Nothing -loadHeads Storage { stBacking = StorageMemory { memHeads = theads } } = liftIO $ do - let toHead ((tid, hid), ref) | tid == headTypeID @a Proxy = Just $ Head hid $ wrappedLoad ref - | otherwise = Nothing - catMaybes . map toHead <$> readMVar theads - -loadHead :: forall a m. (HeadType a, MonadIO m) => Storage -> HeadID -> m (Maybe (Head a)) -loadHead st hid = fmap (Head hid . wrappedLoad) <$> loadHeadRaw st (headTypeID @a Proxy) hid - -loadHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> HeadID -> m (Maybe Ref) -loadHeadRaw s@(Storage { stBacking = StorageDir { dirPath = spath }}) tid hid = liftIO $ do - handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do - (h:_) <- BC.lines <$> B.readFile (headPath spath tid hid) - Just ref <- readRef s h - return $ Just ref -loadHeadRaw Storage { stBacking = StorageMemory { memHeads = theads } } tid hid = liftIO $ do - lookup (tid, hid) <$> readMVar theads - -reloadHead :: (HeadType a, MonadIO m) => Head a -> m (Maybe (Head a)) -reloadHead (Head hid (Stored (Ref st _) _)) = loadHead st hid - -storeHead :: forall a m. MonadIO m => HeadType a => Storage -> a -> m (Head a) -storeHead st obj = do - let tid = headTypeID @a Proxy - stored <- wrappedStore st obj - hid <- storeHeadRaw st tid (storedRef stored) - return $ Head hid stored - -storeHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> Ref -> m HeadID -storeHeadRaw st tid ref = liftIO $ do - hid <- HeadID <$> U.nextRandom - case stBacking st of - StorageDir { dirPath = spath } -> do - Right () <- writeFileChecked (headPath spath tid hid) Nothing $ - showRef ref `B.append` BC.singleton '\n' - return () - StorageMemory { memHeads = theads } -> do - modifyMVar_ theads $ return . (((tid, hid), ref) :) - return hid - -replaceHead :: forall a m. (HeadType a, MonadIO m) => Head a -> Stored a -> m (Either (Maybe (Head a)) (Head a)) -replaceHead prev@(Head hid pobj) stored' = liftIO $ do - let st = headStorage prev - tid = headTypeID @a Proxy - stored <- copyStored st stored' - bimap (fmap $ Head hid . wrappedLoad) (const $ Head hid stored) <$> - replaceHeadRaw st tid hid (storedRef pobj) (storedRef stored) - -replaceHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> HeadID -> Ref -> Ref -> m (Either (Maybe Ref) Ref) -replaceHeadRaw st tid hid prev new = liftIO $ do - case stBacking st of - StorageDir { dirPath = spath } -> do - let filename = headPath spath tid hid - showRefL r = showRef r `B.append` BC.singleton '\n' - - writeFileChecked filename (Just $ showRefL prev) (showRefL new) >>= \case - Left Nothing -> return $ Left Nothing - Left (Just bs) -> do Just oref <- readRef st $ BC.takeWhile (/='\n') bs - return $ Left $ Just oref - Right () -> return $ Right new - - StorageMemory { memHeads = theads, memWatchers = twatch } -> do - res <- modifyMVar theads $ \hs -> do - ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar twatch - return $ case partition ((==(tid, hid)) . fst) hs of - ([] , _ ) -> (hs, Left Nothing) - ((_, r):_, hs') | r == prev -> (((tid, hid), new) : hs', - Right (new, ws)) - | otherwise -> (hs, Left $ Just r) - case res of - Right (r, ws) -> mapM_ ($ r) ws >> return (Right r) - Left x -> return $ Left x - -updateHead :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a, b)) -> m (Maybe (Head a), b) -updateHead h f = do - (o, x) <- f $ headStoredObject h - replaceHead h o >>= \case - Right h' -> return (Just h', x) - Left Nothing -> return (Nothing, x) - Left (Just h') -> updateHead h' f - -updateHead_ :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a)) -> m (Maybe (Head a)) -updateHead_ h = fmap fst . updateHead h . (fmap (,()) .) - - -data WatchedHead = forall a. WatchedHead Storage WatchID (MVar a) - -watchHead :: forall a. HeadType a => Head a -> (Head a -> IO ()) -> IO WatchedHead -watchHead h = watchHeadWith h id - -watchHeadWith :: forall a b. (HeadType a, Eq b) => Head a -> (Head a -> b) -> (b -> IO ()) -> IO WatchedHead -watchHeadWith (Head hid (Stored (Ref st _) _)) sel cb = do - watchHeadRaw st (headTypeID @a Proxy) hid (sel . Head hid . wrappedLoad) cb - -watchHeadRaw :: forall b. Eq b => Storage -> HeadTypeID -> HeadID -> (Ref -> b) -> (b -> IO ()) -> IO WatchedHead -watchHeadRaw st tid hid sel cb = do - memo <- newEmptyMVar - let addWatcher wl = (wl', WatchedHead st (wlNext wl) memo) - where wl' = wl { wlNext = wlNext wl + 1 - , wlList = WatchListItem - { wlID = wlNext wl - , wlHead = (tid, hid) - , wlFun = \r -> do - let x = sel r - modifyMVar_ memo $ \prev -> do - when (Just x /= prev) $ cb x - return $ Just x - } : wlList wl - } - - watched <- case stBacking st of - StorageDir { dirPath = spath, dirWatchers = mvar } -> modifyMVar mvar $ \(mbmanager, ilist, wl) -> do - manager <- maybe startManager return mbmanager - ilist' <- case tid `elem` ilist of - True -> return ilist - False -> do - void $ watchDir manager (headTypePath spath tid) (const True) $ \case - Added { eventPath = fpath } | Just ihid <- HeadID <$> U.fromString (takeFileName fpath) -> do - loadHeadRaw st tid ihid >>= \case - Just ref -> do - (_, _, iwl) <- readMVar mvar - mapM_ ($ ref) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList $ iwl - Nothing -> return () - _ -> return () - return $ tid : ilist - return $ first ( Just manager, ilist', ) $ addWatcher wl - - StorageMemory { memWatchers = mvar } -> modifyMVar mvar $ return . addWatcher - - cur <- fmap sel <$> loadHeadRaw st tid hid - maybe (return ()) cb cur - putMVar memo cur - - return watched - -unwatchHead :: WatchedHead -> IO () -unwatchHead (WatchedHead st wid _) = do - let delWatcher wl = wl { wlList = filter ((/=wid) . wlID) $ wlList wl } - case stBacking st of - StorageDir { dirWatchers = mvar } -> modifyMVar_ mvar $ return . second delWatcher - StorageMemory { memWatchers = mvar } -> modifyMVar_ mvar $ return . delWatcher - class Monad m => MonadStorage m where getStorage :: m Storage @@ -605,9 +405,6 @@ class Monad m => MonadStorage m where instance MonadIO m => MonadStorage (ReaderT Storage m) where getStorage = ask -instance MonadIO m => MonadStorage (ReaderT (Head a) m) where - getStorage = asks $ headStorage - class Storable a where store' :: a -> Store diff --git a/src/Erebos/Pairing.hs b/src/Erebos/Pairing.hs index 772eda0..da6a9b4 100644 --- a/src/Erebos/Pairing.hs +++ b/src/Erebos/Pairing.hs @@ -27,10 +27,11 @@ import Data.Word import Erebos.Identity import Erebos.Network -import Erebos.Object.Internal +import Erebos.Object import Erebos.PubKey import Erebos.Service import Erebos.State +import Erebos.Storable data PairingService a = PairingRequest (Stored (Signed IdentityData)) (Stored (Signed IdentityData)) RefDigest | PairingResponse Bytes diff --git a/src/Erebos/PubKey.hs b/src/Erebos/PubKey.hs index 5d0cf62..bea208b 100644 --- a/src/Erebos/PubKey.hs +++ b/src/Erebos/PubKey.hs @@ -21,7 +21,7 @@ import Data.ByteArray import Data.ByteString (ByteString) import qualified Data.Text as T -import Erebos.Object.Internal +import Erebos.Storable import Erebos.Storage.Key data PublicKey = PublicKey ED.PublicKey diff --git a/src/Erebos/Service.hs b/src/Erebos/Service.hs index 5341c52..f640feb 100644 --- a/src/Erebos/Service.hs +++ b/src/Erebos/Service.hs @@ -34,8 +34,9 @@ import qualified Data.UUID as U import Erebos.Identity import {-# SOURCE #-} Erebos.Network -import Erebos.Object.Internal import Erebos.State +import Erebos.Storable +import Erebos.Storage.Head class (Typeable s, Storable s, Typeable (ServiceState s), Typeable (ServiceGlobalState s)) => Service s where serviceID :: proxy s -> ServiceID diff --git a/src/Erebos/Set.hs b/src/Erebos/Set.hs index 1dc96ee..270c0ba 100644 --- a/src/Erebos/Set.hs +++ b/src/Erebos/Set.hs @@ -19,7 +19,8 @@ import Data.Map qualified as M import Data.Maybe import Data.Ord -import Erebos.Object.Internal +import Erebos.Object +import Erebos.Storable import Erebos.Storage.Merge import Erebos.Util diff --git a/src/Erebos/State.hs b/src/Erebos/State.hs index 40896f7..79f17b7 100644 --- a/src/Erebos/State.hs +++ b/src/Erebos/State.hs @@ -35,8 +35,10 @@ import Data.UUID qualified as U import System.IO import Erebos.Identity -import Erebos.Object.Internal +import Erebos.Object import Erebos.PubKey +import Erebos.Storable +import Erebos.Storage.Head import Erebos.Storage.Merge data LocalState = LocalState diff --git a/src/Erebos/Storable.hs b/src/Erebos/Storable.hs index 15f43b3..ee389ce 100644 --- a/src/Erebos/Storable.hs +++ b/src/Erebos/Storable.hs @@ -34,6 +34,8 @@ module Erebos.Storable ( wrappedStore, wrappedLoad, copyStored, unsafeMapStored, + + Storage, MonadStorage(..), ) where import Erebos.Object.Internal diff --git a/src/Erebos/Storage.hs b/src/Erebos/Storage.hs index 3b2ce4a..4344b75 100644 --- a/src/Erebos/Storage.hs +++ b/src/Erebos/Storage.hs @@ -10,12 +10,11 @@ module Erebos.Storage ( openStorage, memoryStorage, deriveEphemeralStorage, derivePartialStorage, - Head, HeadType(..), - HeadTypeID, mkHeadTypeID, + Head, HeadType, + HeadID, HeadTypeID, headId, headStorage, headRef, headObject, headStoredObject, loadHeads, loadHead, reloadHead, storeHead, replaceHead, updateHead, updateHead_, - loadHeadRaw, storeHeadRaw, replaceHeadRaw, WatchedHead, watchHead, watchHeadWith, unwatchHead, @@ -25,3 +24,4 @@ module Erebos.Storage ( ) where import Erebos.Object.Internal +import Erebos.Storage.Head diff --git a/src/Erebos/Storage/Head.hs b/src/Erebos/Storage/Head.hs new file mode 100644 index 0000000..dc8b7bc --- /dev/null +++ b/src/Erebos/Storage/Head.hs @@ -0,0 +1,348 @@ +{-| +Description: Define, use and watch heads + +Provides data types and functions for reading, writing or watching `Head's. +Type class `HeadType' is used to define custom new `Head' types. +-} + +module Erebos.Storage.Head ( + -- * Head type and accessors + Head, HeadType(..), + HeadID, HeadTypeID, mkHeadTypeID, + headId, headStorage, headRef, headObject, headStoredObject, + + -- * Loading and storing heads + loadHeads, loadHead, reloadHead, + storeHead, replaceHead, updateHead, updateHead_, + loadHeadRaw, storeHeadRaw, replaceHeadRaw, + + -- * Watching heads + WatchedHead, + watchHead, watchHeadWith, unwatchHead, + watchHeadRaw, +) where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Reader + +import Data.Bifunctor +import Data.ByteString qualified as B +import Data.ByteString.Char8 qualified as BC +import Data.List +import Data.Maybe +import Data.Typeable +import Data.UUID qualified as U +import Data.UUID.V4 qualified as U + +import System.Directory +import System.FSNotify +import System.FilePath +import System.IO.Error + +import Erebos.Object +import Erebos.Storable +import Erebos.Storage.Internal + + +-- | Represents loaded Erebos storage head, along with the object it pointed to +-- at the time it was loaded. +-- +-- Each possible head type has associated unique ID, represented as +-- `HeadTypeID'. For each type, there can be multiple individual heads in given +-- storage, each also identified by unique ID (`HeadID'). +data Head a = Head HeadID (Stored a) + deriving (Eq, Show) + +-- | Instances of this class can be used as objects pointed to by heads in +-- Erebos storage. Each such type must be `Storable' and have a unique ID. +-- +-- To create a custom head type, generate a new UUID and assign it to the type using +-- `mkHeadTypeID': +-- +-- > instance HeadType MyType where +-- > headTypeID _ = mkHeadTypeID "86e8033d-c476-4f81-9b7c-fd36b9144475" +class Storable a => HeadType a where + headTypeID :: proxy a -> HeadTypeID + -- ^ Get the ID of the given head type; must be unique for each `HeadType' instance. + +instance MonadIO m => MonadStorage (ReaderT (Head a) m) where + getStorage = asks $ headStorage + + +-- | Get `HeadID' associated with given `Head'. +headId :: Head a -> HeadID +headId (Head uuid _) = uuid + +-- | Get storage from which the `Head' was loaded. +headStorage :: Head a -> Storage +headStorage = refStorage . headRef + +-- | Get `Ref' of the `Head'\'s associated object. +headRef :: Head a -> Ref +headRef (Head _ sx) = storedRef sx + +-- | Get the object the `Head' pointed to when it was loaded. +headObject :: Head a -> a +headObject (Head _ sx) = fromStored sx + +-- | Get the object the `Head' pointed to when it was loaded as a `Stored' value. +headStoredObject :: Head a -> Stored a +headStoredObject (Head _ sx) = sx + +-- | Create `HeadTypeID' from string representation of UUID. +mkHeadTypeID :: String -> HeadTypeID +mkHeadTypeID = maybe (error "Invalid head type ID") HeadTypeID . U.fromString + + +headTypePath :: FilePath -> HeadTypeID -> FilePath +headTypePath spath (HeadTypeID tid) = spath </> "heads" </> U.toString tid + +headPath :: FilePath -> HeadTypeID -> HeadID -> FilePath +headPath spath tid (HeadID hid) = headTypePath spath tid </> U.toString hid + +-- | Load all `Head's of type @a@ from storage. +loadHeads :: forall a m. MonadIO m => HeadType a => Storage -> m [Head a] +loadHeads s@(Storage { stBacking = StorageDir { dirPath = spath }}) = liftIO $ do + let hpath = headTypePath spath $ headTypeID @a Proxy + + files <- filterM (doesFileExist . (hpath </>)) =<< + handleJust (\e -> guard (isDoesNotExistError e)) (const $ return []) + (getDirectoryContents hpath) + fmap catMaybes $ forM files $ \hname -> do + case U.fromString hname of + Just hid -> do + (h:_) <- BC.lines <$> B.readFile (hpath </> hname) + Just ref <- readRef s h + return $ Just $ Head (HeadID hid) $ wrappedLoad ref + Nothing -> return Nothing +loadHeads Storage { stBacking = StorageMemory { memHeads = theads } } = liftIO $ do + let toHead ((tid, hid), ref) | tid == headTypeID @a Proxy = Just $ Head hid $ wrappedLoad ref + | otherwise = Nothing + catMaybes . map toHead <$> readMVar theads + +-- | Try to load a `Head' of type @a@ from storage. +loadHead + :: forall a m. (HeadType a, MonadIO m) + => Storage -- ^ Storage from which to load the head + -> HeadID -- ^ ID of the particular head + -> m (Maybe (Head a)) -- ^ Head object, or `Nothing' if not found +loadHead st hid = fmap (Head hid . wrappedLoad) <$> loadHeadRaw st (headTypeID @a Proxy) hid + +-- | Try to load `Head' using a raw head and type IDs, getting `Ref' if found. +loadHeadRaw + :: forall m. MonadIO m + => Storage -- ^ Storage from which to load the head + -> HeadTypeID -- ^ ID of the head type + -> HeadID -- ^ ID of the particular head + -> m (Maybe Ref) -- ^ `Ref' pointing to the head object, or `Nothing' if not found +loadHeadRaw s@(Storage { stBacking = StorageDir { dirPath = spath }}) tid hid = liftIO $ do + handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do + (h:_) <- BC.lines <$> B.readFile (headPath spath tid hid) + Just ref <- readRef s h + return $ Just ref +loadHeadRaw Storage { stBacking = StorageMemory { memHeads = theads } } tid hid = liftIO $ do + lookup (tid, hid) <$> readMVar theads + +-- | Reload the given head from storage, returning `Head' with updated object, +-- or `Nothing' if there is no longer head with the particular ID in storage. +reloadHead :: (HeadType a, MonadIO m) => Head a -> m (Maybe (Head a)) +reloadHead (Head hid (Stored (Ref st _) _)) = loadHead st hid + +-- | Store a new `Head' of type 'a' in the storage. +storeHead :: forall a m. MonadIO m => HeadType a => Storage -> a -> m (Head a) +storeHead st obj = do + let tid = headTypeID @a Proxy + stored <- wrappedStore st obj + hid <- storeHeadRaw st tid (storedRef stored) + return $ Head hid stored + +-- | Store a new `Head' in the storage, using the raw `HeadTypeID' and `Ref', +-- the function returns the assigned `HeadID' of the new head. +storeHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> Ref -> m HeadID +storeHeadRaw st tid ref = liftIO $ do + hid <- HeadID <$> U.nextRandom + case stBacking st of + StorageDir { dirPath = spath } -> do + Right () <- writeFileChecked (headPath spath tid hid) Nothing $ + showRef ref `B.append` BC.singleton '\n' + return () + StorageMemory { memHeads = theads } -> do + modifyMVar_ theads $ return . (((tid, hid), ref) :) + return hid + +-- | Try to replace existing `Head' of type @a@ in the storage. Function fails +-- if the head value in storage changed after being loaded here; for automatic +-- retry see `updateHead'. +replaceHead + :: forall a m. (HeadType a, MonadIO m) + => Head a -- ^ Existing head, associated object is supposed to match the one in storage + -> Stored a -- ^ Intended new value + -> m (Either (Maybe (Head a)) (Head a)) + -- ^ + -- [@`Left' `Nothing'@]: + -- Nothing was stored – the head no longer exists in storage. + -- [@`Left' (`Just' h)@]: + -- Nothing was stored – the head value in storage does not match + -- the first parameter, but is @h@ instead. + -- [@`Right' h@]: + -- Head value was updated in storage, the new head is @h@ (which is + -- the same as first parameter with associated object replaced by + -- the second parameter). +replaceHead prev@(Head hid pobj) stored' = liftIO $ do + let st = headStorage prev + tid = headTypeID @a Proxy + stored <- copyStored st stored' + bimap (fmap $ Head hid . wrappedLoad) (const $ Head hid stored) <$> + replaceHeadRaw st tid hid (storedRef pobj) (storedRef stored) + +-- | Try to replace existing head using raw IDs and `Ref's. +replaceHeadRaw + :: forall m. MonadIO m + => Storage -- ^ Storage to use + -> HeadTypeID -- ^ ID of the head type + -> HeadID -- ^ ID of the particular head + -> Ref -- ^ Expected value in storage + -> Ref -- ^ Intended new value + -> m (Either (Maybe Ref) Ref) + -- ^ + -- [@`Left' `Nothing'@]: + -- Nothing was stored – the head no longer exists in storage. + -- [@`Left' (`Just' r)@]: + -- Nothing was stored – the head value in storage does not match + -- the expected value, but is @r@ instead. + -- [@`Right' r@]: + -- Head value was updated in storage, the new head value is @r@ + -- (which is the same as the indended value). +replaceHeadRaw st tid hid prev new = liftIO $ do + case stBacking st of + StorageDir { dirPath = spath } -> do + let filename = headPath spath tid hid + showRefL r = showRef r `B.append` BC.singleton '\n' + + writeFileChecked filename (Just $ showRefL prev) (showRefL new) >>= \case + Left Nothing -> return $ Left Nothing + Left (Just bs) -> do Just oref <- readRef st $ BC.takeWhile (/='\n') bs + return $ Left $ Just oref + Right () -> return $ Right new + + StorageMemory { memHeads = theads, memWatchers = twatch } -> do + res <- modifyMVar theads $ \hs -> do + ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar twatch + return $ case partition ((==(tid, hid)) . fst) hs of + ([] , _ ) -> (hs, Left Nothing) + ((_, r):_, hs') | r == prev -> (((tid, hid), new) : hs', + Right (new, ws)) + | otherwise -> (hs, Left $ Just r) + case res of + Right (r, ws) -> mapM_ ($ r) ws >> return (Right r) + Left x -> return $ Left x + +-- | Update existing existing `Head' of type @a@ in the storage, using a given +-- function. The update function may be called multiple times in case the head +-- content changes concurrently during evaluation. +updateHead + :: (HeadType a, MonadIO m) + => Head a -- ^ Existing head to be updated + -> (Stored a -> m ( Stored a, b )) + -- ^ Function that gets current value of the head and returns updated + -- value, along with a custom extra value to be returned from + -- `updateHead' call. The function may be called multiple times. + -> m ( Maybe (Head a), b ) + -- ^ First element contains either the new head as @`Just' h@, or + -- `Nothing' in case the head no longer exists in storage. Second + -- element is the value from last call to the update function. +updateHead h f = do + (o, x) <- f $ headStoredObject h + replaceHead h o >>= \case + Right h' -> return (Just h', x) + Left Nothing -> return (Nothing, x) + Left (Just h') -> updateHead h' f + +-- | Update existing existing `Head' of type @a@ in the storage, using a given +-- function. The update function may be called multiple times in case the head +-- content changes concurrently during evaluation. +updateHead_ + :: (HeadType a, MonadIO m) + => Head a -- ^ Existing head to be updated + -> (Stored a -> m (Stored a)) + -- ^ Function that gets current value of the head and returns updated + -- value; may be called multiple times. + -> m (Maybe (Head a)) + -- ^ The new head as @`Just' h@, or `Nothing' in case the head no + -- longer exists in storage. +updateHead_ h = fmap fst . updateHead h . (fmap (,()) .) + + +-- | Represents a handle of a watched head, which can be used to cancel the +-- watching. +data WatchedHead = forall a. WatchedHead Storage WatchID (MVar a) + +-- | Watch the given head. The callback will be called with the current head +-- value, and then again each time the head changes. +watchHead :: forall a. HeadType a => Head a -> (Head a -> IO ()) -> IO WatchedHead +watchHead h = watchHeadWith h id + +-- | Watch the given head using custom selector function. The callback will be +-- called with the value derived from current head state, and then again each +-- time the selected value changes according to its `Eq' instance. +watchHeadWith + :: forall a b. (HeadType a, Eq b) + => Head a -- ^ Head to watch + -> (Head a -> b) -- ^ Selector function + -> (b -> IO ()) -- ^ Callback + -> IO WatchedHead -- ^ Watched head handle +watchHeadWith (Head hid (Stored (Ref st _) _)) sel cb = do + watchHeadRaw st (headTypeID @a Proxy) hid (sel . Head hid . wrappedLoad) cb + +-- | Watch the given head using raw IDs and a selector from `Ref'. +watchHeadRaw :: forall b. Eq b => Storage -> HeadTypeID -> HeadID -> (Ref -> b) -> (b -> IO ()) -> IO WatchedHead +watchHeadRaw st tid hid sel cb = do + memo <- newEmptyMVar + let addWatcher wl = (wl', WatchedHead st (wlNext wl) memo) + where wl' = wl { wlNext = wlNext wl + 1 + , wlList = WatchListItem + { wlID = wlNext wl + , wlHead = (tid, hid) + , wlFun = \r -> do + let x = sel r + modifyMVar_ memo $ \prev -> do + when (Just x /= prev) $ cb x + return $ Just x + } : wlList wl + } + + watched <- case stBacking st of + StorageDir { dirPath = spath, dirWatchers = mvar } -> modifyMVar mvar $ \(mbmanager, ilist, wl) -> do + manager <- maybe startManager return mbmanager + ilist' <- case tid `elem` ilist of + True -> return ilist + False -> do + void $ watchDir manager (headTypePath spath tid) (const True) $ \case + Added { eventPath = fpath } | Just ihid <- HeadID <$> U.fromString (takeFileName fpath) -> do + loadHeadRaw st tid ihid >>= \case + Just ref -> do + (_, _, iwl) <- readMVar mvar + mapM_ ($ ref) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList $ iwl + Nothing -> return () + _ -> return () + return $ tid : ilist + return $ first ( Just manager, ilist', ) $ addWatcher wl + + StorageMemory { memWatchers = mvar } -> modifyMVar mvar $ return . addWatcher + + cur <- fmap sel <$> loadHeadRaw st tid hid + maybe (return ()) cb cur + putMVar memo cur + + return watched + +-- | Stop watching previously watched head. +unwatchHead :: WatchedHead -> IO () +unwatchHead (WatchedHead st wid _) = do + let delWatcher wl = wl { wlList = filter ((/=wid) . wlID) $ wlList wl } + case stBacking st of + StorageDir { dirWatchers = mvar } -> modifyMVar_ mvar $ return . second delWatcher + StorageMemory { memWatchers = mvar } -> modifyMVar_ mvar $ return . delWatcher diff --git a/src/Erebos/Storage/Internal.hs b/src/Erebos/Storage/Internal.hs index 8b794d8..3e8d8b6 100644 --- a/src/Erebos/Storage/Internal.hs +++ b/src/Erebos/Storage/Internal.hs @@ -159,12 +159,11 @@ readHex = return . BA.concat <=< readHex' newtype Generation = Generation Int deriving (Eq, Show) -data Head' c a = Head HeadID (Stored' c a) - deriving (Eq, Show) - +-- | UUID of individual Erebos storage head. newtype HeadID = HeadID UUID deriving (Eq, Ord, Show) +-- | UUID of Erebos storage head type. newtype HeadTypeID = HeadTypeID UUID deriving (Eq, Ord) diff --git a/src/Erebos/Storage/Key.hs b/src/Erebos/Storage/Key.hs index 9e52397..626d684 100644 --- a/src/Erebos/Storage/Key.hs +++ b/src/Erebos/Storage/Key.hs @@ -18,7 +18,7 @@ import System.Directory import System.FilePath import System.IO.Error -import Erebos.Object.Internal +import Erebos.Storable import Erebos.Storage.Internal class Storable pub => KeyPair sec pub | sec -> pub, pub -> sec where diff --git a/src/Erebos/Storage/Merge.hs b/src/Erebos/Storage/Merge.hs index d5d184e..41725af 100644 --- a/src/Erebos/Storage/Merge.hs +++ b/src/Erebos/Storage/Merge.hs @@ -31,7 +31,8 @@ import Data.Set qualified as S import System.IO.Unsafe (unsafePerformIO) -import Erebos.Object.Internal +import Erebos.Object +import Erebos.Storable import Erebos.Storage.Internal import Erebos.Util diff --git a/src/Erebos/Sync.hs b/src/Erebos/Sync.hs index 71122f7..32e2e22 100644 --- a/src/Erebos/Sync.hs +++ b/src/Erebos/Sync.hs @@ -8,9 +8,9 @@ import Control.Monad.Reader import Data.List import Erebos.Identity -import Erebos.Object.Internal import Erebos.Service import Erebos.State +import Erebos.Storable import Erebos.Storage.Merge data SyncService = SyncPacket (Stored SharedState) |