Attach device service

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