diff options
29 files changed, 547 insertions, 360 deletions
diff --git a/erebos.cabal b/erebos.cabal index 93af480..ba00538 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -7,14 +7,14 @@ Description: Library and simple CLI interface implementing the Erebos identity management, decentralized messaging and synchronization protocol, along with local storage. - . + Erebos identity is based on locally stored cryptographic keys, all communication is end-to-end encrypted. Multiple devices can be attached to the same identity, after which they function interchangeably, without any one being in any way "primary"; messages and other state data are then synchronized automatically whenever the devices are able to connect with one another. - . + See README for usage of the CLI tool. License: BSD-3-Clause License-File: LICENSE @@ -94,28 +94,32 @@ library hs-source-dirs: src exposed-modules: Erebos.Attach - Erebos.Channel Erebos.Chatroom Erebos.Contact Erebos.Conversation + Erebos.DirectMessage Erebos.Identity - Erebos.Message Erebos.Network + Erebos.Network.Channel Erebos.Network.Protocol + Erebos.Object Erebos.Pairing Erebos.PubKey Erebos.Service Erebos.Set Erebos.State + Erebos.Storable + Erebos.Storage + Erebos.Storage.Head Erebos.Storage.Key Erebos.Storage.Merge Erebos.Sync -- Used by test tool: - Erebos.Object.Internal Erebos.Storage.Internal other-modules: Erebos.Flow + Erebos.Object.Internal Erebos.Storage.Platform Erebos.Util diff --git a/main/Main.hs b/main/Main.hs index b2aca21..7f9250b 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -40,18 +40,20 @@ import Erebos.Attach import Erebos.Contact import Erebos.Chatroom import Erebos.Conversation +import Erebos.DirectMessage #ifdef ENABLE_ICE_SUPPORT import Erebos.Discovery import Erebos.ICE #endif import Erebos.Identity -import Erebos.Message hiding (formatMessage) import Erebos.Network -import Erebos.Object.Internal +import Erebos.Object import Erebos.PubKey import Erebos.Service import Erebos.Set import Erebos.State +import Erebos.Storable +import Erebos.Storage import Erebos.Storage.Merge import Erebos.Sync diff --git a/main/Test.hs b/main/Test.hs index 7dc7e43..628e351 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -34,15 +34,18 @@ import System.IO.Error import Erebos.Attach import Erebos.Chatroom import Erebos.Contact +import Erebos.DirectMessage import Erebos.Identity -import Erebos.Message import Erebos.Network -import Erebos.Object.Internal +import Erebos.Object import Erebos.Pairing import Erebos.PubKey import Erebos.Service 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/main/Test/Service.hs b/main/Test/Service.hs index c81722d..8c58dee 100644 --- a/main/Test/Service.hs +++ b/main/Test/Service.hs @@ -8,8 +8,9 @@ import Control.Monad.Reader import Data.ByteString.Lazy.Char8 qualified as BL import Erebos.Network -import Erebos.Object.Internal +import Erebos.Object import Erebos.Service +import Erebos.Storable data TestMessage = TestMessage (Stored Object) 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..fce8780 100644 --- a/src/Erebos/Conversation.hs +++ b/src/Erebos/Conversation.hs @@ -30,10 +30,10 @@ import Data.Time.Format import Data.Time.LocalTime import Erebos.Chatroom +import Erebos.DirectMessage 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/Message.hs b/src/Erebos/DirectMessage.hs index a558d1a..39d453c 100644 --- a/src/Erebos/Message.hs +++ b/src/Erebos/DirectMessage.hs @@ -1,4 +1,4 @@ -module Erebos.Message ( +module Erebos.DirectMessage ( DirectMessage(..), sendDirectMessage, @@ -13,7 +13,6 @@ module Erebos.Message ( messageThreadView, watchReceivedMessages, - formatMessage, formatDirectMessage, ) where @@ -31,9 +30,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 @@ -259,10 +259,6 @@ watchReceivedMessages h f = do forM_ (map fromStored sms) $ \ms -> do mapM_ f $ filter (not . sameIdentity self . msgFrom . fromStored) $ msReceived ms -{-# DEPRECATED formatMessage "use formatDirectMessage instead" #-} -formatMessage :: TimeZone -> DirectMessage -> String -formatMessage = formatDirectMessage - formatDirectMessage :: TimeZone -> DirectMessage -> String formatDirectMessage tzone msg = concat [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg 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/Network.hs b/src/Erebos/Network.hs index 358bb7c..364597f 100644 --- a/src/Erebos/Network.hs +++ b/src/Erebos/Network.hs @@ -57,16 +57,17 @@ import qualified Network.Socket.ByteString as S import Foreign.C.Types import Foreign.Marshal.Alloc -import Erebos.Channel #ifdef ENABLE_ICE_SUPPORT import Erebos.ICE #endif import Erebos.Identity +import Erebos.Network.Channel import Erebos.Network.Protocol 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/Channel.hs b/src/Erebos/Network/Channel.hs index c17c9ab..17e1a37 100644 --- a/src/Erebos/Channel.hs +++ b/src/Erebos/Network/Channel.hs @@ -1,4 +1,4 @@ -module Erebos.Channel ( +module Erebos.Network.Channel ( Channel, ChannelRequest, ChannelRequestData(..), ChannelAccept, ChannelAcceptData(..), @@ -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 bceb355..c657759 100644 --- a/src/Erebos/Network/Protocol.hs +++ b/src/Erebos/Network/Protocol.hs @@ -64,11 +64,13 @@ import Data.Void import System.Clock -import Erebos.Channel import Erebos.Flow import Erebos.Identity -import Erebos.Object.Internal +import Erebos.Network.Channel +import Erebos.Object import Erebos.Service +import Erebos.Storable +import Erebos.Storage protocolVersion :: Text diff --git a/src/Erebos/Object.hs b/src/Erebos/Object.hs new file mode 100644 index 0000000..26ca09f --- /dev/null +++ b/src/Erebos/Object.hs @@ -0,0 +1,22 @@ +{-| +Description: Core Erebos objects and references + +Data types and functions for working with "raw" Erebos objects and references. +-} + +module Erebos.Object ( + Object, PartialObject, Object'(..), + serializeObject, deserializeObject, deserializeObjects, + ioLoadObject, ioLoadBytes, + storeRawBytes, lazyLoadBytes, + + RecItem, RecItem'(..), + + Ref, PartialRef, RefDigest, + refDigest, + readRef, showRef, showRefDigest, + refDigestFromByteString, hashToRefDigest, + copyRef, partialRef, partialRefFromDigest, +) where + +import Erebos.Object.Internal diff --git a/src/Erebos/Object/Internal.hs b/src/Erebos/Object/Internal.hs index 638689a..f08e734 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(..), @@ -56,12 +45,6 @@ module Erebos.Object.Internal ( wrappedStore, wrappedLoad, copyStored, unsafeMapStored, - - StoreInfo(..), makeStoreInfo, - - StoredHistory, - fromHistory, fromHistoryAt, storedFromHistory, storedHistoryList, - beginHistory, modifyHistory, ) where import Control.Applicative @@ -84,7 +67,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 +80,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 +383,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 +399,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 @@ -841,91 +632,97 @@ loadEmpty :: String -> LoadRec () loadEmpty name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name loadMbEmpty :: String -> LoadRec (Maybe ()) -loadMbEmpty name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecEmpty) -> return (Just ()) - Just _ -> throwError $ "Expecting type int of record item '"++name++"'" +loadMbEmpty name = listToMaybe . mapMaybe p <$> loadRecItems + where + bname = BC.pack name + p ( name', RecEmpty ) | name' == bname + = Just () + p _ = Nothing loadInt :: Num a => String -> LoadRec a loadInt name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbInt name loadMbInt :: Num a => String -> LoadRec (Maybe a) -loadMbInt name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecInt x) -> return (Just $ fromInteger x) - Just _ -> throwError $ "Expecting type int of record item '"++name++"'" +loadMbInt name = listToMaybe . mapMaybe p <$> loadRecItems + where + bname = BC.pack name + p ( name', RecInt x ) | name' == bname + = Just (fromInteger x) + p _ = Nothing loadNum :: (Real a, Fractional a) => String -> LoadRec a loadNum name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbNum name loadMbNum :: (Real a, Fractional a) => String -> LoadRec (Maybe a) -loadMbNum name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecNum x) -> return (Just $ fromRational x) - Just _ -> throwError $ "Expecting type number of record item '"++name++"'" +loadMbNum name = listToMaybe . mapMaybe p <$> loadRecItems + where + bname = BC.pack name + p ( name', RecNum x ) | name' == bname + = Just (fromRational x) + p _ = Nothing loadText :: StorableText a => String -> LoadRec a loadText name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbText name loadMbText :: StorableText a => String -> LoadRec (Maybe a) -loadMbText name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecText x) -> Just <$> fromText x - Just _ -> throwError $ "Expecting type text of record item '"++name++"'" +loadMbText name = listToMaybe <$> loadTexts name loadTexts :: StorableText a => String -> LoadRec [a] -loadTexts name = do - items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems - forM items $ \case RecText x -> fromText x - _ -> throwError $ "Expecting type text of record item '"++name++"'" +loadTexts name = sequence . mapMaybe p =<< loadRecItems + where + bname = BC.pack name + p ( name', RecText x ) | name' == bname + = Just (fromText x) + p _ = Nothing loadBinary :: BA.ByteArray a => String -> LoadRec a loadBinary name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbBinary name loadMbBinary :: BA.ByteArray a => String -> LoadRec (Maybe a) -loadMbBinary name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecBinary x) -> return $ Just $ BA.convert x - Just _ -> throwError $ "Expecting type binary of record item '"++name++"'" +loadMbBinary name = listToMaybe <$> loadBinaries name loadBinaries :: BA.ByteArray a => String -> LoadRec [a] -loadBinaries name = do - items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems - forM items $ \case RecBinary x -> return $ BA.convert x - _ -> throwError $ "Expecting type binary of record item '"++name++"'" +loadBinaries name = mapMaybe p <$> loadRecItems + where + bname = BC.pack name + p ( name', RecBinary x ) | name' == bname + = Just (BA.convert x) + p _ = Nothing loadDate :: StorableDate a => String -> LoadRec a loadDate name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbDate name loadMbDate :: StorableDate a => String -> LoadRec (Maybe a) -loadMbDate name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecDate x) -> return $ Just $ fromDate x - Just _ -> throwError $ "Expecting type date of record item '"++name++"'" +loadMbDate name = listToMaybe . mapMaybe p <$> loadRecItems + where + bname = BC.pack name + p ( name', RecDate x ) | name' == bname + = Just (fromDate x) + p _ = Nothing loadUUID :: StorableUUID a => String -> LoadRec a loadUUID name = maybe (throwError $ "Missing record iteem '"++name++"'") return =<< loadMbUUID name loadMbUUID :: StorableUUID a => String -> LoadRec (Maybe a) -loadMbUUID name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecUUID x) -> return $ Just $ fromUUID x - Just _ -> throwError $ "Expecting type UUID of record item '"++name++"'" +loadMbUUID name = listToMaybe . mapMaybe p <$> loadRecItems + where + bname = BC.pack name + p ( name', RecUUID x ) | name' == bname + = Just (fromUUID x) + p _ = Nothing loadRawRef :: String -> LoadRec Ref loadRawRef name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name loadMbRawRef :: String -> LoadRec (Maybe Ref) -loadMbRawRef name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecRef x) -> return (Just x) - Just _ -> throwError $ "Expecting type ref of record item '"++name++"'" +loadMbRawRef name = listToMaybe <$> loadRawRefs name loadRawRefs :: String -> LoadRec [Ref] -loadRawRefs name = do - items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems - forM items $ \case RecRef x -> return x - _ -> throwError $ "Expecting type ref of record item '"++name++"'" +loadRawRefs name = mapMaybe p <$> loadRecItems + where + bname = BC.pack name + p ( name', RecRef x ) | name' == bname = Just x + p _ = Nothing loadRef :: Storable a => String -> LoadRec a loadRef name = load <$> loadRawRef name @@ -975,72 +772,6 @@ unsafeMapStored :: (a -> b) -> Stored a -> Stored b unsafeMapStored f (Stored ref x) = Stored ref (f x) -data StoreInfo = StoreInfo - { infoDate :: ZonedTime - , infoNote :: Maybe Text - } - deriving (Show) - -makeStoreInfo :: IO StoreInfo -makeStoreInfo = StoreInfo - <$> getZonedTime - <*> pure Nothing - -storeInfoRec :: StoreInfo -> StoreRec c -storeInfoRec info = do - storeDate "date" $ infoDate info - storeMbText "note" $ infoNote info - -loadInfoRec :: LoadRec StoreInfo -loadInfoRec = StoreInfo - <$> loadDate "date" - <*> loadMbText "note" - - -data History a = History StoreInfo (Stored a) (Maybe (StoredHistory a)) - deriving (Show) - -type StoredHistory a = Stored (History a) - -instance Storable a => Storable (History a) where - store' (History si x prev) = storeRec $ do - storeInfoRec si - storeMbRef "prev" prev - storeRef "item" x - - load' = loadRec $ History - <$> loadInfoRec - <*> loadRef "item" - <*> loadMbRef "prev" - -fromHistory :: StoredHistory a -> a -fromHistory = fromStored . storedFromHistory - -fromHistoryAt :: ZonedTime -> StoredHistory a -> Maybe a -fromHistoryAt zat = fmap (fromStored . snd) . listToMaybe . dropWhile ((at<) . zonedTimeToUTC . fst) . storedHistoryTimedList - where at = zonedTimeToUTC zat - -storedFromHistory :: StoredHistory a -> Stored a -storedFromHistory sh = let History _ item _ = fromStored sh - in item - -storedHistoryList :: StoredHistory a -> [Stored a] -storedHistoryList = map snd . storedHistoryTimedList - -storedHistoryTimedList :: StoredHistory a -> [(ZonedTime, Stored a)] -storedHistoryTimedList sh = let History hinfo item prev = fromStored sh - in (infoDate hinfo, item) : maybe [] storedHistoryTimedList prev - -beginHistory :: Storable a => Storage -> StoreInfo -> a -> IO (StoredHistory a) -beginHistory st si x = do sx <- wrappedStore st x - wrappedStore st $ History si sx Nothing - -modifyHistory :: Storable a => StoreInfo -> (a -> a) -> StoredHistory a -> IO (StoredHistory a) -modifyHistory si f prev@(Stored (Ref st _) _) = do - sx <- wrappedStore st $ f $ fromHistory prev - wrappedStore st $ History si sx (Just prev) - - showRatio :: Rational -> String showRatio r = case decimalRatio r of Just (n, 1) -> show n 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 new file mode 100644 index 0000000..ee389ce --- /dev/null +++ b/src/Erebos/Storable.hs @@ -0,0 +1,41 @@ +{-| +Description: Encoding custom types into Erebos objects + +Module provides the 'Storable' class for types that can be serialized to/from +Erebos objects, along with various helpers, mostly for encoding using records. + +The 'Stored' wrapper for objects actually encoded and stored in some storage is +defined here as well. +-} + +module Erebos.Storable ( + Storable(..), ZeroStorable(..), + StorableText(..), StorableDate(..), StorableUUID(..), + + Store, StoreRec, + storeBlob, storeRec, storeZero, + storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeRef, storeRawRef, + storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbRef, storeMbRawRef, + storeZRef, + storeRecItems, + + Load, LoadRec, + loadCurrentRef, loadCurrentObject, + loadRecCurrentRef, loadRecItems, + + loadBlob, loadRec, loadZero, + loadEmpty, loadInt, loadNum, loadText, loadBinary, loadDate, loadUUID, loadRef, loadRawRef, + loadMbEmpty, loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbRef, loadMbRawRef, + loadTexts, loadBinaries, loadRefs, loadRawRefs, + loadZRef, + + Stored, + fromStored, storedRef, + wrappedStore, wrappedLoad, + copyStored, + unsafeMapStored, + + Storage, MonadStorage(..), +) where + +import Erebos.Object.Internal diff --git a/src/Erebos/Storage.hs b/src/Erebos/Storage.hs new file mode 100644 index 0000000..4344b75 --- /dev/null +++ b/src/Erebos/Storage.hs @@ -0,0 +1,27 @@ +{-| +Description: Working with storage and heads + +Provides functions for opening 'Storage' backed either by disk or memory. For +conveniance also function for working with 'Head's are reexported here. +-} + +module Erebos.Storage ( + Storage, PartialStorage, + openStorage, memoryStorage, + deriveEphemeralStorage, derivePartialStorage, + + Head, HeadType, + HeadID, HeadTypeID, + headId, headStorage, headRef, headObject, headStoredObject, + loadHeads, loadHead, reloadHead, + storeHead, replaceHead, updateHead, updateHead_, + + WatchedHead, + watchHead, watchHeadWith, unwatchHead, + watchHeadRaw, + + MonadStorage(..), +) 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) |