Partial and memory-backed storage variants

7 files changed, 481 insertions, 272 deletions

diff --git a/erebos.cabal b/erebos.cabal
index 0eedaa4..cf50a74 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -32,8 +32,10 @@ executable erebos
                        FunctionalDependencies,
                        LambdaCase,
                        MultiWayIf,
+                       RankNTypes,
                        ScopedTypeVariables,
-                       TupleSections
+                       TupleSections,
+                       TypeFamilies
 
   -- other-extensions:
   build-depends:       aeson >=1.4 && <1.5,
@@ -42,6 +44,7 @@ executable erebos
                        cereal >= 0.5 && <0.6,
                        containers >= 0.6 && <0.7,
                        cryptonite >=0.25 && <0.26,
+                       deepseq >= 1.4 && <1.5,
                        directory >= 1.3 && <1.4,
                        filepath >=1.4 && <1.5,
                        haskeline >=0.7 && <0.8,
diff --git a/src/Main.hs b/src/Main.hs
index 59e6d5c..b42c3cf 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,7 +1,6 @@
 module Main (main) where
 
 import Control.Concurrent
-import Control.Exception
 import Control.Monad
 import Control.Monad.Reader
 import Control.Monad.State
@@ -18,7 +17,6 @@ import Data.Time.LocalTime
 import System.Console.Haskeline
 import System.Environment
 import System.IO
-import System.IO.Error
 
 import Identity
 import Message
@@ -43,36 +41,32 @@ instance Storable Erebos where
 
 
 loadErebosHead :: Storage -> IO Head
-loadErebosHead st = do
-    catchJust (guard . isDoesNotExistError) (loadHead st "erebos") $ \_ -> do
-        putStr "Name: "
-        hFlush stdout
-        name <- T.getLine
-
-        (secret, public) <- generateKeys st
-        (_secretMsg, publicMsg) <- generateKeys st
-        (devSecret, devPublic) <- generateKeys st
-        (_devSecretMsg, devPublicMsg) <- generateKeys st
-
-        owner <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentity public publicMsg) { idName = Just name }
-        identity <- wrappedStore st =<< signAdd devSecret =<< sign secret =<<
-            wrappedStore st (emptyIdentity devPublic devPublicMsg) { idOwner = Just owner }
-
-        msgs <- emptySList st
-        let erebos = Erebos
-                { erbIdentity = identity
-                , erbMessages = msgs
-                }
-
-        Right h <- replaceHead erebos (Left (st, "erebos"))
-        return h
+loadErebosHead st = loadHeadDef st "erebos" $ do
+    putStr "Name: "
+    hFlush stdout
+    name <- T.getLine
+
+    (secret, public) <- generateKeys st
+    (_secretMsg, publicMsg) <- generateKeys st
+    (devSecret, devPublic) <- generateKeys st
+    (_devSecretMsg, devPublicMsg) <- generateKeys st
+
+    owner <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentity public publicMsg) { idName = Just name }
+    identity <- wrappedStore st =<< signAdd devSecret =<< sign secret =<<
+        wrappedStore st (emptyIdentity devPublic devPublicMsg) { idOwner = Just owner }
+
+    msgs <- emptySList st
+    return $ Erebos
+        { erbIdentity = identity
+        , erbMessages = msgs
+        }
 
 updateErebosHead_ :: Storage -> (Stored Erebos -> IO (Stored Erebos)) -> IO ()
 updateErebosHead_ st f = updateErebosHead st (fmap (,()) . f)
 
 updateErebosHead :: Storage -> (Stored Erebos -> IO (Stored Erebos, a)) -> IO a
 updateErebosHead st f = do
-    erebosHead <- loadHead st "erebos"
+    Just erebosHead <- loadHead st "erebos"
     (erebos, x) <- f $ wrappedLoad (headRef erebosHead)
     Right _ <- replaceHead erebos (Right erebosHead)
     return x
@@ -211,7 +205,7 @@ cmdHistory = void $ runMaybeT $ do
     Just peer <- gets csPeer
     Just powner <- return $ finalOwner <$> peerIdentity peer
 
-    erebosHead <- liftIO $ loadHead st "erebos"
+    Just erebosHead <- liftIO $ loadHead st "erebos"
     let erebos = wrappedLoad (headRef erebosHead)
     Just thread <- return $ find ((==powner) . msgPeer) $ fromSList $ erbMessages $ fromStored erebos
     tzone <- liftIO $ getCurrentTimeZone
diff --git a/src/Message.hs b/src/Message.hs
index 0b633ae..0a1a70e 100644
--- a/src/Message.hs
+++ b/src/Message.hs
@@ -76,4 +76,4 @@ threadToList thread = helper S.empty $ msgHead thread
               | msg : msgs' <- filter (`S.notMember` seen) $ reverse $ sortBy (comparing cmpView) msgs =
                   fromStored msg : helper (S.insert msg seen) (msgs' ++ msgPrev (fromStored msg))
               | otherwise = []
-          cmpView msg = (zonedTimeToUTC $ msgTime $ fromStored msg, storedRef msg)
+          cmpView msg = (zonedTimeToUTC $ msgTime $ fromStored msg, msg)
diff --git a/src/Network.hs b/src/Network.hs
index 391e236..c5ce8cb 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -33,6 +33,7 @@ data Peer = Peer
     , peerIdentity :: Maybe (Stored Identity)
     , peerChannels :: [Channel]
     , peerSocket :: Socket
+    , peerInStorage :: PartialStorage
     }
     deriving (Show)
 
@@ -40,15 +41,15 @@ data PeerAddress = DatagramAddress SockAddr
     deriving (Show)
 
 
-data TransportHeader = AnnouncePacket Ref
-                     | IdentityRequest Ref Ref
-                     | IdentityResponse Ref
-                     | TrChannelRequest Ref
-                     | TrChannelAccept Ref
+data TransportHeader = AnnouncePacket PartialRef
+                     | IdentityRequest PartialRef PartialRef
+                     | IdentityResponse PartialRef
+                     | TrChannelRequest PartialRef
+                     | TrChannelAccept PartialRef
 
-data ServiceHeader = ServiceHeader T.Text Ref
+data ServiceHeader = ServiceHeader T.Text PartialRef
 
-transportToObject :: TransportHeader -> Object
+transportToObject :: TransportHeader -> PartialObject
 transportToObject = \case
     AnnouncePacket ref -> Rec
         [ (BC.pack "TRANS", RecText $ T.pack "announce")
@@ -72,7 +73,7 @@ transportToObject = \case
         , (BC.pack "acc", RecRef ref)
         ]
 
-transportFromObject :: Object -> Maybe TransportHeader
+transportFromObject :: PartialObject -> Maybe TransportHeader
 transportFromObject (Rec items)
     | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "announce"
     , Just (RecRef ref) <- lookup (BC.pack "identity") items
@@ -97,13 +98,13 @@ transportFromObject (Rec items)
 
 transportFromObject _ = Nothing
 
-serviceToObject :: ServiceHeader -> Object
+serviceToObject :: ServiceHeader -> PartialObject
 serviceToObject (ServiceHeader svc ref) = Rec
         [ (BC.pack "SVC", RecText svc)
         , (BC.pack "ref", RecRef ref)
         ]
 
