Cache storage

1 files changed, 96 insertions, 0 deletions

diff --git a/src/Storage/Cache.hs b/src/Storage/Cache.hs
new file mode 100644
index 0000000..9be59c2
--- /dev/null
+++ b/src/Storage/Cache.hs
@@ -0,0 +1,96 @@
+module Storage.Cache (
+    cacheStorage,
+) where
+
+import Control.Concurrent
+
+import Data.ByteString qualified as B
+import Data.ByteString.Lazy qualified as BL
+import Data.Function
+import Data.Map (Map)
+import Data.Map qualified as M
+
+import Erebos.Object
+import Erebos.Storage.Backend
+import Erebos.Storage.Head
+
+import Storage.WatchList
+
+
+data CacheStorage = StorageCache
+    { cacheParent :: Storage
+    , cacheHeads :: MVar [ (( HeadTypeID, HeadID ), RefDigest ) ]
+    , cacheObjs :: MVar (Map RefDigest BL.ByteString)
+    , cacheKeys :: MVar (Map RefDigest B.ByteString)
+    , cacheWatchers :: MVar WatchList
+    }
+
+instance Eq CacheStorage where
+    (==) = (==) `on` cacheObjs
+
+instance Show CacheStorage where
+    show StorageCache {} = "cache"
+
+instance StorageBackend CacheStorage where
+    backendLoadBytes StorageCache {..} dgst =
+        (M.lookup dgst <$> readMVar cacheObjs) >>= \case
+            x@Just {} -> return x
+            Nothing -> withStorageBackend cacheParent $ \bck -> do
+                backendLoadBytes bck dgst >>= \case
+                    x@(Just raw) -> do
+                        modifyMVar_ cacheObjs (return . M.insert dgst raw)
+                        return x
+                    Nothing -> return Nothing
+
+    backendStoreBytes StorageCache {..} dgst raw = do
+        modifyMVar_ cacheObjs (return . M.insert dgst raw)
+        withStorageBackend cacheParent $ \bck ->
+            backendStoreBytes bck dgst raw
+
+
+    backendLoadHeads StorageCache {..} tid = do
+        withStorageBackend cacheParent $ \bck ->
+            backendLoadHeads bck tid
+
+    backendLoadHead StorageCache {..} tid hid =
+        withStorageBackend cacheParent $ \bck ->
+            backendLoadHead bck tid hid
+
+    backendStoreHead StorageCache {..} tid hid dgst =
+        withStorageBackend cacheParent $ \bck ->
+            backendStoreHead bck tid hid dgst
+
+    backendReplaceHead StorageCache {..} tid hid expected new = do
+        withStorageBackend cacheParent $ \bck ->
+            backendReplaceHead bck tid hid expected new
+
+    backendWatchHead StorageCache {..} tid hid cb = do
+        withStorageBackend cacheParent $ \bck ->
+            backendWatchHead bck tid hid cb
+
+    backendUnwatchHead StorageCache {..} wid = do
+        withStorageBackend cacheParent $ \bck ->
+            backendUnwatchHead bck wid
+
+
+    backendListKeys StorageCache {..} = do
+        withStorageBackend cacheParent $ \bck ->
+            backendListKeys bck
+    backendLoadKey StorageCache {..} dgst = do
+        withStorageBackend cacheParent $ \bck ->
+            backendLoadKey bck dgst
+    backendStoreKey StorageCache {..} dgst key = do
+        withStorageBackend cacheParent $ \bck ->
+            backendStoreKey bck dgst key
+    backendRemoveKey StorageCache {..} dgst = do
+        withStorageBackend cacheParent $ \bck ->
+            backendRemoveKey bck dgst
+
+
+cacheStorage :: Storage -> IO Storage
+cacheStorage cacheParent = do
+    cacheHeads <- newMVar []
+    cacheObjs <- newMVar M.empty
+    cacheKeys <- newMVar M.empty
+    cacheWatchers <- newMVar (WatchList startWatchID [])
+    newStorage $ StorageCache {..}