IndexedDB storage for objects and keys

1 files changed, 176 insertions, 0 deletions

diff --git a/src/Storage/IndexedDB.hs b/src/Storage/IndexedDB.hs
new file mode 100644
index 0000000..576908c
--- /dev/null
+++ b/src/Storage/IndexedDB.hs
@@ -0,0 +1,176 @@
+module Storage.IndexedDB (
+    indexedDBStorage,
+) where
+
+import Control.Concurrent.MVar
+
+import Data.ByteString.Lazy qualified as BL
+import Data.ByteString.Unsafe
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Word
+
+import Erebos.Object
+import Erebos.Storage.Backend
+import Erebos.Storage.Head
+
+import Foreign.Marshal.Alloc
+import Foreign.Ptr
+
+import GHC.Wasm.Prim
+
+import JavaScript qualified as JS
+
+
+data IndexedDBStorage = IndexedDBStorage
+    { bsName :: String
+    , bsDatabase :: JSVal
+    , bsHeads :: MVar [ (( HeadTypeID, HeadID ), RefDigest ) ]
+    , bsWatchers :: MVar WatchList
+    }
+
+instance Eq IndexedDBStorage where
+    (==) = (==) `on` bsName
+
+instance Show IndexedDBStorage where
+    show IndexedDBStorage {..} = "IndexedDB@" <> bsName
+
+instance StorageBackend IndexedDBStorage where
+    backendLoadBytes IndexedDBStorage {..} dgst = do
+        mvar <- newEmptyMVar
+        handler <- JS.asEventListener $ \ev -> do
+            res <- js_get_targetResult ev
+            js_get_byteLength res >>= \case
+                0 -> putMVar mvar $ Nothing
+                len -> do
+                    ptr <- mallocBytes len
+                    js_copyBytes ptr res
+                    bs <- unsafePackCStringFinalizer ptr len (free ptr)
+                    putMVar mvar $ Just $ BL.fromStrict bs
+        js_db_get bsDatabase (toJSString "objects") (toJSString $ show dgst) handler
+        takeMVar mvar
+
+    backendStoreBytes IndexedDBStorage {..} dgst raw = do
+        unsafeUseAsCStringLen (BL.toStrict raw) $ \( ptr, len ) -> do
+            js_db_put bsDatabase (toJSString "objects") (toJSString $ show dgst) (castPtr ptr) len
+
+
+    backendLoadHeads IndexedDBStorage {..} tid = do
+        let toRes ( ( tid', hid ), dgst )
+                | tid' == tid = Just ( hid, dgst )
+                | otherwise   = Nothing
+        catMaybes . map toRes <$> readMVar bsHeads
+
+    backendLoadHead IndexedDBStorage {..} tid hid =
+        lookup (tid, hid) <$> readMVar bsHeads
+
+    backendStoreHead IndexedDBStorage {..} tid hid dgst =
+        modifyMVar_ bsHeads $ return . (( ( tid, hid ), dgst ) :)
+
+    backendReplaceHead IndexedDBStorage {..} tid hid expected new = do
+        res <- modifyMVar bsHeads $ \hs -> do
+            ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar bsWatchers
+            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 IndexedDBStorage {..} tid hid cb = do
+        modifyMVar bsWatchers $ return . watchListAdd tid hid cb
+
+    backendUnwatchHead IndexedDBStorage {..} wid = do
+        modifyMVar_ bsWatchers $ return . watchListDel wid
+
+
+    backendListKeys IndexedDBStorage {..} = _
+    backendLoadKey IndexedDBStorage {..} dgst = do
+        mvar <- newEmptyMVar
+        handler <- JS.asEventListener $ \ev -> do
+            res <- js_get_targetResult ev
+            len <- js_get_byteLength res
+            ptr <- mallocBytes len
+            js_copyBytes ptr res
+            bs <- unsafePackCStringFinalizer ptr len (free ptr)
+            putMVar mvar $ Just bs
+        js_db_get bsDatabase (toJSString "keys") (toJSString $ show dgst) handler
+        takeMVar mvar
+
+    backendStoreKey IndexedDBStorage {..} dgst key = do
+        unsafeUseAsCStringLen key $ \( ptr, len ) -> do
+            js_db_put bsDatabase (toJSString "keys") (toJSString $ show dgst) (castPtr ptr) len
+
+    backendRemoveKey IndexedDBStorage {..} dgst = do
+        js_db_delete bsDatabase (toJSString "keys") (toJSString $ show dgst)
+
+
+indexedDBStorage :: String -> IO Storage
+indexedDBStorage bsName = do
+    dbVar <- newEmptyMVar
+    handler <- JS.asEventListener $ \db -> do
+        putMVar dbVar db
+    js_indexedDB_open (toJSString bsName) handler
+    bsDatabase <- takeMVar dbVar
+    bsHeads <- newMVar []
+    bsWatchers <- newMVar (WatchList startWatchID [])
+    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 ()
+
+
+foreign import javascript unsafe
+    "const tr = $1.transaction($2, \"readwrite\"); tr.onerror = (event) => { console.log(\"put transaction error\"); }; tr.objectStore($2).put(new Uint8Array(globalThis.wasi_memory.buffer, $4, $5), $3); tr.commit();"
+    js_db_put :: JSVal -> JSString -> JSString -> Ptr Word8 -> Int -> IO ()
+
+foreign import javascript unsafe
+    "const tr = $1.transaction($2, \"readonly\"); tr.onerror = (event) => { console.log(\"get transaction error\"); }; const req = tr.objectStore($2).get($3); req.onsuccess = $4; tr.commit();"
+    js_db_get :: JSVal -> JSString -> JSString -> JSVal -> IO ()
+
+foreign import javascript unsafe
+    "const tr = $1.transaction($2, \"readwrite\"); tr.onerror = (event) => { console.log(\"delete transaction error\"); }; const req = tr.objectStore($2).delete($3); tr.commit();"
+    js_db_delete :: JSVal -> JSString -> JSString -> IO ()
+
+foreign import javascript unsafe "$1.target.result"
+    js_get_targetResult :: JSVal -> IO JSVal
+
+
+foreign import javascript unsafe "if (!$1) { return 0; }; return $1.byteLength"
+    js_get_byteLength :: JSVal -> IO Int
+
+foreign import javascript unsafe "new Uint8Array(globalThis.wasi_memory.buffer, $1, $2.byteLength).set(new Uint8Array($2))"
+    js_copyBytes :: Ptr Word8 -> JSVal -> IO ()