-serviceFromObject :: Object -> Maybe ServiceHeader
+serviceFromObject :: PartialObject -> Maybe ServiceHeader
 serviceFromObject (Rec items)
     | Just (RecText svc) <- lookup (BC.pack "SVC") items
     , Just (RecRef ref) <- lookup (BC.pack "ref") items
@@ -126,127 +127,146 @@ startServer logd bhost sidentity = do
             return sock
 
         loop sock = do
+            st <- derivePartialStorage $ storedStorage sidentity
             baddr:_ <- getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just bhost) (Just discoveryPort)
-            void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ AnnouncePacket $ storedRef sidentity) (addrAddress baddr)
+            void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ AnnouncePacket $ partialRef st $ storedRef sidentity) (addrAddress baddr)
             forever $ do
                 (msg, paddr) <- recvFrom sock 4096
                 mbpeer <- M.lookup paddr <$> readMVar peers
                 if | Just peer <- mbpeer
                    , ch:_ <- peerChannels peer
                    , Just plain <- channelDecrypt ch msg
-                   , Right (obj:objs) <- runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict plain
+                   , Right (obj:objs) <- runExcept $ deserializeObjects (peerInStorage peer) $ BL.fromStrict plain
                    , Just (ServiceHeader svc ref) <- serviceFromObject obj
-                   -> do forM_ objs $ store $ storedStorage sidentity
-                         writeChan chanSvc (peer, svc, ref)
-
-                   | Right (obj:objs) <- runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict msg
-                   , Just tpack <- transportFromObject obj
-                   -> packet sock paddr tpack objs
-
-                   | otherwise -> logd $ show paddr ++ ": invalid packet"
-
-        packet sock paddr (AnnouncePacket ref) _ = do
+                   -> do forM_ objs $ storeObject $ peerInStorage peer
+                         copyRef (storedStorage sidentity) ref >>= \case
+                             Just pref -> writeChan chanSvc (peer, svc, pref)
+                             Nothing   -> logd $ show paddr ++ ": incomplete service packet"
+
+                   | otherwise -> do
+                       ist <- case mbpeer of
+                                   Just peer -> return $ peerInStorage peer
+                                   Nothing   -> derivePartialStorage $ storedStorage sidentity
+                       if | Right (obj:objs) <- runExcept $ deserializeObjects ist $ BL.fromStrict msg
+                          , Just tpack <- transportFromObject obj
+                          -> packet sock paddr tpack objs ist
+
+                          | otherwise -> logd $ show paddr ++ ": invalid packet"
+
+        packet sock paddr (AnnouncePacket ref) _ ist = do
             logd $ "Got announce: " ++ show ref ++ " from " ++ show paddr
-            when (ref /= storedRef sidentity) $ void $ sendTo sock (BL.toStrict $ BL.concat
-                [ serializeObject $ transportToObject $ IdentityRequest ref (storedRef sidentity)
+            when (refDigest ref /= refDigest (storedRef sidentity)) $ void $ sendTo sock (BL.toStrict $ BL.concat
+                [ serializeObject $ transportToObject $ IdentityRequest ref (partialRef ist $ storedRef sidentity)
                 , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
                 ]) paddr
 
-        packet _ paddr (IdentityRequest ref from) [] = do
+        packet _ paddr (IdentityRequest ref from) [] _ = do
             logd $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr ++ " without content"
 
-        packet sock paddr (IdentityRequest ref from) (obj:objs) = do
+        packet sock paddr (IdentityRequest ref from) (obj:objs) ist = do
             logd $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr
             logd $ show (obj:objs)
-            from' <- store (storedStorage sidentity) obj
+            from' <- storeObject ist obj
             if from == from'
-               then do forM_ objs $ store $ storedStorage sidentity
-                       let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad from) [] sock
-                       modifyMVar_ peers $ return . M.insert paddr peer
-                       writeChan chanPeer peer
-                       void $ sendTo sock (BL.toStrict $ BL.concat
-                           [ serializeObject $ transportToObject $ IdentityResponse (storedRef sidentity)
-                           , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
-                           ]) paddr
+               then do forM_ objs $ storeObject ist
+                       copyRef (storedStorage sidentity) from >>= \case
+                           Nothing -> logd $ "Incomplete peer identity"
+                           Just sfrom -> do
+                               let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad sfrom) [] sock ist
+                               modifyMVar_ peers $ return . M.insert paddr peer
+                               writeChan chanPeer peer
+                               void $ sendTo sock (BL.toStrict $ BL.concat
+                                   [ serializeObject $ transportToObject $ IdentityResponse (partialRef ist $ storedRef sidentity)
+                                   , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
+                                   ]) paddr
                else logd $ "Mismatched content"
 
-        packet _ paddr (IdentityResponse ref) [] = do
+        packet _ paddr (IdentityResponse ref) [] _ = do
             logd $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr ++ " without content"
 
-        packet sock paddr (IdentityResponse ref) (obj:objs) = do
+        packet sock paddr (IdentityResponse ref) (obj:objs) ist = do
             logd $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr
             logd $ show (obj:objs)
-            ref' <- store (storedStorage sidentity) obj
+            ref' <- storeObject ist obj
             if ref == ref'
-               then do forM_ objs $ store $ storedStorage sidentity
-                       let pidentity = wrappedLoad ref
-                           peer = Peer (DatagramAddress paddr) (Just pidentity) [] sock
-                       modifyMVar_ peers $ return . M.insert paddr peer
-                       writeChan chanPeer peer
-                       req <- createChannelRequest sidentity pidentity
-                       void $ sendTo sock (BL.toStrict $ BL.concat
-                           [ serializeObject $ transportToObject $ TrChannelRequest (storedRef req)
-                           , lazyLoadBytes $ storedRef req
-                           , lazyLoadBytes $ storedRef $ signedData $ fromStored req
-                           , lazyLoadBytes $ storedRef $ crKey $ fromStored $ signedData $ fromStored req
-                           , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored req
-                           ]) paddr
+               then do forM_ objs $ storeObject ist
+                       copyRef (storedStorage sidentity) ref >>= \case
+                           Nothing -> logd $ "Incomplete peer identity"
+                           Just sref -> do
+                               let pidentity = wrappedLoad sref
+                                   peer = Peer (DatagramAddress paddr) (Just pidentity) [] sock ist
+                               modifyMVar_ peers $ return . M.insert paddr peer
+                               writeChan chanPeer peer
+                               req <- createChannelRequest sidentity pidentity
+                               void $ sendTo sock (BL.toStrict $ BL.concat
+                                   [ serializeObject $ transportToObject $ TrChannelRequest (partialRef ist $ storedRef req)
+                                   , lazyLoadBytes $ storedRef req
+                                   , lazyLoadBytes $ storedRef $ signedData $ fromStored req
+                                   , lazyLoadBytes $ storedRef $ crKey $ fromStored $ signedData $ fromStored req
+                                   , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored req
+                                   ]) paddr
                else logd $ "Mismatched content"
 
-        packet _ paddr (TrChannelRequest _) [] = do
+        packet _ paddr (TrChannelRequest _) [] _ = do
             logd $ "Got channel request: from " ++ show paddr ++ " without content"
 
