From 35c48f033106c9f2d8a6a0e5ada7f5dcc5cc732e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Mon, 18 Dec 2023 20:55:02 +0100
Subject: Storage: export store and load helpers
---
src/Erebos/Storage.hs | 119 +++++++++++++++++++++++++++++----------------
src/Erebos/Storage/List.hs | 4 +-
2 files changed, 77 insertions(+), 46 deletions(-)
(limited to 'src/Erebos')
diff --git a/src/Erebos/Storage.hs b/src/Erebos/Storage.hs
index 88f3132..bad1b37 100644
--- a/src/Erebos/Storage.hs
+++ b/src/Erebos/Storage.hs
@@ -1,5 +1,5 @@
module Erebos.Storage (
- Storage, PartialStorage,
+ Storage, PartialStorage, StorageCompleteness,
openStorage, memoryStorage,
deriveEphemeralStorage, derivePartialStorage,
@@ -30,12 +30,18 @@ module Erebos.Storage (
Storable(..), ZeroStorable(..),
StorableText(..), StorableDate(..), StorableUUID(..),
+ Store, StoreRec,
+ evalStore, evalStoreObject,
storeBlob, storeRec, storeZero,
storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeRef, storeRawRef,
storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbRef, storeMbRawRef,
storeZRef,
- LoadRec,
+ Load, LoadRec,
+ evalLoad,
+ 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,
@@ -236,6 +242,8 @@ serializeObject = \case
in BL.fromChunks [BC.pack "rec ", BC.pack (show $ BL.length cnt), BC.singleton '\n'] `BL.append` cnt
ZeroObject -> BL.empty
+-- |Serializes and stores object data without ony dependencies, so is safe only
+-- if all the referenced objects are already stored or reference is partial.
unsafeStoreObject :: Storage' c -> Object' c -> IO (Ref' c)
unsafeStoreObject storage = \case
ZeroObject -> return $ zeroRef storage
@@ -544,10 +552,9 @@ class Storable a where
load' :: Load a
store :: StorageCompleteness c => Storage' c -> a -> IO (Ref' c)
- store st = unsafeStoreObject st <=< evalStore st . store'
+ store st = evalStore st . store'
load :: Ref -> a
- load ref = let Load f = load'
- in either (error {- TODO throw -} . ((BC.unpack (showRef ref) ++ ": ")++)) id $ runReaderT f (ref, lazyLoadObject ref)
+ load = evalLoad load'
class Storable a => ZeroStorable a where
fromZero :: Storage -> a
@@ -556,17 +563,39 @@ data Store = StoreBlob ByteString
| StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]])
| StoreZero
-evalStore :: StorageCompleteness c => Storage' c -> Store -> IO (Object' c)
-evalStore _ (StoreBlob x) = return $ Blob x
-evalStore s (StoreRec f) = Rec . concat <$> sequence (f s)
-evalStore _ StoreZero = return ZeroObject
+evalStore :: StorageCompleteness c => Storage' c -> Store -> IO (Ref' c)
+evalStore st = unsafeStoreObject st <=< evalStoreObject st
+
+evalStoreObject :: StorageCompleteness c => Storage' c -> Store -> IO (Object' c)
+evalStoreObject _ (StoreBlob x) = return $ Blob x
+evalStoreObject s (StoreRec f) = Rec . concat <$> sequence (f s)
+evalStoreObject _ StoreZero = return ZeroObject
-type StoreRec c = ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
+newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a)
+ deriving (Functor, Applicative, Monad)
+
+type StoreRec c = StoreRecM c ()
newtype Load a = Load (ReaderT (Ref, Object) (Either String) a)
- deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadReader (Ref, Object), MonadError String)
+ deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String)
+
+evalLoad :: Load a -> Ref -> a
+evalLoad (Load f) ref = either (error {- TODO throw -} . ((BC.unpack (showRef ref) ++ ": ")++)) id $ runReaderT f (ref, lazyLoadObject ref)
+
+loadCurrentRef :: Load Ref
+loadCurrentRef = Load $ asks fst
+
+loadCurrentObject :: Load Object
+loadCurrentObject = Load $ asks snd
+
+newtype LoadRec a = LoadRec (ReaderT (Ref, [(ByteString, RecItem)]) (Either String) a)
+ deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String)
+
+loadRecCurrentRef :: LoadRec Ref
+loadRecCurrentRef = LoadRec $ asks fst
-type LoadRec a = ReaderT (Ref, [(ByteString, RecItem)]) (Either String) a
+loadRecItems :: LoadRec [(ByteString, RecItem)]
+loadRecItems = LoadRec $ asks snd
instance Storable Object where
@@ -576,7 +605,7 @@ instance Storable Object where
return xs'
store' ZeroObject = StoreZero
- load' = asks snd
+ load' = loadCurrentObject
store st = unsafeStoreObject st <=< copyObject st
load = lazyLoadObject
@@ -591,7 +620,7 @@ instance Storable a => Storable [a] where
storeRef "i" x
storeRef "n" xs
- load' = asks snd >>= \case
+ load' = loadCurrentObject >>= \case
ZeroObject -> return []
_ -> loadRec $ (:)
<$> loadRef "i"
@@ -605,7 +634,9 @@ storeBlob :: ByteString -> Store
storeBlob = StoreBlob
storeRec :: (forall c. StorageCompleteness c => StoreRec c) -> Store
-storeRec r = StoreRec $ execWriter . runReaderT r
+storeRec sr = StoreRec $ do
+ let StoreRecM r = sr
+ execWriter . runReaderT r
storeZero :: Store
storeZero = StoreZero
@@ -651,49 +682,49 @@ instance StorableUUID UUID where
storeEmpty :: String -> StoreRec c
-storeEmpty name = tell [return [(BC.pack name, RecEmpty)]]
+storeEmpty name = StoreRecM $ tell [return [(BC.pack name, RecEmpty)]]
storeMbEmpty :: String -> Maybe () -> StoreRec c
storeMbEmpty name = maybe (return ()) (const $ storeEmpty name)
storeInt :: Integral a => String -> a -> StoreRec c
-storeInt name x = tell [return [(BC.pack name, RecInt $ toInteger x)]]
+storeInt name x = StoreRecM $ tell [return [(BC.pack name, RecInt $ toInteger x)]]
storeMbInt :: Integral a => String -> Maybe a -> StoreRec c
storeMbInt name = maybe (return ()) (storeInt name)
storeNum :: (Real a, Fractional a) => String -> a -> StoreRec c
-storeNum name x = tell [return [(BC.pack name, RecNum $ toRational x)]]
+storeNum name x = StoreRecM $ tell [return [(BC.pack name, RecNum $ toRational x)]]
storeMbNum :: (Real a, Fractional a) => String -> Maybe a -> StoreRec c
storeMbNum name = maybe (return ()) (storeNum name)
storeText :: StorableText a => String -> a -> StoreRec c
-storeText name x = tell [return [(BC.pack name, RecText $ toText x)]]
+storeText name x = StoreRecM $ tell [return [(BC.pack name, RecText $ toText x)]]
storeMbText :: StorableText a => String -> Maybe a -> StoreRec c
storeMbText name = maybe (return ()) (storeText name)
storeBinary :: BA.ByteArrayAccess a => String -> a -> StoreRec c
-storeBinary name x = tell [return [(BC.pack name, RecBinary $ BA.convert x)]]
+storeBinary name x = StoreRecM $ tell [return [(BC.pack name, RecBinary $ BA.convert x)]]
storeMbBinary :: BA.ByteArrayAccess a => String -> Maybe a -> StoreRec c
storeMbBinary name = maybe (return ()) (storeBinary name)
storeDate :: StorableDate a => String -> a -> StoreRec c
-storeDate name x = tell [return [(BC.pack name, RecDate $ toDate x)]]
+storeDate name x = StoreRecM $ tell [return [(BC.pack name, RecDate $ toDate x)]]
storeMbDate :: StorableDate a => String -> Maybe a -> StoreRec c
storeMbDate name = maybe (return ()) (storeDate name)
storeUUID :: StorableUUID a => String -> a -> StoreRec c
-storeUUID name x = tell [return [(BC.pack name, RecUUID $ toUUID x)]]
+storeUUID name x = StoreRecM $ tell [return [(BC.pack name, RecUUID $ toUUID x)]]
storeMbUUID :: StorableUUID a => String -> Maybe a -> StoreRec c
storeMbUUID name = maybe (return ()) (storeUUID name)
storeRef :: Storable a => StorageCompleteness c => String -> a -> StoreRec c
-storeRef name x = do
+storeRef name x = StoreRecM $ do
s <- ask
tell $ (:[]) $ do
ref <- store s x
@@ -703,7 +734,7 @@ storeMbRef :: Storable a => StorageCompleteness c => String -> Maybe a -> StoreR
storeMbRef name = maybe (return ()) (storeRef name)
storeRawRef :: StorageCompleteness c => String -> Ref -> StoreRec c
-storeRawRef name ref = do
+storeRawRef name ref = StoreRecM $ do
st <- ask
tell $ (:[]) $ do
ref' <- copyRef st ref
@@ -713,7 +744,7 @@ storeMbRawRef :: StorageCompleteness c => String -> Maybe Ref -> StoreRec c
storeMbRawRef name = maybe (return ()) (storeRawRef name)
storeZRef :: (ZeroStorable a, StorageCompleteness c) => String -> a -> StoreRec c
-storeZRef name x = do
+storeZRef name x = StoreRecM $ do
s <- ask
tell $ (:[]) $ do
ref <- store s x
@@ -722,17 +753,19 @@ storeZRef name x = do
loadBlob :: (ByteString -> a) -> Load a
-loadBlob f = asks snd >>= \case
+loadBlob f = loadCurrentObject >>= \case
Blob x -> return $ f x
_ -> throwError "Expecting blob"
loadRec :: LoadRec a -> Load a
-loadRec lrec = ask >>= \case
- (ref, Rec rs) -> either throwError return $ runReaderT lrec (ref, rs)
- _ -> throwError "Expecting record"
+loadRec (LoadRec lrec) = loadCurrentObject >>= \case
+ Rec rs -> do
+ ref <- loadCurrentRef
+ either throwError return $ runReaderT lrec (ref, rs)
+ _ -> throwError "Expecting record"
loadZero :: a -> Load a
-loadZero x = asks snd >>= \case
+loadZero x = loadCurrentObject >>= \case
ZeroObject -> return x
_ -> throwError "Expecting zero"
@@ -741,7 +774,7 @@ loadEmpty :: String -> LoadRec ()
loadEmpty name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name
loadMbEmpty :: String -> LoadRec (Maybe ())
-loadMbEmpty name = asks (lookup (BC.pack name) . snd) >>= \case
+loadMbEmpty name = (lookup (BC.pack name) <$> loadRecItems) >>= \case
Nothing -> return Nothing
Just (RecEmpty) -> return (Just ())
Just _ -> throwError $ "Expecting type int of record item '"++name++"'"
@@ -750,7 +783,7 @@ 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 = asks (lookup (BC.pack name) . snd) >>= \case
+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++"'"
@@ -759,7 +792,7 @@ 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 = asks (lookup (BC.pack name) . snd) >>= \case
+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++"'"
@@ -768,14 +801,14 @@ 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 = asks (lookup (BC.pack name) . snd) >>= \case
+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++"'"
loadTexts :: StorableText a => String -> LoadRec [a]
loadTexts name = do
- items <- map snd . filter ((BC.pack name ==) . fst) <$> asks snd
+ items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems
forM items $ \case RecText x -> fromText x
_ -> throwError $ "Expecting type text of record item '"++name++"'"
@@ -783,14 +816,14 @@ 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 = asks (lookup (BC.pack name) . snd) >>= \case
+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++"'"
loadBinaries :: BA.ByteArray a => String -> LoadRec [a]
loadBinaries name = do
- items <- map snd . filter ((BC.pack name ==) . fst) <$> asks snd
+ 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++"'"
@@ -798,7 +831,7 @@ 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 = asks (lookup (BC.pack name) . snd) >>= \case
+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++"'"
@@ -807,7 +840,7 @@ 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 = asks (lookup (BC.pack name) . snd) >>= \case
+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++"'"
@@ -816,14 +849,14 @@ loadRawRef :: String -> LoadRec Ref
loadRawRef name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name
loadMbRawRef :: String -> LoadRec (Maybe Ref)
-loadMbRawRef name = asks (lookup (BC.pack name) . snd) >>= \case
+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++"'"
loadRawRefs :: String -> LoadRec [Ref]
loadRawRefs name = do
- items <- map snd . filter ((BC.pack name ==) . fst) <$> asks snd
+ items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems
forM items $ \case RecRef x -> return x
_ -> throwError $ "Expecting type ref of record item '"++name++"'"
@@ -838,7 +871,7 @@ loadRefs name = map load <$> loadRawRefs name
loadZRef :: ZeroStorable a => String -> LoadRec a
loadZRef name = loadMbRef name >>= \case
- Nothing -> do Ref st _ <- asks fst
+ Nothing -> do Ref st _ <- loadRecCurrentRef
return $ fromZero st
Just x -> return x
@@ -848,7 +881,7 @@ type Stored a = Stored' Complete a
instance Storable a => Storable (Stored a) where
store st = copyRef st . storedRef
store' (Stored _ x) = store' x
- load' = Stored <$> asks fst <*> load'
+ load' = Stored <$> loadCurrentRef <*> load'
instance ZeroStorable a => ZeroStorable (Stored a) where
fromZero st = Stored (zeroRef st) $ fromZero st
diff --git a/src/Erebos/Storage/List.hs b/src/Erebos/Storage/List.hs
index ef56c60..f0f8786 100644
--- a/src/Erebos/Storage/List.hs
+++ b/src/Erebos/Storage/List.hs
@@ -10,8 +10,6 @@ module Erebos.Storage.List (
-- TODO withStoredListItem, withStoredListItemS,
) where
-import Control.Monad.Reader
-
import Data.List
import Data.Maybe
import qualified Data.Set as S
@@ -35,7 +33,7 @@ instance Storable a => Storable (List a) where
mapM_ (storeRef "item") $ listItem x
mapM_ (storeRef "remove") $ listRemove x
- load' = asks snd >>= \case
+ load' = loadCurrentObject >>= \case
ZeroObject -> return ListNil
_ -> loadRec $ ListItem <$> loadRefs "PREV"
<*> loadMbRef "item"
--
cgit v1.2.3