1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
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
import Storage.WatchList
data IndexedDBStorage = IndexedDBStorage
{ bsName :: String
, bsDatabase :: JSVal
, bsHeads :: MVar [ (( HeadTypeID, HeadID ), RefDigest ) ]
, bsWatchers :: MVar WatchList
, idbReadLock :: MVar ()
, idbReadValue :: MVar (Maybe BL.ByteString)
, idbReadHandler :: JSVal
}
instance Eq IndexedDBStorage where
(==) = (==) `on` bsName
instance Show IndexedDBStorage where
show IndexedDBStorage {..} = "IndexedDB@" <> bsName
instance StorageBackend IndexedDBStorage where
backendLoadBytes IndexedDBStorage {..} dgst = do
withMVar idbReadLock $ \_ -> do
unsafeUseAsCStringLen (refDigestBytes dgst) $ \( dgstPtr, dgstLen ) -> do
js_db_get bsDatabase (toJSString "objects") (castPtr dgstPtr) dgstLen idbReadHandler
takeMVar idbReadValue
backendStoreBytes IndexedDBStorage {..} dgst raw = do
unsafeUseAsCStringLen (refDigestBytes dgst) $ \( dgstPtr, dgstLen ) -> do
unsafeUseAsCStringLen (BL.toStrict raw) $ \( ptr, len ) -> do
js_db_put bsDatabase (toJSString "objects") (castPtr dgstPtr) dgstLen (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
unsafeUseAsCStringLen (refDigestBytes dgst) $ \( dgstPtr, dgstLen ) -> do
js_db_get bsDatabase (toJSString "keys") (castPtr dgstPtr) dgstLen handler
takeMVar mvar
backendStoreKey IndexedDBStorage {..} dgst key = do
unsafeUseAsCStringLen (refDigestBytes dgst) $ \( dgstPtr, dgstLen ) -> do
unsafeUseAsCStringLen key $ \( ptr, len ) -> do
js_db_put bsDatabase (toJSString "keys") (castPtr dgstPtr) dgstLen (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 [])
idbReadLock <- newMVar ()
idbReadValue <- newEmptyMVar
idbReadHandler <- JS.asEventListener $ \ev -> do
res <- js_get_targetResult ev
js_get_byteLength res >>= \case
0 -> putMVar idbReadValue $ Nothing
len -> do
ptr <- mallocBytes len
js_copyBytes ptr res
bs <- unsafePackCStringFinalizer ptr len (free ptr)
putMVar idbReadValue $ Just $ BL.fromStrict bs
newStorage IndexedDBStorage {..}
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\"); }; const key = new Uint8Array(globalThis.wasi_memory.buffer, $3, $4); const value = new Uint8Array(globalThis.wasi_memory.buffer, $5, $6); tr.objectStore($2).put(value, key); tr.commit();"
js_db_put :: JSVal -> JSString -> Ptr Word8 -> Int -> 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(new Uint8Array(globalThis.wasi_memory.buffer, $3, $4)); req.onsuccess = $5; tr.commit();"
js_db_get :: JSVal -> JSString -> Ptr Word8 -> Int -> 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 ()
|