-        packet sock paddr (TrChannelRequest ref) (obj:objs) = do
+        packet sock paddr (TrChannelRequest ref) (obj:objs) ist = do
             logd $ "Got channel request: from " ++ show paddr
             logd $ show (obj:objs)
-            ref' <- store (storedStorage sidentity) obj
+            ref' <- storeObject ist obj
             if ref == ref'
-               then do forM_ objs $ store $ storedStorage sidentity
-                       let request = wrappedLoad ref :: Stored ChannelRequest
-                       modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
-                           Just peer | Just pid <- peerIdentity peer ->
-                               runExceptT (acceptChannelRequest sidentity pid request) >>= \case
-                                   Left errs -> do mapM_ logd ("Invalid channel request" : errs)
-                                                   return pval
-                                   Right (acc, channel) -> do
-                                       logd $ "Got channel: " ++ show (storedRef channel)
-                                       let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
-                                       writeChan chanPeer peer'
-                                       void $ sendTo sock (BL.toStrict $ BL.concat
-                                           [ serializeObject $ transportToObject $ TrChannelAccept (storedRef acc)
-                                           , lazyLoadBytes $ storedRef acc
-                                           , lazyLoadBytes $ storedRef $ signedData $ fromStored acc
-                                           , lazyLoadBytes $ storedRef $ caKey $ fromStored $ signedData $ fromStored acc
-                                           , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored acc
-                                           ]) paddr
-                                       return $ M.insert paddr peer' pval
-
-                           _ -> do logd $ "Invalid channel request - no peer identity"
-                                   return pval
+               then do forM_ objs $ storeObject ist
+                       copyRef (storedStorage sidentity) ref >>= \case
+                           Nothing -> logd $ "Incomplete channel request"
+                           Just sref -> do
+                               let request = wrappedLoad sref :: Stored ChannelRequest
+                               modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
+                                   Just peer | Just pid <- peerIdentity peer ->
+                                       runExceptT (acceptChannelRequest sidentity pid request) >>= \case
+                                           Left errs -> do mapM_ logd ("Invalid channel request" : errs)
+                                                           return pval
+                                           Right (acc, channel) -> do
+                                               logd $ "Got channel: " ++ show (storedRef channel)
+                                               let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
+                                               writeChan chanPeer peer'
+                                               void $ sendTo sock (BL.toStrict $ BL.concat
+                                                   [ serializeObject $ transportToObject $ TrChannelAccept (partialRef ist $ storedRef acc)
+                                                   , lazyLoadBytes $ storedRef acc
+                                                   , lazyLoadBytes $ storedRef $ signedData $ fromStored acc
+                                                   , lazyLoadBytes $ storedRef $ caKey $ fromStored $ signedData $ fromStored acc
+                                                   , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored acc
+                                                   ]) paddr
+                                               return $ M.insert paddr peer' pval
+
+                                   _ -> do logd $ "Invalid channel request - no peer identity"
+                                           return pval
                else logd $ "Mismatched content"
 
-        packet _ paddr (TrChannelAccept _) [] = do
+        packet _ paddr (TrChannelAccept _) [] _ = do
             logd $ "Got channel accept: from " ++ show paddr ++ " without content"
 
-        packet _ paddr (TrChannelAccept ref) (obj:objs) = do
+        packet _ paddr (TrChannelAccept ref) (obj:objs) ist = do
             logd $ "Got channel accept: from " ++ show paddr
             logd $ show (obj:objs)
-            ref' <- store (storedStorage sidentity) obj
+            ref' <- storeObject ist obj
             if ref == ref'
-               then do forM_ objs $ store $ storedStorage sidentity
-                       let accepted = wrappedLoad ref :: Stored ChannelAccept
-                       modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
-                           Just peer | Just pid <- peerIdentity peer ->
-                               runExceptT (acceptedChannel sidentity pid accepted) >>= \case
-                                   Left errs -> do mapM_ logd ("Invalid channel accept" : errs)
-                                                   return pval
-                                   Right channel -> do
-                                       logd $ "Got channel: " ++ show (storedRef channel)
-                                       let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
-                                       writeChan chanPeer peer'
-                                       return $ M.insert paddr peer' pval
-                           _ -> do logd $ "Invalid channel accept - no peer identity"
-                                   return pval
+               then do forM_ objs $ storeObject ist
+                       copyRef (storedStorage sidentity) ref >>= \case
+                           Nothing -> logd $ "Incomplete channel accept"
+                           Just sref -> do
+                               let accepted = wrappedLoad sref :: Stored ChannelAccept
+                               modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
+                                   Just peer | Just pid <- peerIdentity peer ->
+                                       runExceptT (acceptedChannel sidentity pid accepted) >>= \case
+                                           Left errs -> do mapM_ logd ("Invalid channel accept" : errs)
+                                                           return pval
+                                           Right channel -> do
+                                               logd $ "Got channel: " ++ show (storedRef channel)
+                                               let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
+                                               writeChan chanPeer peer'
+                                               return $ M.insert paddr peer' pval
+                                   _ -> do logd $ "Invalid channel accept - no peer identity"
+                                           return pval
 
                else logd $ "Mismatched content"
 
@@ -262,12 +282,13 @@ startServer logd bhost sidentity = do
 
 
 sendToPeer :: Storable a => Stored Identity -> Peer -> T.Text -> a -> IO ()
-sendToPeer self peer@Peer { peerChannels = ch:_ } svc obj = do
-    let st = storedStorage self
+sendToPeer _ peer@Peer { peerChannels = ch:_ } svc obj = do
+    let st = peerInStorage peer
     ref <- store st obj
+    Just bytes <- return $ lazyLoadBytes ref
     let plain = BL.toStrict $ BL.concat
             [ serializeObject $ serviceToObject $ ServiceHeader svc ref
-            , lazyLoadBytes ref
+            , bytes
             ]
     ctext <- channelEncrypt ch plain
     let DatagramAddress paddr = peerAddress peer
