[Database] Refactor functions accessing the database

src/Gargantext/API.hs

@@ -24,6 +24,7 @@ Thanks @yannEsposito for this.
 {-# LANGUAGE NoImplicitPrelude    #-}
 {-# LANGUAGE DataKinds            #-}
 {-# LANGUAGE DeriveGeneric        #-}
+{-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE OverloadedStrings    #-}
 {-# LANGUAGE TemplateHaskell      #-}
@@ -37,14 +38,14 @@ module Gargantext.API
       where
 ---------------------------------------------------------------------
 
-import           Database.PostgreSQL.Simple (Connection)
 import           System.IO (FilePath)
 
 import           GHC.Generics (D1, Meta (..), Rep)
 import           GHC.TypeLits (AppendSymbol, Symbol)
 
 import           Control.Lens
-import Control.Monad.IO.Class (liftIO)
+import           Control.Monad.IO.Class (liftIO)
+import           Control.Monad.Reader (runReaderT)
 import           Data.Aeson.Encode.Pretty (encodePretty)
 import qualified Data.ByteString.Lazy.Char8 as BL8
 import           Data.Swagger
@@ -70,8 +71,9 @@ import           Text.Blaze.Html (Html)
 import Gargantext.Prelude
 import Gargantext.API.FrontEnd (FrontEndAPI, frontEndServer)
 
-import Gargantext.API.Auth (AuthRequest, AuthResponse, auth')
-import Gargantext.API.Node ( Roots    , roots
+import Gargantext.API.Auth (AuthRequest, AuthResponse, auth)
+import Gargantext.API.Node ( GargServer
+                           , Roots    , roots
                            , NodeAPI  , nodeAPI
                            , NodesAPI , nodesAPI
                            , GraphAPI , graphAPI
@@ -208,9 +210,6 @@ type GargAPI = "api" :> Summary "API " :> GargAPIVersion
 
 type GargAPIVersion = "v1.0" :> Summary "v1.0: " :> GargAPI'
 
-auth :: Connection -> AuthRequest -> Handler AuthResponse
-auth conn ar = liftIO $ auth' conn ar
-
 type GargAPI' =
            -- Auth endpoint
                 "auth"  :> Summary "AUTH API"
@@ -277,27 +276,24 @@ type API = SwaggerFrontAPI :<|> GargAPI :<|> Get '[HTML] Html
 
 server :: Env -> IO (Server API)
 server env = do
-  gargAPI <- serverGargAPI env
+  -- orchestrator <- scrapyOrchestrator env
   pure $  swaggerFront
-     :<|> gargAPI
+     :<|> hoistServer (Proxy :: Proxy GargAPI) (`runReaderT` env) serverGargAPI
      :<|> serverIndex
 
-serverGargAPI :: Env -> IO (Server GargAPI)
-serverGargAPI env = do
-  -- orchestrator <- scrapyOrchestrator env
-  pure $  auth     conn
-     :<|> roots    conn
-     :<|> nodeAPI  conn (Proxy :: Proxy HyperdataAny)
-     :<|> nodeAPI  conn (Proxy :: Proxy HyperdataCorpus)
-     :<|> nodeAPI  conn (Proxy :: Proxy HyperdataAnnuaire)
-     :<|> nodesAPI conn
+serverGargAPI :: GargServer GargAPI
+serverGargAPI -- orchestrator
+       =  auth
+     :<|> roots
+     :<|> nodeAPI  (Proxy :: Proxy HyperdataAny)
+     :<|> nodeAPI  (Proxy :: Proxy HyperdataCorpus)
+     :<|> nodeAPI  (Proxy :: Proxy HyperdataAnnuaire)
+     :<|> nodesAPI
      :<|> count -- TODO: undefined
-     :<|> search   conn
-     :<|> graphAPI conn -- TODO: mock
-     :<|> treeAPI  conn
+     :<|> search
+     :<|> graphAPI -- TODO: mock
+     :<|> treeAPI
   --   :<|> orchestrator
-  where
-    conn = env ^. env_conn
 
 serverIndex :: Server (Get '[HTML] Html)
 serverIndex = $(do (Just s) <- liftIO (fileTypeToFileTree (FileTypeFile "purescript-gargantext/dist/index.html"))

src/Gargantext/API/Auth.hs

@@ -22,6 +22,7 @@ Main authorisation of Gargantext are managed in this module
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
 {-# LANGUAGE TemplateHaskell   #-}
 
 module Gargantext.API.Auth
@@ -31,11 +32,11 @@ import Data.Aeson.TH (deriveJSON)
 import Data.List (elem)
 import Data.Swagger
 import Data.Text (Text, reverse)
-import Database.PostgreSQL.Simple (Connection)
 import GHC.Generics (Generic)
 import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Database.Root (getRoot)
 import Gargantext.Database.Types.Node (NodePoly(_node_id))
+import Gargantext.Database.Utils (Cmd)
 import Gargantext.Prelude hiding (reverse)
 import Test.QuickCheck (elements, oneof)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
@@ -81,17 +82,17 @@ arbitraryUsername = ["gargantua", "user1", "user2"]
 arbitraryPassword :: [Password]
 arbitraryPassword = map reverse arbitraryUsername
 
-checkAuthRequest :: Username -> Password -> Connection -> IO CheckAuth
-checkAuthRequest u p c
+checkAuthRequest :: Username -> Password -> Cmd err CheckAuth
+checkAuthRequest u p
   | not (u `elem` arbitraryUsername) = pure InvalidUser
   | u /= reverse p = pure InvalidPassword
   | otherwise = do
-      muId <- getRoot u c
+      muId <- getRoot u
       pure $ maybe InvalidUser (Valid "token" . _node_id) $ head muId
 
-auth' :: Connection -> AuthRequest -> IO AuthResponse
-auth' c (AuthRequest u p) = do
-  checkAuthRequest' <- checkAuthRequest u p c
+auth :: AuthRequest -> Cmd err AuthResponse
+auth (AuthRequest u p) = do
+  checkAuthRequest' <- checkAuthRequest u p
   case checkAuthRequest' of
     InvalidUser     -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid user")
     InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")

src/Gargantext/API/Count.hs

@@ -146,5 +146,5 @@ instance ToSchema Count
 --    arbitrary = Count <$> arbitrary <*> arbitrary <*> arbitrary
 
 -----------------------------------------------------------------------
-count :: Query -> Handler Counts
+count :: Monad m => Query -> m Counts
 count _ = undefined

src/Gargantext/API/Ngrams.hs

@@ -28,6 +28,7 @@ add get
 {-# LANGUAGE TypeOperators     #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes        #-}
 {-# OPTIONS -fno-warn-orphans #-}
 
 module Gargantext.API.Ngrams
@@ -35,6 +36,7 @@ module Gargantext.API.Ngrams
 
 import Prelude (round)
 -- import Gargantext.Database.Schema.User  (UserId)
+import Data.Functor (($>))
 import Data.Patch.Class (Replace, replace)
 --import qualified Data.Map.Strict.Patch as PM
 import Data.Monoid
@@ -42,24 +44,26 @@ import Data.Monoid
 import Data.Set (Set)
 import qualified Data.Set as Set
 --import Data.Maybe (catMaybes)
---import qualified Data.Map.Strict as DM
+-- import qualified Data.Map.Strict as DM
+import Data.Map.Strict (Map)
 --import qualified Data.Set as Set
-import Control.Lens ((.~))
-import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Lens (Prism', prism', (.~), (#))
+import Control.Monad (guard)
+import Control.Monad.Error.Class (MonadError, throwError)
 import Data.Aeson
 import Data.Aeson.TH (deriveJSON)
 import Data.Either(Either(Left))
 import Data.Map (lookup)
 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
-import Data.Swagger
+import Data.Swagger hiding (version)
 import Data.Text (Text)
-import Database.PostgreSQL.Simple (Connection)
 import GHC.Generics (Generic)
 --import Gargantext.Core.Types.Main (Tree(..))
 import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Database.Types.Node (NodeType(..))
-import Gargantext.Database.Schema.Node (defaultList)
+import Gargantext.Database.Schema.Node (defaultList, HasNodeError)
 import qualified Gargantext.Database.Schema.Ngrams as Ngrams
+import Gargantext.Database.Utils (Cmd)
 import Gargantext.Prelude
 import Gargantext.Core.Types (ListType(..), ListId, CorpusId, Limit, Offset)
 import Prelude (Enum, Bounded, minBound, maxBound)
@@ -184,27 +188,18 @@ instance ToSchema  NgramsPatch
 instance Arbitrary NgramsPatch where
   arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
 
-data NgramsIdPatch =
-     NgramsIdPatch { _nip_ngrams      :: NgramsTerm
-                   , _nip_ngramsPatch :: NgramsPatch
-                   }
-      deriving (Ord, Eq, Show, Generic)
-$(deriveJSON (unPrefix "_nip_") ''NgramsIdPatch)
-
-instance ToSchema  NgramsIdPatch
-
-instance Arbitrary NgramsIdPatch where
-  arbitrary = NgramsIdPatch <$> arbitrary <*> arbitrary
-
-                       --
 -- TODO:
 -- * This should be a Map NgramsId NgramsPatch
 -- * Patchs -> Patches
-newtype NgramsIdPatchs =
-     NgramsIdPatchs { _nip_ngramsIdPatchs :: [NgramsIdPatch] }
+newtype NgramsTablePatch =
+     NgramsTablePatch { _nip_ngramsIdPatchs :: Map NgramsTerm NgramsPatch }
       deriving (Ord, Eq, Show, Generic, Arbitrary)
-$(deriveJSON (unPrefix "_nip_") ''NgramsIdPatchs)
-instance ToSchema  NgramsIdPatchs
+$(deriveJSON (unPrefix "_nip_") ''NgramsTablePatch)
+instance ToSchema  NgramsTablePatch
+
+-- TODO: replace by mempty once we have the Monoid instance
+emptyNgramsTablePatch :: NgramsTablePatch
+emptyNgramsTablePatch = NgramsTablePatch mempty
 
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
@@ -246,22 +241,34 @@ type TableNgramsApiGet = Summary " Table Ngrams API Get"
 
 type TableNgramsApi = Summary " Table Ngrams API Change"
                       :> QueryParam "list"   ListId
-                      :> ReqBody '[JSON] NgramsIdPatchsFeed -- Versioned ...
-                      :> Put     '[JSON] NgramsIdPatchsBack -- Versioned ...
+                      :> ReqBody '[JSON] NgramsTablePatch -- (Versioned NgramsTablePatch)
+                      :> Put     '[JSON] NgramsTablePatch -- (Versioned NgramsTablePatch)
 
-type NgramsIdPatchsFeed = NgramsIdPatchs
-type NgramsIdPatchsBack = NgramsIdPatchs
+data NgramError = UnsupportedVersion
+  deriving (Show)
 
+class HasNgramError e where
+  _NgramError :: Prism' e NgramError
+
+instance HasNgramError ServantErr where
+  _NgramError = prism' make match
+    where
+      err = err500 { errBody = "NgramError: Unsupported version" }
+      make UnsupportedVersion = err
+      match e = guard (e == err) $> UnsupportedVersion
+
+ngramError :: (MonadError e m, HasNgramError e) => NgramError -> m a
+ngramError nne = throwError $ _NgramError # nne
 
 {-
-toLists :: ListId -> NgramsIdPatchs -> [(ListId, NgramsId, ListTypeId)]
+toLists :: ListId -> NgramsTablePatch -> [(ListId, NgramsId, ListTypeId)]
 -- toLists = undefined
 toLists lId np = [ (lId,ngId,listTypeId lt) | map (toList lId) (_nip_ngramsIdPatchs np) ]
 
 toList :: ListId -> NgramsIdPatch -> (ListId, NgramsId, ListTypeId)
 toList = undefined
 
-toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatchs -> [NodeNgramsNgrams]
+toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsTablePatch -> [NodeNgramsNgrams]
 toGroups lId addOrRem ps = concat $ map (toGroup lId addOrRem) $ _nip_ngramsIdPatchs ps
 
 toGroup :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatch -> [NodeNgramsNgrams]
@@ -271,26 +278,37 @@ toGroup lId addOrRem (NgramsIdPatch ngId patch)  =
 
 -}
 
-tableNgramsPatch :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> IO NgramsIdPatchsBack
-tableNgramsPatch = undefined 
+-- Apply the given patch to the DB and returns the patch to be applied on the
+-- cilent.
+-- TODO:
+-- In this perliminary version the OT aspect is missing, therefore the version
+-- number is always 1 and the returned patch is always empty.
+tableNgramsPatch :: (HasNgramError err, HasNodeError err)
+                 => CorpusId -> Maybe ListId
+                 -- -> Versioned NgramsTablePatch
+                 -- -> Cmd err (Versioned NgramsTablePatch)
+                 -> any
+                 -> Cmd err any
+tableNgramsPatch _ _ _ = undefined
 {-
-tableNgramsPatch conn corpusId maybeList patchs = do
-  listId <- case maybeList of
-              Nothing      -> defaultList conn corpusId
-              Just listId' -> pure listId'
-  _ <- ngramsGroup' conn Add $ toGroups listId _np_add_children patchs
-  _ <- ngramsGroup' conn Del $ toGroups listId _np_rem_children patchs
-  _ <- updateNodeNgrams conn (toLists listId patchs)
-  pure (NgramsIdPatchs [])
+tableNgramsPatch corpusId maybeList (Versioned version _patch) = do
+  when (version /= 1) $ ngramError UnsupportedVersion
+  _listId <- maybe (defaultList corpusId) pure maybeList
+{-
+  _ <- ngramsGroup' Add $ toGroups listId _np_add_children patch
+  _ <- ngramsGroup' Del $ toGroups listId _np_rem_children patch
+  _ <- updateNodeNgrams (toLists listId patch)
+-}
+  pure $ Versioned 1 emptyNgramsTablePatch
 -}
 
 -- | TODO Errors management
 --  TODO: polymorphic for Annuaire or Corpus or ...
-getTableNgrams :: MonadIO m
-               => Connection -> CorpusId -> Maybe TabType
+getTableNgrams :: HasNodeError err
+               => CorpusId -> Maybe TabType
                -> Maybe ListId -> Maybe Limit -> Maybe Offset
-               -> m NgramsTable
-getTableNgrams c cId maybeTabType maybeListId mlimit moffset = liftIO $ do
+               -> Cmd err NgramsTable
+getTableNgrams cId maybeTabType maybeListId mlimit moffset = do
   let lieu = "Garg.API.Ngrams: " :: Text
   let ngramsType = case maybeTabType of
         Nothing  -> Ngrams.Sources -- panic (lieu <> "Indicate the Table")
@@ -301,9 +319,7 @@ getTableNgrams c cId maybeTabType maybeListId mlimit moffset = liftIO $ do
             Terms      -> Ngrams.NgramsTerms
             _          -> panic $ lieu <> "No Ngrams for this tab"
 
-  listId <- case maybeListId of
-      Nothing -> defaultList c cId
-      Just lId -> pure lId
+  listId <- maybe (defaultList cId) pure maybeListId
 
   let
     defaultLimit = 10 -- TODO
@@ -311,7 +327,7 @@ getTableNgrams c cId maybeTabType maybeListId mlimit moffset = liftIO $ do
     offset_ = maybe 0 identity moffset
 
   (ngramsTableDatas, mapToParent, mapToChildren) <-
-    Ngrams.getNgramsTableDb c NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
+    Ngrams.getNgramsTableDb NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
 
   -- printDebug "ngramsTableDatas" ngramsTableDatas
 

src/Gargantext/API/Node.hs

@@ -17,6 +17,7 @@ Node API
 {-# LANGUAGE FlexibleContexts   #-}
 {-# LANGUAGE NoImplicitPrelude  #-}
 {-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE RankNTypes         #-}
 {-# LANGUAGE TemplateHaskell    #-}
 {-# LANGUAGE TypeOperators      #-}
 
@@ -34,28 +35,27 @@ module Gargantext.API.Node
 -------------------------------------------------------------------
 import Control.Lens (prism', set)
 import Control.Monad.IO.Class (liftIO)
-import Control.Monad ((>>))
+import Control.Monad ((>>), guard)
 --import System.IO (putStrLn, readFile)
 
 import Data.Aeson (FromJSON, ToJSON)
+import Data.Functor (($>))
 --import Data.Text (Text(), pack)
 import Data.Text (Text())
 import Data.Swagger
 import Data.Time (UTCTime)
 
-import Database.PostgreSQL.Simple (Connection)
-
 import GHC.Generics (Generic)
 import Servant
 
-import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams, NgramsIdPatchsFeed, NgramsIdPatchsBack)
+import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams)
 import Gargantext.Prelude
 import Gargantext.Database.Types.Node
-import Gargantext.Database.Utils (runCmd)
-import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, deleteNode, deleteNodes, mk, JSONB)
+import Gargantext.Database.Utils (Cmd, CmdM)
+import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, deleteNode, deleteNodes, mk, JSONB, NodeError(..), HasNodeError(..))
 import Gargantext.Database.Node.Children (getChildren)
 import qualified Gargantext.Database.Node.Update as U (update, Update(..))
-import Gargantext.Database.Facet (FacetDoc , runViewDocuments', OrderBy(..),FacetChart,runViewAuthorsDoc)
+import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..),FacetChart,runViewAuthorsDoc)
 import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
 import Gargantext.Database.Schema.NodeNode (nodesToFavorite, nodesToTrash)
 import Gargantext.API.Search ( SearchAPI, searchIn, SearchInQuery)
@@ -64,12 +64,14 @@ import Gargantext.API.Search ( SearchAPI, searchIn, SearchInQuery)
 import Gargantext.Viz.Graph hiding (Node)-- (Graph(_graph_metadata),LegendField(..), GraphMetadata(..),readGraphFromJson,defaultGraph)
 -- import Gargantext.Core (Lang(..))
 import Gargantext.Core.Types (Offset, Limit)
-import Gargantext.Core.Types.Main (Tree, NodeTree, ListId, CorpusId, ContactId)
+import Gargantext.Core.Types.Main (Tree, NodeTree, CorpusId, ContactId)
 -- import Gargantext.Text.Terms (TermType(..))
 
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 
+type GargServer api = forall env m. CmdM env ServantErr m => ServerT api m
+
 -------------------------------------------------------------------
 -- | TODO : access by admin only
 type NodesAPI  = Delete '[JSON] Int
@@ -77,8 +79,8 @@ type NodesAPI  = Delete '[JSON] Int
 -- | Delete Nodes
 -- Be careful: really delete nodes
 -- Access by admin only
-nodesAPI :: Connection -> [NodeId] -> Server NodesAPI
-nodesAPI conn ids = deleteNodes' conn ids
+nodesAPI :: [NodeId] -> GargServer NodesAPI
+nodesAPI ids = deleteNodes ids
 
 ------------------------------------------------------------------------
 -- | TODO: access by admin only
@@ -89,11 +91,11 @@ type Roots =  Get    '[JSON] [NodeAny]
          :<|> Delete '[JSON] Int -- TODO
 
 -- | TODO: access by admin only
-roots :: Connection -> Server Roots
-roots conn = liftIO (putStrLn ( "/user" :: Text) >> getNodesWithParentId 0 Nothing conn)
-          :<|> pure (panic "not implemented yet") -- TODO
-          :<|> pure (panic "not implemented yet") -- TODO
-          :<|> pure (panic "not implemented yet") -- TODO
+roots :: GargServer Roots
+roots = (liftIO (putStrLn ( "/user" :: Text)) >> getNodesWithParentId 0 Nothing)
+   :<|> pure (panic "not implemented yet") -- TODO
+   :<|> pure (panic "not implemented yet") -- TODO
+   :<|> pure (panic "not implemented yet") -- TODO
 
 -------------------------------------------------------------------
 -- | Node API Types management
@@ -136,29 +138,27 @@ type ChildrenApi a = Summary " Summary children"
                  :> Get '[JSON] [Node a]
 ------------------------------------------------------------------------
 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
-nodeAPI :: JSONB a => Connection -> proxy a -> NodeId -> Server (NodeAPI a)
-nodeAPI conn p id
-                =  liftIO (getNode conn id p)
-              :<|> rename        conn id
-              :<|> postNode      conn id
-              :<|> putNode       conn id
-              :<|> deleteNode'   conn id
-              :<|> getChildren'  conn id p
-              
-              -- TODO gather it
-              :<|> getTable      conn id
-              :<|> tableNgramsPatch'  conn id
-              :<|> getTableNgrams  conn id
-              :<|> getPairing      conn id
-
-              :<|> getChart      conn id
-              :<|> favApi        conn id
-              :<|> delDocs       conn id
-              :<|> searchIn      conn id
-
-              -- Annuaire
-              -- :<|> upload
-              -- :<|> query
+nodeAPI :: JSONB a => proxy a -> NodeId -> GargServer (NodeAPI a)
+nodeAPI p id =  getNode     id p
+           :<|> rename      id
+           :<|> postNode    id
+           :<|> putNode     id
+           :<|> deleteNode  id
+           :<|> getChildren id p
+
+           -- TODO gather it
+           :<|> getTable         id
+           :<|> tableNgramsPatch id
+           :<|> getTableNgrams   id
+           :<|> getPairing       id
+
+           :<|> getChart id
+           :<|> favApi   id
+           :<|> delDocs  id
+           :<|> searchIn id
+           -- Annuaire
+           -- :<|> upload
+           -- :<|> query
 ------------------------------------------------------------------------
 data RenameNode = RenameNode { r_name :: Text }
   deriving (Generic)
@@ -191,9 +191,8 @@ instance FromJSON  Documents
 instance ToJSON    Documents
 instance ToSchema  Documents
 
-delDocs :: Connection -> CorpusId -> Documents -> Handler [Int]
-delDocs c cId ds = liftIO $ nodesToTrash c
-                $ map (\n -> (cId, n, True)) $ documents ds
+delDocs :: CorpusId -> Documents -> Cmd err [Int]
+delDocs cId ds = nodesToTrash $ map (\n -> (cId, n, True)) $ documents ds
 
 ------------------------------------------------------------------------
 type FavApi =  Summary " Favorites label"
@@ -210,17 +209,14 @@ instance FromJSON  Favorites
 instance ToJSON    Favorites
 instance ToSchema  Favorites
 
-putFav :: Connection -> CorpusId -> Favorites -> Handler [Int]
-putFav c cId fs = liftIO $ nodesToFavorite c
-                $ map (\n -> (cId, n, True)) $ favorites fs
+putFav :: CorpusId -> Favorites -> Cmd err [Int]
+putFav cId fs = nodesToFavorite $ map (\n -> (cId, n, True)) $ favorites fs
 
-delFav :: Connection -> CorpusId -> Favorites -> Handler [Int]
-delFav c cId fs = liftIO $ nodesToFavorite c
-                $ map (\n -> (cId, n, False)) $ favorites fs
+delFav :: CorpusId -> Favorites -> Cmd err [Int]
+delFav cId fs = nodesToFavorite $ map (\n -> (cId, n, False)) $ favorites fs
 
-favApi :: Connection -> CorpusId -> (Favorites -> Handler [Int])
-                               :<|> (Favorites -> Handler [Int])
-favApi c cId = putFav c cId :<|> delFav c cId
+favApi :: CorpusId -> GargServer FavApi
+favApi cId = putFav cId :<|> delFav cId
 
 ------------------------------------------------------------------------
 type TableApi = Summary " Table API"
@@ -254,13 +250,10 @@ type ChartApi = Summary " Chart API"
 
 ------------------------------------------------------------------------
 type GraphAPI   = Get '[JSON] Graph
-graphAPI :: Connection -> NodeId -> Server GraphAPI
-graphAPI c nId = liftIO $ graphAPI' c nId
+graphAPI :: NodeId -> GargServer GraphAPI
+graphAPI nId = do
 
-graphAPI' :: Connection -> NodeId -> IO Graph
-graphAPI' c nId = do
-  
-  nodeGraph <- getNode c nId HyperdataGraph
+  nodeGraph <- getNode nId HyperdataGraph
 
   let metadata = GraphMetadata "Title" [maybe 0 identity $ _node_parentId nodeGraph] 
                                        [ LegendField 1 "#FFFFFF" "Label 1"
@@ -276,64 +269,58 @@ graphAPI' c nId = do
   -- liftIO $ liftIO $ pure $  maybe t identity maybeGraph
   -- TODO what do we get about the node? to replace contextText
 
+instance HasNodeError ServantErr where
+  _NodeError = prism' make match
+    where
+      err = err404 { errBody = "NodeError: No list found" }
+      make NoListFound = err
+      match e = guard (e == err) $> NoListFound
+
 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 instance HasTreeError ServantErr where
-  _TreeError = prism' mk (const Nothing) -- Note a prism
+  _TreeError = prism' mk (const $ panic "HasTreeError ServantErr: not a prism")
     where
       mk NoRoot       = err404 { errBody = "Root node not found"           }
       mk EmptyRoot    = err500 { errBody = "Root node should not be empty" }
       mk TooManyRoots = err500 { errBody = "Too many root nodes"           }
 
 type TreeAPI   = Get '[JSON] (Tree NodeTree)
-treeAPI :: Connection -> NodeId -> Server TreeAPI
+treeAPI :: NodeId -> GargServer TreeAPI
 treeAPI = treeDB
 
 ------------------------------------------------------------------------
 -- | Check if the name is less than 255 char
-rename :: Connection -> NodeId -> RenameNode -> Handler [Int]
-rename c nId (RenameNode name) = liftIO $ U.update (U.Rename nId name) c
+rename :: NodeId -> RenameNode -> Cmd err [Int]
+rename nId (RenameNode name) = U.update (U.Rename nId name)
 
-getTable :: Connection -> NodeId -> Maybe TabType
+getTable :: NodeId -> Maybe TabType
          -> Maybe Offset  -> Maybe Limit
-         -> Maybe OrderBy -> Handler [FacetDoc]
-getTable c cId ft o l order = liftIO $ case ft of
-                                (Just Docs)  -> runViewDocuments' c cId False o l order
-                                (Just Trash) -> runViewDocuments' c cId True  o l order
+         -> Maybe OrderBy -> Cmd err [FacetDoc]
+getTable cId ft o l order = case ft of
+                                (Just Docs)  -> runViewDocuments cId False o l order
+                                (Just Trash) -> runViewDocuments cId True  o l order
                                 _     -> panic "not implemented"
 
-getPairing :: Connection -> ContactId -> Maybe TabType
+getPairing :: ContactId -> Maybe TabType
          -> Maybe Offset  -> Maybe Limit
-         -> Maybe OrderBy -> Handler [FacetDoc]
-getPairing c cId ft o l order = liftIO $ case ft of
-                                (Just Docs)  -> runViewAuthorsDoc c cId False o l order
-                                (Just Trash) -> runViewAuthorsDoc c cId True  o l order
+         -> Maybe OrderBy -> Cmd err [FacetDoc]
+getPairing cId ft o l order = case ft of
+                                (Just Docs)  -> runViewAuthorsDoc cId False o l order
+                                (Just Trash) -> runViewAuthorsDoc cId True  o l order
                                 _     -> panic "not implemented"
 
 
-getChart :: Connection -> NodeId -> Maybe UTCTime -> Maybe UTCTime
-                        -> Handler [FacetChart]
-getChart _ _ _ _ = undefined -- TODO
+getChart :: NodeId -> Maybe UTCTime -> Maybe UTCTime
+                   -> Cmd err [FacetChart]
+getChart _ _ _ = undefined -- TODO
 
-postNode :: Connection -> NodeId -> PostNode -> Handler [Int]
-postNode c pId (PostNode name nt) = liftIO $ mk c nt (Just pId) name
+postNode :: NodeId -> PostNode -> Cmd err [Int]
+postNode pId (PostNode name nt) = mk nt (Just pId) name
 
-putNode :: Connection -> NodeId -> Handler Int
+putNode :: NodeId -> Cmd err Int
 putNode = undefined -- TODO
 
-deleteNodes' :: Connection -> [NodeId] -> Handler Int
-deleteNodes' conn ids = liftIO (runCmd conn $ deleteNodes ids)
-
-deleteNode' :: Connection -> NodeId -> Handler Int
-deleteNode' conn id = liftIO (runCmd conn $ deleteNode id)
-
-getChildren' :: JSONB a => Connection -> NodeId -> proxy a -> Maybe NodeType
-              -> Maybe Int -> Maybe Int -> Handler [Node a]
-getChildren' conn pId p nodeType offset limit  = liftIO (getChildren conn pId p nodeType offset limit)
-
-tableNgramsPatch' :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> Handler NgramsIdPatchsBack
-tableNgramsPatch' c cId mL ns = liftIO $ tableNgramsPatch c cId mL ns
-
-query :: Text -> Handler Text
+query :: Monad m => Text -> m Text
 query s = pure s
 
 

src/Gargantext/API/Search.hs

@@ -19,17 +19,16 @@ Count API part of Gargantext.
 {-# LANGUAGE DeriveGeneric      #-}
 {-# LANGUAGE DeriveAnyClass     #-}
 {-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE RankNTypes         #-}
 
 module Gargantext.API.Search
       where
 
 import GHC.Generics (Generic)
 import Data.Time (UTCTime)
-import Control.Monad.IO.Class (liftIO)
 import Data.Aeson.TH (deriveJSON)
 import Data.Swagger
 import Data.Text (Text)
-import Database.PostgreSQL.Simple (Connection)
 import Servant
 import Test.QuickCheck.Arbitrary
 import Test.QuickCheck (elements)
@@ -40,6 +39,7 @@ import Gargantext.Core.Types.Main (Offset, Limit)
 import Gargantext.Database.Types.Node
 import Gargantext.Database.TextSearch
 import Gargantext.Database.Facet
+import Gargantext.Database.Utils (Cmd)
 
 -----------------------------------------------------------------------
 -- | SearchIn [NodesId] if empty then global search
@@ -88,12 +88,12 @@ instance ToSchema SearchResults where
 type SearchAPI = Post '[JSON] SearchResults
 -----------------------------------------------------------------------
 
-search :: Connection -> SearchQuery -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Handler SearchResults
-search c (SearchQuery q pId) o l order =
-  liftIO $ SearchResults <$> searchInCorpusWithContacts c pId q o l order
+search :: SearchQuery -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err SearchResults
+search (SearchQuery q pId) o l order =
+  SearchResults <$> searchInCorpusWithContacts pId q o l order
 
-searchIn :: Connection -> NodeId -> SearchInQuery -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Handler SearchResults
-searchIn c nId (SearchInQuery q ) o l order =
-  liftIO $ SearchResults <$> searchInCorpusWithContacts c nId q o l order
+searchIn :: NodeId -> SearchInQuery -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err SearchResults
+searchIn nId (SearchInQuery q ) o l order =
+  SearchResults <$> searchInCorpusWithContacts nId q o l order
 
 

src/Gargantext/API/Settings.hs

@@ -48,7 +48,7 @@ import qualified Jose.Jwa as Jose
 import Control.Monad.Logger
 import Control.Lens
 import Gargantext.Prelude
-import Gargantext.Database.Utils (databaseParameters)
+import Gargantext.Database.Utils (databaseParameters, HasConnection(..))
 import Gargantext.API.Orchestrator.Types
 
 type PortNumber = Int
@@ -136,6 +136,9 @@ data Env = Env
 
 makeLenses ''Env
 
+instance HasConnection Env where
+  connection = env_conn
+
 data MockEnv = MockEnv
   { _menv_firewall :: !FireWall
   }

src/Gargantext/Database.hs

@@ -18,12 +18,8 @@ Gargantext's database.
 
 module Gargantext.Database ( module Gargantext.Database.Utils
                            , module Gargantext.Database.Bashql
-                           , Connection
                            )
     where
 
 import Gargantext.Database.Utils (connectGargandb)
 import Gargantext.Database.Bashql
-import Database.PostgreSQL.Simple (Connection)
-
-

src/Gargantext/Database/Bashql.hs

@@ -59,6 +59,7 @@ AMS, and by SIAM.
 
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE RankNTypes        #-}
 
 module Gargantext.Database.Bashql ( get
                                   , ls
@@ -70,7 +71,6 @@ module Gargantext.Database.Bashql ( get
                                   , rename
                                   , tree
                                   -- , mkCorpus, mkAnnuaire
-                                  , runCmd'
                                  )
     where
 
@@ -80,51 +80,49 @@ import Data.Text (Text)
 import Data.List (concat, last)
 
 import Gargantext.Core.Types
-import Gargantext.Database.Utils (connectGargandb, Cmd(..), runCmd, mkCmd)
+import Gargantext.Database.Utils (runOpaQuery, Cmd)
 import Gargantext.Database.Schema.Node
 import qualified Gargantext.Database.Node.Update as U (Update(..), update)
 import Gargantext.Prelude
 
-import Opaleye hiding (FromField)
-
 
 -- List of NodeId
 -- type PWD a = PWD UserId [a]
 type PWD = [NodeId]
 --data PWD' a = a | PWD' [a]
 
-rename :: NodeId -> Text -> Cmd [Int]
-rename n t = mkCmd $ \conn -> U.update (U.Rename n t) conn
+rename :: NodeId -> Text -> Cmd err [Int]
+rename n t = U.update $ U.Rename n t
 
-mv :: NodeId -> ParentId -> Cmd [Int]
-mv n p = mkCmd $ \conn -> U.update (U.Move n p) conn
+mv :: NodeId -> ParentId -> Cmd err [Int]
+mv n p = U.update $ U.Move n p
 
 -- | TODO get Children or Node
-get :: PWD -> Cmd [NodeAny]
+get :: PWD -> Cmd err [NodeAny]
 get []  = pure []
-get pwd = Cmd . ReaderT $ \conn -> runQuery conn $ selectNodesWithParentID (last pwd)
+get pwd = runOpaQuery $ selectNodesWithParentID (last pwd)
 
 -- | Home, need to filter with UserId
-home :: Cmd PWD
-home = map _node_id <$> Cmd (ReaderT (getNodesWithParentId 0 Nothing))
+home :: Cmd err PWD
+home = map _node_id <$> getNodesWithParentId 0 Nothing
 
 -- | ls == get Children
-ls :: PWD -> Cmd [NodeAny]
+ls :: PWD -> Cmd err [NodeAny]
 ls = get
 
-tree :: PWD -> Cmd [NodeAny]
+tree :: PWD -> Cmd err [NodeAny]
 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 :: PWD -> [NodeWrite'] -> Cmd err Int64
 post [] _   = pure 0
 post _ []   = pure 0
-post pth ns = Cmd . ReaderT $ insertNodesWithParent (Just $ last pth) ns
+post pth ns = insertNodesWithParent (Just $ last pth) ns
 
---postR :: PWD -> [NodeWrite'] -> Cmd [Int]
+--postR :: PWD -> [NodeWrite'] -> Cmd err [Int]
 --postR [] _ _ = pure [0]
 --postR _ [] _ = pure [0]
 --postR pth ns c = mkNodeR (last pth) ns c
@@ -132,15 +130,15 @@ post pth ns = Cmd . ReaderT $ insertNodesWithParent (Just $ last pth) ns
 -- | WIP
 -- rm : mv to trash
 -- del : empty trash
---rm :: Connection -> PWD -> [NodeId] -> IO Int
+--rm :: PWD -> [NodeId] -> IO Int
 --rm = del
-del :: [NodeId] -> Cmd Int
+del :: [NodeId] -> Cmd err Int
 del [] = pure 0
 del ns = deleteNodes ns
 
 -- | TODO
-put :: U.Update -> Cmd [Int]
-put u = mkCmd $ U.update u
+put :: U.Update -> Cmd err [Int]
+put = U.update
 
 -- | TODO
 -- cd (Home UserId) | (Node NodeId)
@@ -151,7 +149,7 @@ put u = mkCmd $ U.update u
 -- type Name = Text
 
 
---mkCorpus :: ToJSON a => Name -> (a -> Text) -> [a] -> Cmd NewNode
+--mkCorpus :: ToJSON a => Name -> (a -> Text) -> [a] -> Cmd err NewNode
 --mkCorpus name title ns = do
 --  pid <- home
 --  
@@ -167,7 +165,7 @@ put u = mkCmd $ U.update u
 ---- |
 ---- import IMTClient as C
 ---- postAnnuaire "Annuaire IMT" (\n -> (maybe "" identity (C.prenom n)) <> " " <> (maybe "" identity (C.nom n))) (take 30 annuaire)
---mkAnnuaire :: ToJSON a => Name -> (a -> Text) -> [a] -> Cmd NewNode
+--mkAnnuaire :: ToJSON a => Name -> (a -> Text) -> [a] -> Cmd err NewNode
 --mkAnnuaire name title ns = do
 --  pid <- lastMay <$> home
 --  let pid' = case lastMay pid of
@@ -185,6 +183,3 @@ put u = mkCmd $ U.update u
 -- let myCorpus' = Prelude.filter (\n -> T.length (maybe "" identity (hyperdataDocument_title n)) > 30) myCorpus
 
 -- corporaOf :: Username -> IO [Corpus]
-
-runCmd' :: Cmd a -> IO a
-runCmd' f = connectGargandb "gargantext.ini" >>= \c -> runCmd c f

src/Gargantext/Database/Cooc.hs

@@ -13,26 +13,24 @@ Portability : POSIX
 --{-# LANGUAGE OverloadedStrings #-}
 
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes  #-}
 
 module Gargantext.Database.Cooc where
 
-import Control.Monad ((>>=))
-import Database.PostgreSQL.Simple
 import Database.PostgreSQL.Simple.SqlQQ
 
 import Gargantext.Prelude
-import Gargantext (connectGargandb)
+import Gargantext.Database.Utils (Cmd, runCmdDevNoErr, runPGSQuery)
 
 type CorpusId    = Int
 type MainListId  = Int
 type GroupListId = Int
 
 coocTest :: IO [(Int, Int, Int)]
-coocTest = connectGargandb "gargantext.ini"
-  >>= \conn -> dBcooc conn 421968 446602 446599 
+coocTest = runCmdDevNoErr $ dBcooc 421968 446602 446599
 
-dBcooc :: Connection -> CorpusId -> MainListId -> GroupListId -> IO [(Int, Int, Int)]
-dBcooc conn corpus mainList groupList = query conn [sql|
+dBcooc :: CorpusId -> MainListId -> GroupListId -> Cmd err [(Int, Int, Int)]
+dBcooc corpus mainList groupList = runPGSQuery [sql|
   set work_mem='1GB';
 
   --EXPLAIN ANALYZE

src/Gargantext/Database/Facet.hs

@@ -21,6 +21,7 @@ Portability : POSIX
 {-# LANGUAGE NoImplicitPrelude         #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RankNTypes                #-}
 {-# LANGUAGE TemplateHaskell           #-}
 ------------------------------------------------------------------------
 module Gargantext.Database.Facet
@@ -37,7 +38,6 @@ import Data.Swagger
 import Data.Text (Text)
 import Data.Time (UTCTime)
 import Data.Time.Segment (jour)
-import Database.PostgreSQL.Simple (Connection)
 import GHC.Generics (Generic)
 import Gargantext.Core.Types
 import Gargantext.Core.Utils.Prefix (unPrefix)
@@ -204,8 +204,8 @@ instance Arbitrary OrderBy
     arbitrary = elements [minBound..maxBound]
 
 
-runViewAuthorsDoc :: Connection -> ContactId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
-runViewAuthorsDoc c cId t o l order = runQuery c (filterWith o l order $ viewAuthorsDoc cId t ntId)
+runViewAuthorsDoc :: ContactId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
+runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
   where
     ntId = NodeDocument
 
@@ -244,13 +244,9 @@ queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable
 
 ------------------------------------------------------------------------
 
-runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd [FacetDoc]
-runViewDocuments cId t o l order = mkCmd $ \c -> runViewDocuments' c cId t o l order
-
--- | TODO use only Cmd with Reader and delete function below
-runViewDocuments' :: Connection -> CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
-runViewDocuments' c cId t o l order = runQuery c ( filterWith o l order
-                                                $ viewDocuments cId t ntId)
+runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
+runViewDocuments cId t o l order =
+    runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
   where
     ntId = nodeTypeId NodeDocument
 

src/Gargantext/Database/Flow.hs

@@ -12,11 +12,13 @@ Portability : POSIX
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
 
 module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
     where
 
 --import Control.Lens (view)
+import Control.Monad.IO.Class (liftIO)
 --import Gargantext.Core.Types
 --import Gargantext.Database.Node.Contact (HyperdataContact(..))
 import Data.Map (Map, lookup)
@@ -29,21 +31,20 @@ import Gargantext.Core.Types (NodePoly(..), ListType(..), listTypeId, Terms(..))
 import Gargantext.Core.Types.Individu (Username)
 import Gargantext.Core.Types.Main
 import Gargantext.Core (Lang(..))
-import Gargantext.Database.Bashql (runCmd') -- , del)
 import Gargantext.Database.Config (userMaster, userArbitrary, corpusMasterName)
 import Gargantext.Database.Flow.Utils (insertToNodeNgrams)
 import Gargantext.Text.Terms (extractTerms)
 import Gargantext.Database.Node.Document.Add    (add)
 import Gargantext.Database.Node.Document.Insert (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
-import Gargantext.Database.Root (getRootCmd)
+import Gargantext.Database.Root (getRoot)
 import Gargantext.Database.Schema.Ngrams (insertNgrams, Ngrams(..), NgramsT(..), NgramsIndexed(..), indexNgramsT,  NgramsType(..), text2ngrams)
-import Gargantext.Database.Schema.Node (mkRoot, mkCorpus, getOrMkList, mkGraph, mkDashboard, mkAnnuaire, getCorporaWithParentId')
+import Gargantext.Database.Schema.Node (mkRoot, mkCorpus, getOrMkList, mkGraph, mkDashboard, mkAnnuaire, getCorporaWithParentId, HasNodeError)
 import Gargantext.Database.Schema.NodeNgram (NodeNgramPoly(..), insertNodeNgrams)
 import Gargantext.Database.Schema.NodeNgramsNgrams (NodeNgramsNgramsPoly(..), insertNodeNgramsNgramsNew)
 import Gargantext.Database.Schema.User (getUser, UserLight(..))
 import Gargantext.Database.Types.Node (HyperdataDocument(..))
 import Gargantext.Database.Types.Node (NodeType(..), NodeId)
-import Gargantext.Database.Utils (Cmd(..))
+import Gargantext.Database.Utils (Cmd)
 import Gargantext.Text.Terms (TermType(..))
 import Gargantext.Ext.IMT (toSchoolName)
 import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
@@ -52,56 +53,57 @@ import Gargantext.Text.Parsers (parseDocs, FileFormat)
 import System.FilePath (FilePath)
 import qualified Data.Map as DM
 
-flowCorpus :: FileFormat -> FilePath -> CorpusName -> IO CorpusId
+flowCorpus :: HasNodeError err => FileFormat -> FilePath -> CorpusName -> Cmd err CorpusId
 flowCorpus ff fp cName = do
-  hyperdataDocuments' <- map addUniqIdsDoc <$> parseDocs ff fp
+  hyperdataDocuments' <- map addUniqIdsDoc <$> liftIO (parseDocs ff fp)
   params <- flowInsert NodeCorpus hyperdataDocuments' cName
   flowCorpus' NodeCorpus hyperdataDocuments' params
 
 
 flowInsert :: NodeType -> [HyperdataDocument] -> CorpusName
-     -> IO ([ReturnId], MasterUserId, MasterCorpusId, UserId, CorpusId)
+     -> Cmd err ([ReturnId], MasterUserId, MasterCorpusId, UserId, CorpusId)
 flowInsert _nt hyperdataDocuments cName = do
   let hyperdataDocuments' = map (\h -> ToDbDocument h) hyperdataDocuments
 
   (masterUserId, _, masterCorpusId) <- subFlowCorpus userMaster corpusMasterName
-  ids  <- runCmd' $ insertDocuments masterUserId masterCorpusId NodeDocument hyperdataDocuments'
+  ids  <- insertDocuments masterUserId masterCorpusId NodeDocument hyperdataDocuments'
   
   (userId, _, userCorpusId) <- subFlowCorpus userArbitrary cName
-  _ <- runCmd' $ add userCorpusId (map reId ids)
+  _ <- add userCorpusId (map reId ids)
   
   pure (ids, masterUserId, masterCorpusId, userId, userCorpusId)
 
 
-flowAnnuaire :: FilePath -> IO ()
+flowAnnuaire :: FilePath -> Cmd err ()
 flowAnnuaire filePath = do
-  contacts <- deserialiseImtUsersFromFile filePath
+  contacts <- liftIO $ deserialiseImtUsersFromFile filePath
   ps <- flowInsertAnnuaire "Annuaire" $ map (\h-> ToDbContact h) $ map addUniqIdsContact contacts
   printDebug "length annuaire" ps
 
 
 flowInsertAnnuaire :: CorpusName -> [ToDbData]
-                    -> IO ([ReturnId], UserId, CorpusId, UserId, CorpusId)
+                    -> Cmd err ([ReturnId], UserId, CorpusId, UserId, CorpusId)
 flowInsertAnnuaire name children = do
 
   (masterUserId, _, masterCorpusId) <- subFlowCorpus userMaster corpusMasterName
-  ids  <- runCmd' $ insertDocuments masterUserId masterCorpusId NodeContact children
+  ids  <- insertDocuments masterUserId masterCorpusId NodeContact children
   
   (userId, _, userCorpusId) <- subFlowAnnuaire userArbitrary name
-  _ <- runCmd' $ add userCorpusId (map reId ids)
+  _ <- add userCorpusId (map reId ids)
   
   printDebug "AnnuaireID" userCorpusId
 
   pure (ids, masterUserId, masterCorpusId, userId, userCorpusId)
 
 
-flowCorpus' :: NodeType -> [HyperdataDocument]
+flowCorpus' :: HasNodeError err
+            => NodeType -> [HyperdataDocument]
             -> ([ReturnId], UserId, CorpusId, UserId, CorpusId)
-            -> IO CorpusId
+            -> Cmd err CorpusId
 flowCorpus' NodeCorpus hyperdataDocuments (ids,masterUserId,masterCorpusId, userId,userCorpusId) = do
 --------------------------------------------------
   -- List Ngrams Flow
-  userListId <- runCmd' $ flowListUser userId userCorpusId
+  userListId <- flowListUser userId userCorpusId
   printDebug "Working on User ListId : " userListId
   
   let documentsWithId = mergeData (toInserted ids) (toInsert hyperdataDocuments)
@@ -111,22 +113,22 @@ flowCorpus' NodeCorpus hyperdataDocuments (ids,masterUserId,masterCorpusId, user
   let maps            = mapNodeIdNgrams docsWithNgrams
   
   -- printDebug "maps" (maps)
-  indexedNgrams <- runCmd' $ indexNgrams maps
+  indexedNgrams <- indexNgrams maps
   -- printDebug "inserted ngrams" indexedNgrams
-  _             <- runCmd' $ insertToNodeNgrams indexedNgrams
+  _             <- insertToNodeNgrams indexedNgrams
   
-  listId2    <- runCmd' $ flowList masterUserId masterCorpusId indexedNgrams
+  listId2    <- flowList masterUserId masterCorpusId indexedNgrams
   printDebug "Working on ListId : " listId2
   --}
 --------------------------------------------------
-  _ <- runCmd' $ mkDashboard userCorpusId userId
-  _ <- runCmd' $ mkGraph     userCorpusId userId
+  _ <- mkDashboard userCorpusId userId
+  _ <- mkGraph     userCorpusId userId
   
   -- Annuaire Flow
-  -- _ <- runCmd' $ mkAnnuaire  rootUserId userId
+  -- _ <- mkAnnuaire  rootUserId userId
 
   pure userCorpusId
-  -- runCmd' $ del [corpusId2, corpusId]
+  -- del [corpusId2, corpusId]
 
 flowCorpus' NodeAnnuaire _hyperdataDocuments (_ids,_masterUserId,_masterCorpusId,_userId,_userCorpusId) = undefined
 flowCorpus' _ _ _ = undefined
@@ -134,19 +136,19 @@ flowCorpus' _ _ _ = undefined
 
 type CorpusName = Text
 
-subFlowCorpus :: Username -> CorpusName -> IO (UserId, RootId, CorpusId)
+subFlowCorpus :: Username -> CorpusName -> Cmd err (UserId, RootId, CorpusId)
 subFlowCorpus username cName = do
-  maybeUserId <- runCmd' (getUser username)
+  maybeUserId <- getUser username
 
   let userId = case maybeUserId of
         Nothing   -> panic "Error: User does not exist (yet)"
         -- mk NodeUser gargantua_id "Node Gargantua"
         Just user -> userLight_id user
 
-  rootId' <- map _node_id <$> runCmd' (getRootCmd username)
+  rootId' <- map _node_id <$> getRoot username
 
   rootId'' <- case rootId' of
-        []  -> runCmd' (mkRoot username userId)
+        []  -> mkRoot username userId
         n   -> case length n >= 2 of
             True  -> panic "Error: more than 1 userNode / user"
             False -> pure rootId'
@@ -154,14 +156,14 @@ subFlowCorpus username cName = do
 
   corpusId'' <- if username == userMaster
                   then do
-                    ns <- runCmd' $ getCorporaWithParentId' rootId
+                    ns <- getCorporaWithParentId rootId
                     pure $ map _node_id ns
                   else
                     pure []
 
   corpusId' <- if corpusId'' /= []
                   then pure corpusId''
-                  else runCmd' $ mkCorpus (Just cName) Nothing rootId userId
+                  else mkCorpus (Just cName) Nothing rootId userId
 
   let corpusId = maybe (panic "error corpusId") identity (head corpusId')
 
@@ -170,25 +172,25 @@ subFlowCorpus username cName = do
   pure (userId, rootId, corpusId)
 
 
-subFlowAnnuaire :: Username -> CorpusName -> IO (UserId, RootId, CorpusId)
+subFlowAnnuaire :: Username -> CorpusName -> Cmd err (UserId, RootId, CorpusId)
 subFlowAnnuaire username _cName = do
-  maybeUserId <- runCmd' (getUser username)
+  maybeUserId <- getUser username
 
   let userId = case maybeUserId of
         Nothing   -> panic "Error: User does not exist (yet)"
         -- mk NodeUser gargantua_id "Node Gargantua"
         Just user -> userLight_id user
 
-  rootId' <- map _node_id <$> runCmd' (getRootCmd username)
+  rootId' <- map _node_id <$> getRoot username
 
   rootId'' <- case rootId' of
-        []  -> runCmd' (mkRoot username userId)
+        []  -> mkRoot username userId
         n   -> case length n >= 2 of
             True  -> panic "Error: more than 1 userNode / user"
             False -> pure rootId'
   let rootId = maybe (panic "error rootId") identity (head rootId'')
 
-  corpusId' <- runCmd' $ mkAnnuaire rootId userId
+  corpusId' <- mkAnnuaire rootId userId
   
   let corpusId = maybe (panic "error corpusId") identity (head corpusId')
 
@@ -232,14 +234,14 @@ data DocumentIdWithNgrams =
 -- add f :: Text -> Text
 -- newtype Ngrams = Ngrams Text
 -- TODO group terms
-extractNgramsT :: HyperdataDocument -> IO (Map (NgramsT Ngrams) Int)
+extractNgramsT :: HyperdataDocument -> Cmd err (Map (NgramsT Ngrams) Int)
 extractNgramsT doc = do
   
   let source    = text2ngrams $ maybe "Nothing" identity $ _hyperdataDocument_source doc
   let institutes = map text2ngrams $ maybe ["Nothing"] (map toSchoolName . (splitOn ", "))  $ _hyperdataDocument_institutes doc
   let authors    = map text2ngrams $ maybe ["Nothing"] (splitOn ", ") $ _hyperdataDocument_authors doc
   let leText = catMaybes [_hyperdataDocument_title doc, _hyperdataDocument_abstract doc]
-  terms' <- map text2ngrams <$> map (intercalate " " . _terms_label) <$> concat <$> extractTerms (Multi EN) leText
+  terms' <- map text2ngrams <$> map (intercalate " " . _terms_label) <$> concat <$> liftIO (extractTerms (Multi EN) leText)
 
   pure $ DM.fromList $  [(NgramsT Sources source, 1)]
                      <> [(NgramsT Institutes  i' , 1)| i' <- institutes ]
@@ -249,8 +251,8 @@ extractNgramsT doc = do
 
 
 
-documentIdWithNgrams :: (HyperdataDocument -> IO (Map (NgramsT Ngrams) Int))
-                     -> [DocumentWithId]   -> IO [DocumentIdWithNgrams]
+documentIdWithNgrams :: (HyperdataDocument -> Cmd err (Map (NgramsT Ngrams) Int))
+                     -> [DocumentWithId]   -> Cmd err [DocumentIdWithNgrams]
 documentIdWithNgrams f = mapM toDocumentIdWithNgrams
   where
     toDocumentIdWithNgrams d = do
@@ -265,7 +267,7 @@ mapNodeIdNgrams ds = DM.map (DM.fromListWith (+)) $ DM.fromListWith (<>) xs
     n2i = map (\d -> ((documentId . documentWithId) d, document_ngrams d))
 
 indexNgrams :: Map (NgramsT Ngrams       ) (Map NodeId Int)
-       -> Cmd (Map (NgramsT NgramsIndexed) (Map NodeId Int))
+  -> Cmd err (Map (NgramsT NgramsIndexed) (Map NodeId Int))
 indexNgrams ng2nId = do
   terms2id <- insertNgrams (map _ngramsT $ DM.keys ng2nId)
   pure $ DM.mapKeys (indexNgramsT terms2id) ng2nId
@@ -273,7 +275,7 @@ indexNgrams ng2nId = do
 
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
-flowList :: UserId -> CorpusId -> Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Cmd ListId
+flowList :: HasNodeError err => UserId -> CorpusId -> Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Cmd err ListId
 flowList uId cId ngs = do
   -- printDebug "ngs:" ngs
   lId <- getOrMkList cId uId
@@ -291,7 +293,7 @@ flowList uId cId ngs = do
 
   pure lId
 
-flowListUser :: UserId -> CorpusId -> Cmd Int
+flowListUser :: HasNodeError err => UserId -> CorpusId -> Cmd err Int
 flowListUser uId cId = getOrMkList cId uId
 
 ------------------------------------------------------------------------
@@ -304,11 +306,11 @@ groupNgramsBy isEqual cId = DM.fromList $ catMaybes [ isEqual n1 n2 | n1 <- DM.k
 
 
 -- TODO check: do not insert duplicates
-insertGroups :: ListId -> Map NgramsIndexed NgramsIndexed -> Cmd Int
+insertGroups :: ListId -> Map NgramsIndexed NgramsIndexed -> Cmd err Int
 insertGroups lId ngrs =
   insertNodeNgramsNgramsNew [ NodeNgramsNgrams lId ng1 ng2 (Just 1)
-                              | (ng1, ng2) <- map (both _ngramsId) $ DM.toList ngrs
-                              , ng1 /= ng2
+                            | (ng1, ng2) <- map (both _ngramsId) $ DM.toList ngrs
+                            , ng1 /= ng2
                             ]
 
 ------------------------------------------------------------------------
@@ -317,7 +319,7 @@ ngrams2list :: Map (NgramsT NgramsIndexed) (Map NodeId Int) -> [(ListType,Ngrams
 ngrams2list = zip (repeat CandidateList) . map (\(NgramsT _lost_t ng) -> ng) . DM.keys
 
 -- | TODO: weight of the list could be a probability
-insertLists :: ListId -> [(ListType,NgramsIndexed)] -> Cmd Int
+insertLists :: ListId -> [(ListType,NgramsIndexed)] -> Cmd err Int
 insertLists lId lngs =
   insertNodeNgrams [ NodeNgram Nothing lId ngr (fromIntegral $ listTypeId l) (listTypeId l)
                      | (l,ngr) <- map (second _ngramsId) lngs

src/Gargantext/Database/Flow/Pairing.hs

@@ -9,9 +9,10 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE QuasiQuotes            #-}
+{-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
 -- {-# LANGUAGE Arrows #-}
 
 module Gargantext.Database.Flow.Pairing
@@ -19,7 +20,6 @@ module Gargantext.Database.Flow.Pairing
 
 --import Debug.Trace (trace)
 import Control.Lens (_Just,view)
-import Database.PostgreSQL.Simple (Connection, query)
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 -- import Opaleye
 -- import Opaleye.Aggregate
@@ -36,27 +36,26 @@ import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
 --import Gargantext.Database.Types.Node -- (Hyperdata(..))
 import Gargantext.Database.Node.Contact
 import Gargantext.Database.Flow.Utils
-import Gargantext.Database.Utils (Cmd, mkCmd)
+import Gargantext.Database.Utils (Cmd, runPGSQuery)
 import Gargantext.Database.Node.Children
 import Gargantext.Core.Types.Main
 import Gargantext.Core.Types (NodeType(..))
-import Gargantext.Database.Bashql (runCmd')
 
 -- TODO mv this type in Types Main
 type Terms = Text
 
 -- | TODO : add paring policy as parameter
-pairing :: AnnuaireId -> CorpusId -> IO Int
+pairing :: AnnuaireId -> CorpusId -> Cmd err Int
 pairing aId cId = do
-  contacts' <- runCmd' $ getContacts aId (Just NodeContact)
+  contacts' <- getContacts aId (Just NodeContact)
   let contactsMap = pairingPolicyToMap toLower $ toMaps extractNgramsT contacts'
-  
-  ngramsMap' <- runCmd' $ getNgramsTindexed cId Authors
+
+  ngramsMap' <- getNgramsTindexed cId Authors
   let ngramsMap = pairingPolicyToMap lastName ngramsMap'
 
   let indexedNgrams = pairMaps contactsMap ngramsMap
-  
-  runCmd' $ insertToNodeNgrams indexedNgrams
+
+  insertToNodeNgrams indexedNgrams
   -- TODO add List
 
 lastName :: Terms -> Terms
@@ -92,13 +91,13 @@ pairMaps m1 m2 = DM.fromList $ catMaybes $ map (\(k,n) -> (,) <$> lookup' k m2 <
 
 
 -----------------------------------------------------------------------
-getNgramsTindexed:: CorpusId -> NgramsType -> Cmd (Map (NgramsT Ngrams) NgramsId)
-getNgramsTindexed corpusId ngramsType' = mkCmd $ \c -> fromList
+getNgramsTindexed:: CorpusId -> NgramsType -> Cmd err (Map (NgramsT Ngrams) NgramsId)
+getNgramsTindexed corpusId ngramsType' = fromList
     <$> map (\(ngramsId',t,n) -> (NgramsT ngramsType' (Ngrams t n),ngramsId'))
-    <$> selectNgramsTindexed c corpusId ngramsType'
+    <$> selectNgramsTindexed corpusId ngramsType'
 
-selectNgramsTindexed :: Connection -> CorpusId -> NgramsType -> IO [(NgramsId, Terms, Int)]
-selectNgramsTindexed c corpusId ngramsType'' = query c selectQuery (corpusId, ngramsTypeId ngramsType'')
+selectNgramsTindexed :: CorpusId -> NgramsType -> Cmd err [(NgramsId, Terms, Int)]
+selectNgramsTindexed corpusId ngramsType'' = runPGSQuery selectQuery (corpusId, ngramsTypeId ngramsType'')
   where
     selectQuery = [sql| SELECT n.id,n.terms,n.n from ngrams n
                   JOIN nodes_ngrams occ ON occ.ngram_id = n.id

src/Gargantext/Database/Flow/Utils.hs

@@ -11,6 +11,7 @@ Portability : POSIX
 
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
 
 module Gargantext.Database.Flow.Utils
     where
@@ -53,11 +54,11 @@ data DocumentIdWithNgrams a =
      } deriving (Show)
 
 
-insertToNodeNgrams :: Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Cmd Int
+insertToNodeNgrams :: Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Cmd err Int
 insertToNodeNgrams m = insertNodeNgrams [ NodeNgram Nothing nId  ((_ngramsId    . _ngramsT   ) ng)
                                                 (fromIntegral n) ((ngramsTypeId . _ngramsType) ng)
-                                          | (ng, nId2int) <- DM.toList m
-                                          , (nId, n)      <- DM.toList nId2int
+                                        | (ng, nId2int) <- DM.toList m
+                                        , (nId, n)      <- DM.toList nId2int
                                         ]
 
 

src/Gargantext/Database/Node/Children.hs

@@ -14,10 +14,10 @@ Portability : POSIX
 {-# LANGUAGE Arrows                 #-}
 {-# LANGUAGE FlexibleInstances      #-}
 {-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE RankNTypes             #-}
 
 module Gargantext.Database.Node.Children where
 
-import Database.PostgreSQL.Simple (Connection)
 import Opaleye
 import Gargantext.Core.Types
 import Gargantext.Database.Schema.Node
@@ -29,12 +29,12 @@ import Gargantext.Database.Node.Contact (HyperdataContact)
 import Control.Arrow (returnA)
 
 -- | TODO: use getChildren with Proxy ?
-getContacts :: ParentId -> Maybe NodeType -> Cmd [Node HyperdataContact]
-getContacts pId maybeNodeType = mkCmd $ \c -> runQuery c $ selectChildren pId maybeNodeType
+getContacts :: ParentId -> Maybe NodeType -> Cmd err [Node HyperdataContact]
+getContacts pId maybeNodeType = runOpaQuery $ selectChildren pId maybeNodeType
 
 
-getChildren :: JSONB a => Connection -> ParentId -> proxy a -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> IO [Node a]
-getChildren c pId _ maybeNodeType maybeOffset maybeLimit = runQuery c 
+getChildren :: JSONB a => ParentId -> proxy a -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
+getChildren pId _ maybeNodeType maybeOffset maybeLimit = runOpaQuery
                   $ limit' maybeLimit $ offset' maybeOffset
                   $ orderBy (asc _node_id)
                   $ selectChildren pId maybeNodeType

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

@@ -17,6 +17,7 @@ Add Documents/Contact to a Corpus/Annuaire.
 {-# LANGUAGE NoImplicitPrelude    #-}
 {-# LANGUAGE OverloadedStrings    #-}
 {-# LANGUAGE QuasiQuotes          #-}
+{-# LANGUAGE RankNTypes           #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 ------------------------------------------------------------------------
 module Gargantext.Database.Node.Document.Add where
@@ -24,7 +25,7 @@ module Gargantext.Database.Node.Document.Add where
 
 import Data.ByteString.Internal (ByteString)
 import Data.Typeable (Typeable)
-import Database.PostgreSQL.Simple (Query, formatQuery, query, Only(..))
+import Database.PostgreSQL.Simple (Query, Only(..))
 import Database.PostgreSQL.Simple.SqlQQ
 import Database.PostgreSQL.Simple.ToField (toField)
 import Database.PostgreSQL.Simple.ToRow (ToRow(..))
@@ -32,7 +33,7 @@ import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
 
 import Data.Text (Text)
 
-import Gargantext.Database.Utils (mkCmd, Cmd(..))
+import Gargantext.Database.Utils (Cmd, runPGSQuery, formatPGSQuery)
 import Gargantext.Database.Types.Node
 import Gargantext.Prelude
 
@@ -41,14 +42,14 @@ import GHC.Generics (Generic)
 
 type ParentId = Int
 
-add :: ParentId -> [NodeId] -> Cmd [Only Int]
-add pId ns = mkCmd $ \c -> query c queryAdd (Only $ Values fields inputData)
+add :: ParentId -> [NodeId] -> Cmd err [Only Int]
+add pId ns = runPGSQuery queryAdd (Only $ Values fields inputData)
   where
     fields    = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
     inputData = prepare pId ns
 
-add_debug :: ParentId -> [NodeId] -> Cmd ByteString
-add_debug pId ns = mkCmd $ \c -> formatQuery c queryAdd (Only $ Values fields inputData)
+add_debug :: ParentId -> [NodeId] -> Cmd err ByteString
+add_debug pId ns = formatPGSQuery queryAdd (Only $ Values fields inputData)
   where
     fields    = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
     inputData = prepare pId ns

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

@@ -44,8 +44,7 @@ the concatenation of the parameters defined by @hashParameters@.
 > -- * Example
 > insertTest :: FromRow r => CorpusId -> [Node HyperdataDocument] -> IO [r]
 > insertTest :: IO [ReturnId]
-> insertTest = connectGargandb "gargantext.ini"
->          >>= \conn -> insertDocuments conn 1 452162 hyperdataDocuments
+> insertTest = runCmdDev $ insertDocuments 1 452162 hyperdataDocuments
 
 -}
 ------------------------------------------------------------------------
@@ -55,6 +54,7 @@ the concatenation of the parameters defined by @hashParameters@.
 {-# LANGUAGE NoImplicitPrelude    #-}
 {-# LANGUAGE OverloadedStrings    #-}
 {-# LANGUAGE QuasiQuotes          #-}
+{-# LANGUAGE RankNTypes           #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 ------------------------------------------------------------------------
 module Gargantext.Database.Node.Document.Insert where
@@ -66,7 +66,7 @@ import Data.Aeson (toJSON, Value)
 import Data.Maybe (maybe)
 import Data.Text (Text)
 import Data.Typeable (Typeable)
-import Database.PostgreSQL.Simple (FromRow, Query, query, Only(..))
+import Database.PostgreSQL.Simple (FromRow, Query, Only(..))
 import Database.PostgreSQL.Simple.FromRow (fromRow, field)
 import Database.PostgreSQL.Simple.SqlQQ
 import Database.PostgreSQL.Simple.ToField (toField)
@@ -74,7 +74,7 @@ import Database.PostgreSQL.Simple.ToRow (ToRow(..))
 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
 import GHC.Generics (Generic)
 import Gargantext.Database.Config (nodeTypeId)
-import Gargantext.Database.Utils (mkCmd, Cmd(..))
+import Gargantext.Database.Utils (Cmd, runPGSQuery)
 import Gargantext.Database.Node.Contact -- (HyperdataContact(..), ContactWho(..))
 import Gargantext.Database.Types.Node
 import Gargantext.Prelude
@@ -113,8 +113,9 @@ import Database.PostgreSQL.Simple (formatQuery)
 
 data ToDbData = ToDbDocument HyperdataDocument | ToDbContact HyperdataContact
 
-insertDocuments :: UserId -> ParentId -> NodeType -> [ToDbData] -> Cmd [ReturnId]
-insertDocuments uId pId nodeType hs = mkCmd $ \c -> query c queryInsert (Only $ Values fields $ prepare uId pId nodeType hs)
+insertDocuments :: UserId -> ParentId -> NodeType -> [ToDbData] -> Cmd err [ReturnId]
+insertDocuments uId pId nodeType =
+    runPGSQuery queryInsert . Only . Values fields . prepare uId pId nodeType
   where
     fields    = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
 
@@ -123,7 +124,7 @@ insertDocuments uId pId nodeType hs = mkCmd $ \c -> query c queryInsert (Only $
 -- to print rendered query (Debug purpose) use @formatQuery@ function.
 {-
 insertDocuments_Debug :: (Hyperdata a, ToJSON a, ToRow a) => UserId -> ParentId -> [a] -> Cmd ByteString
-insertDocuments_Debug uId pId hs = mkCmd $ \conn -> formatQuery conn queryInsert (Only $ Values fields inputData)
+insertDocuments_Debug uId pId hs = formatPGSQuery queryInsert (Only $ Values fields inputData)
   where
     fields    = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
     inputData = prepare uId pId hs

src/Gargantext/Database/Node/Update.hs

@@ -10,8 +10,9 @@ Portability : POSIX
 -}
 
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE RankNTypes        #-}
 
 
 module Gargantext.Database.Node.Update (Update(..), update) where
@@ -21,10 +22,11 @@ import qualified Data.Text as DT
 import Database.PostgreSQL.Simple
 
 import Gargantext.Prelude
+import Gargantext.Database.Utils
 
 -- import Data.ByteString
---rename :: Connection -> NodeId -> Text -> IO ByteString
---rename conn nodeId name = formatQuery conn "UPDATE nodes SET name=? where id=?" (name,nodeId)
+--rename :: NodeId -> Text -> IO ByteString
+--rename nodeId name = formatPGSQuery "UPDATE nodes SET name=? where id=?" (name,nodeId)
 ------------------------------------------------------------------------
 type NodeId = Int
 type Name   = Text
@@ -41,10 +43,10 @@ data Update = Rename NodeId Name
 unOnly :: Only a -> a
 unOnly (Only a) = a
 
-update :: Update -> Connection -> IO [Int]
-update (Rename nId name) conn = map unOnly <$> query conn "UPDATE nodes SET name=? where id=? returning id"
+update :: Update -> Cmd err [Int]
+update (Rename nId name) = map unOnly <$> runPGSQuery "UPDATE nodes SET name=? where id=? returning id"
                                            (DT.take 255 name,nId)
-update (Move nId pId) conn    = map unOnly <$> query conn "UPDATE nodes SET parent_id= ? where id=? returning id"
+update (Move nId pId)    = map unOnly <$> runPGSQuery "UPDATE nodes SET parent_id= ? where id=? returning id"
                                            (pId, nId)
 
 

src/Gargantext/Database/Root.hs

@@ -21,12 +21,12 @@ Portability : POSIX
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE MultiParamTypeClasses  #-}
 {-# LANGUAGE NoImplicitPrelude      #-}
+{-# LANGUAGE RankNTypes             #-}
 {-# LANGUAGE TemplateHaskell        #-}
 
 module Gargantext.Database.Root where
 
-import Database.PostgreSQL.Simple (Connection)
-import Opaleye (restrict, (.==), Query, runQuery)
+import Opaleye (restrict, (.==), Query)
 import Opaleye.PGTypes (pgStrictText, pgInt4)
 import Control.Arrow (returnA)
 import Gargantext.Prelude
@@ -36,13 +36,10 @@ import Gargantext.Database.Schema.Node (queryNodeTable)
 import Gargantext.Database.Schema.User (queryUserTable, UserPoly(..))
 import Gargantext.Database.Config (nodeTypeId)
 import Gargantext.Core.Types.Individu (Username)
-import Gargantext.Database.Utils (Cmd(..), mkCmd)
+import Gargantext.Database.Utils (Cmd, runOpaQuery)
 
-getRootCmd :: Username -> Cmd [Node HyperdataUser]
-getRootCmd u = mkCmd $ \c -> getRoot u c
-
-getRoot :: Username -> Connection -> IO [Node HyperdataUser]
-getRoot uname conn = runQuery conn (selectRoot uname)
+getRoot :: Username -> Cmd err [Node HyperdataUser]
+getRoot = runOpaQuery . selectRoot
 
 selectRoot :: Username -> Query NodeRead
 selectRoot username = proc () -> do

src/Gargantext/Database/Schema/Ngrams.hs

@@ -19,6 +19,7 @@ Ngrams connection to the Database.
 {-# LANGUAGE NoImplicitPrelude      #-}
 {-# LANGUAGE OverloadedStrings      #-}
 {-# LANGUAGE QuasiQuotes            #-}
+{-# LANGUAGE RankNTypes             #-}
 {-# LANGUAGE TemplateHaskell        #-}
 
 module Gargantext.Database.Schema.Ngrams where
@@ -43,12 +44,12 @@ import Gargantext.Database.Config (nodeTypeId,userMaster)
 import Gargantext.Database.Root (getRoot)
 import Gargantext.Database.Types.Node (NodeType)
 import Gargantext.Database.Schema.Node (getListsWithParentId, getCorporaWithParentId)
-import Gargantext.Database.Utils (mkCmd, Cmd(..))
+import Gargantext.Database.Utils (Cmd, runPGSQuery, runOpaQuery, formatPGSQuery)
 import Gargantext.Prelude
 import Opaleye
 import Prelude (Enum, Bounded, minBound, maxBound)
 import qualified Data.Set as DS
-import qualified Database.PostgreSQL.Simple as DPS
+import qualified Database.PostgreSQL.Simple as PGS
 
 --{-
 data NgramsPoly id terms n = NgramsDb { ngrams_id    :: id
@@ -85,8 +86,8 @@ ngramsTable = Table "ngrams" (pNgramsDb NgramsDb { ngrams_id    = optional "id"
 queryNgramsTable :: Query NgramsRead
 queryNgramsTable = queryTable ngramsTable
 
-dbGetNgramsDb :: DPS.Connection -> IO [NgramsDb]
-dbGetNgramsDb conn = runQuery conn queryNgramsTable
+dbGetNgramsDb :: Cmd err [NgramsDb]
+dbGetNgramsDb = runOpaQuery queryNgramsTable
 --}
 
 -- | Main Ngrams Types
@@ -118,7 +119,7 @@ data Ngrams = Ngrams { _ngramsTerms :: Text
            } deriving (Generic, Show, Eq, Ord)
 
 makeLenses ''Ngrams
-instance DPS.ToRow Ngrams where
+instance PGS.ToRow Ngrams where
   toRow (Ngrams t s) = [toField t, toField s]
 
 text2ngrams :: Text -> Ngrams
@@ -148,7 +149,7 @@ data NgramIds =
   , ngramTerms :: Text
   } deriving (Show, Generic, Eq, Ord)
 
-instance DPS.FromRow NgramIds where
+instance PGS.FromRow NgramIds where
   fromRow = NgramIds <$> field <*> field
 
 ----------------------
@@ -160,21 +161,21 @@ indexNgramsT m ngrId = indexNgramsTWith f ngrId
 indexNgramsTWith :: (NgramsTerms -> NgramsId) -> NgramsT Ngrams-> NgramsT NgramsIndexed
 indexNgramsTWith f (NgramsT t n) = NgramsT t (NgramsIndexed n ((f . _ngramsTerms) n))
 
-insertNgrams :: [Ngrams] -> Cmd (Map NgramsTerms NgramsId)
+insertNgrams :: [Ngrams] -> Cmd err (Map NgramsTerms NgramsId)
 insertNgrams ns = fromList <$> map (\(NgramIds i t) -> (t, i)) <$> (insertNgrams' ns)
 
-insertNgrams' :: [Ngrams] -> Cmd [NgramIds]
-insertNgrams' ns = mkCmd $ \conn -> DPS.query conn queryInsertNgrams (DPS.Only $ Values fields ns)
+insertNgrams' :: [Ngrams] -> Cmd err [NgramIds]
+insertNgrams' ns = runPGSQuery queryInsertNgrams (PGS.Only $ Values fields ns)
   where
     fields = map (\t -> QualifiedIdentifier Nothing t) ["text", "int4"]
 
-insertNgrams_Debug :: [(NgramsTerms, Size)] -> Cmd ByteString
-insertNgrams_Debug ns = mkCmd $ \conn -> DPS.formatQuery conn queryInsertNgrams (DPS.Only $ Values fields ns)
+insertNgrams_Debug :: [(NgramsTerms, Size)] -> Cmd err ByteString
+insertNgrams_Debug ns = formatPGSQuery queryInsertNgrams (PGS.Only $ Values fields ns)
   where
     fields = map (\t -> QualifiedIdentifier Nothing t) ["text", "int4"]
 
 ----------------------
-queryInsertNgrams :: DPS.Query
+queryInsertNgrams :: PGS.Query
 queryInsertNgrams = [sql|
     WITH input_rows(terms,n) AS (?)
     , ins AS (
@@ -197,26 +198,25 @@ queryInsertNgrams = [sql|
 -- TODO: the way we are getting main Master Corpus and List ID is not clean
 -- TODO: if ids are not present -> create
 -- TODO: Global Env State Monad to keep in memory the ids without retrieving it each time
-getNgramsTableDb :: DPS.Connection
-               -> NodeType             -> NgramsType
-               -> NgramsTableParamUser
-               -> Limit -> Offset
-               -> IO ([NgramsTableData], MapToParent, MapToChildren)
-getNgramsTableDb c nt ngrt ntp@(NgramsTableParam listIdUser _) limit_ offset_ = do
+getNgramsTableDb :: NodeType -> NgramsType
+                 -> NgramsTableParamUser
+                 -> Limit -> Offset
+                 -> Cmd err ([NgramsTableData], MapToParent, MapToChildren)
+getNgramsTableDb nt ngrt ntp@(NgramsTableParam listIdUser _) limit_ offset_ = do
   
   
-  maybeRoot <- head <$> getRoot userMaster c
+  maybeRoot <- head <$> getRoot userMaster
   let path = "Garg.Db.Ngrams.getTableNgrams: "
   let masterRootId = maybe (panic $ path <> "no userMaster Tree") (view node_id) maybeRoot
   -- let errMess = panic "Error"
 
-  corpusMasterId <- maybe (panic "error master corpus") (view node_id) <$> head <$> getCorporaWithParentId c masterRootId
+  corpusMasterId <- maybe (panic "error master corpus") (view node_id) <$> head <$> getCorporaWithParentId masterRootId
   
-  listMasterId   <- maybe (panic "error master list") (view node_id) <$> head <$> getListsWithParentId   c corpusMasterId
+  listMasterId   <- maybe (panic "error master list") (view node_id) <$> head <$> getListsWithParentId corpusMasterId
   
-  ngramsTableData <- getNgramsTableData c nt ngrt ntp (NgramsTableParam listMasterId corpusMasterId) limit_ offset_
+  ngramsTableData <- getNgramsTableData nt ngrt ntp (NgramsTableParam listMasterId corpusMasterId) limit_ offset_
   
-  (mapToParent,mapToChildren) <- getNgramsGroup c listIdUser listMasterId
+  (mapToParent,mapToChildren) <- getNgramsGroup listIdUser listMasterId
   pure (ngramsTableData, mapToParent,mapToChildren)
 
 
@@ -234,15 +234,14 @@ data NgramsTableData = NgramsTableData { _ntd_ngrams   :: Text
                                        , _ntd_weight   :: Double
     } deriving (Show)
 
-getNgramsTableData :: DPS.Connection
-                   -> NodeType -> NgramsType
+getNgramsTableData :: NodeType -> NgramsType
                    -> NgramsTableParamUser -> NgramsTableParamMaster 
                    -> Limit -> Offset
-                   -> IO [NgramsTableData]
-getNgramsTableData conn nodeT ngrmT (NgramsTableParam ul uc) (NgramsTableParam ml mc) limit_ offset_ =
+                   -> Cmd err [NgramsTableData]
+getNgramsTableData nodeT ngrmT (NgramsTableParam ul uc) (NgramsTableParam ml mc) limit_ offset_ =
   trace ("Ngrams table params" <> show params) <$>
   map (\(t,n,nt,w) -> NgramsTableData t n (fromListTypeId nt) w) <$>
-    DPS.query conn querySelectTableNgrams params
+    runPGSQuery querySelectTableNgrams params
       where
         nodeTId = nodeTypeId   nodeT
         ngrmTId = ngramsTypeId ngrmT
@@ -251,7 +250,7 @@ getNgramsTableData conn nodeT ngrmT (NgramsTableParam ul uc) (NgramsTableParam m
 
 
 
-querySelectTableNgrams :: DPS.Query
+querySelectTableNgrams :: PGS.Query
 querySelectTableNgrams = [sql|
 
     WITH tableUser AS (
@@ -296,20 +295,14 @@ type ListIdMaster = Int
 type MapToChildren = Map Text (Set Text)
 type MapToParent   = Map Text Text
 
-getNgramsGroup :: DPS.Connection -> ListIdUser -> ListIdMaster -> IO (MapToParent, MapToChildren)
-getNgramsGroup conn lu lm = do
-  groups <- getNgramsGroup' conn lu lm
+getNgramsGroup :: ListIdUser -> ListIdMaster -> Cmd err (MapToParent, MapToChildren)
+getNgramsGroup lu lm = do
+  groups <- runPGSQuery querySelectNgramsGroup (lu,lm)
   let mapChildren = fromListWith (<>) $ map (\(a,b) -> (a, DS.singleton b)) groups
   let mapParent   = fromListWith (<>) $ map (\(a,b) -> (b, a)) groups
   pure (mapParent, mapChildren)
 
-getNgramsGroup' :: DPS.Connection -> ListIdUser -> ListIdMaster -> IO [(Text,Text)]
-getNgramsGroup' conn lu lm = DPS.query conn querySelectNgramsGroup (lu,lm)
-
-getNgramsGroup'' :: ListIdUser -> ListIdMaster -> Cmd [(Text, Text)]
-getNgramsGroup'' lu lm = mkCmd $ \conn -> DPS.query conn querySelectNgramsGroup (lu,lm)
-
-querySelectNgramsGroup :: DPS.Query
+querySelectNgramsGroup :: PGS.Query
 querySelectNgramsGroup = [sql|
     WITH groupUser AS (
       SELECT n1.terms AS t1, n2.terms AS t2 FROM nodes_ngrams_ngrams nnn

src/Gargantext/Database/Schema/Node.hs

@@ -20,20 +20,21 @@ Portability : POSIX
 {-# LANGUAGE OverloadedStrings      #-}
 {-# LANGUAGE MultiParamTypeClasses  #-}
 {-# LANGUAGE NoImplicitPrelude      #-}
+{-# LANGUAGE RankNTypes             #-}
 {-# LANGUAGE TemplateHaskell        #-}
 
 module Gargantext.Database.Schema.Node where
 
 import Control.Arrow (returnA)
-import Control.Lens (set)
+import Control.Lens (Prism', set, view, (#), (^?))
 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
+import Control.Monad.Error.Class (MonadError(..))
 import Data.Aeson
 import Data.ByteString (ByteString)
 import Data.Maybe (Maybe(..), fromMaybe)
 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
 import Data.Text (Text, pack)
 import Data.Time (UTCTime)
-import Database.PostgreSQL.Simple (Connection)
 import Database.PostgreSQL.Simple.FromField (FromField, fromField)
 import GHC.Int (Int64)
 import Gargantext.Core (Lang(..))
@@ -53,8 +54,26 @@ import qualified Data.ByteString.Lazy as DBL
 import qualified Data.Profunctor.Product as PP
 
 ------------------------------------------------------------------------
-instance FromField HyperdataAny
-  where
+
+data NodeError = NoListFound
+  deriving (Show)
+
+class HasNodeError e where
+  _NodeError :: Prism' e NodeError
+
+nodeError :: (MonadError e m, HasNodeError e) => NodeError -> m a
+nodeError ne = throwError $ _NodeError # ne
+
+catchNodeError :: (MonadError e m, HasNodeError e) => m a -> (NodeError -> m a) -> m a
+catchNodeError f g = catchError f (\e -> maybe (throwError e) g (e ^? _NodeError))
+
+------------------------------------------------------------------------
+type AnnuaireId = Int
+
+type DocId  = Int
+type TypeId = Int
+------------------------------------------------------------------------
+instance FromField HyperdataAny where
     fromField = fromField'
 
 instance FromField HyperdataCorpus
@@ -267,8 +286,8 @@ selectNode id = proc () -> do
     returnA -< row
 
 
-runGetNodes :: Query NodeRead -> Cmd [NodeAny]
-runGetNodes q = mkCmd $ \conn -> runQuery conn q
+runGetNodes :: Query NodeRead -> Cmd err [NodeAny]
+runGetNodes = runOpaQuery
 
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
@@ -298,53 +317,43 @@ selectNodesWith' parentId maybeNodeType = proc () -> do
     returnA -< node
 
 
-
--- deleteNode :: (MonadReader Connection m, MonadIO m) => Int -> m Int
--- deleteNode :: Int -> Cmd' Int
-
-deleteNode :: Int -> Cmd Int
+deleteNode :: Int -> Cmd err Int
 deleteNode n = mkCmd $ \conn ->
   fromIntegral <$> runDelete conn nodeTable
                  (\(Node n_id _ _ _ _ _ _) -> n_id .== pgInt4 n)
 
-deleteNodes :: [Int] -> Cmd Int
+deleteNodes :: [Int] -> Cmd err Int
 deleteNodes ns = mkCmd $ \conn ->
   fromIntegral <$> runDelete conn nodeTable
                    (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgInt4 ns)) n_id)
 
 
-getNodesWith :: JSONB a => Connection -> Int -> proxy a -> Maybe NodeType
-             -> Maybe Offset -> Maybe Limit -> IO [Node a]
-getNodesWith conn parentId _ nodeType maybeOffset maybeLimit =
-    runQuery conn $ selectNodesWith parentId nodeType maybeOffset maybeLimit
-
+-- TODO: NodeType should match with `a'
+getNodesWith :: JSONB a => Int -> proxy a -> Maybe NodeType
+             -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
+getNodesWith parentId _ nodeType maybeOffset maybeLimit =
+    runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
 
--- NP check type
-getNodesWithParentId :: Int
-                     -> Maybe Text -> Connection -> IO [NodeAny]
-getNodesWithParentId n _ conn = runQuery conn $ selectNodesWithParentID n
 
-getNodesWithParentId' :: Int
-                     -> Maybe Text -> Connection -> IO [NodeAny]
-getNodesWithParentId' n _ conn = runQuery conn $ selectNodesWithParentID n
+-- TODO: Why is the second parameter ignored?
+-- TODO: Why not use getNodesWith?
+getNodesWithParentId :: Int -> Maybe Text -> Cmd err [NodeAny]
+getNodesWithParentId n _ = runOpaQuery $ selectNodesWithParentID n
 
 
 ------------------------------------------------------------------------
-getDocumentsV3WithParentId :: Connection -> Int -> IO [Node HyperdataDocumentV3]
-getDocumentsV3WithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
-
-getDocumentsWithParentId :: Connection -> Int -> IO [Node HyperdataDocument]
-getDocumentsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
+getDocumentsV3WithParentId :: Int -> Cmd err [Node HyperdataDocumentV3]
+getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 
-getListsWithParentId :: Connection -> Int -> IO [Node HyperdataList]
-getListsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeList)
+-- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
+getDocumentsWithParentId :: Int -> Cmd err [Node HyperdataDocument]
+getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 
-getCorporaWithParentId :: Connection -> Int -> IO [Node HyperdataCorpus]
-getCorporaWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeCorpus)
-
-getCorporaWithParentId' :: Int -> Cmd [Node HyperdataCorpus]
-getCorporaWithParentId' n = mkCmd $ \conn -> runQuery conn $ selectNodesWith' n (Just NodeCorpus)
+getListsWithParentId :: Int -> Cmd err [Node HyperdataList]
+getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 
+getCorporaWithParentId :: Int -> Cmd err [Node HyperdataCorpus]
+getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
 
 ------------------------------------------------------------------------
 selectNodesWithParentID :: Int -> Query NodeRead
@@ -363,13 +372,12 @@ selectNodesWithType type_id = proc () -> do
 
 type JSONB = QueryRunnerColumnDefault PGJsonb
 
-getNode :: JSONB a => Connection -> Int -> proxy a -> IO (Node a)
-getNode conn id _ = do
-    fromMaybe (error $ "Node does node exist: " <> show id) . headMay <$> runQuery conn (limit 1 $ selectNode (pgInt4 id))
+getNode :: JSONB a => Int -> proxy a -> Cmd err (Node a)
+getNode id _ = do
+    fromMaybe (error $ "Node does node exist: " <> show id) . headMay <$> runOpaQuery (limit 1 $ selectNode (pgInt4 id))
 
-getNodesWithType :: Connection -> Column PGInt4 -> IO [Node HyperdataDocument]
-getNodesWithType conn type_id = do
-    runQuery conn $ selectNodesWithType type_id
+getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
+getNodesWithType = runOpaQuery . selectNodesWithType
 
 ------------------------------------------------------------------------
 
@@ -476,20 +484,19 @@ node2row (Node id tn ud pid nm dt hp) = ((pgInt4       <$> id)
                                            ,(pgStrictJSONB    hp)
                                            )
 ------------------------------------------------------------------------
-insertNodesR' :: [NodeWrite'] -> Cmd [Int]
-insertNodesR' ns = mkCmd $ \c -> insertNodesR ns c
+insertNodes :: [NodeWrite'] -> Cmd err Int64
+insertNodes ns = mkCmd $ \conn ->
+  runInsertMany conn nodeTable' (map node2row ns)
 
-insertNodes :: [NodeWrite'] -> Connection -> IO Int64
-insertNodes ns conn = runInsertMany conn nodeTable' (map node2row ns)
+insertNodesR :: [NodeWrite'] -> Cmd err [Int]
+insertNodesR ns = mkCmd $ \conn ->
+  runInsert_ conn (Insert nodeTable' (node2row <$> ns) (rReturning (\(i,_,_,_,_,_,_) -> i)) Nothing)
 
-insertNodesR :: [NodeWrite'] -> Connection -> IO [Int]
-insertNodesR ns conn = runInsertManyReturning conn nodeTable' (map node2row ns) (\(i,_,_,_,_,_,_) -> i)
-                       -------------------------
-insertNodesWithParent :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO Int64
-insertNodesWithParent pid ns conn = insertNodes (map (set node_parentId pid) ns) conn
+insertNodesWithParent :: Maybe ParentId -> [NodeWrite'] -> Cmd err Int64
+insertNodesWithParent pid ns = insertNodes (set node_parentId pid <$> ns)
 
-insertNodesWithParentR :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO [Int]
-insertNodesWithParentR pid ns conn = insertNodesR (map (set node_parentId pid) ns) conn
+insertNodesWithParentR :: Maybe ParentId -> [NodeWrite'] -> Cmd err [Int]
+insertNodesWithParentR pid ns = insertNodesR (set node_parentId pid <$> ns)
 ------------------------------------------------------------------------
 -- TODO Hierachy of Nodes
 -- post and get same types Node' and update if changes
@@ -529,14 +536,14 @@ type NodeWriteT =  ( Maybe (Column PGInt4)
                    ,        Column PGJsonb
                    )
 
-mkNode' :: [NodeWrite] -> Cmd Int64
+mkNode' :: [NodeWrite] -> Cmd err Int64
 mkNode' ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
 
 -- TODO: replace mkNodeR'
-mkNodeR'' :: [NodeWrite] -> Cmd [Int]
+mkNodeR'' :: [NodeWrite] -> Cmd err [Int]
 mkNodeR'' ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable ns (_node_id)
 
-mkNodeR' :: [NodeWriteT] -> Cmd [Int]
+mkNodeR' :: [NodeWriteT] -> Cmd err [Int]
 mkNodeR' ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_) -> i)
 
 ------------------------------------------------------------------------
@@ -545,7 +552,7 @@ data NewNode = NewNode { _newNodeId :: Int
                        , _newNodeChildren :: [Int] }
 
 -- | postNode
-postNode :: UserId -> Maybe ParentId -> Node' -> Cmd NewNode
+postNode :: UserId -> Maybe ParentId -> Node' -> Cmd err NewNode
 postNode uid pid (Node' nt txt v []) = do
   pids <- mkNodeR' [node2table uid pid (Node' nt txt v [])]
   case pids of
@@ -571,72 +578,53 @@ childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a c
 
 
 
-mk :: Connection -> NodeType -> Maybe ParentId -> Text -> IO [Int]
-mk c nt pId name  = mk' c nt userId pId name
+mk :: NodeType -> Maybe ParentId -> Text -> Cmd err [Int]
+mk nt pId name  = mk' nt userId pId name
   where
     userId = 1
 
-mk' :: Connection -> NodeType -> UserId -> Maybe ParentId -> Text -> IO [Int]
-mk' c nt uId pId name  = map fromIntegral <$> insertNodesWithParentR pId [node nt name hd pId uId] c
+mk' :: NodeType -> UserId -> Maybe ParentId -> Text -> Cmd err [Int]
+mk' nt uId pId name  = map fromIntegral <$> insertNodesWithParentR pId [node nt name hd pId uId]
   where
     hd = HyperdataUser . Just . pack $ show EN
 
 type Name = Text
 
-mk'' :: NodeType -> Maybe ParentId -> UserId -> Name -> Cmd [Int]
-mk'' NodeUser Nothing uId name  = mkCmd $ \c -> mk' c NodeUser uId Nothing name
+mk'' :: NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [Int]
+mk'' NodeUser Nothing uId name  = mk' NodeUser uId Nothing name
 mk'' NodeUser _       _   _     = panic "NodeUser do not have any parent"
 mk'' _        Nothing _   _     = panic "NodeType does   have a   parent"
-mk'' nt       pId     uId name  = mkCmd $ \c -> mk' c nt uId pId name
-
+mk'' nt       pId     uId name  = mk' nt uId pId name
 
-mkRoot :: Username -> UserId -> Cmd [Int]
+mkRoot :: Username -> UserId -> Cmd err [Int]
 mkRoot uname uId = case uId > 0 of
                False -> panic "UserId <= 0"
                True  -> mk'' NodeUser Nothing uId uname
 
-mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd [Int]
-mkCorpus n h p u = insertNodesR' [nodeCorpusW n h p u]
+mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd err [Int]
+mkCorpus n h p u = insertNodesR [nodeCorpusW n h p u]
 
---{-
-getOrMkList :: ParentId -> UserId -> Cmd Int
-getOrMkList pId uId = do
-  maybeList <- defaultListSafe' pId
-  case maybeList of
-    Nothing -> maybe (panic "no list") identity <$> headMay <$> mkList pId uId
-    Just x  -> pure x
-
-defaultListSafe' :: CorpusId -> Cmd (Maybe ListId)
-defaultListSafe' cId = mkCmd $ \c -> do
-  maybeNode <- headMay <$> getListsWithParentId c cId
-  case maybeNode of
-    Nothing -> pure Nothing
-    (Just node) -> pure $ Just $ _node_id node
---}
+getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err Int
+getOrMkList pId uId =
+  defaultList pId
+    `catchNodeError`
+  (\NoListFound -> maybe (nodeError NoListFound) pure . headMay =<< mkList pId uId)
 
-defaultListSafe :: Connection -> CorpusId -> IO (Maybe ListId)
-defaultListSafe c cId = do
-  maybeNode <- headMay <$> getListsWithParentId c cId
-  case maybeNode of
-    Nothing -> pure Nothing
-    (Just node) -> pure $ Just $ _node_id node
-
-defaultList :: Connection -> CorpusId -> IO ListId
-defaultList c cId = maybe (panic errMessage) identity <$> defaultListSafe c cId
-  where
-    errMessage = "Gargantext.API.Ngrams.defaultList: no list found"
+defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
+defaultList cId =
+  maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 
-mkList :: ParentId -> UserId -> Cmd [Int]
-mkList p u = insertNodesR' [nodeListW Nothing Nothing p u]
+mkList :: HasNodeError err => ParentId -> UserId -> Cmd err [Int]
+mkList p u = insertNodesR [nodeListW Nothing Nothing p u]
 
-mkGraph :: ParentId -> UserId -> Cmd [Int]
-mkGraph p u = insertNodesR' [nodeGraphW Nothing Nothing p u]
+mkGraph :: ParentId -> UserId -> Cmd err [Int]
+mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
 
-mkDashboard :: ParentId -> UserId -> Cmd [Int]
-mkDashboard p u = insertNodesR' [nodeDashboardW Nothing Nothing p u]
+mkDashboard :: ParentId -> UserId -> Cmd err [Int]
+mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
 
-mkAnnuaire :: ParentId -> UserId -> Cmd [Int]
-mkAnnuaire p u = insertNodesR' [nodeAnnuaireW Nothing Nothing p u]
+mkAnnuaire :: ParentId -> UserId -> Cmd err [Int]
+mkAnnuaire p u = insertNodesR [nodeAnnuaireW Nothing Nothing p u]
 
 -- | Default CorpusId Master and ListId Master
 

src/Gargantext/Database/Schema/NodeNgram.hs

@@ -23,6 +23,7 @@ if Node is a List     then it is listing (either Stop, Candidate or Map)
 {-# LANGUAGE NoImplicitPrelude      #-}
 {-# LANGUAGE OverloadedStrings      #-}
 {-# LANGUAGE QuasiQuotes            #-}
+{-# LANGUAGE RankNTypes             #-}
 {-# LANGUAGE TemplateHaskell        #-}
 
 
@@ -35,10 +36,10 @@ import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Gargantext.Core.Types.Main (ListId, ListTypeId)
-import Gargantext.Database.Utils (mkCmd, Cmd(..))
+import Gargantext.Database.Utils (mkCmd, Cmd, runPGSQuery)
 import Gargantext.Prelude
 import Opaleye
-import qualified Database.PostgreSQL.Simple as PGS (Connection, query, Only(..))
+import qualified Database.PostgreSQL.Simple as PGS (Only(..))
 
 -- | TODO : remove id
 data NodeNgramPoly id node_id ngram_id weight ngrams_type
@@ -94,14 +95,14 @@ nodeNgramTable  = Table "nodes_ngrams"
 queryNodeNgramTable :: Query NodeNgramRead
 queryNodeNgramTable = queryTable nodeNgramTable
 
-insertNodeNgrams :: [NodeNgram] -> Cmd Int
+insertNodeNgrams :: [NodeNgram] -> Cmd err Int
 insertNodeNgrams = insertNodeNgramW
                  . map (\(NodeNgram _ n g w t) ->
                           NodeNgram Nothing (pgInt4 n)   (pgInt4 g)
                                             (pgDouble w) (pgInt4 t)
                         )
 
-insertNodeNgramW :: [NodeNgramWrite] -> Cmd Int
+insertNodeNgramW :: [NodeNgramWrite] -> Cmd err Int
 insertNodeNgramW nns =
   mkCmd $ \c -> fromIntegral <$> runInsert_ c insertNothing
     where
@@ -113,8 +114,8 @@ insertNodeNgramW nns =
 
 type NgramsText = Text
 
-updateNodeNgrams :: PGS.Connection -> [(ListId, NgramsText, ListTypeId)] -> IO [PGS.Only Int]
-updateNodeNgrams c input = PGS.query c updateQuery (PGS.Only $ Values fields $ input)
+updateNodeNgrams :: [(ListId, NgramsText, ListTypeId)] -> Cmd err [PGS.Only Int]
+updateNodeNgrams input = runPGSQuery updateQuery (PGS.Only $ Values fields $ input)
   where
     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","text","int4"]
     updateQuery = [sql| UPDATE nodes_ngrams as old SET

src/Gargantext/Database/Schema/NodeNgramsNgrams.hs

@@ -25,22 +25,25 @@ Next Step benchmark:
 {-# LANGUAGE NoImplicitPrelude      #-}
 {-# LANGUAGE OverloadedStrings      #-}
 {-# LANGUAGE QuasiQuotes            #-}
+{-# LANGUAGE RankNTypes             #-}
 {-# LANGUAGE TemplateHaskell        #-}
 {-# OPTIONS_GHC -fno-warn-orphans   #-}
 
 module Gargantext.Database.Schema.NodeNgramsNgrams
   where
 
+import Control.Lens (view)
 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
+import Control.Monad.IO.Class (liftIO)
 import Data.Text (Text)
 import Data.Maybe (Maybe)
 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
-import Gargantext.Database.Utils (mkCmd, Cmd(..))
+import Gargantext.Database.Utils (Cmd, runOpaQuery, runPGSQuery, connection)
 import Gargantext.Prelude
 import Opaleye
-import qualified Database.PostgreSQL.Simple as DPS
+import qualified Database.PostgreSQL.Simple as PGS
 
 data NodeNgramsNgramsPoly node_id ngram1_id ngram2_id weight =
   NodeNgramsNgrams { _nng_NodeId   :: node_id
@@ -90,8 +93,8 @@ queryNodeNgramsNgramsTable = queryTable nodeNgramsNgramsTable
 
 -- | Select NodeNgramsNgrams
 -- TODO not optimized (get all ngrams without filters)
-nodeNgramsNgrams :: DPS.Connection -> IO [NodeNgramsNgrams]
-nodeNgramsNgrams conn = runQuery conn queryNodeNgramsNgramsTable
+nodeNgramsNgrams :: Cmd err [NodeNgramsNgrams]
+nodeNgramsNgrams = runOpaQuery queryNodeNgramsNgramsTable
 
 instance QueryRunnerColumnDefault PGInt4 (Maybe Int) where
     queryRunnerColumnDefault = fieldQueryRunnerColumn
@@ -101,7 +104,7 @@ instance QueryRunnerColumnDefault PGFloat8 (Maybe Double) where
 
 
 -- TODO: Add option on conflict
-insertNodeNgramsNgramsNew :: [NodeNgramsNgrams] -> Cmd Int
+insertNodeNgramsNgramsNew :: [NodeNgramsNgrams] -> Cmd err Int
 insertNodeNgramsNgramsNew = insertNodeNgramsNgramsW
                  . map (\(NodeNgramsNgrams n ng1 ng2 maybeWeight) ->
                           NodeNgramsNgrams (pgInt4 n  )
@@ -110,10 +113,10 @@ insertNodeNgramsNgramsNew = insertNodeNgramsNgramsW
                                            (pgDouble <$> maybeWeight)
                         )
 
-insertNodeNgramsNgramsW :: [NodeNgramsNgramsWrite] -> Cmd Int
-insertNodeNgramsNgramsW ns =
-  mkCmd $ \c -> fromIntegral
-       <$> runInsertMany c nodeNgramsNgramsTable ns
+insertNodeNgramsNgramsW :: [NodeNgramsNgramsWrite] -> Cmd err Int
+insertNodeNgramsNgramsW ns = do
+  c <- view connection
+  liftIO $ fromIntegral <$> runInsertMany c nodeNgramsNgramsTable ns
 
 ------------------------------------------------------------------------
 data Action   = Del | Add
@@ -121,20 +124,17 @@ data Action   = Del | Add
 type NgramsParent = Text
 type NgramsChild  = Text
 
-ngramsGroup :: Action -> [(Int, NgramsParent, NgramsChild, Maybe Double)] -> Cmd [Int]
-ngramsGroup a ngs = mkCmd $ \c -> ngramsGroup' c a ngs
-
--- TODO: remove this function (use Reader Monad only)
-ngramsGroup' :: DPS.Connection -> Action -> [(Int, NgramsParent, NgramsChild, Maybe Double)] -> IO [Int]
-ngramsGroup' c action ngs = runNodeNgramsNgrams c q ngs
+ngramsGroup' :: Action -> [(Int, NgramsParent, NgramsChild, Maybe Double)]
+             -> Cmd err [Int]
+ngramsGroup' action ngs = runNodeNgramsNgrams q ngs
   where
     q = case action of
           Del -> queryDelNodeNgramsNgrams
           Add -> queryInsertNodeNgramsNgrams
 
 
-runNodeNgramsNgrams :: DPS.Connection -> DPS.Query -> [(Int, NgramsParent, NgramsChild, Maybe Double)] -> IO [Int]
-runNodeNgramsNgrams c q ngs = map (\(DPS.Only a) -> a) <$> DPS.query c q (DPS.Only $ Values fields ngs' )
+runNodeNgramsNgrams :: PGS.Query -> [(Int, NgramsParent, NgramsChild, Maybe Double)] -> Cmd err [Int]
+runNodeNgramsNgrams q ngs = map (\(PGS.Only a) -> a) <$> runPGSQuery q (PGS.Only $ Values fields ngs' )
   where
     ngs'   = map (\(n,ng1,ng2,w) -> (n,ng1,ng2,maybe 0 identity w)) ngs
     fields = map (\t -> QualifiedIdentifier Nothing t)
@@ -142,7 +142,7 @@ runNodeNgramsNgrams c q ngs = map (\(DPS.Only a) -> a) <$> DPS.query c q (DPS.On
 
 --------------------------------------------------------------------
 -- TODO: on conflict update weight
-queryInsertNodeNgramsNgrams :: DPS.Query
+queryInsertNodeNgramsNgrams :: PGS.Query
 queryInsertNodeNgramsNgrams = [sql|
     WITH input_rows(nId,ng1,ng2,w) AS (?)
     INSERT INTO nodes_ngrams_ngrams (node_id,ngram1_id,ngram2_id,weight)
@@ -152,7 +152,7 @@ queryInsertNodeNgramsNgrams = [sql|
     ON CONFLICT (node_id,ngram1_id,ngram2_id) DO NOTHING -- unique index created here
            |]
 
-queryDelNodeNgramsNgrams :: DPS.Query
+queryDelNodeNgramsNgrams :: PGS.Query
 queryDelNodeNgramsNgrams = [sql|
     WITH input(nId,ng1,ng2,w) AS (?)
     DELETE FROM nodes_ngrams_ngrams nnn

src/Gargantext/Database/Schema/NodeNode.hs

@@ -20,11 +20,12 @@ commentary with @some markup@.
 {-# LANGUAGE MultiParamTypeClasses  #-}
 {-# LANGUAGE NoImplicitPrelude      #-}
 {-# LANGUAGE OverloadedStrings      #-}
+{-# LANGUAGE RankNTypes             #-}
 {-# LANGUAGE TemplateHaskell        #-}
 
 module Gargantext.Database.Schema.NodeNode where
 
-import qualified Database.PostgreSQL.Simple as PGS (Connection, Query, query, Only(..))
+import qualified Database.PostgreSQL.Simple as PGS (Query, Only(..))
 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
@@ -82,8 +83,8 @@ queryNodeNodeTable = queryTable nodeNodeTable
 
 
 -- | not optimized (get all ngrams without filters)
-nodesNodes :: Cmd [NodeNode]
-nodesNodes = mkCmd $ \c -> runQuery c queryNodeNodeTable
+nodesNodes :: Cmd err [NodeNode]
+nodesNodes = runOpaQuery queryNodeNodeTable
 
 instance QueryRunnerColumnDefault (Nullable PGInt4) Int where
     queryRunnerColumnDefault = fieldQueryRunnerColumn
@@ -97,8 +98,8 @@ instance QueryRunnerColumnDefault PGBool (Maybe Bool) where
 
 ------------------------------------------------------------------------
 -- | Favorite management
-nodeToFavorite :: PGS.Connection -> CorpusId -> DocId -> Bool -> IO [Int]
-nodeToFavorite c cId dId b = map (\(PGS.Only a) -> a) <$> PGS.query c favQuery (b,cId,dId)
+nodeToFavorite :: CorpusId -> DocId -> Bool -> Cmd err [Int]
+nodeToFavorite cId dId b = map (\(PGS.Only a) -> a) <$> runPGSQuery favQuery (b,cId,dId)
   where
     favQuery :: PGS.Query
     favQuery = [sql|UPDATE nodes_nodes SET favorite = ?
@@ -106,9 +107,9 @@ nodeToFavorite c cId dId b = map (\(PGS.Only a) -> a) <$> PGS.query c favQuery (
                RETURNING node2_id;
                |]
 
-nodesToFavorite :: PGS.Connection -> [(CorpusId,DocId,Bool)] -> IO [Int]
-nodesToFavorite c inputData = map (\(PGS.Only a) -> a) 
-                            <$> PGS.query c trashQuery (PGS.Only $ Values fields inputData)
+nodesToFavorite :: [(CorpusId,DocId,Bool)] -> Cmd err [Int]
+nodesToFavorite inputData = map (\(PGS.Only a) -> a)
+                            <$> runPGSQuery trashQuery (PGS.Only $ Values fields inputData)
   where
     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","bool"]
     trashQuery :: PGS.Query
@@ -123,8 +124,8 @@ nodesToFavorite c inputData = map (\(PGS.Only a) -> a)
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
 -- | Trash management
-nodeToTrash :: PGS.Connection -> CorpusId -> DocId -> Bool -> IO [PGS.Only Int]
-nodeToTrash c cId dId b = PGS.query c trashQuery (b,cId,dId)
+nodeToTrash :: CorpusId -> DocId -> Bool -> Cmd err [PGS.Only Int]
+nodeToTrash cId dId b = runPGSQuery trashQuery (b,cId,dId)
   where
     trashQuery :: PGS.Query
     trashQuery = [sql|UPDATE nodes_nodes SET delete = ?
@@ -133,9 +134,9 @@ nodeToTrash c cId dId b = PGS.query c trashQuery (b,cId,dId)
                   |]
 
 -- | Trash Massive
-nodesToTrash :: PGS.Connection -> [(CorpusId,DocId,Bool)] -> IO [Int]
-nodesToTrash c input = map (\(PGS.Only a) -> a)
-                        <$> PGS.query c trashQuery (PGS.Only $ Values fields input)
+nodesToTrash :: [(CorpusId,DocId,Bool)] -> Cmd err [Int]
+nodesToTrash input = map (\(PGS.Only a) -> a)
+                        <$> runPGSQuery trashQuery (PGS.Only $ Values fields input)
   where
     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","bool"]
     trashQuery :: PGS.Query
@@ -148,8 +149,8 @@ nodesToTrash c input = map (\(PGS.Only a) -> a)
                   |]
 
 -- | /!\ Really remove nodes in the Corpus or Annuaire
-emptyTrash :: PGS.Connection -> CorpusId -> IO [PGS.Only Int]
-emptyTrash c cId = PGS.query c delQuery (PGS.Only cId)
+emptyTrash :: CorpusId -> Cmd err [PGS.Only Int]
+emptyTrash cId = runPGSQuery delQuery (PGS.Only cId)
   where
     delQuery :: PGS.Query
     delQuery = [sql|DELETE from nodes_nodes n

src/Gargantext/Database/Schema/NodeNodeNgram.hs

@@ -24,7 +24,7 @@ import Prelude
 import Data.Maybe (Maybe)
 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
-import qualified Database.PostgreSQL.Simple as PGS
+import Gargantext.Database.Utils (Cmd, runOpaQuery)
 
 import Opaleye
 
@@ -76,8 +76,8 @@ queryNodeNodeNgramTable :: Query NodeNodeNgramRead
 queryNodeNodeNgramTable = queryTable nodeNodeNgramTable
 
 -- | not optimized (get all ngrams without filters)
-nodeNodeNgrams :: PGS.Connection -> IO [NodeNodeNgram]
-nodeNodeNgrams conn = runQuery conn queryNodeNodeNgramTable
+nodeNodeNgrams :: Cmd err [NodeNodeNgram]
+nodeNodeNgrams = runOpaQuery queryNodeNodeNgramTable
 
 instance QueryRunnerColumnDefault PGFloat8 (Maybe Double) where
     queryRunnerColumnDefault = fieldQueryRunnerColumn

src/Gargantext/Database/Schema/User.hs

@@ -20,6 +20,7 @@ Functions to deal with users, database side.
 {-# LANGUAGE Arrows                      #-}
 {-# LANGUAGE NoImplicitPrelude           #-}
 {-# LANGUAGE OverloadedStrings           #-}
+{-# LANGUAGE RankNTypes                  #-}
 
 module Gargantext.Database.Schema.User where
 
@@ -156,15 +157,14 @@ instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
   queryRunnerColumnDefault = fieldQueryRunnerColumn
 
 
-users :: Cmd [User]
-users = mkCmd $ \conn -> runQuery conn queryUserTable
+users :: Cmd err [User]
+users = runOpaQuery queryUserTable
 
-usersLight :: Cmd [UserLight]
-usersLight = mkCmd $ \conn -> map toUserLight <$> runQuery conn queryUserTable
+usersLight :: Cmd err [UserLight]
+usersLight = map toUserLight <$> users
 
-
-getUser :: Username -> Cmd (Maybe UserLight)
-getUser u = mkCmd $ \c -> userLightWithUsername u <$> runCmd c usersLight
+getUser :: Username -> Cmd err (Maybe UserLight)
+getUser u = userLightWithUsername u <$> usersLight
 
 
 

src/Gargantext/Database/TextSearch.hs

@@ -11,6 +11,7 @@ Portability : POSIX
 {-# LANGUAGE Arrows            #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
 
 module Gargantext.Database.TextSearch where
 
@@ -21,7 +22,7 @@ import Data.List (intersperse, take, drop)
 import Data.String (IsString(..))
 import Data.Text (Text, words, unpack, intercalate)
 import Data.Time (UTCTime)
-import Database.PostgreSQL.Simple -- (Query, Connection)
+import Database.PostgreSQL.Simple (Query)
 import Database.PostgreSQL.Simple.ToField
 import Gargantext.Database.Config (nodeTypeId)
 import Gargantext.Database.Types.Node (NodeType(..))
@@ -33,6 +34,7 @@ import Gargantext.Database.Schema.Ngrams
 import Gargantext.Database.Schema.NodeNode
 import Gargantext.Database.Schema.NodeNgram
 import Gargantext.Database.Queries.Join (leftJoin6)
+import Gargantext.Database.Utils (Cmd, runPGSQuery, runOpaQuery)
 import Gargantext.Text.Terms.Mono.Stem.En (stemIt)
 import Gargantext.Core.Types
 import Control.Arrow (returnA)
@@ -41,8 +43,8 @@ import Opaleye hiding (Query, Order)
 
 
 ------------------------------------------------------------------------
-searchInDatabase :: Connection -> ParentId -> Text -> IO [(NodeId, HyperdataDocument)]
-searchInDatabase c p t = runQuery c (queryInDatabase p t)
+searchInDatabase :: ParentId -> Text -> Cmd err [(NodeId, HyperdataDocument)]
+searchInDatabase p t = runOpaQuery (queryInDatabase p t)
 
 -- | Global search query where ParentId is Master Node Corpus Id 
 queryInDatabase :: ParentId -> Text -> O.Query (Column PGInt4, Column PGJsonb)
@@ -54,8 +56,8 @@ queryInDatabase _ q = proc () -> do
 
 ------------------------------------------------------------------------
 -- | todo add limit and offset and order
-searchInCorpus :: Connection -> CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
-searchInCorpus c cId q o l order = runQuery c (filterWith o l order $ queryInCorpus cId q')
+searchInCorpus :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
+searchInCorpus cId q o l order = runOpaQuery (filterWith o l order $ queryInCorpus cId q')
   where
     q' = intercalate " | " $ map stemIt q
 
@@ -77,20 +79,20 @@ joinInCorpus = leftJoin queryNodeSearchTable queryNodeNodeTable cond
 type AuthorName = Text
 
 -- | TODO Optim: Offset and Limit in the Query
-searchInCorpusWithContacts :: Connection -> CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]]
-searchInCorpusWithContacts c cId q o l order = take (maybe 5 identity l) <$> drop (maybe 0 identity o)
+searchInCorpusWithContacts :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]]
+searchInCorpusWithContacts cId q o l order = take (maybe 5 identity l) <$> drop (maybe 0 identity o)
   <$> map (\((i,u,h,s), ps) -> FacetPaired i u h s (catMaybes ps))
   <$> toList <$> fromListWith (<>)
   <$> map (\(FacetPaired i u h s p) -> ((i,u,h,s), [maybePair p]))
-  <$> searchInCorpusWithContacts' c cId q o l order
+  <$> searchInCorpusWithContacts' cId q o l order
   where
     maybePair (Pair Nothing Nothing) = Nothing
     maybePair (Pair _ Nothing) = Nothing
     maybePair (Pair Nothing _) = Nothing
     maybePair (Pair (Just p_id) (Just p_label)) = Just $ Pair p_id p_label
 
-searchInCorpusWithContacts' :: Connection -> CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [(FacetPaired Int UTCTime HyperdataDocument Int (Pair (Maybe Int) (Maybe Text)))]
-searchInCorpusWithContacts' c cId q o l order = runQuery c $ queryInCorpusWithContacts cId q' o l order
+searchInCorpusWithContacts' :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [(FacetPaired Int UTCTime HyperdataDocument Int (Pair (Maybe Int) (Maybe Text)))]
+searchInCorpusWithContacts' cId q o l order = runOpaQuery $ queryInCorpusWithContacts cId q' o l order
   where
     q' = intercalate " | " $ map stemIt q
 
@@ -196,13 +198,12 @@ textSearchQuery = "SELECT n.id, n.hyperdata->'publication_year'     \
 -- | Text Search Function for Master Corpus
 -- TODO : text search for user corpus
 -- Example:
--- textSearchTest :: ParentId -> TSQuery -> Cmd [(Int, Value, Value, Value, Value, Maybe Int)]
--- textSearchTest pId q = mkCmd $ \c -> textSearch c q pId 5 0 Asc
-textSearch :: Connection 
-           -> TSQuery -> ParentId
+-- textSearchTest :: ParentId -> TSQuery -> Cmd err [(Int, Value, Value, Value, Value, Maybe Int)]
+-- textSearchTest pId q = textSearch q pId 5 0 Asc
+textSearch :: TSQuery -> ParentId
            -> Limit -> Offset -> Order
-           -> IO [(Int,Value,Value,Value, Value, Maybe Int)]
-textSearch conn q p l o ord = query conn textSearchQuery (q,p,p,typeId,ord,o,l)
+           -> Cmd err [(Int,Value,Value,Value, Value, Maybe Int)]
+textSearch q p l o ord = runPGSQuery textSearchQuery (q,p,p,typeId,ord,o,l)
   where
     typeId = nodeTypeId NodeDocument
 

src/Gargantext/Database/Tree.hs

@@ -13,13 +13,13 @@ Let a Root Node, return the Tree of the Node as a directed acyclic graph
 -}
 
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE RankNTypes        #-}
 
 module Gargantext.Database.Tree (treeDB, TreeError(..), HasTreeError(..), dbTree, toNodeTree, DbTreeNode) where
 
 import Control.Lens (Prism', (#), (^..), at, each, _Just, to)
 import Control.Monad.Error.Class (MonadError(throwError))
-import Control.Monad.IO.Class (MonadIO(liftIO))
 import Data.Map (Map, fromListWith, lookup)
 import Data.Text (Text)
 import Database.PostgreSQL.Simple
@@ -28,11 +28,11 @@ import Database.PostgreSQL.Simple.SqlQQ
 import Gargantext.Prelude
 import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
 import Gargantext.Database.Config (fromNodeTypeId)
+import Gargantext.Database.Utils (Cmd, runPGSQuery)
 ------------------------------------------------------------------------
--- import Gargantext (connectGargandb)
--- import Control.Monad ((>>=))
+-- import Gargantext.Database.Utils (runCmdDev)
 -- treeTest :: IO (Tree NodeTree)
--- treeTest = connectGargandb "gargantext.ini" >>= \c -> treeDB c 347474
+-- treeTest = runCmdDev $ treeDB 347474
 ------------------------------------------------------------------------
 
 data TreeError = NoRoot | EmptyRoot | TooManyRoots
@@ -45,9 +45,8 @@ treeError :: (MonadError e m, HasTreeError e) => TreeError -> m a
 treeError te = throwError $ _TreeError # te
 
 -- | Returns the Tree of Nodes in Database
-treeDB :: (MonadIO m, MonadError e m, HasTreeError e)
-       => Connection -> RootId -> m (Tree NodeTree)
-treeDB c r = toTree =<< (toTreeParent <$> liftIO (dbTree c r))
+treeDB :: HasTreeError err => RootId -> Cmd err (Tree NodeTree)
+treeDB r = toTree =<< (toTreeParent <$> dbTree r)
 
 type RootId = Int
 type ParentId = Int
@@ -83,8 +82,8 @@ data DbTreeNode = DbTreeNode { dt_nodeId :: Int
 
 -- | Main DB Tree function
 -- TODO add typenames as parameters
-dbTree :: Connection -> RootId -> IO [DbTreeNode]
-dbTree conn rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> query conn [sql|
+dbTree :: RootId -> Cmd err [DbTreeNode]
+dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> runPGSQuery [sql|
   WITH RECURSIVE
       -- starting node(s)
       starting (id, typename, parent_id, name) AS

src/Gargantext/Database/Utils.hs

@@ -11,15 +11,18 @@ Here is a longer description of this module, containing some
 commentary with @some markup@.
 -}
 
+{-# LANGUAGE ConstraintKinds   #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes                 #-}
 
 module Gargantext.Database.Utils where
 
-import Control.Applicative (Applicative)
+import Control.Lens (Getter, view)
 import Control.Monad.Reader
+import Control.Monad.Except
 import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
 import Data.Either.Extra (Either(Left, Right))
 import Data.Ini (readIniFile, lookupValue)
@@ -33,36 +36,54 @@ import Database.PostgreSQL.Simple (Connection, connect)
 import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
 import Database.PostgreSQL.Simple.Internal  (Field)
 import Gargantext.Prelude
-import Opaleye (Query, Unpackspec, showSqlForPostgres)
+import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
 import System.IO (FilePath)
 import Text.Read (read)
 import qualified Data.ByteString      as DB
 import qualified Database.PostgreSQL.Simple as PGS
 
-------------------------------------------------------------------------
-{- | Reader Monad reinvented here:
+class HasConnection env where
+  connection :: Getter env Connection
 
-newtype Cmd a = Cmd { unCmd :: Connection -> IO a }
+instance HasConnection Connection where
+  connection = identity
 
-instance Monad Cmd where
-  return a = Cmd $ \_ -> return a
+type CmdM env err m =
+  ( MonadReader env m
+  , HasConnection env
+  , MonadError err m
+  , MonadIO m
+  )
 
-  m >>= f = Cmd $ \c -> do
-    a <- unCmd m c
-    unCmd (f a) c
--}
+type Cmd err a = forall m env. CmdM env err m => m a
+
+-- TODO: ideally there should be very few calls to this functions.
+mkCmd :: (Connection -> IO a) -> Cmd err a
+mkCmd k = do
+  conn <- view connection
+  liftIO $ k conn
+
+runCmd :: Connection -> Cmd err a -> IO (Either err a)
+runCmd conn m = runExceptT $ runReaderT m conn
 
---type Cmd' a = forall m. (MonadReader env m, HasConnection env, MonadIO m) => m a
+-- Use only for dev
+runCmdDev :: Show err => Cmd err a -> IO a
+runCmdDev f = do
+  conn <- connectGargandb "gargantext.ini"
+  either (fail . show) pure =<< runCmd conn f
 
-newtype Cmd a = Cmd (ReaderT Connection IO a)
-  deriving (Functor, Applicative, Monad, MonadReader Connection, MonadIO)
+-- Use only for dev
+runCmdDevNoErr :: Cmd () a -> IO a
+runCmdDevNoErr = runCmdDev
 
-runCmd :: Connection -> Cmd a -> IO a
-runCmd c (Cmd f) = runReaderT f c
+runOpaQuery :: Default FromFields fields haskells => Select fields -> Cmd err [haskells]
+runOpaQuery q = mkCmd $ \c -> runQuery c q
 
-mkCmd :: (Connection -> IO a) -> Cmd a
-mkCmd = Cmd . ReaderT
+formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
+formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
 
+runPGSQuery :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
+runPGSQuery q a = mkCmd $ \conn -> PGS.query conn q a
 ------------------------------------------------------------------------
 
 databaseParameters :: FilePath -> IO PGS.ConnectInfo

src/Gargantext/Text/Flow.hs

@@ -17,6 +17,7 @@ From text to viz, all the flow of texts in Gargantext.
 module Gargantext.Text.Flow
   where
 
+import Control.Monad.Reader
 import GHC.IO (FilePath)
 import qualified Data.Text as T
 import Data.Text.IO (readFile)
@@ -27,7 +28,7 @@ import qualified Data.Set as DS
 import qualified Data.Array.Accelerate as A
 import qualified Data.Map.Strict as M
 ----------------------------------------------
-import Gargantext.Database (Connection)
+import Database.PostgreSQL.Simple (Connection)
 
 import Gargantext.Database.Schema.Node
 import Gargantext.Database.Types.Node
@@ -86,7 +87,7 @@ textFlow termType workType = do
                 FullText path -> splitBy (Sentences 5) <$> readFile path
                 CSV      path -> readCsvOn [csv_title, csv_abstract] path
                 Contexts ctxt -> pure ctxt
-                DBV3 con corpusId -> catMaybes <$> map (\n -> hyperdataDocumentV3_title (_node_hyperdata n)  <> hyperdataDocumentV3_abstract (_node_hyperdata n))<$> getDocumentsV3WithParentId con corpusId
+                DBV3 con corpusId -> catMaybes <$> map (\n -> hyperdataDocumentV3_title (_node_hyperdata n)  <> hyperdataDocumentV3_abstract (_node_hyperdata n))<$> runReaderT (getDocumentsV3WithParentId corpusId) con
                 _             -> undefined -- TODO Query not supported
 
   textFlow' termType contexts

src/Gargantext/Viz/Graph.hs

@@ -18,6 +18,7 @@ module Gargantext.Viz.Graph
 
 ------------------------------------------------------------------------
 import Control.Lens (makeLenses)
+import Control.Monad.IO.Class (MonadIO(liftIO))
 import GHC.IO (FilePath)
 import GHC.Generics (Generic)
 import Data.Aeson.TH (deriveJSON)
@@ -207,7 +208,7 @@ graphV3ToGraphWithFiles g1 g2 = do
 
   DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
 
-readGraphFromJson :: FilePath -> IO (Maybe Graph)
+readGraphFromJson :: MonadIO m => FilePath -> m (Maybe Graph)
 readGraphFromJson fp = do
-  graph <- DBL.readFile fp
+  graph <- liftIO $ DBL.readFile fp
   pure $ DA.decode graph