diff --git a/reflex-indexed-db.cabal b/reflex-indexed-db.cabal index cc11afb..21a91ce 100644 --- a/reflex-indexed-db.cabal +++ b/reflex-indexed-db.cabal @@ -35,6 +35,7 @@ test-suite reflex-indexdb-test hs-source-dirs: test main-is: Spec.hs build-depends: base + , aeson , ghcjs-dom , reflex-indexed-db , reflex-dom diff --git a/src/Reflex/IDB.hs b/src/Reflex/IDB.hs index 7a8c8ae..fea8515 100644 --- a/src/Reflex/IDB.hs +++ b/src/Reflex/IDB.hs @@ -1,14 +1,17 @@ -- | +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Reflex.IDB where @@ -76,9 +79,8 @@ newtype IDBResult t a = IDBResult (Event t (Either IDBError a)) indexedDB :: forall t m. ( HasWebView m , MonadWidget t m - ) => IndexedDBOpen t -> (forall t1. (Reflex t1) => Database t1 DOM.JSM ()) -> m (Either IDBError (IndexedDB t)) -indexedDB idbReq upgrade' = do - let upgrade = upgrade' :: Database t DOM.JSM () + ) => IndexedDBOpen t -> (Database t DOM.JSM ()) -> m (Either IDBError (IndexedDB t)) +indexedDB idbReq upgrade = do (eOpen, eOpenTrigger) <- newTriggerEvent (eUpgrade, eUpgradeTrigger) <- newTriggerEvent idbRef <- liftIO $ newIORef Nothing @@ -114,7 +116,7 @@ indexedDB idbReq upgrade' = do idbAny <- (IDBReq.getResult idbReq) !! "Error getting database" idb <- DOM.castTo IDBD.IDBDatabase idbAny !! "Error getting idb" let upgradeCode = runDatabase upgrade - let res = runExceptT (iterT (interpertDB idb) upgradeCode) + let res = runExceptT (iterT (interpretDB idb) upgradeCode) DOM.liftJSM $ onUpgradeNeeded res return () return () @@ -136,14 +138,21 @@ indexedDB idbReq upgrade' = do Right _ -> Right $ IndexedDB isOpenE idbState eUpgrade where idbName = _idb_name idbReq idbVer = _idb_version idbReq - interpertDB idb (OpCreateObjectStore storeN opts f) = do - liftIO $ print "OpCreateObjectStore" - store <- IDBD.createObjectStore idb storeN (Nothing :: Maybe DOM.IDBObjectStoreParameters) - f (ObjectStore store) - interpertDB idb (OpDeleteObjectStore storeN f) = do - IDBD.deleteObjectStore idb storeN - f + +interpretDB + :: DOM.IDBDatabase + -> DatabaseOp t Item DOM.JSM (ExceptT IDBError DOM.JSM ()) + -> ExceptT IDBError DOM.JSM () +interpretDB idb (OpCreateObjectStore storeN opts f) = do + liftIO $ print "OpCreateObjectStore" + store <- IDBD.createObjectStore idb storeN (Nothing :: Maybe DOM.IDBObjectStoreParameters) + f (ObjectStore store) +interpretDB idb (OpDeleteObjectStore storeN f) = do + IDBD.deleteObjectStore idb storeN + f +interpretDB idb (OpIDB act f) = + ExceptT $ flip runReaderT (T.pack "tmp") $ runExceptT $ iterT (interpret (T.pack "tmp") undefined) $ runIDB act isClosed :: IndexedDBState -> Bool @@ -178,7 +187,7 @@ data IndexParam = IndexParam , locale :: Text } -type NewIndex = (Text, Text, IndexParam) +type NewIndex = (Text, Text, Maybe IndexParam) data KeyRange = UpperBound Text Bool | LowerBound Text Bool @@ -197,6 +206,7 @@ data DatabaseOp t item (m :: * -> *) f | OpDeleteObjectStore Text f -- | OpStore (StoreOp t item m f) f -- | OpTransaction (IDB t m item) f + | OpIDB (IDB t Text m ()) f deriving (Functor) newtype Database t m a = Database {runDatabase :: FreeT (DatabaseOp t Item m) (ExceptT IDBError m) a} @@ -212,6 +222,9 @@ createObjectStore store opts = Database $ liftF $ OpCreateObjectStore store opts deleteObjectStore :: Monad m => Text -> Database t m () deleteObjectStore store = Database $ liftF $ OpDeleteObjectStore store () +runIDBAction :: Monad m => IDB t Text m () -> Database t m () +runIDBAction act = Database $ liftF $ OpIDB act () + type St = () data StoreOp t item m f = OpOpenStore Text (ObjectStore t -> f) @@ -221,8 +234,8 @@ data StoreOp t item m f | OpNewIndex (ObjectStore t) NewIndex f | OpDelete (ObjectStore t) Text f | OpDeleteIndex (ObjectStore t) Text f - | OpGet (ObjectStore t) Text (Either IDBError (Maybe Text) -> f) - | OpGetAll (ObjectStore t) (Maybe KeyOrKeyRange) (Maybe Int) (Either IDBError [Text] -> f) + | OpGet (ObjectStore t) Text (Either IDBError (Maybe item) -> f) + | OpGetAll (ObjectStore t) (Maybe KeyOrKeyRange) (Maybe Int) (Either IDBError [item] -> f) | OpGetAllKeys (ObjectStore t) (Maybe KeyRange) (Maybe Int) (Either IDBError [Text] -> f) | OpIndex (ObjectStore t) Text f | OpCursor (ObjectStore t) (Maybe KeyOrKeyRange) (Maybe DOM.IDBCursorDirection) () (Cursor t St m ()) f @@ -258,7 +271,7 @@ currentUpdate item = Cursor $ liftF $ OpCurUpdate item () currentDelete :: (Monad m) => Cursor t s m () currentDelete = Cursor $ liftF $ OpCurDelete () -type Item = Text +type Item = A.Value newtype Cursor t s m a = Cursor { runCursor :: FreeT (CursorOp t Item) (ExceptT IDBError (StateT s m)) a} deriving ( Functor @@ -274,9 +287,17 @@ newtype IDB t r m a = IDB { runIDB :: FreeT (StoreOp t Item m) (ExceptT IDBError , MonadIO ) +#ifndef ghcjs_HOST_OS +instance DOM.MonadJSM m => DOM.MonadJSM (IDB t r m) where + liftJSM' = IDB . FreeT . liftM Pure . DOM.liftJSM +#endif + openStore :: (Monad m) => Text -> IDB t r m (ObjectStore t) openStore store = IDB $ liftF $ OpOpenStore store id +createIndex :: (Monad m) => ObjectStore t -> NewIndex -> IDB t r m () +createIndex store newIndex = IDB $ liftF $ OpNewIndex store newIndex () + add :: (Monad m) => (ObjectStore t) -> Item -> Maybe Text -> IDB t r m () add store item key = IDB $ liftF $ OpAdd store item key () @@ -286,10 +307,10 @@ clear store = IDB $ liftF $ OpClear store () count :: (Monad m) => (ObjectStore t) -> Maybe KeyOrKeyRange -> IDB t r m (Either IDBError Int) count store key = IDB $ liftF $ OpCount store key id -get :: (Monad m) => (ObjectStore t) -> Text -> IDB t r m (Either IDBError (Maybe Text)) +get :: (Monad m) => (ObjectStore t) -> Text -> IDB t r m (Either IDBError (Maybe Item)) get store key = IDB $ liftF $ OpGet store key id -getAll :: (Monad m) => (ObjectStore t) -> Maybe KeyOrKeyRange -> Maybe Int -> IDB t r m (Either IDBError [Text]) +getAll :: (Monad m) => (ObjectStore t) -> Maybe KeyOrKeyRange -> Maybe Int -> IDB t r m (Either IDBError [Item]) getAll store key count = IDB $ liftF $ OpGetAll store key count id openCursor :: (Monad m) => (ObjectStore t) -> Maybe KeyOrKeyRange -> (Maybe DOM.IDBCursorDirection) -> () -> (Cursor t St m ()) -> IDB t r m () @@ -309,15 +330,17 @@ runTransaction :: forall t m input output. ( MonadIO m , MonadSample t m , MonadWidget t m --- , input ~ () - ) => IndexedDB t -> TransactionConfig t input -> (forall t1. (Reflex t1) => IDB t1 input (WidgetHost m) output) -> m (Event t (Either IDBError output)) + ) => IndexedDB t + -> TransactionConfig t input + -> (forall t1. (Reflex t1) => IDB t1 input (WidgetHost m) output) + -> m (Event t (Either IDBError output)) runTransaction idb transCfg transact = do let trigger = _transCfg_trigger transCfg fixT = const :: IDB t input m1 o -> Event t a -> IDB t input m1 o code = transact `fixT` trigger scopes = case _transCfg_scopes transCfg of (s : _) -> s - [] -> error $ "Atleast one trasanction scopes are required" + [] -> error $ "At least one trasanction scope is required" performEvent $ ffor trigger $ \input -> do idbState <- sample $ current $ _idb_state idb case idbState of @@ -327,20 +350,24 @@ runTransaction idb transCfg transact = do idb <- liftIO $ readIORef idbRef trans <- IDBD.transaction idb (T.unpack <$> _transCfg_scopes transCfg) (Just $ _transCfg_mode transCfg) runReaderT (runExceptT $ iterT (interpret input trans) $ runIDB code) input - where - interpret input idbTrans (OpOpenStore storeN f) = do + +interpret + :: DOM.MonadJSM m + => input + -> DOM.IDBTransaction + -> StoreOp t Item m (ExceptT IDBError (ReaderT input m) output) + -> ExceptT IDBError (ReaderT input m) output +interpret input idbTrans (OpOpenStore storeN f) = do objStore <- IDBTrans.objectStore idbTrans storeN f $ ObjectStore objStore - interpret input idbTrans (OpAdd (ObjectStore store) item key f) = do +interpret input idbTrans (OpAdd (ObjectStore store) item key f) = do liftIO $ print $ "adding " ++ (show key) req <- IDBStore.add store item key f - - interpret input idbTrans (OpClear (ObjectStore store) f) = do +interpret input idbTrans (OpClear (ObjectStore store) f) = do req <- IDBStore.clear store f - - interpret input idbTrans (OpCount (ObjectStore store) key f) = do +interpret input idbTrans (OpCount (ObjectStore store) key f) = do req <- case key of Nothing -> do IDBStore.countRange store Nothing @@ -362,31 +389,35 @@ runTransaction idb transCfg transact = do range <- IDBKeyRan.only k IDBStore.countRange store (Just range) f (Left $ T.pack "TODO") - - interpret input idbTrans (OpGet (ObjectStore store) key f) = do +interpret input idbTrans (OpGet (ObjectStore store) key f) = do keyVal <- DOM.liftJSM $ DOM.toJSVal key req <- IDBStore.get store key f (Left $ T.pack "TODO") - - interpret input idbTrans (OpGetAll (ObjectStore store) key kcount f) = do - error "getAll is not available in GHCJS" - - interpret input idbTrans (OpGetAllKeys (ObjectStore store) key kcount f) = do - error "getAllKeys is not available in GHCJS" - - interpret input idbTrans (OpIndex (ObjectStore store) idx f) = do +interpret input idbTrans (OpGetAll (ObjectStore store) key kcount f) = do + error "getAll is not available in GHCJS" +interpret input idbTrans (OpGetAllKeys (ObjectStore store) key kcount f) = do + error "getAllKeys is not available in GHCJS" +interpret input idbTrans (OpIndex (ObjectStore store) idx f) = do req <- IDBStore.index store idx f - interpret input idbTrans (OpNewIndex (ObjectStore store) (idxName, key, idxPar) f) = do - idx <- IDBStore.createIndex store (idxName) (T.unpack key) (Nothing :: Maybe DOM.IDBIndexParameters) +interpret input idbTrans (OpNewIndex (ObjectStore store) (idxName, key, idxPar_) f) = do + idxPar' <- case idxPar_ of + Nothing -> return Nothing + Just idxPar -> + fmap (Just . DOM.IDBIndexParameters) $ DOM.liftJSM $ DOM.toJSVal $ A.object + [ (T.pack "unique" .= isUnique idxPar) + , (T.pack "multiEntry" .= isMultiEntry idxPar) + , (T.pack "locale" .= locale idxPar) + ] + idx <- IDBStore.createIndex store (idxName) (T.unpack key) idxPar' f - interpret input idbTrans (OpDelete (ObjectStore store) key f) = do +interpret input idbTrans (OpDelete (ObjectStore store) key f) = do req <- IDBStore.delete store key f - interpret input idbTrans (OpDeleteIndex (ObjectStore store) key f) = do +interpret input idbTrans (OpDeleteIndex (ObjectStore store) key f) = do req <- IDBStore.deleteIndex store key f - interpret input idbTrans (OpCursor (ObjectStore store) key' move init curOps f) = do +interpret input idbTrans (OpCursor (ObjectStore store) key' move init curOps f) = do req <- case key' of Nothing -> do IDBStore.openCursorRange store Nothing move @@ -408,15 +439,14 @@ runTransaction idb transCfg transact = do IDBStore.openCursorRange store (Just range) move let cursorRes = runStateT (runExceptT $ iterT (interpretCursor undefined) (runCursor curOps)) init f - - interpret input idbTrans (OpKeyCursor (ObjectStore store) key move curOps f) = do +interpret input idbTrans (OpKeyCursor (ObjectStore store) key move curOps f) = do req <- IDBStore.openCursorRange store Nothing move f - interpret input idbTrans (OpPut (ObjectStore store) item key f) = do +interpret input idbTrans (OpPut (ObjectStore store) item key f) = do req <- IDBStore.put store item (Just key) f - interpretCursor curs (OpContinue f) = do +interpretCursor curs (OpContinue f) = do f getInput :: Monad m => IDB t r m r diff --git a/test/Spec.hs b/test/Spec.hs index f806c48..5171f63 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,6 +2,7 @@ import Reflex.IDB import Reflex.Dom +import qualified Data.Aeson as A import qualified Data.Text as T import Control.Monad.IO.Class import qualified GHCJS.DOM.Enums as DOM @@ -23,8 +24,8 @@ testIDB = mainWidget $ do tres <- runTransaction idb (TransactionConfig ["todo"] DOM.IDBTransactionModeReadwrite todoAddE never) $ do todoSt <- openStore "todo" inp <- getInput - add todoSt (T.pack "testV") (Just $ inp) - add todoSt (T.pack "testV") (Just $ inp <> "_1") + add todoSt (A.String "testV") (Just $ inp) + add todoSt (A.String "testV") (Just $ inp <> "_1") liftIO $ print inp return () text "Is DB Open: "