diff --git a/src/Storage.hs b/src/Storage.hs
index caf9d30..52cda85 100644
--- a/src/Storage.hs
+++ b/src/Storage.hs
@@ -1,18 +1,22 @@
 module Storage (
-    Storage,
-    openStorage,
+    Storage, PartialStorage,
+    openStorage, memoryStorage,
+    deriveEphemeralStorage, derivePartialStorage,
 
-    Ref,
+    Ref, PartialRef,
+    RefDigest, refDigest,
     readRef, showRef,
+    copyRef, partialRef,
 
-    Object(..), RecItem(..),
+    Object, PartialObject, Object'(..), RecItem, RecItem'(..),
     serializeObject, deserializeObject, deserializeObjects,
     storeRawBytes, lazyLoadBytes,
+    storeObject,
     collectObjects, collectStoredObjects,
 
     Head,
     headName, headRef, headObject,
-    loadHeads, loadHead, replaceHead,
+    loadHeads, loadHead, loadHeadDef, replaceHead,
 
     Storable(..),
     StorableText(..), StorableDate(..),
@@ -51,8 +55,12 @@ import qualified Codec.MIME.Type as MIME
 import qualified Codec.MIME.Parse as MIME
 
 import Control.Arrow
+import Control.Concurrent
+import Control.DeepSeq
+import Control.Exception
 import Control.Monad
 import Control.Monad.Except
+import Control.Monad.Identity
 import Control.Monad.Reader
 import Control.Monad.Writer
 
@@ -85,29 +93,43 @@ import Data.Time.Format
 import Data.Time.LocalTime
 
 import System.Directory
+import System.IO.Error
 import System.IO.Unsafe
 
 import Storage.Internal
 
 
+type Storage = Storage' Identity
+type PartialStorage = Storage' Maybe
+
 openStorage :: FilePath -> IO Storage
 openStorage path = do
     createDirectoryIfMissing True $ path ++ "/objects"
     createDirectoryIfMissing True $ path ++ "/heads"
-    return $ Storage path
+    return $ Storage { stBacking = StorageDir path, stParent = Nothing }
+
+memoryStorage' :: IO (Storage' c')
+memoryStorage' = do
+    backing <- StorageMemory <$> newMVar [] <*> newMVar M.empty <*> newMVar M.empty
+    return $ Storage { stBacking = backing, stParent = Nothing }
 
+memoryStorage :: IO Storage
+memoryStorage = memoryStorage'
 
-data Ref = Ref Storage (Digest Blake2b_256)
-    deriving (Eq, Ord)
+deriveEphemeralStorage :: Storage -> IO Storage
+deriveEphemeralStorage parent = do
+    st <- memoryStorage
+    return $ st { stParent = Just parent }
 
-instance Show Ref where
-    show ref@(Ref (Storage path) _) = path ++ ":" ++ BC.unpack (showRef ref)
+derivePartialStorage :: Storage -> IO PartialStorage
+derivePartialStorage parent = do
+    st <- memoryStorage'
+    return $ st { stParent = Just parent }
 
-instance BA.ByteArrayAccess Ref where
-    length (Ref _ dgst) = BA.length dgst
-    withByteArray (Ref _ dgst) = BA.withByteArray dgst
+type Ref = Ref' Identity
+type PartialRef = Ref' Maybe
 
-zeroRef :: Storage -> Ref
+zeroRef :: Storage' c -> Ref' c
 zeroRef s = Ref s h
     where h = case digestFromByteString $ B.replicate (hashDigestSize $ digestAlgo h) 0 of
                    Nothing -> error $ "Failed to create zero hash"
@@ -115,12 +137,12 @@ zeroRef s = Ref s h
           digestAlgo :: Digest a -> a
           digestAlgo = undefined
 
-isZeroRef :: Ref -> Bool
+isZeroRef :: Ref' c -> Bool
 isZeroRef (Ref _ h) = all (==0) $ BA.unpack h
 
 
-unsafeReadRef :: Storage -> ByteString -> Maybe Ref
-unsafeReadRef s = Just . Ref s <=< digestFromByteString . B.concat <=< readHex
+readRefDigest :: ByteString -> Maybe RefDigest
+readRefDigest = digestFromByteString . B.concat <=< readHex
     where readHex bs | B.null bs = Just []
           readHex bs = do (bx, bs') <- B.uncons bs
                           (by, bs'') <- B.uncons bs'
@@ -132,59 +154,93 @@ unsafeReadRef s = Just . Ref s <=< digestFromByteString . B.concat <=< readHex
                      | otherwise                = Nothing
           o = fromIntegral . ord
 
+refFromDigest :: Storage' c -> RefDigest -> IO (Maybe (Ref' c))
+refFromDigest st dgst = fmap (const $ Ref st dgst) <$> ioLoadBytesFromStorage st dgst
+
 readRef :: Storage -> ByteString -> IO (Maybe Ref)
 readRef s b =
-    case unsafeReadRef s b of
+    case readRefDigest b of
          Nothing -> return Nothing
