diff options
Diffstat (limited to 'src/Erebos')
| -rw-r--r-- | src/Erebos/State.hs | 27 | ||||
| -rw-r--r-- | src/Erebos/Storage.hs | 33 |
2 files changed, 39 insertions, 21 deletions
diff --git a/src/Erebos/State.hs b/src/Erebos/State.hs index 324127a..3012064 100644 --- a/src/Erebos/State.hs +++ b/src/Erebos/State.hs @@ -22,13 +22,15 @@ module Erebos.State ( import Control.Monad.Except import Control.Monad.Reader +import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as BC import Data.Foldable import Data.Maybe -import qualified Data.Text as T -import qualified Data.Text.IO as T +import Data.Text qualified as T +import Data.Text.IO qualified as T import Data.Typeable import Data.UUID (UUID) -import qualified Data.UUID as U +import Data.UUID qualified as U import System.IO @@ -40,6 +42,7 @@ import Erebos.Storage.Merge data LocalState = LocalState { lsIdentity :: Stored (Signed ExtendedIdentityData) , lsShared :: [Stored SharedState] + , lsOther :: [ ( ByteString, RecItem ) ] } data SharedState = SharedState @@ -58,13 +61,16 @@ class Mergeable a => SharedType a where sharedTypeID :: proxy a -> SharedTypeID instance Storable LocalState where - store' st = storeRec $ do - storeRef "id" $ lsIdentity st - mapM_ (storeRef "shared") $ lsShared st + store' LocalState {..} = storeRec $ do + storeRef "id" lsIdentity + mapM_ (storeRef "shared") lsShared + storeRecItems lsOther - load' = loadRec $ LocalState - <$> loadRef "id" - <*> loadRefs "shared" + load' = loadRec $ do + lsIdentity <- loadRef "id" + lsShared <- loadRefs "shared" + lsOther <- filter ((`notElem` [ BC.pack "id", BC.pack "shared" ]) . fst) <$> loadRecItems + return LocalState {..} instance HeadType LocalState where headTypeID _ = mkHeadTypeID "1d7491a9-7bcb-4eaa-8f13-c8c4c4087e4e" @@ -123,7 +129,8 @@ loadLocalStateHead st = loadHeads st >>= \case } storeHead st $ LocalState { lsIdentity = idExtData identity - , lsShared = [shared] + , lsShared = [ shared ] + , lsOther = [] } localIdentity :: LocalState -> UnifiedIdentity diff --git a/src/Erebos/Storage.hs b/src/Erebos/Storage.hs index 2e6653a..2e60f4e 100644 --- a/src/Erebos/Storage.hs +++ b/src/Erebos/Storage.hs @@ -38,6 +38,7 @@ module Erebos.Storage ( storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeRef, storeRawRef, storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbRef, storeMbRawRef, storeZRef, + storeRecItems, Load, LoadRec, evalLoad, @@ -210,24 +211,28 @@ copyRef' st ref'@(Ref _ dgst) = refFromDigest st dgst >>= \case Just ref -> retu mbobj <- sequence $ copyObject' st <$> mbobj' sequence $ unsafeStoreObject st <$> join mbobj +copyRecItem' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> RecItem' c -> IO (c (RecItem' c')) +copyRecItem' st = \case + RecEmpty -> return $ return $ RecEmpty + RecInt x -> return $ return $ RecInt x + RecNum x -> return $ return $ RecNum x + RecText x -> return $ return $ RecText x + RecBinary x -> return $ return $ RecBinary x + RecDate x -> return $ return $ RecDate x + RecUUID x -> return $ return $ RecUUID x + RecRef x -> fmap RecRef <$> copyRef' st x + copyObject' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (c (Object' c')) copyObject' _ (Blob bs) = return $ return $ Blob bs -copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM copyItem rs - where copyItem :: (ByteString, RecItem' c) -> IO (c (ByteString, RecItem' c')) - copyItem (n, item) = fmap (n,) <$> case item of - RecEmpty -> return $ return $ RecEmpty - RecInt x -> return $ return $ RecInt x - RecNum x -> return $ return $ RecNum x - RecText x -> return $ return $ RecText x - RecBinary x -> return $ return $ RecBinary x - RecDate x -> return $ return $ RecDate x - RecUUID x -> return $ return $ RecUUID x - RecRef x -> fmap RecRef <$> copyRef' st x +copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM (\( n, item ) -> fmap ( n, ) <$> copyRecItem' st item) rs copyObject' _ ZeroObject = return $ return ZeroObject copyRef :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> Ref' c -> m (LoadResult c (Ref' c')) copyRef st ref' = liftIO $ returnLoadResult <$> copyRef' st ref' +copyRecItem :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> RecItem' c -> m (LoadResult c (RecItem' c')) +copyRecItem st item' = liftIO $ returnLoadResult <$> copyRecItem' st item' + copyObject :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (LoadResult c (Object' c')) copyObject st obj' = returnLoadResult <$> copyObject' st obj' @@ -790,6 +795,12 @@ storeZRef name x = StoreRecM $ do return $ if isZeroRef ref then [] else [(BC.pack name, RecRef ref)] +storeRecItems :: StorageCompleteness c => [ ( ByteString, RecItem ) ] -> StoreRec c +storeRecItems items = StoreRecM $ do + st <- ask + tell $ flip map items $ \( name, value ) -> do + value' <- copyRecItem st value + return [ ( name, value' ) ] loadBlob :: (ByteString -> a) -> Load a loadBlob f = loadCurrentObject >>= \case |