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
    , 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 {..}


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\"); }; 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 ()