-         Just ref -> do
-             doesFileExist (refPath ref) >>= \case
-                 True -> return $ Just ref
-                 False -> return Nothing
-
-showRef :: Ref -> ByteString
-showRef (Ref _ h) = B.concat $ map showHexByte $ BA.unpack h
-    where showHex x | x < 10    = x + 48
-                    | otherwise = x + 87
-          showHexByte x = B.pack [ showHex (x `div` 16), showHex (x `mod` 16) ]
-
-refPath :: Ref -> FilePath
-refPath ref@(Ref (Storage spath) _) = intercalate "/" [spath, "objects", pref, rest]
-    where (pref, rest) = splitAt 2 $ BC.unpack $ showRef ref
-
-
-data Object = Blob ByteString
-            | Rec [(ByteString, RecItem)]
-            | ZeroObject
+         Just dgst -> refFromDigest s dgst
+
+copyRef' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Ref' c -> IO (c (Ref' c'))
+copyRef' st ref'@(Ref _ dgst) = refFromDigest st dgst >>= \case Just ref -> return $ return ref
+                                                                Nothing  -> doCopy
+    where doCopy = do mbobj' <- ioLoadObject ref'
+                      mbobj <- sequence $ copyObject' st <$> mbobj'
+                      sequence $ storeObject st <$> join mbobj
+
+copyObject' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (c (Object' c'))
+copyObject' _ (Blob bs) = return $ return $ Blob bs
+copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM copyItem rs
+    where copyItem :: (ByteString, RecItem' c) -> IO (c (ByteString, RecItem' c'))
+          copyItem (n, item) = fmap (n,) <$> case item of
+              RecInt x -> return $ return $ RecInt x
+              RecNum x -> return $ return $ RecNum x
+              RecText x -> return $ return $ RecText x
+              RecBinary x -> return $ return $ RecBinary x
+              RecDate x -> return $ return $ RecDate x
+              RecJson x -> return $ return $ RecJson x
+              RecRef x -> fmap RecRef <$> copyRef' st x
+copyObject' _ ZeroObject = return $ return ZeroObject
+
+copyRef :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Ref' c -> IO (LoadResult c (Ref' c'))
+copyRef st ref' = returnLoadResult <$> copyRef' st ref'
+
+copyObject :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (LoadResult c (Object' c'))
+copyObject st obj' = returnLoadResult <$> copyObject' st obj'
+
+partialRef :: PartialStorage -> Ref -> PartialRef
+partialRef st (Ref _ dgst) = Ref st dgst
+
+
+data Object' c
+    = Blob ByteString
+    | Rec [(ByteString, RecItem' c)]
+    | ZeroObject
     deriving (Show)
 
-data RecItem = RecInt Integer
-             | RecNum Rational
-             | RecText Text
-             | RecBinary ByteString
-             | RecDate ZonedTime
-             | RecJson J.Value
-             | RecRef Ref
+type Object = Object' Identity
+type PartialObject = Object' Maybe
+
+data RecItem' c
+    = RecInt Integer
+    | RecNum Rational
+    | RecText Text
+    | RecBinary ByteString
+    | RecDate ZonedTime
+    | RecJson J.Value
+    | RecRef (Ref' c)
     deriving (Show)
 
-serializeObject :: Object -> BL.ByteString
+type RecItem = RecItem' Identity
+
+serializeObject :: Object' c -> BL.ByteString
 serializeObject = \case
     Blob cnt -> BL.fromChunks [BC.pack "blob ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt]
     Rec rec -> let cnt = BL.fromChunks $ concatMap (uncurry serializeRecItem) rec
                 in BL.fromChunks [BC.pack "rec ", BC.pack (show $ BL.length cnt), BC.singleton '\n'] `BL.append` cnt
     ZeroObject -> BL.empty
 
-storeObject :: Storage -> Object -> IO Ref
+storeObject :: Storage' c -> Object' c -> IO (Ref' c)
 storeObject storage = \case
     ZeroObject -> return $ zeroRef storage
-    obj -> storeRawBytes storage $ serializeObject obj
-
-storeRawBytes :: Storage -> BL.ByteString -> IO Ref
-storeRawBytes st raw = do
-  let ref = Ref st $ hashFinalize $ hashUpdates hashInit $ BL.toChunks raw
-  writeFileOnce (refPath ref) $ compress raw
-  return ref
-
-serializeRecItem :: ByteString -> RecItem -> [ByteString]
+    obj -> unsafeStoreRawBytes storage $ serializeObject obj
+
+storeRawBytes :: PartialStorage -> BL.ByteString -> IO PartialRef
+storeRawBytes = unsafeStoreRawBytes
+
+unsafeStoreRawBytes :: Storage' c -> BL.ByteString -> IO (Ref' c)
+unsafeStoreRawBytes st raw = do
+    let dgst = hashFinalize $ hashUpdates hashInit $ BL.toChunks raw
+    case stBacking st of
+         StorageDir sdir -> writeFileOnce (refPath sdir dgst) $ compress raw
+         StorageMemory { memObjs = tobjs } ->
+             dgst `deepseq` -- the TVar may be accessed when evaluating the data to be written
+                 modifyMVar_ tobjs (return . M.insert dgst raw)
+    return $ Ref st dgst
+
+serializeRecItem :: ByteString -> RecItem' c -> [ByteString]
 serializeRecItem name (RecInt x) = [name, BC.pack ":i", BC.singleton ' ', BC.pack (show x), BC.singleton '\n']
 serializeRecItem name (RecNum x) = [name, BC.pack ":n", BC.singleton ' ', BC.pack (showRatio x), BC.singleton '\n']
 serializeRecItem name (RecText x) = [name, BC.pack ":t", BC.singleton ' ', escaped, BC.singleton '\n']
@@ -197,27 +253,29 @@ serializeRecItem name (RecDate x) = [name, BC.pack ":d", BC.singleton ' ', BC.pa
 serializeRecItem name (RecJson x) = [name, BC.pack ":j", BC.singleton ' '] ++ BL.toChunks (J.encode x) ++ [BC.singleton '\n']
 serializeRecItem name (RecRef x) = [name, BC.pack ":r.b2 ", showRef x, BC.singleton '\n']
 
-lazyLoadObject :: Ref -> Object
-lazyLoadObject = fst . lazyLoadObject'
-
-lazyLoadBytes :: Ref -> BL.ByteString
-lazyLoadBytes = snd . lazyLoadObject'
-
-lazyLoadObject' :: Ref -> (Object, BL.ByteString)
-lazyLoadObject' ref | isZeroRef ref = (ZeroObject, BL.empty)
-lazyLoadObject' ref@(Ref st rhash) = unsafePerformIO $ do
-    file <- decompress <$> (BL.readFile $ refPath ref)
-    let Ref _ chash = Ref st $ hashFinalize $ hashUpdates hashInit $ BL.toChunks file
-    when (chash /= rhash) $ error $ "Hash mismatch on object " ++ BC.unpack (showRef ref) {- TODO throw -}
-    let obj = case runExcept $ deserializeObject st file of
-                   Left err -> error $ err ++ ", ref " ++ BC.unpack (showRef ref) {- TODO throw -}
-                   Right (x, rest) | BL.null rest -> x
-                                   | otherwise -> error $ "Superfluous content after " ++ BC.unpack (showRef ref) {- TODO throw -}
-    return (obj, file)
-
-deserializeObject :: Storage -> BL.ByteString -> Except String (Object, BL.ByteString)
-deserializeObject _  bytes | BL.null bytes = return (ZeroObject, bytes)
-deserializeObject st bytes =
+lazyLoadObject :: forall c. StorageCompleteness c => Ref' c -> LoadResult c (Object' c)
+lazyLoadObject = returnLoadResult . unsafePerformIO . ioLoadObject
+
+ioLoadObject :: forall c. StorageCompleteness c => Ref' c -> IO (c (Object' c))
+ioLoadObject ref | isZeroRef ref = return $ return ZeroObject
+ioLoadObject ref@(Ref st rhash) = do
+    file' <- ioLoadBytes ref
+    return $ do
+        file <- file'
+        let chash = hashFinalize $ hashUpdates hashInit $ BL.toChunks file
+        when (chash /= rhash) $ error $ "Hash mismatch on object " ++ BC.unpack (showRef ref) {- TODO throw -}
+        return $ case runExcept $ unsafeDeserializeObject st file of
+                      Left err -> error $ err ++ ", ref " ++ BC.unpack (showRef ref) {- TODO throw -}
+                      Right (x, rest) | BL.null rest -> x
+                                      | otherwise -> error $ "Superfluous content after " ++ BC.unpack (showRef ref) {- TODO throw -}
+
+lazyLoadBytes :: forall c. StorageCompleteness c => Ref' c -> LoadResult c BL.ByteString
+lazyLoadBytes ref | isZeroRef ref = returnLoadResult (return BL.empty :: c BL.ByteString)
+lazyLoadBytes ref = returnLoadResult $ unsafePerformIO $ ioLoadBytes ref
+
+unsafeDeserializeObject :: Storage' c -> BL.ByteString -> Except String (Object' c, BL.ByteString)
+unsafeDeserializeObject _  bytes | BL.null bytes = return (ZeroObject, bytes)
+unsafeDeserializeObject st bytes =
     case BLC.break (=='\n') bytes of
         (line, rest) | Just (otype, len) <- splitObjPrefix line -> do
             let (content, next) = first BL.toStrict $ BL.splitAt (fromIntegral len) $ BL.drop 1 rest
@@ -251,11 +309,14 @@ deserializeObject st bytes =
                           "b" -> either (const Nothing) (Just . RecBinary) $ convertFromBase Base64 content
                           "d" -> RecDate <$> parseTimeM False defaultTimeLocale "%s %z" (BC.unpack content)
                           "j" -> RecJson <$> J.decode (BL.fromStrict content)
-                          "r.b2" -> RecRef <$> unsafeReadRef st content
+                          "r.b2" -> RecRef . Ref st <$> readRefDigest content
                           _   -> Nothing
               return (name, val)
 
-deserializeObjects :: Storage -> BL.ByteString -> Except String [Object]
+deserializeObject :: PartialStorage -> BL.ByteString -> Except String (PartialObject, BL.ByteString)
+deserializeObject = unsafeDeserializeObject
+
+deserializeObjects :: PartialStorage -> BL.ByteString -> Except String [PartialObject]
 deserializeObjects _  bytes | BL.null bytes = return []
 deserializeObjects st bytes = do (obj, rest) <- deserializeObject st bytes
                                  (obj:) <$> deserializeObjects st rest
@@ -267,17 +328,18 @@ collectObjects obj = obj : map fromStored (fst $ collectOtherStored S.empty obj)
 collectStoredObjects :: Stored Object -> [Stored Object]
 collectStoredObjects obj = obj : (fst $ collectOtherStored S.empty $ fromStored obj)
 
-collectOtherStored :: Set Ref -> Object -> ([Stored Object], Set Ref)
+collectOtherStored :: Set RefDigest -> Object -> ([Stored Object], Set RefDigest)
 collectOtherStored seen (Rec items) = foldr helper ([], seen) $ map snd items
-    where helper (RecRef r) (xs, s) | r `S.notMember` s = let o = wrappedLoad r
-                                                              (xs', s') = collectOtherStored (S.insert r s) $ fromStored o
-                                                           in ((o : xs') ++ xs, s')
+    where helper (RecRef ref) (xs, s) | r <- refDigest ref
+                                      , r `S.notMember` s
+                                      = let o = wrappedLoad ref
+                                            (xs', s') = collectOtherStored (S.insert r s) $ fromStored o
+                                         in ((o : xs') ++ xs, s')
           helper _          (xs, s) = (xs, s)
 collectOtherStored seen _ = ([], seen)
 
 
-data Head = Head String Ref
-    deriving (Show)
+type Head = Head' Identity
 
 headName :: Head -> String
 headName (Head name _) = name
@@ -290,39 +352,63 @@ headObject = load . headRef
 
 
 loadHeads :: Storage -> IO [Head]
-loadHeads s@(Storage spath) = do
+loadHeads s@(Storage { stBacking = StorageDir spath }) = do
     let hpath = spath ++ "/heads/"
     files <- filterM (doesFileExist . (hpath++)) =<< getDirectoryContents hpath
     forM files $ \hname -> do
         (h:_) <- BC.lines <$> B.readFile (hpath ++ "/" ++ hname)
         Just ref <- readRef s h
         return $ Head hname ref
+loadHeads Storage { stBacking = StorageMemory { memHeads = theads } } = readMVar theads
 
-loadHead :: Storage -> String -> IO Head
-loadHead s@(Storage spath) hname = do
-    let hpath = spath ++ "/heads/"
-    (h:_) <- BC.lines <$> B.readFile (hpath ++ hname)
-    Just ref <- readRef s h
-    return $ Head hname ref
+loadHead :: Storage -> String -> IO (Maybe Head)
+loadHead s@(Storage { stBacking = StorageDir spath }) hname = do
+    handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do
+        let hpath = spath ++ "/heads/"
+        (h:_) <- BC.lines <$> B.readFile (hpath ++ hname)
+        Just ref <- readRef s h
+        return $ Just $ Head hname ref
+loadHead Storage { stBacking = StorageMemory { memHeads = theads } } hname =
+    find ((==hname) . headName) <$> readMVar theads
+
+loadHeadDef :: Storable a => Storage -> String -> IO a -> IO Head
+loadHeadDef s hname gen = loadHead s hname >>= \case
+        Just h  -> return h
+        Nothing -> do obj <- gen
+                      Right h <- replaceHead obj (Left (s, hname))
+                      return h
 
 replaceHead :: Storable a => a -> Either (Storage, String) Head -> IO (Either (Maybe Head) Head)
 replaceHead obj prev = do
+    let (st, name) = either id (\(Head n (Ref s _)) -> (s, n)) prev
     ref <- store st obj
-    writeFileChecked filename (either (const Nothing) (Just . showRefL . headRef) prev) (showRefL ref) >>= \case
-        Left Nothing -> return $ Left Nothing
-        Left (Just bs) -> do Just oref <- readRef st $ BC.takeWhile (/='\n') bs
-                             return $ Left $ Just $ Head name oref
-        Right () -> return $ Right $ Head name ref
-    where (st@(Storage spath), name) = either id (\(Head n (Ref s _)) -> (s, n)) prev
-          filename = spath ++ "/heads/" ++ name
-          showRefL ref = showRef ref `B.append` BC.singleton '\n'
+    case stBacking st of
+         StorageDir spath -> do
+             let filename = spath ++ "/heads/" ++ name
+                 showRefL r = showRef r `B.append` BC.singleton '\n'
+
+             writeFileChecked filename (either (const Nothing) (Just . showRefL . headRef) prev) (showRefL ref) >>= \case
+                 Left Nothing -> return $ Left Nothing
+                 Left (Just bs) -> do Just oref <- readRef st $ BC.takeWhile (/='\n') bs
+                                      return $ Left $ Just $ Head name oref
+                 Right () -> return $ Right $ Head name ref
+
+         StorageMemory { memHeads = theads } -> modifyMVar theads $ \hs ->
+             case (partition ((== name) . headName) hs, prev) of
+                  (([], _), Left _)  -> let h = Head name ref
+                                         in return (h:hs, Right h)
+                  (([], _), Right _) -> return (hs, Left Nothing)
+                  ((h:_, _), Left _) -> return (hs, Left (Just h))
+                  ((h:_, hs'), Right h') | headRef h == headRef h' -> let nh = Head name ref
+                                                                       in return (nh:hs', Right nh)
+                                         | otherwise -> return (hs, Left (Just h))
 
 
 class Storable a where
     store' :: a -> Store
     load' :: Load a
 
-    store :: Storage -> a -> IO Ref
+    store :: StorageCompleteness c => Storage' c -> a -> IO (Ref' c)
     store st = storeObject st <=< evalStore st . store'
     load :: Ref -> a
     load ref = let Load f = load'
@@ -332,15 +418,15 @@ class Storable a => ZeroStorable a where
     fromZero :: Storage -> a
 
 data Store = StoreBlob ByteString
-           | StoreRec (Storage -> [IO [(ByteString, RecItem)]])
+           | StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]])
            | StoreZero
 
-evalStore :: Storage -> Store -> IO Object
+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
 
-type StoreRec = ReaderT Storage (Writer [IO [(ByteString, RecItem)]]) ()
+type StoreRec c = ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
 
 data Load a = Load (Ref -> Object -> Either String a)
 
@@ -349,12 +435,14 @@ type LoadRec a = ReaderT (Ref, [(ByteString, RecItem)]) (Either String) a
 
 instance Storable Object where
     store' (Blob bs) = StoreBlob bs
-    store' (Rec xs) = StoreRec $ const $ map (return.return) xs
+    store' (Rec xs) = StoreRec $ \st -> return $ do
+        Rec xs' <- copyObject st (Rec xs)
+        return xs'
     store' ZeroObject = StoreZero
 
     load' = Load $ const return
 
-    store = storeObject
+    store st = storeObject st <=< copyObject st
     load = lazyLoadObject
 
 instance Storable ByteString where
@@ -382,7 +470,7 @@ instance Storable a => ZeroStorable [a] where
 storeBlob :: ByteString -> Store
 storeBlob = StoreBlob
 
-storeRec :: StoreRec -> Store
+storeRec :: (forall c. StorageCompleteness c => StoreRec c) -> Store
 storeRec r = StoreRec $ execWriter . runReaderT r
 
 storeZero :: Store
@@ -420,59 +508,63 @@ instance StorableDate Day where
     fromDate = utctDay . fromDate
 
 
-storeInt :: Integral a => String -> a -> StoreRec
+storeInt :: Integral a => String -> a -> StoreRec c
 storeInt name x = tell [return [(BC.pack name, RecInt $ toInteger x)]]
 
-storeMbInt :: Integral a => String -> Maybe a -> StoreRec
+storeMbInt :: Integral a => String -> Maybe a -> StoreRec c
 storeMbInt name = maybe (return ()) (storeInt name)
 
-storeNum :: (Real a, Fractional a) => String -> a -> StoreRec
+storeNum :: (Real a, Fractional a) => String -> a -> StoreRec c
 storeNum name x = tell [return [(BC.pack name, RecNum $ toRational x)]]
 
-storeMbNum :: (Real a, Fractional a) => String -> Maybe a -> StoreRec
+storeMbNum :: (Real a, Fractional a) => String -> Maybe a -> StoreRec c
 storeMbNum name = maybe (return ()) (storeNum name)
 
-storeText :: StorableText a => String -> a -> StoreRec
+storeText :: StorableText a => String -> a -> StoreRec c
 storeText name x = tell [return [(BC.pack name, RecText $ toText x)]]
 
-storeMbText :: StorableText a => String -> Maybe a -> StoreRec
+storeMbText :: StorableText a => String -> Maybe a -> StoreRec c
 storeMbText name = maybe (return ()) (storeText name)
 
-storeBinary :: BA.ByteArrayAccess a => String -> a -> StoreRec
+storeBinary :: BA.ByteArrayAccess a => String -> a -> StoreRec c
 storeBinary name x = tell [return [(BC.pack name, RecBinary $ BA.convert x)]]
 
-storeMbBinary :: BA.ByteArrayAccess a => String -> Maybe a -> StoreRec
+storeMbBinary :: BA.ByteArrayAccess a => String -> Maybe a -> StoreRec c
 storeMbBinary name = maybe (return ()) (storeBinary name)
 
-storeDate :: StorableDate a => String -> a -> StoreRec
+storeDate :: StorableDate a => String -> a -> StoreRec c
 storeDate name x = tell [return [(BC.pack name, RecDate $ toDate x)]]
 
-storeMbDate :: StorableDate a => String -> Maybe a -> StoreRec
+storeMbDate :: StorableDate a => String -> Maybe a -> StoreRec c
 storeMbDate name = maybe (return ()) (storeDate name)
 
-storeJson :: J.ToJSON a => String -> a -> StoreRec
+storeJson :: J.ToJSON a => String -> a -> StoreRec c
 storeJson name x = tell [return [(BC.pack name, RecJson $ J.toJSON x)]]
 
-storeMbJson :: J.ToJSON a => String -> Maybe a -> StoreRec
+storeMbJson :: J.ToJSON a => String -> Maybe a -> StoreRec c
 storeMbJson name = maybe (return ()) (storeJson name)
 
-storeRef :: Storable a => String -> a -> StoreRec
+storeRef :: Storable a => StorageCompleteness c => String -> a -> StoreRec c
 storeRef name x = do
     s <- ask
     tell $ (:[]) $ do
         ref <- store s x
         return [(BC.pack name, RecRef ref)]
 
-storeMbRef :: Storable a => String -> Maybe a -> StoreRec
+storeMbRef :: Storable a => StorageCompleteness c => String -> Maybe a -> StoreRec c
 storeMbRef name = maybe (return ()) (storeRef name)
 
-storeRawRef :: String -> Ref -> StoreRec
-storeRawRef name ref = tell [return [(BC.pack name, RecRef ref)]]
+storeRawRef :: StorageCompleteness c => String -> Ref -> StoreRec c
+storeRawRef name ref = do
+    st <- ask
+    tell $ (:[]) $ do
+        ref' <- copyRef st ref
+        return [(BC.pack name, RecRef ref')]
 
-storeMbRawRef :: String -> Maybe Ref -> StoreRec
+storeMbRawRef :: StorageCompleteness c => String -> Maybe Ref -> StoreRec c
 storeMbRawRef name = maybe (return ()) (storeRawRef name)
 
-storeZRef :: ZeroStorable a => String -> a -> StoreRec
+storeZRef :: (ZeroStorable a, StorageCompleteness c) => String -> a -> StoreRec c
 storeZRef name x = do
     s <- ask
     tell $ (:[]) $ do
@@ -588,14 +680,13 @@ data Stored a = Stored Ref a
     deriving (Show)
 
 instance Eq (Stored a) where
-    Stored r1 _ == Stored r2 _  =  r1 == r2
+    Stored r1 _ == Stored r2 _  =  refDigest r1 == refDigest r2
 
 instance Ord (Stored a) where
-    compare (Stored r1 _) (Stored r2 _) = compare r1 r2
+    compare (Stored r1 _) (Stored r2 _) = compare (refDigest r1) (refDigest r2)
 
 instance Storable a => Storable (Stored a) where
-    store st (Stored ref@(Ref st' _) x) | st' == st = return ref
-                                        | otherwise = store st x
+    store st = copyRef st . storedRef
     store' (Stored _ x) = store' x
     load' = Load $ \ref obj ->
                 let Load fres = load'
@@ -632,7 +723,7 @@ makeStoreInfo = StoreInfo
     <$> getZonedTime
     <*> pure Nothing
 
-storeInfoRec :: StoreInfo -> StoreRec
+storeInfoRec :: StoreInfo -> StoreRec c
 storeInfoRec info = do
     storeDate "date" $ infoDate info
     storeMbText "note" $ infoNote info
@@ -785,23 +876,23 @@ findSListRef _ (Stored _ ListNil) = Nothing
 findSListRef x (Stored ref (ListItem _ _ y next)) | y == Just x = Just ref
                                                   | otherwise   = findSListRef x next
 
-mapFromSList :: Storable a => StoredList a -> Map Ref (Stored a)
+mapFromSList :: Storable a => StoredList a -> Map RefDigest (Stored a)
 mapFromSList list = helper list M.empty
-    where helper :: Storable a => StoredList a -> Map Ref (Stored a) -> Map Ref (Stored a)
+    where helper :: Storable a => StoredList a -> Map RefDigest (Stored a) -> Map RefDigest (Stored a)
           helper (Stored _ ListNil) cur = cur
           helper (Stored _ (ListItem (Just rref) _ (Just x) rest)) cur =
               let rxref = case load rref of
                                ListItem _ _ (Just rx) _  -> sameType rx x $ storedRef rx
                                _ -> error "mapFromSList: malformed list"
-               in helper rest $ case M.lookup (storedRef x) cur of
-                                     Nothing -> M.insert rxref x cur
-                                     Just x' -> M.insert rxref x' cur
+               in helper rest $ case M.lookup (refDigest $ storedRef x) cur of
+                                     Nothing -> M.insert (refDigest rxref) x cur
+                                     Just x' -> M.insert (refDigest rxref) x' cur
           helper (Stored _ (ListItem _ _ _ rest)) cur = helper rest cur
           sameType :: a -> a -> b -> b
           sameType _ _ x = x
 
-updateOld :: Map Ref (Stored a) -> Stored a -> Stored a
-updateOld m x = fromMaybe x $ M.lookup (storedRef x) m
+updateOld :: Map RefDigest (Stored a) -> Stored a -> Stored a
+updateOld m x = fromMaybe x $ M.lookup (refDigest $ storedRef x) m
 
 
 data StoreUpdate a = StoreKeep
diff --git a/src/Storage/Internal.hs b/src/Storage/Internal.hs
index 6a86dea..400af8f 100644
--- a/src/Storage/Internal.hs
+++ b/src/Storage/Internal.hs
@@ -1,20 +1,113 @@
 module Storage.Internal where
 
+import Codec.Compression.Zlib
+
+import Control.Concurrent
 import Control.Exception
+import Control.Monad
+import Control.Monad.Identity
+
+import Crypto.Hash
 
+import Data.ByteArray (ByteArrayAccess, ScrubbedBytes)
+import qualified Data.ByteArray as BA
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString.Lazy as BL
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as M
 
 import System.Directory
 import System.FilePath
 import System.IO
+import System.IO.Error
 import System.Posix.Files
 import System.Posix.IO
 import System.Posix.Types
 
-data Storage = Storage FilePath
-    deriving (Eq, Ord)
+
+data Storage' c = Storage
+    { stBacking :: StorageBacking c
+    , stParent :: Maybe (Storage' Identity)
+    }
+    deriving (Eq)
+
+instance Show (Storage' c) where
+    show st@(Storage { stBacking = StorageDir path }) = "dir" ++ showParentStorage st ++ ":" ++ path
+    show st@(Storage { stBacking = StorageMemory {} }) = "mem" ++ showParentStorage st
+
+showParentStorage :: Storage' c -> String
+showParentStorage Storage { stParent = Nothing } = ""
+showParentStorage Storage { stParent = Just st } = "@" ++ show st
+
+data StorageBacking c
+         = StorageDir FilePath
+         | StorageMemory { memHeads :: MVar [Head' c]
+                         , memObjs :: MVar (Map RefDigest BL.ByteString)
+                         , memKeys :: MVar (Map RefDigest ScrubbedBytes)
+                         }
+    deriving (Eq)
+
+
+type RefDigest = Digest Blake2b_256
+
+data Ref' c = Ref (Storage' c) RefDigest
+    deriving (Eq)
+
+instance Show (Ref' c) where
+    show ref@(Ref st _) = show st ++ ":" ++ BC.unpack (showRef ref)
+
+instance ByteArrayAccess (Ref' c) where
+    length (Ref _ dgst) = BA.length dgst
+    withByteArray (Ref _ dgst) = BA.withByteArray dgst
+
+refDigest :: Ref' c -> RefDigest
+refDigest (Ref _ dgst) = dgst
+
+showRef :: Ref' c -> ByteString
+showRef = showRefDigest . refDigest
+
+showRefDigest :: RefDigest -> ByteString
+showRefDigest = B.concat . map showHexByte . BA.unpack
+    where showHex x | x < 10    = x + 48
+                    | otherwise = x + 87
+          showHexByte x = B.pack [ showHex (x `div` 16), showHex (x `mod` 16) ]
+
+
+data Head' c = Head String (Ref' c)
+    deriving (Show)
+
+
+class (Traversable compl, Monad compl) => StorageCompleteness compl where
+    type LoadResult compl a :: *
+    returnLoadResult :: compl a -> LoadResult compl a
+    ioLoadBytes :: Ref' compl -> IO (compl BL.ByteString)
+
+instance StorageCompleteness Identity where
+    type LoadResult Identity a = a
+    returnLoadResult = runIdentity
+    ioLoadBytes ref@(Ref st dgst) = maybe (error $ "Ref not found in complete storage: "++show ref) Identity
+        <$> ioLoadBytesFromStorage st dgst
+
+instance StorageCompleteness Maybe where
+    type LoadResult Maybe a = Maybe a
+    returnLoadResult = id
+    ioLoadBytes (Ref st dgst) = ioLoadBytesFromStorage st dgst
+
+ioLoadBytesFromStorage :: Storage' c -> RefDigest -> IO (Maybe BL.ByteString)
+ioLoadBytesFromStorage st dgst = loadCurrent st >>=
+    \case Just bytes -> return $ Just bytes
+          Nothing | Just parent <- stParent st -> ioLoadBytesFromStorage parent dgst
+                  | otherwise                  -> return Nothing
+    where loadCurrent Storage { stBacking = StorageDir spath } = handleJust (guard . isDoesNotExistError) (const $ return Nothing) $
+              Just . decompress <$> (BL.readFile $ refPath spath dgst)
+          loadCurrent Storage { stBacking = StorageMemory { memObjs = tobjs } } = M.lookup dgst <$> readMVar tobjs
+
+refPath :: FilePath -> RefDigest -> FilePath
+refPath spath dgst = intercalate "/" [spath, "objects", pref, rest]
+    where (pref, rest) = splitAt 2 $ BC.unpack $ showRefDigest dgst
 
 
 openFdParents :: FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
diff --git a/src/Storage/Key.hs b/src/Storage/Key.hs
index 3ed4a66..8e6d04c 100644
--- a/src/Storage/Key.hs
+++ b/src/Storage/Key.hs
@@ -3,9 +3,13 @@ module Storage.Key (
     storeKey, loadKey,
 ) where
 
+import Control.Concurrent.MVar
+import Control.Monad
+
 import Data.ByteArray
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString.Lazy as BL
+import qualified Data.Map as M
 
 import System.FilePath
 import System.IO.Error
@@ -20,17 +24,20 @@ class Storable pub => KeyPair sec pub | sec -> pub, pub -> sec where
     keyFromData :: ScrubbedBytes -> Stored pub -> Maybe sec
 
 
-keyStorage :: Storage -> FilePath
-keyStorage (Storage base) = base </> "keys"
-
-keyFilePath :: KeyPair sec pub => Stored pub -> FilePath
-keyFilePath pkey = keyStorage (storedStorage pkey) </> (BC.unpack $ showRef $ storedRef pkey)
+keyFilePath :: KeyPair sec pub => FilePath -> Stored pub -> FilePath
+keyFilePath sdir pkey = sdir </> "keys" </> (BC.unpack $ showRef $ storedRef pkey)
 
 storeKey :: KeyPair sec pub => sec -> IO ()
-storeKey key = writeFileOnce (keyFilePath $ keyGetPublic key) (BL.fromStrict $ convert $ keyGetData key)
+storeKey key = do
+    let spub = keyGetPublic key
+    case stBacking $ storedStorage spub of
+         StorageDir dir -> writeFileOnce (keyFilePath dir spub) (BL.fromStrict $ convert $ keyGetData key)
+         StorageMemory { memKeys = kstore } -> modifyMVar_ kstore $ return . M.insert (refDigest $ storedRef spub) (keyGetData key)
 
 loadKey :: KeyPair sec pub => Stored pub -> IO (Maybe sec)
 loadKey spub = do
-    tryIOError (BC.readFile (keyFilePath spub)) >>= \case
-        Right kdata -> return $ keyFromData (convert kdata) spub
-        Left _ -> return Nothing
+    case stBacking $ storedStorage spub of
+         StorageDir dir -> tryIOError (BC.readFile (keyFilePath dir spub)) >>= \case
+             Right kdata -> return $ keyFromData (convert kdata) spub
+             Left _ -> return Nothing
+         StorageMemory { memKeys = kstore } -> (flip keyFromData spub <=< M.lookup (refDigest $ storedRef spub)) <$> readMVar kstore