diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Storage/Cache.hs | 96 | ||||
| -rw-r--r-- | src/Storage/IndexedDB.hs | 28 | ||||
| -rw-r--r-- | src/Storage/WatchList.hs | 37 |
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 } |