From 2169f1030cded87e6ab38b4ae8293e7f147b5e96 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 9 Nov 2019 21:24:57 +0100 Subject: Attach device service --- src/Storage.hs | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) (limited to 'src/Storage.hs') 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 -- cgit v1.2.3