WIP: Port DB operations to transactional API

gargantext.cabal

@@ -295,6 +295,7 @@ library
       Gargantext.Database.Admin.Types.Hyperdata.Document
       Gargantext.Database.Admin.Types.Hyperdata.Folder
       Gargantext.Database.Admin.Types.Node
+      Gargantext.Database.Class
       Gargantext.Database.Prelude
       Gargantext.Database.Query.Facet
       Gargantext.Database.Query.Table.Ngrams

src/Gargantext/Core/Viz/Phylo/Legacy/LegacyMain.hs

@@ -37,6 +37,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument(_h
 import Gargantext.Database.Query.Table.Node(defaultList, getNodeWith)
 import Gargantext.Database.Query.Table.NodeContext (selectDocs)
 import Gargantext.Database.Schema.Node ( node_hyperdata )
+import Gargantext.Database.Prelude
 import Gargantext.Prelude hiding (to)
 
 type MinSizeBranch = Int
@@ -44,7 +45,7 @@ type MinSizeBranch = Int
 flowPhylo :: (HasNodeStory env err m, HasDBid NodeType)
           => CorpusId
           -> m Phylo
-flowPhylo cId = do
+flowPhylo cId = runDBQuery $ do
 
   corpus_node <- getNodeWith cId (Proxy @HyperdataCorpus)
   let lang = withDefaultLanguage $ view (node_hyperdata . to _hc_lang) corpus_node

src/Gargantext/Database/Action/Metrics/NgramsByContext.hs

@@ -32,7 +32,7 @@ import Gargantext.Core.Text.Ngrams (NgramsType(..))
 import Gargantext.Data.HashMap.Strict.Utils as HM ( unionsWith )
 import Gargantext.Database.Admin.Types.Hyperdata.Document
 import Gargantext.Database.Admin.Types.Node (ListId, CorpusId, NodeId(..), ContextId (..), MasterCorpusId, NodeType(NodeDocument), UserCorpusId, DocId)
-import Gargantext.Database.Prelude (DBCmd, runPGSQuery)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Schema.Ngrams ()  -- toDBid instance
 import Gargantext.Prelude
 
@@ -60,7 +60,7 @@ countContextsByNgramsWith f m = (total, m')
 getContextsByNgramsUser :: HasDBid NodeType
                         => CorpusId
                         -> NgramsType
-                        -> DBCmd err (HashMap NgramsTerm (Set ContextId))
+                        -> DBQuery err x (HashMap NgramsTerm (Set ContextId))
 getContextsByNgramsUser cId nt =
   HM.fromListWith (<>) <$> map (\(n,t) -> (NgramsTerm t, Set.singleton n))
                     <$> selectNgramsByContextUser cId nt
@@ -69,9 +69,9 @@ getContextsByNgramsUser cId nt =
       selectNgramsByContextUser :: HasDBid NodeType
                                 => CorpusId
                                 -> NgramsType
-                                -> DBCmd err [(ContextId, Text)]
+                                -> DBQuery err x [(ContextId, Text)]
       selectNgramsByContextUser cId' nt' =
-        runPGSQuery queryNgramsByContextUser
+        mkPGQuery queryNgramsByContextUser
                     ( cId'
                     , toDBid NodeDocument
                     , toDBid nt'
@@ -95,16 +95,16 @@ getContextsByNgramsUser cId nt =
 getTreeInstitutesUser :: HasDBid NodeType
                         => CorpusId
                         -> NgramsType
-                        -> DBCmd err (HashMap Text [Text])
+                        -> DBQuery err x (HashMap Text [Text])
 getTreeInstitutesUser cId nt =
     HM.unionsWith (++) . map (\(_, hd) -> HM.fromList $ Map.toList $ fromMaybe Map.empty (_hd_institutes_tree hd)) <$> selectHyperDataByContextUser cId nt
 
 selectHyperDataByContextUser :: HasDBid NodeType
                               => CorpusId
                               -> NgramsType
-                              -> DBCmd err [(ContextId, HyperdataDocument)]
+                              -> DBQuery err x [(ContextId, HyperdataDocument)]
 selectHyperDataByContextUser cId' nt' =
-  runPGSQuery queryHyperDataByContextUser
+  mkPGQuery queryHyperDataByContextUser
                                         ( cId'
                                         , toDBid nt'
                                         )
@@ -127,7 +127,7 @@ getOccByNgramsOnlyFast_withSample :: HasDBid NodeType
                                   -> Int
                                   -> NgramsType
                                   -> [NgramsTerm]
-                                  -> DBCmd err (HashMap NgramsTerm Int)
+                                  -> DBQuery err x (HashMap NgramsTerm Int)
 getOccByNgramsOnlyFast_withSample cId int nt ngs =
   HM.fromListWith (+) <$> selectNgramsOccurrencesOnlyByContextUser_withSample cId int nt ngs
 
@@ -135,7 +135,7 @@ getOccByNgramsOnlyFast_withSample cId int nt ngs =
 getOccByNgramsOnlyFast :: CorpusId
                        -> ListId
                        -> NgramsType
-                       -> DBCmd err (HashMap NgramsTerm [ContextId])
+                       -> DBQuery err x (HashMap NgramsTerm [ContextId])
 getOccByNgramsOnlyFast cId lId nt = do
     --HM.fromList <$> map (\(t,n) -> (NgramsTerm t, round n)) <$> run cId lId nt
     HM.fromList <$> map (\(t, ns) -> (NgramsTerm t, UnsafeMkContextId <$> DPST.fromPGArray ns)) <$> run cId lId nt
@@ -144,8 +144,8 @@ getOccByNgramsOnlyFast cId lId nt = do
       run :: CorpusId
            -> ListId
            -> NgramsType
-           -> DBCmd err [(Text, DPST.PGArray Int)]
-      run cId' lId' nt' = runPGSQuery query
+           -> DBQuery err x [(Text, DPST.PGArray Int)]
+      run cId' lId' nt' = mkPGQuery query
                 ( cId'
                 , lId'
                 , toDBid nt'
@@ -208,10 +208,10 @@ selectNgramsOccurrencesOnlyByContextUser_withSample :: HasDBid NodeType
                                                     -> Int
                                                     -> NgramsType
                                                     -> [NgramsTerm]
-                                                    -> DBCmd err [(NgramsTerm, Int)]
+                                                    -> DBQuery err x [(NgramsTerm, Int)]
 selectNgramsOccurrencesOnlyByContextUser_withSample cId int nt tms =
   fmap (first NgramsTerm) <$>
-  runPGSQuery queryNgramsOccurrencesOnlyByContextUser_withSample
+  mkPGQuery queryNgramsOccurrencesOnlyByContextUser_withSample
                 ( int
                 , toDBid NodeDocument
                 , cId
@@ -269,10 +269,10 @@ selectNgramsOccurrencesOnlyByContextUser_withSample' :: HasDBid NodeType
                                                      => CorpusId
                                                      -> Int
                                                      -> NgramsType
-                                                     -> DBCmd err [(NgramsTerm, Int)]
+                                                     -> DBQuery err x [(NgramsTerm, Int)]
 selectNgramsOccurrencesOnlyByContextUser_withSample' cId int nt =
   fmap (first NgramsTerm) <$>
-  runPGSQuery queryNgramsOccurrencesOnlyByContextUser_withSample
+  mkPGQuery queryNgramsOccurrencesOnlyByContextUser_withSample
                 ( int
                 , toDBid NodeDocument
                 , cId
@@ -303,7 +303,7 @@ getContextsByNgramsOnlyUser :: HasDBid NodeType
                             -> [ListId]
                             -> NgramsType
                             -> [NgramsTerm]
-                            -> DBCmd err (HashMap NgramsTerm (Set ContextId))
+                            -> DBQuery err x (HashMap NgramsTerm (Set ContextId))
 getContextsByNgramsOnlyUser cId ls nt ngs =
      HM.unionsWith        (<>)
    . map (HM.fromListWith (<>)
@@ -316,7 +316,7 @@ getNgramsByContextOnlyUser :: HasDBid NodeType
                            -> [ListId]
                            -> NgramsType
                            -> [NgramsTerm]
-                           -> DBCmd err (Map ContextId (Set NgramsTerm))
+                           -> DBQuery err x (Map ContextId (Set NgramsTerm))
 getNgramsByContextOnlyUser cId ls nt ngs =
      Map.unionsWith         (<>)
    . map ( Map.fromListWith (<>)
@@ -332,10 +332,10 @@ selectNgramsOnlyByContextUser :: HasDBid NodeType
                            -> [ListId]
                            -> NgramsType
                            -> [NgramsTerm]
-                           -> DBCmd err [(NgramsTerm, ContextId)]
+                           -> DBQuery err x [(NgramsTerm, ContextId)]
 selectNgramsOnlyByContextUser cId ls nt tms =
   fmap (first NgramsTerm) <$>
-  runPGSQuery queryNgramsOnlyByContextUser
+  mkPGQuery queryNgramsOnlyByContextUser
                 ( Values fields ((DPS.Only . unNgramsTerm) <$> tms)
                 , Values [QualifiedIdentifier Nothing "int4"]
                          (DPS.Only <$> map DPS.toField ls)
@@ -367,7 +367,7 @@ getNgramsByDocOnlyUser :: DocId
                        -> [ListId]
                        -> NgramsType
                        -> [NgramsTerm]
-                       -> DBCmd err (HashMap NgramsTerm (Set NodeId))
+                       -> DBQuery err x (HashMap NgramsTerm (Set NodeId))
 getNgramsByDocOnlyUser cId ls nt ngs =
   HM.unionsWith (<>)
   . map (HM.fromListWith (<>) . map (second Set.singleton))
@@ -378,10 +378,10 @@ selectNgramsOnlyByDocUser :: DocId
                           -> [ListId]
                           -> NgramsType
                           -> [NgramsTerm]
-                          -> DBCmd err [(NgramsTerm, NodeId)]
+                          -> DBQuery err x [(NgramsTerm, NodeId)]
 selectNgramsOnlyByDocUser dId ls nt tms =
   fmap (first NgramsTerm) <$>
-  runPGSQuery queryNgramsOnlyByDocUser
+  mkPGQuery queryNgramsOnlyByDocUser
                 ( Values fields ((DPS.Only . unNgramsTerm) <$> tms)
                 , Values [QualifiedIdentifier Nothing "int4"]
                          (DPS.Only <$> (map DPS.toField ls))
@@ -410,7 +410,7 @@ queryNgramsOnlyByDocUser = [sql|
 getContextsByNgramsMaster :: HasDBid NodeType
                           =>  UserCorpusId
                           -> MasterCorpusId
-                          -> DBCmd err (HashMap Text (Set NodeId))
+                          -> DBQuery err x (HashMap Text (Set NodeId))
 getContextsByNgramsMaster ucId mcId = unionsWith (<>)
                                  . map (HM.fromListWith (<>) . map (\(n,t) -> (t, Set.singleton n)))
                                  -- . takeWhile (not . List.null)
@@ -422,8 +422,8 @@ selectNgramsByContextMaster :: HasDBid NodeType
                             -> UserCorpusId
                             -> MasterCorpusId
                             -> Int
-                            -> DBCmd err [(NodeId, Text)]
-selectNgramsByContextMaster n ucId mcId p = runPGSQuery
+                            -> DBQuery err x [(NodeId, Text)]
+selectNgramsByContextMaster n ucId mcId p = mkPGQuery
                                queryNgramsByContextMaster'
                                  ( ucId
                                  , toDBid NgramsTerms
@@ -438,7 +438,7 @@ selectNgramsByContextMaster n ucId mcId p = runPGSQuery
                                  )
 
 -- | TODO fix context_node_ngrams relation
-queryNgramsByContextMaster' :: DPS.Query
+queryNgramsByContextMaster' :: DPST.Query
 queryNgramsByContextMaster' = [sql|
   WITH contextsByNgramsUser AS (
 

src/Gargantext/Database/Action/Metrics/TFICF.hs

@@ -21,7 +21,7 @@ import Gargantext.Core.Text.Metrics.TFICF
 import Gargantext.Core.Text.Ngrams (NgramsType(..))
 import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsUser, {-getOccByNgramsOnlyFast,-} getOccByNgramsOnlyFast_withSample)
 import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
-import Gargantext.Database.Prelude (DBCmd)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.NodeContext (selectCountDocs)
 import Gargantext.Prelude
 
@@ -56,7 +56,7 @@ getTficf_withSample :: HasDBid NodeType
                     => UserCorpusId
                     -> MasterCorpusId
                     -> NgramsType
-                    -> DBCmd err (HashMap NgramsTerm Double)
+                    -> DBQuery err x (HashMap NgramsTerm Double)
 getTficf_withSample cId mId nt = do
   mapTextDoubleLocal <- HM.filter (> 1)
      <$> HM.map (fromIntegral . Set.size)

src/Gargantext/Database/Admin/Trigger/ContextNodeNgrams.hs

@@ -21,12 +21,12 @@ import Gargantext.Core
 -- import Gargantext.Core.Types.Main (ListType(CandidateTerm))
 import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
 -- (ListId, CorpusId, NodeId)
-import Gargantext.Database.Prelude (execPGSQuery, DBCmd)
+import Gargantext.Database.Prelude
 import Gargantext.Prelude
 import qualified Database.PostgreSQL.Simple as DPS
 
-triggerCountInsert :: HasDBid NodeType => DBCmd err Int64
-triggerCountInsert = execPGSQuery query (toDBid NodeDocument, toDBid NodeList)
+triggerCountInsert :: HasDBid NodeType => DBUpdate err Int64
+triggerCountInsert = mkPGUpdate query (toDBid NodeDocument, toDBid NodeList)
   where
     query :: DPS.Query
     query = [sql|
@@ -61,11 +61,11 @@ triggerCountInsert = execPGSQuery query (toDBid NodeDocument, toDBid NodeList)
           EXECUTE PROCEDURE set_ngrams_global_count();
    |]
 
-triggerCountInsert2 :: HasDBid NodeType => DBCmd err Int64
-triggerCountInsert2 = execPGSQuery query ( toDBid NodeCorpus
-                                         , toDBid NodeDocument
-                                         , toDBid NodeList
-                                         )
+triggerCountInsert2 :: HasDBid NodeType => DBUpdate err Int64
+triggerCountInsert2 = mkPGUpdate query ( toDBid NodeCorpus
+                                       , toDBid NodeDocument
+                                       , toDBid NodeList
+                                       )
   where
     query :: DPS.Query
     query = [sql|

src/Gargantext/Database/Admin/Trigger/Contexts.hs

@@ -20,15 +20,15 @@ import Database.PostgreSQL.Simple qualified as DPS
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Gargantext.Core (HasDBid(..))
 import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
-import Gargantext.Database.Prelude (execPGSQuery, DBCmd)
+import Gargantext.Database.Prelude
 import Gargantext.Prelude
 
 
-triggerSearchUpdate :: HasDBid NodeType => DBCmd err Int64
-triggerSearchUpdate = execPGSQuery query ( toDBid NodeDocument
-                                         , toDBid NodeDocument
-                                         , toDBid NodeContact
-                                         )
+triggerSearchUpdate :: HasDBid NodeType => DBUpdate err Int64
+triggerSearchUpdate = mkPGUpdate query ( toDBid NodeDocument
+                                       , toDBid NodeDocument
+                                       , toDBid NodeContact
+                                       )
   where
     query :: DPS.Query
     query = [sql|
@@ -68,16 +68,16 @@ triggerSearchUpdate = execPGSQuery query ( toDBid NodeDocument
 
 type Secret = Text
 
-triggerUpdateHash :: HasDBid NodeType => Secret -> DBCmd err Int64
-triggerUpdateHash secret = execPGSQuery query ( toDBid NodeDocument
-                                              , toDBid NodeContact
-                                              , secret
-                                              , secret
-                                              , toDBid NodeDocument
-                                              , toDBid NodeContact
-                                              , secret
-                                              , secret
-                                              )
+triggerUpdateHash :: HasDBid NodeType => Secret -> DBUpdate err Int64
+triggerUpdateHash secret = mkPGUpdate query ( toDBid NodeDocument
+                                            , toDBid NodeContact
+                                            , secret
+                                            , secret
+                                            , toDBid NodeDocument
+                                            , toDBid NodeContact
+                                            , secret
+                                            , secret
+                                            )
   where
     query :: DPS.Query
     query = [sql|

src/Gargantext/Database/Admin/Trigger/Init.hs

@@ -20,16 +20,16 @@ import Gargantext.Database.Admin.Trigger.ContextNodeNgrams (triggerCountInsert,
 import Gargantext.Database.Admin.Trigger.Contexts (triggerSearchUpdate, triggerUpdateHash)
 import Gargantext.Database.Admin.Trigger.NodesContexts ({-triggerDeleteCount,-} triggerInsertCount, triggerUpdateAdd, triggerUpdateDel, MasterListId) -- , triggerCoocInsert)
 -- , triggerCoocInsert)
-import Gargantext.Database.Prelude (DBCmd)
+import Gargantext.Database.Prelude
 import Gargantext.Prelude
 
 ------------------------------------------------------------------------
-initFirstTriggers :: Text -> DBCmd err [Int64]
+initFirstTriggers :: Text -> DBUpdate err [Int64]
 initFirstTriggers secret = do
   t0  <- triggerUpdateHash secret
   pure [t0]
 
-initLastTriggers :: MasterListId -> DBCmd err [Int64]
+initLastTriggers :: MasterListId -> DBUpdate err [Int64]
 initLastTriggers lId = do
   t0  <- triggerSearchUpdate
   t1 <- triggerCountInsert

src/Gargantext/Database/Admin/Trigger/NodesContexts.hs

@@ -21,14 +21,14 @@ import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Gargantext.Core
 import Gargantext.Database.Admin.Config ()
 import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
-import Gargantext.Database.Prelude (execPGSQuery, DBCmd)
+import Gargantext.Database.Prelude
 import Gargantext.Prelude
 import qualified Database.PostgreSQL.Simple as DPS
 
 type MasterListId = ListId
 
-triggerInsertCount :: MasterListId -> DBCmd err Int64
-triggerInsertCount lId = execPGSQuery query (lId, toDBid NodeList)
+triggerInsertCount :: MasterListId -> DBUpdate err Int64
+triggerInsertCount lId = mkPGUpdate query (lId, toDBid NodeList)
   where
     query :: DPS.Query
     query = [sql|
@@ -63,8 +63,8 @@ triggerInsertCount lId = execPGSQuery query (lId, toDBid NodeList)
   |]
 
 
-triggerUpdateAdd :: MasterListId -> DBCmd err Int64
-triggerUpdateAdd lId = execPGSQuery query (lId, toDBid NodeList)
+triggerUpdateAdd :: MasterListId -> DBUpdate err Int64
+triggerUpdateAdd lId = mkPGUpdate query (lId, toDBid NodeList)
   where
     query :: DPS.Query
     query = [sql|
@@ -103,8 +103,8 @@ triggerUpdateAdd lId = execPGSQuery query (lId, toDBid NodeList)
   |]
 
 
-triggerUpdateDel :: MasterListId -> DBCmd err Int64
-triggerUpdateDel lId = execPGSQuery query (lId, toDBid NodeList)
+triggerUpdateDel :: MasterListId -> DBUpdate err Int64
+triggerUpdateDel lId = mkPGUpdate query (lId, toDBid NodeList)
   where
     query :: DPS.Query
     query = [sql|
@@ -145,8 +145,8 @@ triggerUpdateDel lId = execPGSQuery query (lId, toDBid NodeList)
 
 
 
-triggerDeleteCount :: MasterListId -> DBCmd err Int64
-triggerDeleteCount lId = execPGSQuery query (lId, toDBid NodeList)
+triggerDeleteCount :: MasterListId -> DBUpdate err Int64
+triggerDeleteCount lId = mkPGUpdate query (lId, toDBid NodeList)
   where
     query :: DPS.Query
     query = [sql|

src/Gargantext/Database/Class.hs

+{-# LANGUAGE ConstraintKinds #-}
+
+module Gargantext.Database.Class where
+
+import Control.Lens (Getter)
+import Control.Monad.Random ( MonadRandom )
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Data.Pool (Pool)
+import Database.PostgreSQL.Simple (Connection)
+import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
+import Gargantext.Core.Config (HasConfig(..))
+import Gargantext.Core.Mail.Types (HasMail)
+import Gargantext.Core.NLP (HasNLPServer)
+import Gargantext.Prelude
+
+-- $typesAndConstraints
+--
+-- The names of the constraints and types in this module are chosen based on
+-- the following guidelines:
+-- * By default, constraints are relatively lenient. Stricter constraints are
+--   obtained by appending the `Extra` suffix to the minimal constraint name.
+-- * `IsDBEnv(Extra)` applies to the environment; the basic constraint allows
+--   access to the database, and the `Extra` variant offers some more
+--   capabilities such as access to mail.
+-- * `IsCmd` is the basic constraint for command monads. Append `DB` to it to get
+--   a monad of commands that can talk to the database. Append `Extra` to get
+--   the ability to send mail, make use of the NLP server and deal with central
+--   exchange notifications. Append `Random` to get access to randomness.
+-- * Existential versions of the constraints bear the same name as the constraint
+--   they are based on, but without the `Is` prefix.
+
+class HasConnectionPool env where
+  connPool :: Getter env (Pool Connection)
+
+instance HasConnectionPool (Pool Connection) where
+  connPool = identity
+
+-- | The most basic constraints for an environment with a database.
+-- If possible, try to not add more constraints here. When performing
+-- a query/update on the DB, one shouldn't need more than being able to
+-- fetch from the underlying 'env' the connection pool and access the
+-- 'GargConfig' for some sensible defaults to store into the DB.
+type IsDBEnv env =
+  ( HasConnectionPool env
+  , HasConfig         env
+  )
+
+-- | Constraints for a full-fledged environment, with a database, mail exchange,
+-- NLP processing, notifications.
+type IsDBEnvExtra env =
+  ( IsDBEnv                            env
+  , HasMail                            env
+  , HasNLPServer                       env
+  , CET.HasCentralExchangeNotification env
+  )
+
+-- | The most general constraints for commands. To interact with the database,
+-- or access extra features (such as sending mail), you'll need to add some more
+-- constraints (see the rest of this module)
+type IsCmd env err m =
+  ( MonadReader     env     m
+  , MonadError          err m
+  , MonadBaseControl IO     m
+  )
+
+-- | Only the /minimum/ amount of class constraints required
+-- to use the Gargantext Database. It's important, to ease testability,
+-- that these constraints stays as few as possible.
+type IsDBCmd env err m =
+  ( IsCmd env err m
+  , IsDBEnv env
+  )
+
+-- | Full-fledged command class. Types in this class provide commands that can
+-- interact with the database, perform NLP processing, etc.
+type IsDBCmdExtra env err m =
+  ( IsCmd        env err m
+  , IsDBEnvExtra env
+  )
+
+-- | Basic command with access to randomness. It feels a little ad hoc to have
+-- such a constraint instead of substituting it (and its counterpart existential
+-- type `CmdRandom`) with its definition every time it appears in the codebase,
+-- but I tried to doing that substitution and it wasn't so easy.
+type IsCmdRandom env err m =
+  ( IsCmd env err m
+  , MonadRandom   m
+  )
+
+-- | Barebones command type, without any built-in ability to interact with the
+-- database or do stuff like email exchanges.
+type Cmd env err a = forall m. IsCmd env err m => m a
+
+-- | Basic command type with access to randomness
+type CmdRandom env err a = forall m. IsCmdRandom  env err m => m a
+
+-- | Command type that allows for interaction with the database.
+type DBCmd err a = forall m env. IsDBCmd env err m => m a
+
+-- | Command type that allows for interaction with the database. Similar to
+-- `DBCmd`, except you can constraint the environment type some more.
+type DBCmdWithEnv env err a = forall m. IsDBCmd env err m => m a
+
+-- | Full-fledged command types, with access to the database, mail, NLP
+-- processing and central exchange notifications.
+type DBCmdExtra err a = forall m env. IsDBCmdExtra env err m => m a

src/Gargantext/Database/Query/Table/Context.hs

@@ -21,7 +21,7 @@ import Gargantext.Core.Types
 import Gargantext.Core.Types.Query (Limit, Offset)
 import Gargantext.Database.Admin.Types.Hyperdata.Any ( HyperdataAny )
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument, HyperdataDocumentV3 )
-import Gargantext.Database.Prelude (DBCmd, JSONB, runOpaQuery)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Filter (limit', offset')
 import Gargantext.Database.Query.Table.Node.Error ( HasNodeError, nodeError, NodeError(NoContextFound) )
 import Gargantext.Database.Schema.Context
@@ -31,9 +31,9 @@ import Prelude            hiding (null, id, map, sum)
 
 
 getContextWith :: (HasNodeError err, JSONB a)
-            => ContextId -> proxy a -> DBCmd err (Node a)
+            => ContextId -> proxy a -> DBQuery err x (Node a)
 getContextWith cId _ = do
-  maybeContext <- headMay <$> runOpaQuery (selectContext (pgContextId cId))
+  maybeContext <- headMay <$> mkOpaQuery (selectContext (pgContextId cId))
   case maybeContext of
     Nothing -> nodeError (NoContextFound cId)
     Just  r -> pure $ context2node r
@@ -47,8 +47,8 @@ selectContext id' = proc () -> do
     restrict -< _context_id row .== id'
     returnA  -< row
 
-runGetContexts :: Select ContextRead -> DBCmd err [Context HyperdataAny]
-runGetContexts = runOpaQuery
+runGetContexts :: Select ContextRead -> DBQuery err x [Context HyperdataAny]
+runGetContexts = mkOpaQuery
 
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
@@ -80,12 +80,12 @@ selectContextsWith' parentId maybeContextType = proc () -> do
 
 
 ------------------------------------------------------------------------
-getDocumentsV3WithParentId :: HasDBid NodeType => NodeId -> DBCmd err [Context HyperdataDocumentV3]
-getDocumentsV3WithParentId n = runOpaQuery $ selectContextsWith' n (Just NodeDocument)
+getDocumentsV3WithParentId :: HasDBid NodeType => NodeId -> DBQuery err x [Context HyperdataDocumentV3]
+getDocumentsV3WithParentId n = mkOpaQuery $ selectContextsWith' n (Just NodeDocument)
 
 -- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
-getDocumentsWithParentId :: HasDBid NodeType => NodeId -> DBCmd err [Context HyperdataDocument]
-getDocumentsWithParentId n = runOpaQuery $ selectContextsWith' n (Just NodeDocument)
+getDocumentsWithParentId :: HasDBid NodeType => NodeId -> DBQuery err x [Context HyperdataDocument]
+getDocumentsWithParentId n = mkOpaQuery $ selectContextsWith' n (Just NodeDocument)
 
 ------------------------------------------------------------------------
 selectContextsWithParentID :: NodeId -> Select ContextRead
@@ -99,8 +99,8 @@ selectContextsWithParentID n = proc () -> do
 -- | Example of use:
 -- runCmdReplEasy  (getNodesWithType NodeList (Proxy :: Proxy HyperdataList))
 getContextsWithType :: (HasNodeError err, JSONB a, HasDBid NodeType)
-                    => NodeType -> proxy a -> DBCmd err [Context a]
-getContextsWithType nt _ = runOpaQuery $ selectContextsWithType nt
+                    => NodeType -> proxy a -> DBQuery err x [Context a]
+getContextsWithType nt _ = mkOpaQuery $ selectContextsWithType nt
   where
     selectContextsWithType ::  HasDBid NodeType
                          => NodeType -> Select ContextRead
@@ -110,9 +110,9 @@ getContextsWithType nt _ = runOpaQuery $ selectContextsWithType nt
         returnA -< row
 
 getContextsIdWithType :: (HasNodeError err, HasDBid NodeType)
-                      => NodeType -> DBCmd err [ContextId]
+                      => NodeType -> DBQuery err x [ContextId]
 getContextsIdWithType nt = do
-  ns <- runOpaQuery $ selectContextsIdWithType nt
+  ns <- mkOpaQuery $ selectContextsIdWithType nt
   pure (map UnsafeMkContextId ns)
 
 selectContextsIdWithType :: HasDBid NodeType

src/Gargantext/Database/Query/Table/Node/Children.hs

@@ -23,7 +23,7 @@ import Gargantext.Core.Types
 import Gargantext.Core.Types.Query (Limit, Offset)
 import Gargantext.Database.Admin.Types.Hyperdata.Contact ( HyperdataContact )
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument )
-import Gargantext.Database.Prelude (DBCmd, JSONB, runCountOpaQuery, runOpaQuery, runPGSQuery)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Filter ( limit', offset' )
 import Gargantext.Database.Query.Table.NodeContext ( NodeContextPoly(NodeContext), queryNodeContextTable )
 import Gargantext.Database.Schema.Context
@@ -33,12 +33,12 @@ import Opaleye
 
 
 -- TODO getAllTableDocuments
-getAllDocuments :: HasDBid NodeType => ParentId -> DBCmd err (TableResult (Node HyperdataDocument))
+getAllDocuments :: HasDBid NodeType => ParentId -> DBQuery err x (TableResult (Node HyperdataDocument))
 getAllDocuments pId = getAllChildren pId (Proxy :: Proxy HyperdataDocument)
                                          (Just NodeDocument)
 
 -- TODO getAllTableContacts
-getAllContacts :: HasDBid NodeType => ParentId -> DBCmd err (TableResult (Node HyperdataContact))
+getAllContacts :: HasDBid NodeType => ParentId -> DBQuery err x (TableResult (Node HyperdataContact))
 getAllContacts pId = getAllChildren pId (Proxy :: Proxy HyperdataContact)
                                         (Just NodeContact)
 
@@ -46,7 +46,7 @@ getAllChildren :: (JSONB a, HasDBid NodeType)
                => ParentId
                -> proxy a
                -> Maybe NodeType
-               -> DBCmd err (NodeTableResult a)
+               -> DBQuery err x (NodeTableResult a)
 getAllChildren pId p maybeNodeType = getChildren pId p maybeNodeType Nothing Nothing
 
 
@@ -56,7 +56,7 @@ getChildren :: (JSONB a, HasDBid NodeType)
             -> Maybe NodeType
             -> Maybe Offset
             -> Maybe Limit
-            -> DBCmd err (NodeTableResult a)
+            -> DBQuery err x (NodeTableResult a)
 getChildren pId p t@(Just NodeDocument) maybeOffset maybeLimit = getChildrenContext pId p t maybeOffset maybeLimit
 getChildren pId p t@(Just NodeContact ) maybeOffset maybeLimit = getChildrenContext pId p t maybeOffset maybeLimit
 getChildren a b c d e = getChildrenNode a b c d e
@@ -64,8 +64,8 @@ getChildren a b c d e = getChildrenNode a b c d e
 
 -- | Get the list of (IDs of) children of a given node (ID)
 getChildrenByParentId :: NodeId             -- ^ ID of the parent node
-                      -> DBCmd err [NodeId] -- ^ List of IDs of the children nodes
-getChildrenByParentId parentId = runPGSQuery
+                      -> DBQuery err x [NodeId] -- ^ List of IDs of the children nodes
+getChildrenByParentId parentId = mkPGQuery
     [sql| SELECT id FROM public.nodes WHERE parent_id = ?; |]
     parentId
 
@@ -76,16 +76,16 @@ getChildrenNode :: (JSONB a, HasDBid NodeType)
             -> Maybe NodeType
             -> Maybe Offset
             -> Maybe Limit
-            -> DBCmd err (NodeTableResult a)
+            -> DBQuery err x (NodeTableResult a)
 getChildrenNode pId _ maybeNodeType maybeOffset maybeLimit = do
   -- printDebug "getChildrenNode" (pId, maybeNodeType)
   let query = selectChildrenNode pId maybeNodeType
-  docs <- runOpaQuery
+  docs <- mkOpaQuery
         $ limit'  maybeLimit
         $ offset' maybeOffset
         $ orderBy (asc _node_id)
         $ query
-  docCount <- runCountOpaQuery query
+  docCount <- mkOpaCountQuery query
   pure $ TableResult { tr_docs = docs, tr_count = docCount }
 
 
@@ -107,18 +107,18 @@ getChildrenContext :: (JSONB a, HasDBid NodeType)
                    -> Maybe NodeType
                    -> Maybe Offset
                    -> Maybe Limit
-                   -> DBCmd err (NodeTableResult a)
+                   -> DBQuery err x (NodeTableResult a)
 getChildrenContext pId _ maybeNodeType maybeOffset maybeLimit = do
   -- printDebug "getChildrenContext" (pId, maybeNodeType)
   let query = selectChildren' pId maybeNodeType
 
-  docs <- runOpaQuery
+  docs <- mkOpaQuery
         $ limit'  maybeLimit
         $ offset' maybeOffset
         $ orderBy (asc _context_id)
         $ query
 
-  docCount <- runCountOpaQuery query
+  docCount <- mkOpaCountQuery query
   pure $ TableResult { tr_docs = map context2node docs, tr_count = docCount }
 
 

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

@@ -68,7 +68,7 @@ import Gargantext.Core (HasDBid(toDBid))
 import Gargantext.Database.Admin.Types.Hyperdata.Contact ( HyperdataContact )
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument(..) )
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude (runPGSQuery, DBCmd{-, formatPGSQuery-})
+import Gargantext.Database.Prelude
 import Gargantext.Database.Schema.Node (NodePoly(..))
 import Gargantext.Defaults qualified as Defaults
 import Gargantext.Prelude hiding (hash, toLower)
@@ -87,8 +87,8 @@ import Database.PostgreSQL.Simple (formatQuery)
 -- ParentId : folder ID which is parent of the inserted documents
 -- Administrator of the database has to create a uniq index as following SQL command:
 -- `create unique index on contexts table (typename, parent_id, (hyperdata ->> 'uniqId'));`
-insertDb :: (InsertDb a, HasDBid NodeType) => UserId -> Maybe ParentId -> [a] -> DBCmd err [ReturnId]
-insertDb u p = runPGSQuery queryInsert . Only . Values fields . map (insertDb' u p)
+insertDb :: (InsertDb a, HasDBid NodeType) => UserId -> Maybe ParentId -> [a] -> DBQuery err x [ReturnId]
+insertDb u p as = mkPGQuery queryInsert (Only . Values fields $ map (insertDb' u p) as)
       where
         fields    = map (QualifiedIdentifier Nothing) inputSqlTypes
 

src/Gargantext/Database/Query/Table/Node/Error.hs

@@ -135,15 +135,11 @@ instance ToJSON NodeError where
 class HasNodeError e where
   _NodeError :: Prism' e NodeError
 
-errorWith :: ( MonadError e m
-             , HasNodeError e)
-          => Text -> m a
+errorWith :: HasNodeError e => Text -> DBTx e r a
 errorWith x = nodeError (NodeError $ toException $ userError $ T.unpack x)
 
-nodeError :: ( MonadError e m
-             , HasNodeError e )
-          => NodeError -> m a
-nodeError ne = throwError $ _NodeError # ne
+nodeError :: HasNodeError e => NodeError -> DBTx e r a
+nodeError ne = dbFail $ _NodeError # ne
 
 nodeCreationError :: ( MonadError e m, HasNodeError e)
                   => NodeCreationError

src/Gargantext/Database/Query/Table/NodeContext.hs

@@ -68,13 +68,13 @@ queryNodeContextTable :: Select NodeContextRead
 queryNodeContextTable = selectTable nodeContextTable
 
 -- | not optimized (get all ngrams without filters)
-_nodesContexts :: DBCmd err [NodeContext]
-_nodesContexts = runOpaQuery queryNodeContextTable
+_nodesContexts :: DBQuery err x [NodeContext]
+_nodesContexts = mkOpaQuery queryNodeContextTable
 
 ------------------------------------------------------------------------
 -- | Basic NodeContext tools
-getNodeContexts :: NodeId -> DBCmd err [NodeContext]
-getNodeContexts n = runOpaQuery (selectNodeContexts $ pgNodeId n)
+getNodeContexts :: NodeId -> DBQuery err x [NodeContext]
+getNodeContexts n = mkOpaQuery (selectNodeContexts $ pgNodeId n)
   where
     selectNodeContexts :: Field SqlInt4 -> Select NodeContextRead
     selectNodeContexts n' = proc () -> do
@@ -83,9 +83,9 @@ getNodeContexts n = runOpaQuery (selectNodeContexts $ pgNodeId n)
       returnA -< ns
 
 
-getNodeContext :: HasNodeError err => ContextId -> NodeId -> DBCmd err NodeContext
+getNodeContext :: HasNodeError err => ContextId -> NodeId -> DBQuery err x NodeContext
 getNodeContext c n = do
-  maybeNodeContext <- headMay <$> runOpaQuery (selectNodeContext (pgContextId c) (pgNodeId n))
+  maybeNodeContext <- headMay <$> mkOpaQuery (selectNodeContext (pgContextId c) (pgNodeId n))
   case maybeNodeContext of
     Nothing -> nodeError (NoContextFound c)
     Just  r -> pure r
@@ -97,9 +97,9 @@ getNodeContext c n = do
       restrict -< _nc_node_id ns .== n'
       returnA -< ns
 
-updateNodeContextCategory :: ContextId -> NodeId -> Int -> DBCmd err Int64
+updateNodeContextCategory :: ContextId -> NodeId -> Int -> DBUpdate err Int64
 updateNodeContextCategory cId nId cat = do
-  execPGSQuery upScore (cat, cId, nId)
+  mkPGUpdate upScore (cat, cId, nId)
   where
     upScore :: PGS.Query
     upScore = [sql| UPDATE nodes_contexts
@@ -118,9 +118,9 @@ data ContextForNgrams =
 getContextsForNgrams :: HasNodeError err
                      => NodeId
                      -> [Int]
-                     -> DBCmd err [ContextForNgrams]
+                     -> DBQuery err x [ContextForNgrams]
 getContextsForNgrams cId ngramsIds = do
-  res <- runPGSQuery query (cId, PGS.In ngramsIds)
+  res <- mkPGQuery query (cId, PGS.In ngramsIds)
   pure $ (\( _cfn_nodeId
            , _cfn_hash
            , _cfn_userId
@@ -152,10 +152,10 @@ getContextsForNgramsTerms :: HasNodeError err
                           => NodeId
                           -> [Text]
                           -> Maybe Bool
-                          -> DBCmd err [ContextForNgramsTerms]
+                          -> DBQuery err x [ContextForNgramsTerms]
 getContextsForNgramsTerms cId ngramsTerms (Just True) = do
   let terms_length = length ngramsTerms
-  res <- runPGSQuery query (cId, PGS.In ngramsTerms, terms_length)
+  res <- mkPGQuery query (cId, PGS.In ngramsTerms, terms_length)
   pure $ (\( _cfnt_nodeId
            , _cfnt_hash
            , _cfnt_nodeTypeId
@@ -198,7 +198,7 @@ getContextsForNgramsTerms cId ngramsTerms (Just True) = do
                    |]
 
 getContextsForNgramsTerms cId ngramsTerms _ = do
-  res <- runPGSQuery query (cId, PGS.In ngramsTerms)
+  res <- mkPGQuery query (cId, PGS.In ngramsTerms)
   pure $ (\( _cfnt_nodeId
            , _cfnt_hash
            , _cfnt_nodeTypeId
@@ -246,9 +246,9 @@ getContextsForNgramsTerms cId ngramsTerms _ = do
 getContextNgrams :: HasNodeError err
                  => NodeId
                  -> NodeId
-                 -> DBCmd err [Text]
+                 -> DBQuery err x [Text]
 getContextNgrams contextId listId = do
-  res <- runPGSQuery query (contextId, listId)
+  res <- mkPGQuery query (contextId, listId)
   pure $ (\(PGS.Only term) -> term) <$> res
 
   where
@@ -270,9 +270,9 @@ getContextNgrams contextId listId = do
 getContextNgramsMatchingFTS :: HasNodeError err
                             => ContextId
                             -> NodeId
-                            -> DBCmd err [Text]
+                            -> DBQuery err x [Text]
 getContextNgramsMatchingFTS contextId listId = do
-  res <- runPGSQuery query (listId, contextId)
+  res <- mkPGQuery query (listId, contextId)
   pure $ (\(PGS.Only term) -> term) <$> res
 
   where
@@ -299,9 +299,8 @@ getContextNgramsMatchingFTS contextId listId = do
                 AND (contexts.search @@ plainto_tsquery(ngrams.terms)
                   OR contexts.search @@ plainto_tsquery('french', ngrams.terms)) |]
 ------------------------------------------------------------------------
-insertNodeContext :: [NodeContext] -> DBCmd err Int
-insertNodeContext ns = mkCmd $ \conn -> fromIntegral <$> (runInsert conn
-                          $ Insert nodeContextTable ns' rCount (Just doNothing))
+insertNodeContext :: [NodeContext] -> DBUpdate err Int
+insertNodeContext ns = fromIntegral <$> mkOpaInsert (Insert nodeContextTable ns' rCount (Just doNothing))
   where
     ns' :: [NodeContextWrite]
     ns' = map (\(NodeContext i n c x y)
@@ -317,9 +316,8 @@ insertNodeContext ns = mkCmd $ \conn -> fromIntegral <$> (runInsert conn
 type Node_Id    = NodeId
 type Context_Id = NodeId
 
-deleteNodeContext :: Node_Id -> Context_Id -> DBCmd err Int
-deleteNodeContext n c = mkCmd $ \conn ->
-  fromIntegral <$> runDelete conn
+deleteNodeContext :: Node_Id -> Context_Id -> DBUpdate err Int64
+deleteNodeContext n c = mkOpaDelete $
                               (Delete nodeContextTable
                                       (\(NodeContext _ n_id c_id _ _) -> n_id .== pgNodeId n
                                                                    .&& c_id .== pgNodeId c
@@ -329,9 +327,9 @@ deleteNodeContext n c = mkCmd $ \conn ->
 
 ------------------------------------------------------------------------
 -- | Favorite management
-nodeContextsCategory :: [(CorpusId, DocId, Int)] -> DBCmd err [Int]
+nodeContextsCategory :: [(CorpusId, DocId, Int)] -> DBUpdate err [Int]
 nodeContextsCategory inputData = map (\(PGS.Only a) -> a)
-                            <$> runPGSQuery catSelect (PGS.Only $ Values fields inputData)
+                            <$> mkPGUpdateReturningMany catSelect (PGS.Only $ Values fields inputData)
   where
     fields = map (QualifiedIdentifier Nothing) ["int4","int4","int4"]
     catSelect :: PGS.Query
@@ -345,9 +343,9 @@ nodeContextsCategory inputData = map (\(PGS.Only a) -> a)
 
 ------------------------------------------------------------------------
 -- | Score management
-nodeContextsScore :: [(CorpusId, DocId, Int)] -> DBCmd err [Int]
+nodeContextsScore :: [(CorpusId, DocId, Int)] -> DBUpdate err [Int]
 nodeContextsScore inputData = map (\(PGS.Only a) -> a)
-                            <$> runPGSQuery catScore (PGS.Only $ Values fields inputData)
+                            <$> mkPGUpdateReturningMany catScore (PGS.Only $ Values fields inputData)
   where
     fields = map (QualifiedIdentifier Nothing) ["int4","int4","int4"]
     catScore :: PGS.Query
@@ -370,8 +368,8 @@ nodeContextsScore inputData = map (\(PGS.Only a) -> a)
 --     nc.node_id = 88
 --     and nc.category >= 1
 --     and c.typename = 4
-selectCountDocs :: HasDBid NodeType => CorpusId -> DBCmd err Int
-selectCountDocs cId = runCountOpaQuery (queryCountDocs cId)
+selectCountDocs :: HasDBid NodeType => CorpusId -> DBQuery err x Int
+selectCountDocs cId = mkOpaCountQuery (countRows $ queryCountDocs cId)
   where
     queryCountDocs cId' = proc () -> do
       (c, nc) <- joinInCorpus -< ()
@@ -382,14 +380,14 @@ selectCountDocs cId = runCountOpaQuery (queryCountDocs cId)
 
 
 -- | TODO use UTCTime fast
-selectDocsDates :: HasDBid NodeType => CorpusId -> DBCmd err [Text]
+selectDocsDates :: HasDBid NodeType => CorpusId -> DBQuery err x [Text]
 selectDocsDates cId =  map (head' "selectDocsDates" . splitOn "-")
                    <$> catMaybes
                    <$> map (view hd_publication_date)
                    <$> selectDocs cId
 
-selectDocs :: HasDBid NodeType => CorpusId -> DBCmd err [HyperdataDocument]
-selectDocs cId = runOpaQuery (queryDocs cId)
+selectDocs :: HasDBid NodeType => CorpusId -> DBQuery err x [HyperdataDocument]
+selectDocs cId = mkOpaQuery (queryDocs cId)
 
 queryDocs :: HasDBid NodeType => CorpusId -> O.Select (Field SqlJsonb)
 queryDocs cId = proc () -> do
@@ -399,8 +397,8 @@ queryDocs cId = proc () -> do
   restrict -< (c ^. context_typename) .== sqlInt4 (toDBid NodeDocument)
   returnA  -< view (context_hyperdata) c
 
-selectDocNodes :: HasDBid NodeType => CorpusId -> DBCmd err [Context HyperdataDocument]
-selectDocNodes cId = runOpaQuery (queryDocNodes cId)
+selectDocNodes :: HasDBid NodeType => CorpusId -> DBQuery err x [Context HyperdataDocument]
+selectDocNodes cId = mkOpaQuery (queryDocNodes cId)
 
 queryDocNodes :: HasDBid NodeType => CorpusId -> O.Select ContextRead
 queryDocNodes cId = proc () -> do
@@ -414,8 +412,8 @@ queryDocNodes cId = proc () -> do
   restrict -< (c ^. context_typename) .== sqlInt4 (toDBid NodeDocument)
   returnA -<  c
 
-selectDocNodesOnlyId :: HasDBid NodeType => CorpusId -> DBCmd err [ContextOnlyId HyperdataDocument]
-selectDocNodesOnlyId cId = runOpaQuery (queryDocNodesOnlyId cId)
+selectDocNodesOnlyId :: HasDBid NodeType => CorpusId -> DBQuery err x [ContextOnlyId HyperdataDocument]
+selectDocNodesOnlyId cId = mkOpaQuery (queryDocNodesOnlyId cId)
 
 queryDocNodesOnlyId :: HasDBid NodeType => CorpusId -> O.Select ContextOnlyIdRead
 queryDocNodesOnlyId cId = proc () -> do
@@ -441,8 +439,8 @@ joinOn1 = proc () -> do
 
 ------------------------------------------------------------------------
 selectPublicContexts :: HasDBid NodeType => (Hyperdata a, DefaultFromField SqlJsonb a)
-                  => DBCmd err [(Node a, Maybe Int)]
-selectPublicContexts = runOpaQuery (queryWithType NodeFolderPublic)
+                  => DBQuery err x [(Node a, Maybe Int)]
+selectPublicContexts = mkOpaQuery (queryWithType NodeFolderPublic)
 
 queryWithType :: HasDBid NodeType => NodeType -> O.Select (NodeRead, MaybeFields (Field SqlInt4))
 queryWithType nt = proc () -> do

src/Gargantext/Database/Transactional.hs

 {-# LANGUAGE KindSignatures      #-}
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 module Gargantext.Database.Transactional (
     DBOperation
   , DBTransactionOp -- opaque
@@ -15,28 +16,32 @@ module Gargantext.Database.Transactional (
   -- * Smart constructors
   , mkPGQuery
   , mkPGUpdate
-  , mkPGUpdateReturning
+  , mkPGUpdateReturningOne
+  , mkPGUpdateReturningMany
   , mkOpaQuery
+  , mkOpaCountQuery
   , mkOpaUpdate
   , mkOpaInsert
+  , mkOpaDelete
 
   -- * Throwing errors (which allow rollbacks)
   , dbFail
   ) where
 
+import Control.Exception.Safe qualified as Safe
 import Control.Lens
 import Control.Monad.Base
 import Control.Monad.Error.Class
 import Control.Monad.Free
 import Control.Monad.Trans.Control (MonadBaseControl, control)
+import Data.Int (Int64)
 import Data.Pool (withResource, Pool)
 import Data.Profunctor.Product.Default
 import Database.PostgreSQL.Simple qualified as PG
 import Database.PostgreSQL.Simple.Transaction qualified as PG
-import Gargantext.Database.Prelude
+import Gargantext.Database.Class
 import Opaleye
 import Prelude
-import qualified Control.Exception.Safe as Safe
 
 data DBOperation = DBRead | DBWrite
 
@@ -49,20 +54,24 @@ data DBTransactionOp err (r :: DBOperation) next where
   PGQuery   :: (PG.ToRow q, PG.FromRow a) => PG.Query -> q -> ([a] -> next) -> DBTransactionOp err r next
   -- | A Postgres /write/, returning the number of affected rows. It can be used only in
   -- 'DBWrite' transactions.
-  PGUpdate  :: PG.ToRow a => PG.Query -> a -> (Int -> next) -> DBTransactionOp err DBWrite next
+  PGUpdate  :: PG.ToRow a => PG.Query -> a -> (Int64 -> next) -> DBTransactionOp err DBWrite next
   -- | Unlike a 'PGUpdate' that returns the list of affected rows, this can be used
   -- to write updates that returns a value via the \"RETURNING\" directive. It's the programmer's
   -- responsibility to ensure that the SQL fragment contains it.
-  PGUpdateReturning  :: (PG.ToRow q, PG.FromRow a) => PG.Query -> q -> (a -> next) -> DBTransactionOp err DBWrite next
+  PGUpdateReturningMany  :: (PG.ToRow q, PG.FromRow a) => PG.Query -> q -> ([a] -> next) -> DBTransactionOp err DBWrite next
+  -- | Ditto as above, but the contract is that the query has to return /exactly one/ result.
+  PGUpdateReturningOne   :: (PG.ToRow q, PG.FromRow a) => PG.Query -> q -> (a -> next) -> DBTransactionOp err DBWrite next
   -- | An Opaleye /read/, returning a list of results. The 'r' in the result is polymorphic
   -- so that reads can be embedded in updates transactions.
   OpaQuery  :: Default FromFields fields a => Select fields -> ([a] -> next) -> DBTransactionOp err r next
+  OpaCountQuery  :: Select a -> (Int -> next) -> DBTransactionOp err r next
   -- | An Opaleye /write/, returning a result depending on the input 'Insert'. It can be used only in
   -- 'DBWrite' transactions.
   OpaInsert :: Insert a -> (a -> next) -> DBTransactionOp err DBWrite next
   -- | An Opaleye /write/, returning a result depending on the input 'Update'. It can be used only in
   -- 'DBWrite' transactions.
   OpaUpdate :: Update a -> (a -> next) -> DBTransactionOp err DBWrite next
+  OpaDelete :: Delete a -> (a -> next) -> DBTransactionOp err DBWrite next
   -- | Monadic failure for DB transactions.
   DBFail    :: err -> DBTransactionOp err r next
 
@@ -80,13 +89,16 @@ type DBTxCmd err a = forall m env. (IsCmd env err m, HasConnectionPool env) => m
 
 instance Functor (DBTransactionOp err r) where
   fmap f = \case
-    PGQuery   q params cont     -> PGQuery   q params (f . cont)
-    PGUpdate  q a cont          -> PGUpdate  q a      (f . cont)
-    PGUpdateReturning  q a cont -> PGUpdateReturning q a      (f . cont)
-    OpaQuery  sel cont          -> OpaQuery  sel      (f . cont)
-    OpaInsert ins cont          -> OpaInsert ins      (f . cont)
-    OpaUpdate upd cont          -> OpaUpdate upd      (f . cont)
-    DBFail    err               -> DBFail err
+    PGQuery   q params cont        -> PGQuery   q params (f . cont)
+    PGUpdate  q a cont             -> PGUpdate  q a      (f . cont)
+    PGUpdateReturningOne q a cont  -> PGUpdateReturningOne q a      (f . cont)
+    PGUpdateReturningMany q a cont -> PGUpdateReturningMany q a      (f . cont)
+    OpaQuery  sel cont             -> OpaQuery  sel      (f . cont)
+    OpaCountQuery sel cont         -> OpaCountQuery  sel (f . cont)
+    OpaInsert ins cont             -> OpaInsert ins      (f . cont)
+    OpaUpdate upd cont             -> OpaUpdate upd      (f . cont)
+    OpaDelete del cont             -> OpaDelete del      (f . cont)
+    DBFail    err                  -> DBFail err
 
 -- | Generalised version of 'withResource' to work over any unlifted monad.
 -- For some reason 'resource-pool' removed this from version 0.3.0.0 onwards.
@@ -132,13 +144,22 @@ runDBQuery (DBTx m) = do
 -- 'DBCmd'.
 evalOp :: PG.Connection -> DBTransactionOp err r a -> DBTxCmd err a
 evalOp conn = \case
-  PGQuery   qr q cc          -> cc <$> liftBase (PG.query conn qr q)
-  PGUpdate  qr a cc          -> cc <$> liftBase (fromIntegral <$> PG.execute conn qr a)
-  PGUpdateReturning  qr a cc -> cc <$> liftBase (queryOne conn qr a)
-  OpaQuery  sel  cc          -> cc <$> liftBase (runSelect conn sel)
-  OpaInsert ins  cc          -> cc <$> liftBase (runInsert conn ins)
-  OpaUpdate upd  cc          -> cc <$> liftBase (runUpdate conn upd)
-  DBFail    err              -> throwError err
+  PGQuery   qr q cc             -> cc <$> liftBase (PG.query conn qr q)
+  PGUpdate  qr a cc             -> cc <$> liftBase (PG.execute conn qr a)
+  PGUpdateReturningOne qr a cc  -> cc <$> liftBase (queryOne conn qr a)
+  PGUpdateReturningMany qr a cc -> cc <$> liftBase (PG.query conn qr a)
+  OpaQuery  sel  cc             -> cc <$> liftBase (runSelect conn sel)
+  OpaCountQuery  sel  cc        -> cc <$> liftBase (evalOpaCountQuery conn sel)
+  OpaInsert ins  cc             -> cc <$> liftBase (runInsert conn ins)
+  OpaUpdate upd  cc             -> cc <$> liftBase (runUpdate conn upd)
+  OpaDelete del  cc             -> cc <$> liftBase (runDelete conn del)
+  DBFail    err                 -> throwError err
+
+evalOpaCountQuery :: PG.Connection -> Select a -> IO Int
+evalOpaCountQuery conn sel = do
+  counts <- runSelect conn $ countRows sel
+  -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
+  pure $ fromIntegral @Int64 @Int $ head counts
 
 queryOne :: (PG.ToRow q, PG.FromRow r) => PG.Connection -> PG.Query -> q -> IO r
 queryOne conn q v = do
@@ -161,19 +182,29 @@ mkPGQuery :: (PG.ToRow q, PG.FromRow a)
            -> DBQuery err r [a]
 mkPGQuery q a = DBTx $ liftF (PGQuery q a id)
 
-mkPGUpdate :: PG.ToRow a => PG.Query -> a -> DBUpdate err Int
+mkPGUpdate :: PG.ToRow a => PG.Query -> a -> DBUpdate err Int64
 mkPGUpdate q a = DBTx $ liftF (PGUpdate q a id)
 
-mkPGUpdateReturning :: (PG.ToRow q, PG.FromRow a) => PG.Query -> q -> DBUpdate err a
-mkPGUpdateReturning q a = DBTx $ liftF (PGUpdateReturning q a id)
+mkPGUpdateReturningOne :: (PG.ToRow q, PG.FromRow a) => PG.Query -> q -> DBUpdate err a
+mkPGUpdateReturningOne q a = DBTx $ liftF (PGUpdateReturningOne q a id)
+
+mkPGUpdateReturningMany :: (PG.ToRow q, PG.FromRow a) => PG.Query -> q -> DBUpdate err [a]
+mkPGUpdateReturningMany q a = DBTx $ liftF (PGUpdateReturningMany q a id)
 
 mkOpaQuery :: Default FromFields fields a
            => Select fields
            -> DBQuery err x [a]
 mkOpaQuery s = DBTx $ liftF (OpaQuery s id)
 
+mkOpaCountQuery :: Select fields
+                -> DBQuery err x Int
+mkOpaCountQuery s = DBTx $ liftF (OpaCountQuery s id)
+
 mkOpaUpdate :: Update a -> DBUpdate err a
 mkOpaUpdate a = DBTx $ liftF (OpaUpdate a id)
 
 mkOpaInsert :: Insert a -> DBUpdate err a
 mkOpaInsert a = DBTx $ liftF (OpaInsert a id)
+
+mkOpaDelete :: Delete a -> DBUpdate err a
+mkOpaDelete a = DBTx $ liftF (OpaDelete a id)

test/Test/Database/Transactions.hs

@@ -146,17 +146,17 @@ getCounterById (CounterId cid) = do
 
 insertCounter :: DBUpdate IOException Counter
 insertCounter = do
-  mkPGUpdateReturning [sql| INSERT INTO public.ggtx_test_counter_table(counter_value) VALUES(0) RETURNING id, counter_value|] ()
+  mkPGUpdateReturningOne [sql| INSERT INTO public.ggtx_test_counter_table(counter_value) VALUES(0) RETURNING id, counter_value|] ()
 
 updateCounter :: CounterId -> Int -> DBUpdate IOException Counter
 updateCounter cid x = do
-  mkPGUpdateReturning [sql| UPDATE public.ggtx_test_counter_table SET counter_value = ? WHERE id = ? RETURNING *|] (x, cid)
+  mkPGUpdateReturningOne [sql| UPDATE public.ggtx_test_counter_table SET counter_value = ? WHERE id = ? RETURNING *|] (x, cid)
 
 -- | We deliberately write this as a composite operation.
 stepCounter :: CounterId -> DBUpdate IOException Counter
 stepCounter cid = do
   Counter{..} <- getCounterById cid
-  mkPGUpdateReturning [sql| UPDATE public.ggtx_test_counter_table SET counter_value = ? WHERE id = ? RETURNING *|] (counterValue + 1, cid)
+  mkPGUpdateReturningOne [sql| UPDATE public.ggtx_test_counter_table SET counter_value = ? WHERE id = ? RETURNING *|] (counterValue + 1, cid)
 
 --
 -- MAIN TESTS