summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--erebos.cabal3
-rw-r--r--src/Attach.hs232
-rw-r--r--src/Main.hs20
-rw-r--r--src/Message/Service.hs2
-rw-r--r--src/Network.hs45
-rw-r--r--src/PubKey.hs12
-rw-r--r--src/Service.hs15
-rw-r--r--src/State.hs13
-rw-r--r--src/Storage.hs14
9 files changed, 331 insertions, 25 deletions
diff --git a/erebos.cabal b/erebos.cabal
index 8218d91..98310b4 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -18,7 +18,8 @@ cabal-version: >=1.10
executable erebos
ghc-options: -Wall
main-is: Main.hs
- other-modules: Identity,
+ other-modules: Attach
+ Identity,
Channel,
Message,
Message.Service
diff --git a/src/Attach.hs b/src/Attach.hs
new file mode 100644
index 0000000..bf4d61e
--- /dev/null
+++ b/src/Attach.hs
@@ -0,0 +1,232 @@
+module Attach (
+ AttachService,
+ attachToOwner, attachAccept,
+) where
+
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+
+import Crypto.Hash
+import Crypto.Random
+
+import Data.Bits
+import Data.ByteArray (Bytes, ScrubbedBytes, convert)
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy as BL
+import Data.Maybe
+import qualified Data.Text as T
+import Data.Word
+
+import Identity
+import Network
+import PubKey
+import Service
+import State
+import Storage
+import Storage.Key
+
+data AttachService = NoAttach
+ | OurRequest Bytes
+ | OurRequestConfirm (Maybe (UnifiedIdentity, [ScrubbedBytes]))
+ | OurRequestReady
+ | PeerRequest Bytes RefDigest
+ | PeerRequestConfirm
+ | AttachDone
+ | AttachFailed
+
+data AttachStage = AttachRequest RefDigest
+ | AttachResponse Bytes
+ | AttachRequestNonce Bytes
+ | AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes]
+ | AttachDecline
+
+instance Storable AttachStage where
+ store' at = storeRec $ do
+ case at of
+ AttachRequest x -> storeBinary "request" x
+ AttachResponse x -> storeBinary "response" x
+ AttachRequestNonce x -> storeBinary "reqnonce" x
+ AttachIdentity x keys -> do
+ storeRef "identity" x
+ mapM_ (storeBinary "skey") keys
+ AttachDecline -> storeText "decline" ""
+
+ load' = loadRec $ do
+ (req :: Maybe Bytes) <- loadMbBinary "request"
+ rsp <- loadMbBinary "response"
+ rnonce <- loadMbBinary "reqnonce"
+ aid <- loadMbRef "identity"
+ skeys <- loadBinaries "skey"
+ (decline :: Maybe T.Text) <- loadMbText "decline"
+ let res = catMaybes
+ [ AttachRequest <$> (digestFromByteString =<< req)
+ , AttachResponse <$> rsp
+ , AttachRequestNonce <$> rnonce
+ , AttachIdentity <$> aid <*> pure skeys
+ , const AttachDecline <$> decline
+ ]
+ case res of
+ x:_ -> return x
+ [] -> throwError "invalid attach stange"
+
+instance Service AttachService where
+ type ServicePacket AttachService = AttachStage
+ emptyServiceState = NoAttach
+
+ serviceHandler spacket = gets ((,fromStored spacket) . svcValue) >>= \case
+ (NoAttach, AttachRequest confirm) -> do
+ peer <- asks $ svcPeer
+ svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ " initiated"
+ nonce <- liftIO $ getRandomBytes 32
+ svcSet $ PeerRequest nonce confirm
+ return $ Just $ AttachResponse nonce
+ (NoAttach, _) -> return Nothing
+
+ (OurRequest nonce, AttachResponse pnonce) -> do
+ peer <- asks $ svcPeer
+ self <- maybe (throwError "failed to verify own identity") return =<<
+ gets (verifyIdentity . lsIdentity . fromStored . svcLocal)
+ svcPrint $ "Attach to " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirmationNumber (nonceDigest self peer nonce pnonce)
+ svcSet $ OurRequestConfirm Nothing
+ return $ Just $ AttachRequestNonce nonce
+ (OurRequest _, _) -> do
+ svcSet $ AttachFailed
+ return $ Just $ AttachDecline
+
+ (OurRequestConfirm _, AttachIdentity sdata keys) -> do
+ verifyAttachedIdentity sdata >>= \case
+ Just owner -> do
+ svcPrint $ "Attachment confirmed by peer"
+ svcSet $ OurRequestConfirm $ Just (owner, keys)
+ return Nothing
+ Nothing -> do
+ svcPrint $ "Failed to verify new identity"
+ svcSet $ AttachFailed
+ return $ Just AttachDecline
+ (OurRequestConfirm _, _) -> do
+ svcSet $ AttachFailed
+ return $ Just $ AttachDecline
+
+ (OurRequestReady, AttachIdentity sdata keys) -> do
+ verifyAttachedIdentity sdata >>= \case
+ Just identity -> do
+ svcPrint $ "Accepted updated identity"
+ st <- gets $ storedStorage . svcLocal
+ finalizeAttach st identity keys
+ return Nothing
+ Nothing -> do
+ svcPrint $ "Failed to verify new identity"
+ svcSet $ AttachFailed
+ return $ Just AttachDecline
+ (OurRequestReady, _) -> do
+ svcSet $ AttachFailed
+ return $ Just $ AttachDecline
+
+ (PeerRequest nonce dgst, AttachRequestNonce pnonce) -> do
+ peer <- asks $ svcPeer
+ self <- maybe (throwError "failed to verify own identity") return =<<
+ gets (verifyIdentity . lsIdentity . fromStored . svcLocal)
+ if dgst == nonceDigest peer self pnonce BA.empty
+ then do svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirmationNumber (nonceDigest peer self pnonce nonce)
+ svcSet PeerRequestConfirm
+ return Nothing
+ else do svcPrint $ "Failed attach from " ++ T.unpack (displayIdentity peer)
+ svcSet AttachFailed
+ return $ Just $ AttachDecline
+ (PeerRequest _ _, _) -> do
+ svcSet $ AttachFailed
+ return $ Just $ AttachDecline
+ (PeerRequestConfirm, _) -> do
+ svcSet $ AttachFailed
+ return $ Just $ AttachDecline
+
+ (AttachDone, _) -> return Nothing
+ (AttachFailed, _) -> return Nothing
+
+attachToOwner :: (MonadIO m, MonadError String m) => (String -> IO ()) -> UnifiedIdentity -> Peer -> m ()
+attachToOwner _ self peer = do
+ nonce <- liftIO $ getRandomBytes 32
+ pid <- case peerIdentity peer of
+ PeerIdentityFull pid -> return pid
+ _ -> throwError "incomplete peer identity"
+ sendToPeerWith self peer (T.pack "attach") $ \case
+ NoAttach -> return (Just $ AttachRequest (nonceDigest self pid nonce BA.empty), OurRequest nonce)
+ _ -> throwError "alredy in progress"
+
+attachAccept :: (MonadIO m, MonadError String m) => (String -> IO ()) -> UnifiedIdentity -> Peer -> m ()
+attachAccept printMsg self peer = do
+ let st = storedStorage $ idData self
+ sendToPeerWith self peer (T.pack "attach") $ \case
+ NoAttach -> throwError $ "none in progress"
+ OurRequest {} -> throwError $ "waiting for peer"
+ OurRequestConfirm Nothing -> do
+ liftIO $ printMsg $ "Confirmed peer, waiting for updated identity"
+ return (Nothing, OurRequestReady)
+ OurRequestConfirm (Just (identity, keys)) -> do
+ liftIO $ printMsg $ "Accepted updated identity"
+ finalizeAttach st identity keys
+ return (Nothing, AttachDone)
+ OurRequestReady -> throwError $ "alredy accepted, waiting for peer"
+ PeerRequest {} -> throwError $ "waiting for peer"
+ PeerRequestConfirm -> do
+ liftIO $ printMsg $ "Accepted new attached device, seding updated identity"
+ owner <- liftIO $ mergeSharedIdentity st
+ PeerIdentityFull pid <- return $ peerIdentity peer
+ Just secret <- liftIO $ loadKey $ idKeyIdentity owner
+ liftIO $ do
+ identity <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData $ idKeyIdentity pid)
+ { iddPrev = [idData pid], iddOwner = Just (idData owner) }
+ skeys <- map keyGetData . catMaybes <$> mapM loadKey [ idKeyIdentity owner, idKeyMessage owner ]
+ return (Just $ AttachIdentity identity skeys, NoAttach)
+ AttachDone -> throwError $ "alredy done"
+ AttachFailed -> throwError $ "alredy failed"
+
+
+nonceDigest :: UnifiedIdentity -> UnifiedIdentity -> Bytes -> Bytes -> RefDigest
+nonceDigest id1 id2 nonce1 nonce2 = hashFinalize $ hashUpdates hashInit $
+ BL.toChunks $ serializeObject $ Rec
+ [ (BC.pack "id", RecRef $ storedRef $ idData id1)
+ , (BC.pack "id", RecRef $ storedRef $ idData id2)
+ , (BC.pack "nonce", RecBinary $ convert nonce1)
+ , (BC.pack "nonce", RecBinary $ convert nonce2)
+ ]
+
+confirmationNumber :: RefDigest -> String
+confirmationNumber dgst = let (a:b:c:d:_) = map fromIntegral $ BA.unpack dgst :: [Word32]
+ str = show $ (a .|. (b `shift` 8) .|. (c `shift` 16) .|. (d `shift` 24)) `mod` (10 ^ len)
+ in replicate (len - length str) '0' ++ str
+ where len = 6
+
+
+verifyAttachedIdentity :: Stored (Signed IdentityData) -> ServiceHandler s (Maybe UnifiedIdentity)
+verifyAttachedIdentity sdata = do
+ curid <- gets $ lsIdentity . fromStored . svcLocal
+ secret <- maybe (throwError "failed to load own secret key") return =<<
+ liftIO (loadKey $ iddKeyIdentity $ fromStored $ signedData $ fromStored curid)
+ sdata' <- liftIO $ wrappedStore (storedStorage sdata) =<< signAdd secret (fromStored sdata)
+ return $ do
+ guard $ iddKeyIdentity (fromStored $ signedData $ fromStored sdata) ==
+ iddKeyIdentity (fromStored $ signedData $ fromStored curid)
+ identity <- verifyIdentity sdata'
+ guard $ iddPrev (fromStored $ signedData $ fromStored $ idData identity) == [curid]
+ return identity
+
+
+finalizeAttach :: MonadIO m => Storage -> UnifiedIdentity -> [ScrubbedBytes] -> m ()
+finalizeAttach st identity skeys = do
+ liftIO $ updateLocalState_ st $ \slocal -> do
+ let owner = finalOwner identity
+ pkeys <- mapM (copyStored st) [ idKeyIdentity owner, idKeyMessage owner ]
+ mapM_ storeKey $ catMaybes [ keyFromData sec pub | sec <- skeys, pub <- pkeys ]
+
+ mshared <- mergeSharedStates (lsShared $ fromStored slocal)
+ shared <- wrappedStore st $ (fromStored mshared)
+ { ssPrev = lsShared $ fromStored slocal
+ , ssIdentity = [idData owner]
+ }
+ wrappedStore st (fromStored slocal)
+ { lsIdentity = idData identity
+ , lsShared = [ shared ]
+ }
diff --git a/src/Main.hs b/src/Main.hs
index 9e87af5..0e1daf7 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -22,6 +22,7 @@ import Data.Time.LocalTime
import System.Console.Haskeline
import System.Environment
+import Attach
import Identity
import Message
import Message.Service
@@ -70,7 +71,8 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
let extPrintLn str = extPrint $ str ++ "\n";
chanPeer <- liftIO $
startServer extPrintLn bhost self
- [ (T.pack "dmsg", SomeService (emptyServiceState :: DirectMessageService))
+ [ (T.pack "attach", SomeService (emptyServiceState :: AttachService))
+ , (T.pack "dmsg", SomeService (emptyServiceState :: DirectMessageService))
]
peers <- liftIO $ newMVar []
@@ -110,6 +112,7 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
res <- liftIO $ runExceptT $ flip execStateT cstate $ runReaderT cmd CommandInput
{ ciSelf = self
, ciLine = line
+ , ciPrint = extPrintLn
, ciPeers = liftIO $ readMVar peers
}
case res of
@@ -125,6 +128,7 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
data CommandInput = CommandInput
{ ciSelf :: UnifiedIdentity
, ciLine :: String
+ , ciPrint :: String -> IO ()
, ciPeers :: CommandM [Peer]
}
@@ -149,6 +153,8 @@ commands =
, ("peers", cmdPeers)
, ("send", cmdSend)
, ("update-identity", cmdUpdateIdentity)
+ , ("attach", cmdAttach)
+ , ("attach-accept", cmdAttachAccept)
]
cmdUnknown :: String -> Command
@@ -213,3 +219,15 @@ cmdUpdateIdentity :: Command
cmdUpdateIdentity = void $ do
st <- asks $ storedStorage . idData . ciSelf
liftIO $ updateIdentity st
+
+cmdAttach :: Command
+cmdAttach = join $ attachToOwner
+ <$> asks ciPrint
+ <*> asks ciSelf
+ <*> (maybe (throwError "no peer selected") return =<< gets csPeer)
+
+cmdAttachAccept :: Command
+cmdAttachAccept = join $ attachAccept
+ <$> asks ciPrint
+ <*> asks ciSelf
+ <*> (maybe (throwError "no peer selected") return =<< gets csPeer)
diff --git a/src/Message/Service.hs b/src/Message/Service.hs
index a798fb5..37aa3ab 100644
--- a/src/Message/Service.hs
+++ b/src/Message/Service.hs
@@ -1,5 +1,5 @@
module Message.Service (
- DirectMessageService,
+ DirectMessageService(..),
formatMessage,
) where
diff --git a/src/Network.hs b/src/Network.hs
index bff793a..7d70d1d 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -6,7 +6,7 @@ module Network (
WaitingRef, wrDigest,
Service(..),
startServer,
- sendToPeer,
+ sendToPeer, sendToPeerWith,
) where
import Control.Concurrent
@@ -43,7 +43,7 @@ data Peer = Peer
, peerSocket :: Socket
, peerStorage :: Storage
, peerInStorage :: PartialStorage
- , peerServiceState :: M.Map T.Text SomeService
+ , peerServiceState :: MVar (M.Map T.Text SomeService)
, peerServiceQueue :: [(T.Text, WaitingRef)]
, peerWaitingRefs :: [WaitingRef]
}
@@ -184,6 +184,7 @@ startServer logd bhost identity services = do
| otherwise -> do
pst <- deriveEphemeralStorage $ storedStorage sidentity
ist <- derivePartialStorage pst
+ svcs <- newMVar M.empty
let peer = Peer
{ peerAddress = DatagramAddress paddr
, peerIdentity = PeerIdentityUnknown
@@ -192,7 +193,7 @@ startServer logd bhost identity services = do
, peerSocket = sock
, peerStorage = pst
, peerInStorage = ist
- , peerServiceState = M.empty
+ , peerServiceState = svcs
, peerServiceQueue = []
, peerWaitingRefs = []
}
@@ -226,19 +227,20 @@ startServer logd bhost identity services = do
(peer, svc, ref)
| PeerIdentityFull peerId <- peerIdentity peer
, PeerIdentityFull peerOwnerId <- peerOwner peer
- , DatagramAddress paddr <- peerAddress peer
- -> case maybe (lookup svc services) Just $ M.lookup svc (peerServiceState peer) of
- Nothing -> logd $ "unhandled service '" ++ T.unpack svc ++ "'"
- Just (SomeService s) -> do
- let inp = ServiceInput
- { svcPeer = peerId, svcPeerOwner = peerOwnerId
- , svcPrintOp = logd
- }
- (rsp, s') <- handleServicePacket (storedStorage sidentity) inp s (wrappedLoad ref)
- modifyMVar_ peers $ return . M.adjust (\p -> p { peerServiceState = M.insert svc (SomeService s') $ peerServiceState p }) paddr
- runExceptT (maybe (return ()) (sendToPeer identity peer svc) rsp) >>= \case
- Left err -> logd $ "failed to send response to peer: " ++ show err
- Right () -> return ()
+ -> modifyMVar_ (peerServiceState peer) $ \svcs ->
+ case maybe (lookup svc services) Just $ M.lookup svc svcs of
+ Nothing -> do logd $ "unhandled service '" ++ T.unpack svc ++ "'"
+ return svcs
+ Just (SomeService s) -> do
+ let inp = ServiceInput
+ { svcPeer = peerId, svcPeerOwner = peerOwnerId
+ , svcPrintOp = logd
+ }
+ (rsp, s') <- handleServicePacket (storedStorage sidentity) inp s (wrappedLoad ref)
+ runExceptT (maybe (return ()) (sendToPeer identity peer svc) rsp) >>= \case
+ Left err -> logd $ "failed to send response to peer: " ++ show err
+ Right () -> return ()
+ return $ M.insert svc (SomeService s') svcs
| DatagramAddress paddr <- peerAddress peer -> do
logd $ "service packet from peer with incomplete identity " ++ show paddr
@@ -491,3 +493,14 @@ sendToPeer _ peer@Peer { peerChannel = ChannelEstablished ch } svc obj = do
void $ liftIO $ sendTo (peerSocket peer) ctext paddr
sendToPeer _ _ _ _ = throwError $ "no channel to peer"
+
+sendToPeerWith :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> T.Text -> (s -> ExceptT String IO (Maybe (ServicePacket s), s)) -> m ()
+sendToPeerWith identity peer svc fobj = do
+ res <- liftIO $ modifyMVar (peerServiceState peer) $ \svcs -> do
+ runExceptT (fobj $ fromMaybe emptyServiceState $ fromService =<< M.lookup svc svcs) >>= \case
+ Right (obj, s') -> return $ (M.insert svc (SomeService s') svcs, Right obj)
+ Left err -> return $ (svcs, Left err)
+ case res of
+ Right (Just obj) -> sendToPeer identity peer svc obj
+ Right Nothing -> return ()
+ Left err -> throwError err
diff --git a/src/PubKey.hs b/src/PubKey.hs
index d7134c8..8f39bf1 100644
--- a/src/PubKey.hs
+++ b/src/PubKey.hs
@@ -48,7 +48,11 @@ signedSignature = signedSignature_
instance KeyPair SecretKey PublicKey where
keyGetPublic (SecretKey _ pub) = pub
keyGetData (SecretKey sec _) = convert sec
- keyFromData kdata spub = SecretKey <$> maybeCryptoError (ED.secretKey kdata) <*> pure spub
+ keyFromData kdata spub = do
+ skey <- maybeCryptoError $ ED.secretKey kdata
+ let PublicKey pkey = fromStored spub
+ guard $ ED.toPublic skey == pkey
+ return $ SecretKey skey spub
generateKeys st = do
secret <- ED.generateSecretKey
public <- wrappedStore st $ PublicKey $ ED.toPublic secret
@@ -115,7 +119,11 @@ data SecretKexKey = SecretKexKey CX.SecretKey (Stored PublicKexKey)
instance KeyPair SecretKexKey PublicKexKey where
keyGetPublic (SecretKexKey _ pub) = pub
keyGetData (SecretKexKey sec _) = convert sec
- keyFromData kdata spub = SecretKexKey <$> maybeCryptoError (CX.secretKey kdata) <*> pure spub
+ keyFromData kdata spub = do
+ skey <- maybeCryptoError $ CX.secretKey kdata
+ let PublicKexKey pkey = fromStored spub
+ guard $ CX.toPublic skey == pkey
+ return $ SecretKexKey skey spub
generateKeys st = do
secret <- CX.generateSecretKey
public <- wrappedStore st $ PublicKexKey $ CX.toPublic secret
diff --git a/src/Service.hs b/src/Service.hs
index 667196d..f08a7a2 100644
--- a/src/Service.hs
+++ b/src/Service.hs
@@ -1,11 +1,12 @@
module Service (
Service(..),
- SomeService(..),
+ SomeService(..), fromService,
ServiceHandler,
ServiceInput(..), ServiceState(..),
handleServicePacket,
+ svcSet,
svcPrint,
) where
@@ -13,17 +14,22 @@ import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
+import Data.Typeable
+
import Identity
import State
import Storage
-class Storable (ServicePacket s) => Service s where
+class (Typeable s, Storable (ServicePacket s)) => Service s where
type ServicePacket s :: *
emptyServiceState :: s
serviceHandler :: Stored (ServicePacket s) -> ServiceHandler s (Maybe (ServicePacket s))
data SomeService = forall s. Service s => SomeService s
+fromService :: Service s => SomeService -> Maybe s
+fromService (SomeService s) = cast s
+
data ServiceInput = ServiceInput
{ svcPeer :: UnifiedIdentity
, svcPeerOwner :: UnifiedIdentity
@@ -36,7 +42,7 @@ data ServiceState s = ServiceState
}
newtype ServiceHandler s a = ServiceHandler (ReaderT ServiceInput (StateT (ServiceState s) (ExceptT String IO)) a)
- deriving (Functor, Applicative, Monad, MonadReader ServiceInput, MonadState (ServiceState s), MonadIO)
+ deriving (Functor, Applicative, Monad, MonadReader ServiceInput, MonadState (ServiceState s), MonadError String, MonadIO)
handleServicePacket :: Service s => Storage -> ServiceInput -> s -> Stored (ServicePacket s) -> IO (Maybe (ServicePacket s), s)
handleServicePacket st input svc packet = do
@@ -54,5 +60,8 @@ handleServicePacket st input svc packet = do
Left _ -> handleServicePacket st input svc packet
Right _ -> return (rsp, svcValue sstate')
+svcSet :: s -> ServiceHandler s ()
+svcSet x = modify $ \st -> st { svcValue = x }
+
svcPrint :: String -> ServiceHandler s ()
svcPrint str = liftIO . ($str) =<< asks svcPrintOp
diff --git a/src/State.hs b/src/State.hs
index 91fff2b..515391d 100644
--- a/src/State.hs
+++ b/src/State.hs
@@ -4,6 +4,10 @@ module State (
loadLocalState,
updateLocalState, updateLocalState_,
+ updateSharedState, updateSharedState_,
+ mergeSharedStates,
+
+ mergeSharedIdentity,
updateIdentity,
) where
@@ -119,6 +123,15 @@ mergeSharedStates ss@(s:_) = wrappedStore (storedStorage s) $ SharedState
}
mergeSharedStates [] = error "mergeSharedStates: empty list"
+
+mergeSharedIdentity :: Storage -> IO UnifiedIdentity
+mergeSharedIdentity st = updateSharedState st $ \sshared -> do
+ let shared = fromStored sshared
+ Just cidentity = verifyIdentityF $ ssIdentity shared
+ identity <- mergeIdentity cidentity
+ sshared' <- wrappedStore st $ shared { ssIdentity = [idData identity] }
+ return (sshared', identity)
+
updateIdentity :: Storage -> IO ()
updateIdentity st = updateSharedState_ st $ \sshared -> do
let shared = fromStored sshared
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-07 20:28:37 +0000