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
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
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 ()
|