Cache storage

3 files changed, 134 insertions, 27 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 {..}
diff --git a/src/Storage/IndexedDB.hs b/src/Storage/IndexedDB.hs
index e13a549..4c4967d 100644
--- a/src/Storage/IndexedDB.hs
+++ b/src/Storage/IndexedDB.hs
@@ -21,6 +21,7 @@ import Foreign.Ptr
 import GHC.Wasm.Prim
 
 import JavaScript qualified as JS
+import Storage.WatchList
 
 
 data IndexedDBStorage = IndexedDBStorage
@@ -131,33 +132,6 @@ indexedDBStorage bsName = do
     newStorage IndexedDBStorage {..}
 
 
-data WatchList = WatchList
-    { wlNext :: WatchID
-    , wlList :: [ WatchListItem ]
-    }
-
-data WatchListItem = WatchListItem
-    { wlID :: WatchID
-    , 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 }
-
-
 foreign import javascript unsafe
     "const req = window.indexedDB.open($1); req.onerror = (event) => { console.log(\"Error loading database.\"); }; req.onsuccess = (event) => { $2(req.result); }; req.onupgradeneeded = (event) => { const db = event.target.result; db.createObjectStore(\"objects\"); db.createObjectStore(\"heads\"); db.createObjectStore(\"keys\"); }"
     js_indexedDB_open :: JSString -> JSVal -> IO ()
diff --git a/src/Storage/WatchList.hs b/src/Storage/WatchList.hs
new file mode 100644
index 0000000..11ca3e1
--- /dev/null
+++ b/src/Storage/WatchList.hs
@@ -0,0 +1,37 @@
+module Storage.WatchList (
+    WatchList(..),
+    WatchListItem(..),
+    watchListAdd,
+    watchListDel,
+) where
+
+import Erebos.Object
+import Erebos.Storage.Backend
+import Erebos.Storage.Head
+
+
+data WatchList = WatchList
+    { wlNext :: WatchID
+    , wlList :: [ WatchListItem ]
+    }
+
+data WatchListItem = WatchListItem
+    { wlID :: WatchID
+    , 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 }