Add StoreOp-runner command to DatabaseOp

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

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

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: "