Use more the Cmd monad

src/Gargantext/API/Node.hs

@@ -40,7 +40,8 @@ import Servant
 
 import Gargantext.Prelude
 import Gargantext.Database.Types.Node
-import Gargantext.Database.Node ( getNodesWithParentId
+import Gargantext.Database.Node ( runCmd
+                                , getNodesWithParentId
                                 , getNode, getNodesWith
                                 , deleteNode, deleteNodes)
 import Gargantext.Database.Facet (FacetDoc, getDocFacet
@@ -150,10 +151,10 @@ putNode :: Connection -> NodeId -> Handler Int
 putNode = undefined -- TODO
 
 deleteNodes' :: Connection -> [NodeId] -> Handler Int
-deleteNodes' conn ids = liftIO (deleteNodes conn ids)
+deleteNodes' conn ids = liftIO (runCmd conn $ deleteNodes ids)
 
 deleteNode' :: Connection -> NodeId -> Handler Int
-deleteNode' conn id = liftIO (deleteNode conn id)
+deleteNode' conn id = liftIO (runCmd conn $ deleteNode id)
 
 getNodesWith' :: Connection -> NodeId -> Maybe NodeType -> Maybe Int -> Maybe Int 
                         -> Handler [Node Value]

src/Gargantext/Database/Bashql.hs

@@ -72,7 +72,6 @@ module Gargantext.Database.Bashql ( get, get'
 
 import Control.Monad.Reader -- (Reader, ask)
 
-import Database.PostgreSQL.Simple (Connection)
 import Data.Text (Text, pack)
 import Data.Aeson
 import Data.Aeson.Types
@@ -92,16 +91,14 @@ import Opaleye hiding (FromField)
 type PWD = [NodeId]
 --data PWD' a = a | PWD' [a]
 
-type Cmd a = Connection -> IO a
-
 -- | TODO get Children or Node
 get :: PWD -> Cmd [Node Value]
-get []  _    = pure []
-get pwd conn = runQuery conn $ selectNodesWithParentID (last pwd)
+get []  = pure []
+get pwd = Cmd . ReaderT $ \conn -> runQuery conn $ selectNodesWithParentID (last pwd)
 
 -- | Home, need to filter with UserId
 home :: Cmd PWD
-home c = map node_id <$> getNodesWithParentId c 0 Nothing
+home = map node_id <$> Cmd (ReaderT (getNodesWithParentId 0 Nothing))
 
 -- | ls == get Children
 ls :: PWD -> Cmd [Node Value]
@@ -109,30 +106,29 @@ ls = get
 
 
 tree :: PWD -> Cmd [Node Value]
-tree p c = do
-  ns       <- get p c
-  children <- mapM (\p' -> get [p'] c) $ map node_id ns
-  pure $ ns <> (concat children)
+tree p = do
+  ns       <- get p
+  children <- mapM (\n -> get [node_id n]) ns
+  pure $ ns <> concat children
 
 
 -- | TODO
 post :: PWD -> [NodeWrite'] -> Cmd Int64
-post [] _   _ = pure 0
-post _ []   _ = pure 0
-post pth ns c = mkNode c (last pth) ns
+post [] _   = pure 0
+post _ []   = pure 0
+post pth ns = Cmd . ReaderT $ mkNode (last pth) ns
 
---postR :: Connection -> PWD -> [NodeWrite'] -> IO [Int]
---postR _ [] _   = pure [0]
---postR _ _ []   = pure [0]
---postR c pth ns = mkNodeR c (last pth) ns
---
+--postR :: PWD -> [NodeWrite'] -> Cmd [Int]
+--postR [] _ _ = pure [0]
+--postR _ [] _ = pure [0]
+--postR pth ns c = mkNodeR (last pth) ns c
 
 --rm :: Connection -> PWD -> [NodeId] -> IO Int
 --rm = del
 
 del :: [NodeId] -> Cmd Int
-del [] _ = pure 0
-del ns c = deleteNodes c ns
+del [] = pure 0
+del ns = deleteNodes ns
 
 -- | TODO
 --put :: Connection -> PWD -> [a] -> IO Int64
@@ -146,24 +142,24 @@ del ns c = deleteNodes c ns
 
 type CorpusName = Text
 
-postCorpus :: ToJSON a => CorpusName -> (a -> Text) -> [a] -> Cmd [Int]
-postCorpus corpusName title ns c = do
-  pid <- last <$> home c
+postCorpus :: ToJSON a => CorpusName -> (a -> Text) -> [a] -> Cmd NewNode
+postCorpus corpusName title ns = do
+  pid <- last <$> home
   let uid = 1
-  postNode c uid pid ( Node' NodeCorpus  corpusName emptyObject
-                             (map (\n -> Node' Document (title n) (toJSON n) []) ns)
-                     )
+  postNode uid pid ( Node' NodeCorpus  corpusName emptyObject
+                       (map (\n -> Node' Document (title n) (toJSON n) []) ns)
+                   )
 
 -- |
 -- import IMTClient as C
 -- postAnnuaire "Annuaire IMT" (\n -> (maybe "" identity (C.prenom n)) <> " " <> (maybe "" identity (C.nom n))) (take 30 annuaire)
-postAnnuaire :: ToJSON a => CorpusName -> (a -> Text) -> [a] -> Cmd [Int]
-postAnnuaire corpusName title ns c = do
-  pid <- last <$> home c
+postAnnuaire :: ToJSON a => CorpusName -> (a -> Text) -> [a] -> Cmd NewNode
+postAnnuaire corpusName title ns = do
+  pid <- last <$> home
   let uid = 1
-  postNode c uid pid ( Node' Annuaire  corpusName emptyObject
-                             (map (\n -> Node' UserPage (title n) (toJSON n) []) ns)
-                     )
+  postNode uid pid ( Node' Annuaire  corpusName emptyObject
+                       (map (\n -> Node' UserPage (title n) (toJSON n) []) ns)
+                   )
 
 --------------------------------------------------------------
 -- Tests
@@ -171,26 +167,26 @@ postAnnuaire corpusName title ns c = do
 
 
 get' :: PWD -> IO [Node Value]
-get' = runCmd . get
+get' = runCmd' . get
 
 home' :: IO PWD
-home' = runCmd home
+home' = runCmd' home
 
 ls' :: IO [Node Value]
-ls' = runCmd $ \c -> do
-  h <- home c
-  ls h c
+ls' = runCmd' $ do
+  h <- home
+  ls h
 
 tree' :: IO [Node Value]
-tree' = runCmd $ \c -> do
-  h <- home c
-  tree h c
+tree' = runCmd' $ do
+  h <- home
+  tree h
 
-post' :: IO [Int]
-post' = runCmd $ \c -> do
-  pid <- last <$> home c
+post' :: IO NewNode
+post' = runCmd' $ do
+  pid <- last <$> home
   let uid = 1
-  postNode c uid pid ( Node' NodeCorpus  (pack "Premier corpus") emptyObject [ Node' Document (pack "Doc1") emptyObject []
+  postNode uid pid ( Node' NodeCorpus  (pack "Premier corpus") emptyObject [ Node' Document (pack "Doc1") emptyObject []
                                                           , Node' Document (pack "Doc2") emptyObject []
                                                           , Node' Document (pack "Doc3") emptyObject []
                                                           ]
@@ -203,11 +199,11 @@ post' = runCmd $ \c -> do
 
 
 del' :: [NodeId] -> IO Int
-del' ns = runCmd $ del ns
+del' ns = runCmd' $ del ns
 
 -- corporaOf :: Username -> IO [Corpus]
 
-runCmd :: Cmd a -> IO a
-runCmd f = do
+runCmd' :: Cmd a -> IO a
+runCmd' f = do
   c <- connectGargandb "gargantext.ini"
-  f c
+  runCmd c f

src/Gargantext/Database/Node.hs

@@ -15,6 +15,8 @@ Portability : POSIX
 {-# LANGUAGE DeriveGeneric          #-}
 {-# LANGUAGE FlexibleInstances      #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE MultiParamTypeClasses  #-}
 {-# LANGUAGE NoImplicitPrelude      #-}
 {-# LANGUAGE TemplateHaskell        #-}
@@ -41,11 +43,14 @@ import Gargantext.Prelude hiding (sum)
 
 
 import Database.PostgreSQL.Simple.Internal  (Field)
+import Control.Applicative (Applicative)
 import Control.Arrow (returnA)
 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
+import Control.Monad.IO.Class
+import Control.Monad.Reader
 import Data.Aeson
 import Data.Maybe (Maybe, fromMaybe)
-import Data.Text (Text, pack)
+import Data.Text (Text)
 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
 import Data.Typeable (Typeable)
 
@@ -60,6 +65,26 @@ import qualified Data.Profunctor.Product as PP
 -- | Types for Node Database Management
 data PGTSVector
 
+newtype Cmd a = Cmd (ReaderT Connection IO a)
+  deriving (Functor, Applicative, Monad, MonadReader Connection, MonadIO)
+
+runCmd :: Connection -> Cmd a -> IO a
+runCmd c (Cmd f) = runReaderT f c
+
+mkCmd :: (Connection -> IO a) -> Cmd a
+mkCmd = Cmd . ReaderT
+
+{-
+newtype Cmd a = Cmd { unCmd :: Connection -> IO a }
+
+instance Monad Cmd where
+  return a = Cmd $ \_ -> return a
+
+  m >>= f = Cmd $ \c -> do
+    a <- unCmd m c
+    unCmd (f a) c
+-}
+
 ------------------------------------------------------------------------
 type CorpusId = Int
 ------------------------------------------------------------------------
@@ -161,8 +186,8 @@ selectNode id = proc () -> do
     restrict -< node_id row .== id
     returnA -< row
 
-runGetNodes :: Connection -> Query NodeRead -> IO [Node Value]
-runGetNodes = runQuery
+runGetNodes :: Query NodeRead -> Cmd [Node Value]
+runGetNodes q = mkCmd $ \conn -> runQuery conn q
 
 -- | order by publication date
 -- Favorites (Bool), node_ngrams
@@ -187,13 +212,20 @@ selectNodesWith' parentId maybeNodeType = proc () -> do
     returnA -< node
 
 
+--type Cmd' a = forall m. (MonadReader env m, HasConnection env, MonadIO m) => m a
 
-deleteNode :: Connection -> Int -> IO Int
-deleteNode conn n = fromIntegral <$> runDelete conn nodeTable
+
+-- deleteNode :: (MonadReader Connection m, MonadIO m) => Int -> m Int
+-- deleteNode :: Int -> Cmd' Int
+
+deleteNode :: Int -> Cmd Int
+deleteNode n = mkCmd $ \conn ->
+  fromIntegral <$> runDelete conn nodeTable
                  (\(Node n_id _ _ _ _ _ _) -> n_id .== pgInt4 n)
 
-deleteNodes :: Connection -> [Int] -> IO Int
-deleteNodes conn ns = fromIntegral <$> runDelete conn nodeTable
+deleteNodes :: [Int] -> Cmd Int
+deleteNodes ns = mkCmd $ \conn ->
+  fromIntegral <$> runDelete conn nodeTable
                    (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgInt4 ns)) n_id)
 
 
@@ -205,13 +237,13 @@ getNodesWith conn parentId nodeType maybeOffset maybeLimit =
 
 
 -- NP check type
-getNodesWithParentId :: Connection -> Int 
-                     -> Maybe Text -> IO [Node Value]
-getNodesWithParentId conn n _ = runQuery conn $ selectNodesWithParentID n
+getNodesWithParentId :: Int
+                     -> Maybe Text -> Connection -> IO [Node Value]
+getNodesWithParentId n _ conn = runQuery conn $ selectNodesWithParentID n
 
-getNodesWithParentId' :: Connection -> Int 
-                     -> Maybe Text -> IO [Node Value]
-getNodesWithParentId' conn n _ = runQuery conn $ selectNodesWithParentID n
+getNodesWithParentId' :: Int
+                     -> Maybe Text -> Connection -> IO [Node Value]
+getNodesWithParentId' n _ conn = runQuery conn $ selectNodesWithParentID n
 
 
 ------------------------------------------------------------------------
@@ -285,11 +317,11 @@ node2write pid (Node id tn ud _ nm dt hp) = ((pgInt4    <$> id)
                                          )
 
 
-mkNode :: Connection -> ParentId -> [NodeWrite'] -> IO Int64
-mkNode conn pid ns = runInsertMany conn nodeTable' $ map (node2write pid) ns
+mkNode :: ParentId -> [NodeWrite'] -> Connection -> IO Int64
+mkNode pid ns conn = runInsertMany conn nodeTable' $ map (node2write pid) ns
 
-mkNodeR :: Connection -> ParentId -> [NodeWrite'] -> IO [Int]
-mkNodeR conn pid ns = runInsertManyReturning conn nodeTable' (map (node2write pid) ns) (\(i,_,_,_,_,_,_) -> i)
+mkNodeR :: ParentId -> [NodeWrite'] -> Connection -> IO [Int]
+mkNodeR pid ns conn = runInsertManyReturning conn nodeTable' (map (node2write pid) ns) (\(i,_,_,_,_,_,_) -> i)
 
 
 ------------------------------------------------------------------------
@@ -309,10 +341,10 @@ post c uid pid [ Node' Corpus "name" "{}" []
 -- TODO
 -- currently this function remove the child relation
 -- needs a Temporary type between Node' and NodeWriteT
-node2table :: UserId -> ParentId -> Node' -> [NodeWriteT]
-node2table uid pid (Node' nt txt v []) = [( Nothing, (pgInt4$ nodeTypeId nt), (pgInt4 uid), (pgInt4 pid)
-                                         , pgStrictText txt, Nothing, pgStrictJSONB $ DB.pack $ DBL.unpack $ encode v)]
-node2table _ _ (Node' _ _ _ _) = panic $ pack "node2table: should not happen, Tree insert not implemented yet"
+node2table :: UserId -> ParentId -> Node' -> NodeWriteT
+node2table uid pid (Node' nt txt v []) = ( Nothing, (pgInt4$ nodeTypeId nt), (pgInt4 uid), (pgInt4 pid)
+                                         , pgStrictText txt, Nothing, pgStrictJSONB $ DB.pack $ DBL.unpack $ encode v)
+node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 
 
 data Node' = Node' { _n_type :: NodeType
@@ -330,30 +362,37 @@ type NodeWriteT =  ( Maybe (Column PGInt4)
                    )
 
 
-mkNode' :: Connection -> [NodeWriteT] -> IO Int64
-mkNode' conn ns = runInsertMany conn nodeTable' ns
+mkNode' :: [NodeWriteT] -> Cmd Int64
+mkNode' ns = mkCmd $ \conn -> runInsertMany conn nodeTable' ns
 
-mkNodeR' :: Connection -> [NodeWriteT] -> IO [Int]
-mkNodeR' conn ns = runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_) -> i)
-
--- | postNode
-postNode :: Connection -> UserId -> ParentId -> Node' -> IO [Int]
-postNode c uid pid (Node' nt txt v []) = mkNodeR' c (node2table uid pid (Node' nt txt v []))
+mkNodeR' :: [NodeWriteT] -> Cmd [Int]
+mkNodeR' ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_) -> i)
 
-postNode c uid pid (Node' NodeCorpus txt v ns) = do
-  [pid']  <- postNode c uid pid (Node' NodeCorpus txt v [])
-  pids    <- mkNodeR' c $ concat $ map (\n -> childWith uid pid' n) ns
-  pure (pids)
+data NewNode = NewNode { _newNodeId :: Int
+                       , _newNodeChildren :: [Int] }
 
-postNode c uid pid (Node' Annuaire txt v ns) = do
-  [pid']  <- postNode c uid pid (Node' Annuaire txt v [])
-  pids    <- mkNodeR' c $ concat $ map (\n -> childWith uid pid' n) ns
-  pure (pids)
-postNode _ _ _ (Node' _ _ _ _) = panic $ pack "postNode for this type not implemented yet"
-
-
-childWith :: UserId -> ParentId -> Node' -> [NodeWriteT]
+-- | postNode
+postNode :: UserId -> ParentId -> Node' -> Cmd NewNode
+postNode uid pid (Node' nt txt v []) = do
+  pids <- mkNodeR' [node2table uid pid (Node' nt txt v [])]
+  case pids of
+    [pid] -> pure $ NewNode pid []
+    _ -> panic "postNode: only one pid expected"
+
+postNode uid pid (Node' NodeCorpus txt v ns) = do
+  NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
+  pids  <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
+  pure $ NewNode pid' pids
+
+postNode uid pid (Node' Annuaire txt v ns) = do
+  NewNode pid' _ <- postNode uid pid (Node' Annuaire txt v [])
+  pids  <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
+  pure $ NewNode pid' pids
+postNode _ _ (Node' _ _ _ _) = panic "TODO: postNode for this type not implemented yet"
+
+
+childWith :: UserId -> ParentId -> Node' -> NodeWriteT
 childWith uId pId (Node' Document txt v []) = node2table uId pId (Node' Document txt v [])
 childWith uId pId (Node' UserPage txt v []) = node2table uId pId (Node' UserPage txt v [])
-childWith _   _   (Node' _        _   _ _) = panic $ pack "This NodeType can not be a child"
+childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 

src/Gargantext/Database/Node/Document/Import.hs

@@ -143,7 +143,7 @@ queryInsert = [sql|
            |]
 
 prepare :: UserId -> ParentId -> [HyperdataDocument] -> [InputData]
-prepare uId pId = map (\h -> InputData tId uId pId (DT.pack "Doc") (toJSON $ unicize h))
+prepare uId pId = map (\h -> InputData tId uId pId (DT.pack "Doc") (toJSON $ addUniqId h))
   where
     tId = nodeTypeId Document
 
@@ -195,19 +195,13 @@ hashParameters = [ \d -> maybe' (_hyperdataDocument_title    d)
                    where
                      maybe' = maybe (DT.pack "") identity
 
-unicize :: HyperdataDocument -> HyperdataDocument
-unicize = unicize' hashParameters
+addUniqId :: HyperdataDocument -> HyperdataDocument
+addUniqId doc = set hyperdataDocument_uniqId (Just hash) doc
   where
-    unicize' :: [(HyperdataDocument -> Text)] -> HyperdataDocument -> HyperdataDocument
-    unicize' fields doc = set hyperdataDocument_uniqId (Just hash) doc
-      where
-        hash = uniqId $ DT.concat $ map (\f -> f doc) fields
+    hash = uniqId $ DT.concat $ map ($ doc) hashParameters
 
     uniqId :: Text -> Text
-    uniqId txt = (sha256 txt)
-      where
-        sha256 :: Text -> Text
-        sha256 = DT.pack . SHA.showDigest . SHA.sha256 . DC.pack . DT.unpack
+    uniqId = DT.pack . SHA.showDigest . SHA.sha256 . DC.pack . DT.unpack
 
 ---------------------------------------------------------------------------
 -- * Tests