Skip to content

haskell-gargantext
haskell-gargantext
Commit 8d66d21e authored by Alfredo Di Napoli's avatar Alfredo Di Napoli
Browse files
Options

WIP: Port DB operations to transactional API

parent c0f94390
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 395 additions and 396 deletions
gargantext.cabal
View file @ 8d66d21e
......@@ -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
View file @ 8d66d21e
......@@ -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
View file @ 8d66d21e
......@@ -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
View file @ 8d66d21e
......@@ -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
View file @ 8d66d21e
......@@ -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
View file @ 8d66d21e
......@@ -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
View file @ 8d66d21e
......@@ -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
View file @ 8d66d21e
......@@ -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 0 → 100644
View file @ 8d66d21e
{-# 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/Prelude.hs
View file @ 8d66d21e
This diff is collapsed.
src/Gargantext/Database/Query/Table/Context.hs
View file @ 8d66d21e
......@@ -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.hs
View file @ 8d66d21e
This diff is collapsed.
src/Gargantext/Database/Query/Table/Node/Children.hs
View file @ 8d66d21e
......@@ -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
View file @ 8d66d21e
......@@ -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
View file @ 8d66d21e
......@@ -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
View file @ 8d66d21e
......@@ -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
View file @ 8d66d21e
{-# 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
View file @ 8d66d21e
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment