Keep unknown items in local state

Changelog: Keep unknown items in local state

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