summaryrefslogtreecommitdiff
path: root/src/Storage.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Storage.hs')
-rw-r--r--src/Storage.hs14
1 files changed, 13 insertions, 1 deletions
diff --git a/src/Storage.hs b/src/Storage.hs
index d78d99a..d29056f 100644
--- a/src/Storage.hs
+++ b/src/Storage.hs
@@ -29,12 +29,14 @@ module Storage (
loadBlob, loadRec, loadZero,
loadInt, loadNum, loadText, loadBinary, loadDate, loadJson, loadRef,
- loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbJson, loadMbRef, loadRefs,
+ loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbJson, loadMbRef,
+ loadBinaries, loadRefs,
loadZRef,
Stored,
fromStored, storedRef, storedStorage,
wrappedStore, wrappedLoad,
+ copyStored,
StoreInfo(..), makeStoreInfo,
@@ -631,6 +633,12 @@ loadMbBinary name = asks (lookup (BC.pack name) . snd) >>= \case
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
+ forM items $ \case RecBinary x -> return $ BA.convert x
+ _ -> throwError $ "Expecting type binary of record item '"++name++"'"
+
loadDate :: StorableDate a => String -> LoadRec a
loadDate name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbDate name
@@ -719,6 +727,10 @@ wrappedStore st x = do ref <- store st x
wrappedLoad :: Storable a => Ref -> Stored a
wrappedLoad ref = Stored ref (load ref)
+copyStored :: forall c c' m a. (StorageCompleteness c, StorageCompleteness c', MonadIO m) =>
+ Storage' c' -> Stored' c a -> m (LoadResult c (Stored' c' a))
+copyStored st (Stored ref' x) = liftIO $ returnLoadResult . fmap (flip Stored x) <$> copyRef' st ref'
+
data StoreInfo = StoreInfo
{ infoDate :: ZonedTime