[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,7 +38,6 @@ module Gargantext.API
       where
 ---------------------------------------------------------------------
 
-import           Database.PostgreSQL.Simple (Connection)
 import           System.IO (FilePath)
 
 import           GHC.Generics (D1, Meta (..), Rep)
@@ -45,6 +45,7 @@ import           GHC.TypeLits (AppendSymbol, Symbol)
 
 import           Control.Lens
 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 corpusId maybeList (Versioned version _patch) = do
+  when (version /= 1) $ ngramError UnsupportedVersion
+  _listId <- maybe (defaultList corpusId) pure maybeList
 {-
-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 [])
+  _ <- 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/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/Pairing.hs

@@ -12,6 +12,7 @@ Portability : POSIX
 {-# 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,7 +54,7 @@ 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

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
+getNgramsTableDb :: NodeType -> NgramsType
                  -> NgramsTableParamUser
                  -> Limit -> Offset
-               -> IO ([NgramsTableData], MapToParent, MapToChildren)
-getNgramsTableDb c nt ngrt ntp@(NgramsTableParam listIdUser _) limit_ offset_ = do
+                 -> 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/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

@@ -14,12 +14,12 @@ Let a Root Node, return the Tree of the Node as a directed acyclic graph
 
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# 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