StorageBackend type class

Changelog: API: Added `StorageBackend` type class to allow custom storage implementation

8 files changed, 528 insertions, 361 deletions

diff --git a/src/Erebos/Object/Internal.hs b/src/Erebos/Object/Internal.hs
index f08e734..5d88ad0 100644
--- a/src/Erebos/Object/Internal.hs
+++ b/src/Erebos/Object/Internal.hs
@@ -1,7 +1,5 @@
 module Erebos.Object.Internal (
     Storage, PartialStorage, StorageCompleteness,
-    openStorage, memoryStorage,
-    deriveEphemeralStorage, derivePartialStorage,
 
     Ref, PartialRef, RefDigest,
     refDigest,
@@ -48,8 +46,6 @@ module Erebos.Object.Internal (
 ) where
 
 import Control.Applicative
-import Control.Concurrent
-import Control.Exception
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
@@ -66,8 +62,6 @@ import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString.Lazy.Char8 as BLC
 import Data.Char
 import Data.Function
-import qualified Data.HashTable.IO as HT
-import qualified Data.Map as M
 import Data.Maybe
 import Data.Ratio
 import Data.Set (Set)
@@ -83,92 +77,11 @@ import Data.Time.LocalTime
 import Data.UUID (UUID)
 import qualified Data.UUID as U
 
-import System.Directory
-import System.FilePath
-import System.IO.Error
 import System.IO.Unsafe
 
 import Erebos.Storage.Internal
 
 
-type Storage = Storage' Complete
-type PartialStorage = Storage' Partial
-
-storageVersion :: String
-storageVersion = "0.1"
-
-openStorage :: FilePath -> IO Storage
-openStorage path = modifyIOError annotate $ do
-    let versionFileName = "erebos-storage"
-    let versionPath = path </> versionFileName
-    let writeVersionFile = writeFileOnce versionPath $ BLC.pack $ storageVersion <> "\n"
-
-    maybeVersion <- handleJust (guard . isDoesNotExistError) (const $ return Nothing) $
-        Just <$> readFile versionPath
-    version <- case maybeVersion of
-        Just versionContent -> do
-            return $ takeWhile (/= '\n') versionContent
-
-        Nothing -> do
-            files <- handleJust (guard . isDoesNotExistError) (const $ return []) $
-                listDirectory path
-            when (not $ or
-                    [ null files
-                    , versionFileName `elem` files
-                    , (versionFileName ++ ".lock") `elem` files
-                    , "objects" `elem` files && "heads" `elem` files
-                    ]) $ do
-                fail "directory is neither empty, nor an existing erebos storage"
-
-            createDirectoryIfMissing True $ path
-            writeVersionFile
-            takeWhile (/= '\n') <$> readFile versionPath
-
-    when (version /= storageVersion) $ do
-        fail $ "unsupported storage version " <> version
-
-    createDirectoryIfMissing True $ path </> "objects"
-    createDirectoryIfMissing True $ path </> "heads"
-    watchers <- newMVar (Nothing, [], WatchList 1 [])
-    refgen <- newMVar =<< HT.new
-    refroots <- newMVar =<< HT.new
-    return $ Storage
-        { stBacking = StorageDir path watchers
-        , stParent = Nothing
-        , stRefGeneration = refgen
-        , stRefRoots = refroots
-        }
-  where
-    annotate e = annotateIOError e "failed to open storage" Nothing (Just path)
-
-memoryStorage' :: IO (Storage' c')
-memoryStorage' = do
-    backing <- StorageMemory <$> newMVar [] <*> newMVar M.empty <*> newMVar M.empty <*> newMVar (WatchList 1 [])
-    refgen <- newMVar =<< HT.new
-    refroots <- newMVar =<< HT.new
-    return $ Storage
-        { stBacking = backing
-        , stParent = Nothing
-        , stRefGeneration = refgen
-        , stRefRoots = refroots
-        }
-
-memoryStorage :: IO Storage
-memoryStorage = memoryStorage'
-
-deriveEphemeralStorage :: Storage -> IO Storage
-deriveEphemeralStorage parent = do
-    st <- memoryStorage
-    return $ st { stParent = Just parent }
-
-derivePartialStorage :: Storage -> IO PartialStorage
-derivePartialStorage parent = do
-    st <- memoryStorage'
-    return $ st { stParent = Just parent }
-
-type Ref = Ref' Complete
-type PartialRef = Ref' Partial
-
 zeroRef :: Storage' c -> Ref' c
 zeroRef s = Ref s (RefDigest h)
     where h = case digestFromByteString $ B.replicate (hashDigestSize $ digestAlgo h) 0 of
diff --git a/src/Erebos/Storage.hs b/src/Erebos/Storage.hs
index 4344b75..f1cce84 100644
--- a/src/Erebos/Storage.hs
+++ b/src/Erebos/Storage.hs
@@ -24,4 +24,6 @@ module Erebos.Storage (
 ) where
 
 import Erebos.Object.Internal
+import Erebos.Storage.Disk
 import Erebos.Storage.Head
+import Erebos.Storage.Memory
diff --git a/src/Erebos/Storage/Backend.hs b/src/Erebos/Storage/Backend.hs
new file mode 100644
index 0000000..620d423
--- /dev/null
+++ b/src/Erebos/Storage/Backend.hs
@@ -0,0 +1,28 @@
+{-|
+Description: Implement custom storage backend
+
+Exports type class, which can be used to create custom 'Storage' backend.
+-}
+
+module Erebos.Storage.Backend (
+    StorageBackend(..),
+    Complete, Partial,
+    Storage, PartialStorage,
+    newStorage,
+
+    WatchID, startWatchID, nextWatchID,
+) where
+
+import Control.Concurrent.MVar
+
+import Data.HashTable.IO qualified as HT
+
+import Erebos.Object.Internal
+import Erebos.Storage.Internal
+
+
+newStorage :: StorageBackend bck => bck -> IO (Storage' (BackendCompleteness bck))
+newStorage stBackend = do
+    stRefGeneration <- newMVar =<< HT.new
+    stRefRoots <- newMVar =<< HT.new
+    return Storage {..}
diff --git a/src/Erebos/Storage/Disk.hs b/src/Erebos/Storage/Disk.hs
new file mode 100644
index 0000000..01821f7
--- /dev/null
+++ b/src/Erebos/Storage/Disk.hs
@@ -0,0 +1,230 @@
+module Erebos.Storage.Disk (
+    openStorage,
+) where
+
+import Codec.Compression.Zlib
+
+import Control.Arrow
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+
+import Data.ByteArray qualified as BA
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as B
+import Data.ByteString.Char8 qualified as BC
+import Data.ByteString.Lazy qualified as BL
+import Data.ByteString.Lazy.Char8 qualified as BLC
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.UUID qualified as U
+
+import System.Directory
+import System.FSNotify
+import System.FilePath
+import System.IO
+import System.IO.Error
+
+import Erebos.Object
+import Erebos.Storage.Backend
+import Erebos.Storage.Head
+import Erebos.Storage.Internal
+import Erebos.Storage.Platform
+
+
+data DiskStorage = StorageDir
+    { dirPath :: FilePath
+    , dirWatchers :: MVar ( Maybe WatchManager, [ HeadTypeID ], WatchList )
+    }
+
+instance Eq DiskStorage where
+    (==) = (==) `on` dirPath
+
+instance Show DiskStorage where
+    show StorageDir { dirPath = path } = "dir:" ++ path
+
+instance StorageBackend DiskStorage where
+    backendLoadBytes StorageDir {..} dgst =
+        handleJust (guard . isDoesNotExistError) (const $ return Nothing) $
+              Just . decompress . BL.fromChunks . (:[]) <$> (B.readFile $ refPath dirPath dgst)
+    backendStoreBytes StorageDir {..} dgst = writeFileOnce (refPath dirPath dgst) . compress
+
+
+    backendLoadHeads StorageDir {..} tid = do
+        let hpath = headTypePath dirPath tid
+
+        files <- filterM (doesFileExist . (hpath </>)) =<<
+            handleJust (\e -> guard (isDoesNotExistError e)) (const $ return [])
+            (getDirectoryContents hpath)
+        fmap catMaybes $ forM files $ \hname -> do
+            case U.fromString hname of
+                 Just hid -> do
+                     content <- B.readFile (hpath </> hname)
+                     return $ do
+                         (h : _) <- Just (BC.lines content)
+                         dgst <- readRefDigest h
+                         Just $ ( HeadID hid, dgst )
+                 Nothing -> return Nothing
+
+    backendLoadHead StorageDir {..} tid hid = do
+        handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do
+            (h:_) <- BC.lines <$> B.readFile (headPath dirPath tid hid)
+            return $ readRefDigest h
+
+    backendStoreHead StorageDir {..} tid hid dgst = do
+         Right () <- writeFileChecked (headPath dirPath tid hid) Nothing $
+             showRefDigest dgst `B.append` BC.singleton '\n'
+         return ()
+
+    backendReplaceHead StorageDir {..} tid hid expected new = do
+         let filename = headPath dirPath tid hid
+             showDgstL r = showRefDigest r `B.append` BC.singleton '\n'
+
+         writeFileChecked filename (Just $ showDgstL expected) (showDgstL new) >>= \case
+             Left Nothing -> return $ Left Nothing
+             Left (Just bs) -> do Just cur <- return $ readRefDigest $ BC.takeWhile (/='\n') bs
+                                  return $ Left $ Just cur
+             Right () -> return $ Right new
+
+    backendWatchHead st@StorageDir {..} tid hid cb = do
+        modifyMVar dirWatchers $ \( mbmanager, ilist, wl ) -> do
+            manager <- maybe startManager return mbmanager
+            ilist' <- case tid `elem` ilist of
+                True -> return ilist
+                False -> do
+                    void $ watchDir manager (headTypePath dirPath tid) (const True) $ \case
+                        Added { eventPath = fpath } | Just ihid <- HeadID <$> U.fromString (takeFileName fpath) -> do
+                            backendLoadHead st tid ihid >>= \case
+                                Just dgst -> do
+                                    (_, _, iwl) <- readMVar dirWatchers
+                                    mapM_ ($ dgst) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList $ iwl
+                                Nothing -> return ()
+                        _ -> return ()
+                    return $ tid : ilist
+            return $ first ( Just manager, ilist', ) $ watchListAdd tid hid cb wl
+
+    backendUnwatchHead StorageDir {..} wid = do
+        modifyMVar_ dirWatchers $ \( mbmanager, ilist, wl ) -> do
+            return ( mbmanager, ilist, watchListDel wid wl )
+
+
+    backendListKeys StorageDir {..} = do
+        catMaybes . map (readRefDigest . BC.pack) <$>
+            listDirectory (keyDirPath dirPath)
+
+    backendLoadKey StorageDir {..} dgst = do
+        tryIOError (BC.readFile (keyFilePath dirPath dgst)) >>= \case
+            Right kdata -> return $ Just $ BA.convert kdata
+            Left _ -> return Nothing
+
+    backendStoreKey StorageDir {..} dgst key = do
+        writeFileOnce (keyFilePath dirPath dgst) (BL.fromStrict $ BA.convert key)
+
+    backendRemoveKey StorageDir {..} dgst = do
+        void $ tryIOError (removeFile $ keyFilePath dirPath dgst)
+
+
+storageVersion :: String
+storageVersion = "0.1"
+
+openStorage :: FilePath -> IO Storage
+openStorage path = modifyIOError annotate $ do
+    let versionFileName = "erebos-storage"
+    let versionPath = path </> versionFileName
+    let writeVersionFile = writeFileOnce versionPath $ BLC.pack $ storageVersion <> "\n"
+
+    maybeVersion <- handleJust (guard . isDoesNotExistError) (const $ return Nothing) $
+        Just <$> readFile versionPath
+    version <- case maybeVersion of
+        Just versionContent -> do
+            return $ takeWhile (/= '\n') versionContent
+
+        Nothing -> do
+            files <- handleJust (guard . isDoesNotExistError) (const $ return []) $
+                listDirectory path
+            when (not $ or
+                    [ null files
+                    , versionFileName `elem` files
+                    , (versionFileName ++ ".lock") `elem` files
+                    , "objects" `elem` files && "heads" `elem` files
+                    ]) $ do
+                fail "directory is neither empty, nor an existing erebos storage"
+
+            createDirectoryIfMissing True $ path
+            writeVersionFile
+            takeWhile (/= '\n') <$> readFile versionPath
+
+    when (version /= storageVersion) $ do
+        fail $ "unsupported storage version " <> version
+
+    createDirectoryIfMissing True $ path </> "objects"
+    createDirectoryIfMissing True $ path </> "heads"
+    watchers <- newMVar ( Nothing, [], WatchList startWatchID [] )
+    newStorage $ StorageDir path watchers
+  where
+    annotate e = annotateIOError e "failed to open storage" Nothing (Just path)
+
+
+refPath :: FilePath -> RefDigest -> FilePath
+refPath spath rdgst = intercalate "/" [ spath, "objects", BC.unpack alg, pref, rest ]
+    where (alg, dgst) = showRefDigestParts rdgst
+          (pref, rest) = splitAt 2 $ BC.unpack dgst
+
+headTypePath :: FilePath -> HeadTypeID -> FilePath
+headTypePath spath (HeadTypeID tid) = spath </> "heads" </> U.toString tid
+
+headPath :: FilePath -> HeadTypeID -> HeadID -> FilePath
+headPath spath tid (HeadID hid) = headTypePath spath tid </> U.toString hid
+
+keyDirPath :: FilePath -> FilePath
+keyDirPath sdir = sdir </> "keys"
+
+keyFilePath :: FilePath -> RefDigest -> FilePath
+keyFilePath sdir dgst = keyDirPath sdir </> (BC.unpack $ showRefDigest dgst)
+
+
+openLockFile :: FilePath -> IO Handle
+openLockFile path = do
+    createDirectoryIfMissing True (takeDirectory path)
+    retry 10 $ createFileExclusive path
+  where
+    retry :: Int -> IO a -> IO a
+    retry 0 act = act
+    retry n act = catchJust (\e -> if isAlreadyExistsError e then Just () else Nothing)
+                      act (\_ -> threadDelay (100 * 1000) >> retry (n - 1) act)
+
+writeFileOnce :: FilePath -> BL.ByteString -> IO ()
+writeFileOnce file content = bracket (openLockFile locked)
+    hClose $ \h -> do
+        doesFileExist file >>= \case
+            True  -> removeFile locked
+            False -> do BL.hPut h content
+                        hClose h
+                        renameFile locked file
+    where locked = file ++ ".lock"
+
+writeFileChecked :: FilePath -> Maybe ByteString -> ByteString -> IO (Either (Maybe ByteString) ())
+writeFileChecked file prev content = bracket (openLockFile locked)
+    hClose $ \h -> do
+        (prev,) <$> doesFileExist file >>= \case
+            (Nothing, True) -> do
+                current <- B.readFile file
+                removeFile locked
+                return $ Left $ Just current
+            (Nothing, False) -> do B.hPut h content
+                                   hClose h
+                                   renameFile locked file
+                                   return $ Right ()
+            (Just expected, True) -> do
+                current <- B.readFile file
+                if current == expected then do B.hPut h content
+                                               hClose h
+                                               renameFile locked file
+                                               return $ return ()
+                                       else do removeFile locked
+                                               return $ Left $ Just current
+            (Just _, False) -> do
+                removeFile locked
+                return $ Left Nothing
+    where locked = file ++ ".lock"
diff --git a/src/Erebos/Storage/Head.hs b/src/Erebos/Storage/Head.hs
index dc8b7bc..8f8e009 100644
--- a/src/Erebos/Storage/Head.hs
+++ b/src/Erebos/Storage/Head.hs
@@ -23,27 +23,17 @@ module Erebos.Storage.Head (
 ) where
 
 import Control.Concurrent
-import Control.Exception
 import Control.Monad
-import Control.Monad.IO.Class
 import Control.Monad.Reader
 
 import Data.Bifunctor
-import Data.ByteString qualified as B
-import Data.ByteString.Char8 qualified as BC
-import Data.List
-import Data.Maybe
 import Data.Typeable
 import Data.UUID qualified as U
 import Data.UUID.V4 qualified as U
 
-import System.Directory
-import System.FSNotify
-import System.FilePath
-import System.IO.Error
-
 import Erebos.Object
 import Erebos.Storable
+import Erebos.Storage.Backend
 import Erebos.Storage.Internal
 
 
@@ -97,31 +87,11 @@ mkHeadTypeID :: String -> HeadTypeID
 mkHeadTypeID = maybe (error "Invalid head type ID") HeadTypeID . U.fromString
 
 
-headTypePath :: FilePath -> HeadTypeID -> FilePath
-headTypePath spath (HeadTypeID tid) = spath </> "heads" </> U.toString tid
-
-headPath :: FilePath -> HeadTypeID -> HeadID -> FilePath
-headPath spath tid (HeadID hid) = headTypePath spath tid </> U.toString hid
-
 -- | Load all `Head's of type @a@ from storage.
 loadHeads :: forall a m. MonadIO m => HeadType a => Storage -> m [Head a]
-loadHeads s@(Storage { stBacking = StorageDir { dirPath = spath }}) = liftIO $ do
-    let hpath = headTypePath spath $ headTypeID @a Proxy
-
-    files <- filterM (doesFileExist . (hpath </>)) =<<
-        handleJust (\e -> guard (isDoesNotExistError e)) (const $ return [])
-        (getDirectoryContents hpath)
-    fmap catMaybes $ forM files $ \hname -> do
-        case U.fromString hname of
-             Just hid -> do
-                 (h:_) <- BC.lines <$> B.readFile (hpath </> hname)
-                 Just ref <- readRef s h
-                 return $ Just $ Head (HeadID hid) $ wrappedLoad ref
-             Nothing -> return Nothing
-loadHeads Storage { stBacking = StorageMemory { memHeads = theads } } = liftIO $ do
-    let toHead ((tid, hid), ref) | tid == headTypeID @a Proxy = Just $ Head hid $ wrappedLoad ref
-                                 | otherwise                  = Nothing
-    catMaybes . map toHead <$> readMVar theads
+loadHeads st@Storage {..} =
+    map (uncurry Head . fmap (wrappedLoad . Ref st))
+        <$> liftIO (backendLoadHeads stBackend (headTypeID @a Proxy))
 
 -- | Try to load a `Head' of type @a@ from storage.
 loadHead
@@ -138,13 +108,8 @@ loadHeadRaw
     -> HeadTypeID  -- ^ ID of the head type
     -> HeadID  -- ^ ID of the particular head
     -> m (Maybe Ref)  -- ^ `Ref' pointing to the head object, or `Nothing' if not found
-loadHeadRaw s@(Storage { stBacking = StorageDir { dirPath = spath }}) tid hid = liftIO $ do
-    handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do
-        (h:_) <- BC.lines <$> B.readFile (headPath spath tid hid)
-        Just ref <- readRef s h
-        return $ Just ref
-loadHeadRaw Storage { stBacking = StorageMemory { memHeads = theads } } tid hid = liftIO $ do
-    lookup (tid, hid) <$> readMVar theads
+loadHeadRaw st@Storage {..} tid hid = do
+    fmap (Ref st) <$> liftIO (backendLoadHead stBackend tid hid)
 
 -- | Reload the given head from storage, returning `Head' with updated object,
 -- or `Nothing' if there is no longer head with the particular ID in storage.
@@ -162,15 +127,9 @@ storeHead st obj = do
 -- | Store a new `Head' in the storage, using the raw `HeadTypeID' and `Ref',
 -- the function returns the assigned `HeadID' of the new head.
 storeHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> Ref -> m HeadID
-storeHeadRaw st tid ref = liftIO $ do
+storeHeadRaw Storage {..} tid ref = liftIO $ do
     hid <- HeadID <$> U.nextRandom
-    case stBacking st of
-         StorageDir { dirPath = spath } -> do
-             Right () <- writeFileChecked (headPath spath tid hid) Nothing $
-                 showRef ref `B.append` BC.singleton '\n'
-             return ()
-         StorageMemory { memHeads = theads } -> do
-             modifyMVar_ theads $ return . (((tid, hid), ref) :)
+    backendStoreHead stBackend tid hid (refDigest ref)
     return hid
 
 -- | Try to replace existing `Head' of type @a@ in the storage. Function fails
@@ -216,29 +175,9 @@ replaceHeadRaw
         -- [@`Right' r@]:
         --     Head value was updated in storage, the new head value is @r@
         --     (which is the same as the indended value).
-replaceHeadRaw st tid hid prev new = liftIO $ do
-    case stBacking st of
-         StorageDir { dirPath = spath } -> do
-             let filename = headPath spath tid hid
-                 showRefL r = showRef r `B.append` BC.singleton '\n'
-
-             writeFileChecked filename (Just $ showRefL prev) (showRefL new) >>= \case
-                 Left Nothing -> return $ Left Nothing
-                 Left (Just bs) -> do Just oref <- readRef st $ BC.takeWhile (/='\n') bs
-                                      return $ Left $ Just oref
-                 Right () -> return $ Right new
-
-         StorageMemory { memHeads = theads, memWatchers = twatch } -> do
-             res <- modifyMVar theads $ \hs -> do
-                 ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar twatch
-                 return $ case partition ((==(tid, hid)) . fst) hs of
-                     ([] , _  ) -> (hs, Left Nothing)
-                     ((_, r):_, hs') | r == prev -> (((tid, hid), new) : hs',
-                                                                  Right (new, ws))
-                                     | otherwise -> (hs, Left $ Just r)
-             case res of
-                  Right (r, ws) -> mapM_ ($ r) ws >> return (Right r)
-                  Left x -> return $ Left x
+replaceHeadRaw st@Storage {..} tid hid prev new = liftIO $ do
+    _ <- copyRef st new
+    bimap (fmap $ Ref st) (Ref st) <$> backendReplaceHead stBackend tid hid (refDigest prev) (refDigest new)
 
 -- | Update existing existing `Head' of type @a@ in the storage, using a given
 -- function. The update function may be called multiple times in case the head
@@ -299,50 +238,22 @@ watchHeadWith (Head hid (Stored (Ref st _) _)) sel cb = do
 
 -- | Watch the given head using raw IDs and a selector from `Ref'.
 watchHeadRaw :: forall b. Eq b => Storage -> HeadTypeID -> HeadID -> (Ref -> b) -> (b -> IO ()) -> IO WatchedHead
-watchHeadRaw st tid hid sel cb = do
+watchHeadRaw st@Storage {..} tid hid sel cb = do
     memo <- newEmptyMVar
-    let addWatcher wl = (wl', WatchedHead st (wlNext wl) memo)
-            where wl' = wl { wlNext = wlNext wl + 1
-                           , wlList = WatchListItem
-                               { wlID = wlNext wl
-                               , wlHead = (tid, hid)
-                               , wlFun = \r -> do
-                                   let x = sel r
-                                   modifyMVar_ memo $ \prev -> do
-                                       when (Just x /= prev) $ cb x
-                                       return $ Just x
-                               } : wlList wl
-                           }
-
-    watched <- case stBacking st of
-         StorageDir { dirPath = spath, dirWatchers = mvar } -> modifyMVar mvar $ \(mbmanager, ilist, wl) -> do
-             manager <- maybe startManager return mbmanager
-             ilist' <- case tid `elem` ilist of
-                 True -> return ilist
-                 False -> do
-                     void $ watchDir manager (headTypePath spath tid) (const True) $ \case
-                         Added { eventPath = fpath } | Just ihid <- HeadID <$> U.fromString (takeFileName fpath) -> do
-                             loadHeadRaw st tid ihid >>= \case
-                                 Just ref -> do
-                                     (_, _, iwl) <- readMVar mvar
-                                     mapM_ ($ ref) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList $ iwl
-                                 Nothing -> return ()
-                         _ -> return ()
-                     return $ tid : ilist
-             return $ first ( Just manager, ilist', ) $ addWatcher wl
-
-         StorageMemory { memWatchers = mvar } -> modifyMVar mvar $ return . addWatcher
+    let cb' dgst = do
+            let x = sel (Ref st dgst)
+            modifyMVar_ memo $ \prev -> do
+                when (Just x /= prev) $ cb x
+                return $ Just x
+    wid <- backendWatchHead stBackend tid hid cb'
 
     cur <- fmap sel <$> loadHeadRaw st tid hid
     maybe (return ()) cb cur
     putMVar memo cur
 
-    return watched
+    return $ WatchedHead st wid memo
 
 -- | Stop watching previously watched head.
 unwatchHead :: WatchedHead -> IO ()
-unwatchHead (WatchedHead st wid _) = do
-    let delWatcher wl = wl { wlList = filter ((/=wid) . wlID) $ wlList wl }
-    case stBacking st of
-        StorageDir { dirWatchers = mvar } -> modifyMVar_ mvar $ return . second delWatcher
-        StorageMemory { memWatchers = mvar } -> modifyMVar_ mvar $ return . delWatcher
+unwatchHead (WatchedHead Storage {..} wid _) = do
+    backendUnwatchHead stBackend wid
diff --git a/src/Erebos/Storage/Internal.hs b/src/Erebos/Storage/Internal.hs
index 3e8d8b6..59d0af0 100644
--- a/src/Erebos/Storage/Internal.hs
+++ b/src/Erebos/Storage/Internal.hs
@@ -1,11 +1,8 @@
 module Erebos.Storage.Internal where
 
-import Codec.Compression.Zlib
-
 import Control.Arrow
 import Control.Concurrent
 import Control.DeepSeq
-import Control.Exception
 import Control.Monad
 import Control.Monad.Identity
 
@@ -13,76 +10,145 @@ import Crypto.Hash
 
 import Data.Bits
 import Data.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes)
-import qualified Data.ByteArray as BA
+import Data.ByteArray qualified 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.ByteString qualified as B
+import Data.ByteString.Char8 qualified as BC
+import Data.ByteString.Lazy qualified as BL
 import Data.Char
-import Data.Function
+import Data.HashTable.IO qualified as HT
 import Data.Hashable
-import qualified Data.HashTable.IO as HT
 import Data.Kind
-import Data.List
-import Data.Map (Map)
-import qualified Data.Map as M
+import Data.Typeable
 import Data.UUID (UUID)
 
 import Foreign.Storable (peek)
 
-import System.Directory
-import System.FSNotify (WatchManager)
-import System.FilePath
-import System.IO
-import System.IO.Error
 import System.IO.Unsafe (unsafePerformIO)
 
-import Erebos.Storage.Platform
-
 
-data Storage' c = Storage
-    { stBacking :: StorageBacking c
-    , stParent :: Maybe (Storage' Identity)
+data Storage' c = forall bck. (StorageBackend bck, BackendCompleteness bck ~ c) => Storage
+    { stBackend :: bck
     , stRefGeneration :: MVar (HT.BasicHashTable RefDigest Generation)
     , stRefRoots :: MVar (HT.BasicHashTable RefDigest [RefDigest])
     }
 
+type Storage = Storage' Complete
+type PartialStorage = Storage' Partial
+
 instance Eq (Storage' c) where
-    (==) = (==) `on` (stBacking &&& stParent)
+    Storage { stBackend = b } == Storage { stBackend = b' }
+        | Just b'' <- cast b' =  b == b''
+        | otherwise           =  False
 
 instance Show (Storage' c) where
-    show st@(Storage { stBacking = StorageDir { dirPath = 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 { dirPath :: FilePath
-                      , dirWatchers :: MVar ( Maybe WatchManager, [ HeadTypeID ], WatchList c )
-                      }
-         | StorageMemory { memHeads :: MVar [((HeadTypeID, HeadID), Ref' c)]
-                         , memObjs :: MVar (Map RefDigest BL.ByteString)
-                         , memKeys :: MVar (Map RefDigest ScrubbedBytes)
-                         , memWatchers :: MVar (WatchList c)
-                         }
-    deriving (Eq)
+    show Storage { stBackend = b } = show b ++ showParentStorage b
+
+showParentStorage :: StorageBackend bck => bck -> String
+showParentStorage bck
+    | Just (st :: Storage) <- cast (backendParent bck) = "@" ++ show st
+    | Just (st :: PartialStorage) <- cast (backendParent bck) = "@" ++ show st
+    | otherwise = ""
+
+
+class (Eq bck, Show bck, Typeable bck, Typeable (BackendParent bck)) => StorageBackend bck where
+    type BackendCompleteness bck :: Type -> Type
+    type BackendCompleteness bck = Complete
+
+    type BackendParent bck :: Type
+    type BackendParent bck = ()
+    backendParent :: bck -> BackendParent bck
+    default backendParent :: BackendParent bck ~ () => bck -> BackendParent bck
+    backendParent _ = ()
+
+
+    backendLoadBytes :: bck -> RefDigest -> IO (Maybe BL.ByteString)
+    default backendLoadBytes :: BackendParent bck ~ Storage => bck -> RefDigest -> IO (Maybe BL.ByteString)
+    backendLoadBytes bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadBytes bck'
+
+    backendStoreBytes :: bck -> RefDigest -> BL.ByteString -> IO ()
+    default backendStoreBytes :: BackendParent bck ~ Storage => bck -> RefDigest -> BL.ByteString -> IO ()
+    backendStoreBytes bck = case backendParent bck of Storage { stBackend = bck' } -> backendStoreBytes bck'
+
+
+    backendLoadHeads :: bck -> HeadTypeID -> IO [ ( HeadID, RefDigest ) ]
+    default backendLoadHeads :: BackendParent bck ~ Storage => bck -> HeadTypeID -> IO [ ( HeadID, RefDigest ) ]
+    backendLoadHeads bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadHeads bck'
+
+    backendLoadHead :: bck -> HeadTypeID -> HeadID -> IO (Maybe RefDigest)
+    default backendLoadHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> IO (Maybe RefDigest)
+    backendLoadHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadHead bck'
+
+    backendStoreHead :: bck -> HeadTypeID -> HeadID -> RefDigest -> IO ()
+    default backendStoreHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> RefDigest -> IO ()
+    backendStoreHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendStoreHead bck'
+
+    backendReplaceHead :: bck -> HeadTypeID -> HeadID -> RefDigest -> RefDigest -> IO (Either (Maybe RefDigest) RefDigest)
+    default backendReplaceHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> RefDigest -> RefDigest -> IO (Either (Maybe RefDigest) RefDigest)
+    backendReplaceHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendReplaceHead bck'
+
+    backendWatchHead :: bck -> HeadTypeID -> HeadID -> (RefDigest -> IO ()) -> IO WatchID
+    default backendWatchHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> (RefDigest -> IO ()) -> IO WatchID
+    backendWatchHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendWatchHead bck'
+
+    backendUnwatchHead :: bck -> WatchID -> IO ()
+    default backendUnwatchHead :: BackendParent bck ~ Storage => bck -> WatchID -> IO ()
+    backendUnwatchHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendUnwatchHead bck'
+
+
+    backendListKeys :: bck -> IO [ RefDigest ]
+    default backendListKeys :: BackendParent bck ~ Storage => bck -> IO [ RefDigest ]
+    backendListKeys bck = case backendParent bck of Storage { stBackend = bck' } -> backendListKeys bck'
+
+    backendLoadKey :: bck -> RefDigest -> IO (Maybe ScrubbedBytes)
+    default backendLoadKey :: BackendParent bck ~ Storage => bck -> RefDigest -> IO (Maybe ScrubbedBytes)
+    backendLoadKey bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadKey bck'
+
+    backendStoreKey :: bck -> RefDigest -> ScrubbedBytes -> IO ()
+    default backendStoreKey :: BackendParent bck ~ Storage => bck -> RefDigest -> ScrubbedBytes -> IO ()
+    backendStoreKey bck = case backendParent bck of Storage { stBackend = bck' } -> backendStoreKey bck'
+
+    backendRemoveKey :: bck -> RefDigest -> IO ()
+    default backendRemoveKey :: BackendParent bck ~ Storage => bck -> RefDigest -> IO ()
+    backendRemoveKey bck = case backendParent bck of Storage { stBackend = bck' } -> backendRemoveKey bck'
+
+
 
 newtype WatchID = WatchID Int
-    deriving (Eq, Ord, Num)
+    deriving (Eq, Ord)
+
+startWatchID :: WatchID
+startWatchID = WatchID 1
 
-data WatchList c = WatchList
+nextWatchID :: WatchID -> WatchID
+nextWatchID (WatchID n) = WatchID (n + 1)
+
+data WatchList = WatchList
     { wlNext :: WatchID
-    , wlList :: [WatchListItem c]
+    , wlList :: [ WatchListItem ]
     }
 
-data WatchListItem c = WatchListItem
+data WatchListItem = WatchListItem
     { wlID :: WatchID
-    , wlHead :: (HeadTypeID, HeadID)
-    , wlFun :: Ref' c -> IO ()
+    , wlHead :: ( HeadTypeID, HeadID )
+    , wlFun :: RefDigest -> IO ()
     }
 
+watchListAdd :: HeadTypeID -> HeadID -> (RefDigest -> IO ()) -> WatchList -> ( WatchList, WatchID )
+watchListAdd tid hid cb wl = ( wl', wlNext wl )
+  where
+    wl' = wl
+        { wlNext = nextWatchID (wlNext wl)
+        , wlList = WatchListItem
+            { wlID = wlNext wl
+            , wlHead = (tid, hid)
+            , wlFun = cb
+            } : wlList wl
+        }
+
+watchListDel :: WatchID -> WatchList -> WatchList
+watchListDel wid wl = wl { wlList = filter ((/= wid) . wlID) $ wlList wl }
+
 
 newtype RefDigest = RefDigest (Digest Blake2b_256)
     deriving (Eq, Ord, NFData, ByteArrayAccess)
@@ -92,6 +158,9 @@ instance Show RefDigest where
 
 data Ref' c = Ref (Storage' c) RefDigest
 
+type Ref = Ref' Complete
+type PartialRef = Ref' Partial
+
 instance Eq (Ref' c) where
     Ref _ d1 == Ref _ d2  =  d1 == d2
 
@@ -183,7 +252,7 @@ storedStorage (Stored (Ref st _) _) = st
 type Complete = Identity
 type Partial = Either RefDigest
 
-class (Traversable compl, Monad compl) => StorageCompleteness compl where
+class (Traversable compl, Monad compl, Typeable compl) => StorageCompleteness compl where
     type LoadResult compl a :: Type
     returnLoadResult :: compl a -> LoadResult compl a
     ioLoadBytes :: Ref' compl -> IO (compl BL.ByteString)
@@ -200,71 +269,16 @@ instance StorageCompleteness Partial where
     ioLoadBytes (Ref st dgst) = maybe (Left dgst) Right <$> ioLoadBytesFromStorage st dgst
 
 unsafeStoreRawBytes :: Storage' c -> BL.ByteString -> IO (Ref' c)
-unsafeStoreRawBytes st raw = do
+unsafeStoreRawBytes st@Storage {..} raw = do
     let dgst = hashToRefDigest raw
-    case stBacking st of
-         StorageDir { dirPath = 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)
+    backendStoreBytes stBackend dgst raw
     return $ Ref 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 { dirPath = spath } } = handleJust (guard . isDoesNotExistError) (const $ return Nothing) $
-              Just . decompress . BL.fromChunks . (:[]) <$> (B.readFile $ refPath spath dgst)
-          loadCurrent Storage { stBacking = StorageMemory { memObjs = tobjs } } = M.lookup dgst <$> readMVar tobjs
-
-refPath :: FilePath -> RefDigest -> FilePath
-refPath spath rdgst = intercalate "/" [spath, "objects", BC.unpack alg, pref, rest]
-    where (alg, dgst) = showRefDigestParts rdgst
-          (pref, rest) = splitAt 2 $ BC.unpack dgst
-
-
-openLockFile :: FilePath -> IO Handle
-openLockFile path = do
-    createDirectoryIfMissing True (takeDirectory path)
-    retry 10 $ createFileExclusive path
-  where
-    retry :: Int -> IO a -> IO a
-    retry 0 act = act
-    retry n act = catchJust (\e -> if isAlreadyExistsError e then Just () else Nothing)
-                      act (\_ -> threadDelay (100 * 1000) >> retry (n - 1) act)
-
-writeFileOnce :: FilePath -> BL.ByteString -> IO ()
-writeFileOnce file content = bracket (openLockFile locked)
-    hClose $ \h -> do
-        doesFileExist file >>= \case
-            True  -> removeFile locked
-            False -> do BL.hPut h content
-                        hClose h
-                        renameFile locked file
-    where locked = file ++ ".lock"
-
-writeFileChecked :: FilePath -> Maybe ByteString -> ByteString -> IO (Either (Maybe ByteString) ())
-writeFileChecked file prev content = bracket (openLockFile locked)
-    hClose $ \h -> do
-        (prev,) <$> doesFileExist file >>= \case
-            (Nothing, True) -> do
-                current <- B.readFile file
-                removeFile locked
-                return $ Left $ Just current
-            (Nothing, False) -> do B.hPut h content
-                                   hClose h
-                                   renameFile locked file
-                                   return $ Right ()
-            (Just expected, True) -> do
-                current <- B.readFile file
-                if current == expected then do B.hPut h content
-                                               hClose h
-                                               renameFile locked file
-                                               return $ return ()
-                                       else do removeFile locked
-                                               return $ Left $ Just current
-            (Just _, False) -> do
-                removeFile locked
-                return $ Left Nothing
-    where locked = file ++ ".lock"
+ioLoadBytesFromStorage Storage {..} dgst =
+    backendLoadBytes stBackend dgst >>= \case
+        Just bytes -> return $ Just bytes
+        Nothing
+            | Just (parent :: Storage) <- cast (backendParent stBackend) -> ioLoadBytesFromStorage parent dgst
+            | Just (parent :: PartialStorage) <- cast (backendParent stBackend) -> ioLoadBytesFromStorage parent dgst
+            | otherwise -> return Nothing
diff --git a/src/Erebos/Storage/Key.hs b/src/Erebos/Storage/Key.hs
index 626d684..fab2103 100644
--- a/src/Erebos/Storage/Key.hs
+++ b/src/Erebos/Storage/Key.hs
@@ -4,19 +4,12 @@ module Erebos.Storage.Key (
     moveKeys,
 ) where
 
-import Control.Concurrent.MVar
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class
 
 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.Directory
-import System.FilePath
-import System.IO.Error
+import Data.Typeable
 
 import Erebos.Storable
 import Erebos.Storage.Internal
@@ -28,59 +21,32 @@ class Storable pub => KeyPair sec pub | sec -> pub, pub -> sec where
     keyFromData :: ScrubbedBytes -> Stored pub -> Maybe sec
 
 
-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 = do
     let spub = keyGetPublic key
-    case stBacking $ storedStorage spub of
-         StorageDir { dirPath = dir } -> writeFileOnce (keyFilePath dir spub) (BL.fromStrict $ convert $ keyGetData key)
-         StorageMemory { memKeys = kstore } -> modifyMVar_ kstore $ return . M.insert (refDigest $ storedRef spub) (keyGetData key)
+    case storedStorage spub of
+        Storage {..} -> backendStoreKey stBackend (refDigest $ storedRef spub) (keyGetData key)
 
 loadKey :: (KeyPair sec pub, MonadIO m, MonadError String m) => Stored pub -> m sec
 loadKey pub = maybe (throwError $ "secret key not found for " <> show (storedRef pub)) return =<< loadKeyMb pub
 
-loadKeyMb :: (KeyPair sec pub, MonadIO m) => Stored pub -> m (Maybe sec)
+loadKeyMb :: forall sec pub m. (KeyPair sec pub, MonadIO m) => Stored pub -> m (Maybe sec)
 loadKeyMb spub = liftIO $ run $ storedStorage spub
   where
-    run st = tryOneLevel (stBacking st) >>= \case
-        key@Just {} -> return key
-        Nothing | Just parent <- stParent st -> run parent
-                | otherwise -> return Nothing
-    tryOneLevel = \case
-        StorageDir { dirPath = 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
+    run :: Storage' c -> IO (Maybe sec)
+    run Storage {..} = backendLoadKey stBackend (refDigest $ storedRef spub) >>= \case
+        Just bytes -> return $ keyFromData bytes spub
+        Nothing
+            | Just (parent :: Storage) <- cast (backendParent stBackend) -> run parent
+            | Just (parent :: PartialStorage) <- cast (backendParent stBackend) -> run parent
+            | otherwise -> return Nothing
 
 moveKeys :: MonadIO m => Storage -> Storage -> m ()
-moveKeys from to = liftIO $ do
-    case (stBacking from, stBacking to) of
-        (StorageDir { dirPath = fromPath }, StorageDir { dirPath = toPath }) -> do
-            files <- listDirectory (fromPath </> "keys")
-            forM_ files $ \file -> do
-                renameFile (fromPath </> "keys" </> file) (toPath </> "keys" </> file)
-
-        (StorageDir { dirPath = fromPath }, StorageMemory { memKeys = toKeys }) -> do
-            let move m file
-                    | Just dgst <- readRefDigest (BC.pack file) = do
-                        let path = fromPath </> "keys" </> file
-                        key <- convert <$> BC.readFile path
-                        removeFile path
-                        return $ M.insert dgst key m
-                    | otherwise = return m
-            files <- listDirectory (fromPath </> "keys")
-            modifyMVar_ toKeys $ \keys -> foldM move keys files
-
-        (StorageMemory { memKeys = fromKeys }, StorageDir { dirPath = toPath }) -> do
-            modifyMVar_ fromKeys $ \keys -> do
-                forM_ (M.assocs keys) $ \(dgst, key) ->
-                    writeFileOnce (toPath </> "keys" </> (BC.unpack $ showRefDigest dgst)) (BL.fromStrict $ convert key)
-                return M.empty
-
-        (StorageMemory { memKeys = fromKeys }, StorageMemory { memKeys = toKeys }) -> do
-            when (fromKeys /= toKeys) $ do
-                modifyMVar_ fromKeys $ \fkeys -> do
-                    modifyMVar_ toKeys $ return . M.union fkeys
-                    return M.empty
+moveKeys Storage { stBackend = from } Storage { stBackend = to } = liftIO $ do
+    keys <- backendListKeys from
+    forM_ keys $ \key -> do
+        backendLoadKey from key >>= \case
+            Just sec -> do
+                backendStoreKey to key sec
+                backendRemoveKey from key
+            Nothing -> return ()
diff --git a/src/Erebos/Storage/Memory.hs b/src/Erebos/Storage/Memory.hs
new file mode 100644
index 0000000..dd382b6
--- /dev/null
+++ b/src/Erebos/Storage/Memory.hs
@@ -0,0 +1,103 @@
+module Erebos.Storage.Memory (
+    memoryStorage,
+    deriveEphemeralStorage,
+    derivePartialStorage,
+) where
+
+import Control.Concurrent.MVar
+import Control.DeepSeq
+
+import Data.ByteArray (ScrubbedBytes)
+import Data.ByteString.Lazy qualified as BL
+import Data.Function
+import Data.Kind
+import Data.List
+import Data.Map (Map)
+import Data.Map qualified as M
+import Data.Maybe
+import Data.Typeable
+
+import Erebos.Object
+import Erebos.Storage.Backend
+import Erebos.Storage.Head
+import Erebos.Storage.Internal
+
+
+data MemoryStorage p (c :: Type -> Type) = StorageMemory
+    { memParent :: p
+    , memHeads :: MVar [ (( HeadTypeID, HeadID ), RefDigest ) ]
+    , memObjs :: MVar (Map RefDigest BL.ByteString)
+    , memKeys :: MVar (Map RefDigest ScrubbedBytes)
+    , memWatchers :: MVar WatchList
+    }
+
+instance Eq (MemoryStorage p c) where
+    (==) = (==) `on` memObjs
+
+instance Show (MemoryStorage p c) where
+    show StorageMemory {} = "mem"
+
+instance (StorageCompleteness c, Typeable p) => StorageBackend (MemoryStorage p c) where
+    type BackendCompleteness (MemoryStorage p c) = c
+    type BackendParent (MemoryStorage p c) = p
+    backendParent = memParent
+
+    backendLoadBytes StorageMemory {..} dgst =
+        M.lookup dgst <$> readMVar memObjs
+
+    backendStoreBytes StorageMemory {..} dgst raw =
+        dgst `deepseq` -- the TVar may be accessed when evaluating the data to be written
+            modifyMVar_ memObjs (return . M.insert dgst raw)
+
+
+    backendLoadHeads StorageMemory {..} tid = do
+        let toRes ( ( tid', hid ), dgst )
+                | tid' == tid = Just ( hid, dgst )
+                | otherwise   = Nothing
+        catMaybes . map toRes <$> readMVar memHeads
+
+    backendLoadHead StorageMemory {..} tid hid =
+        lookup (tid, hid) <$> readMVar memHeads
+
+    backendStoreHead StorageMemory {..} tid hid dgst =
+        modifyMVar_ memHeads $ return . (( ( tid, hid ), dgst ) :)
+
+    backendReplaceHead StorageMemory {..} tid hid expected new = do
+        res <- modifyMVar memHeads $ \hs -> do
+            ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar memWatchers
+            return $ case partition ((==(tid, hid)) . fst) hs of
+                ( [] , _ ) -> ( hs, Left Nothing )
+                (( _, dgst ) : _, hs' )
+                    | dgst == expected -> ((( tid, hid ), new ) : hs', Right ( new, ws ))
+                    | otherwise -> ( hs, Left $ Just dgst )
+        case res of
+            Right ( dgst, ws ) -> mapM_ ($ dgst) ws >> return (Right dgst)
+            Left x -> return $ Left x
+
+    backendWatchHead StorageMemory {..} tid hid cb = modifyMVar memWatchers $ return . watchListAdd tid hid cb
+
+    backendUnwatchHead StorageMemory {..} wid = modifyMVar_ memWatchers $ return . watchListDel wid
+
+
+    backendListKeys StorageMemory {..} = M.keys <$> readMVar memKeys
+    backendLoadKey StorageMemory {..} dgst = M.lookup dgst <$> readMVar memKeys
+    backendStoreKey StorageMemory {..} dgst key = modifyMVar_ memKeys $ return . M.insert dgst key
+    backendRemoveKey StorageMemory {..} dgst = modifyMVar_ memKeys $ return . M.delete dgst
+
+
+memoryStorage' :: (StorageCompleteness c, Typeable p) => p -> IO (Storage' c)
+memoryStorage' memParent = do
+    memHeads <- newMVar []
+    memObjs <- newMVar M.empty
+    memKeys <- newMVar M.empty
+    memWatchers <- newMVar (WatchList startWatchID [])
+    newStorage $ StorageMemory {..}
+
+memoryStorage :: IO Storage
+memoryStorage = memoryStorage' ()
+
+deriveEphemeralStorage :: Storage -> IO Storage
+deriveEphemeralStorage parent = memoryStorage' parent
+
+derivePartialStorage :: Storage -> IO PartialStorage
+derivePartialStorage parent = memoryStorage' parent