Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
haskell-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
153
Issues
153
List
Board
Labels
Milestones
Merge Requests
7
Merge Requests
7
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
gargantext
haskell-gargantext
Commits
41ad6f5d
Commit
41ad6f5d
authored
Apr 24, 2025
by
Alfredo Di Napoli
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Implement DBTx in terms of a 'Free' monad.
parent
1eca6e88
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
88 additions
and
42 deletions
+88
-42
gargantext.cabal
gargantext.cabal
+1
-0
Transactional.hs
src/Gargantext/Database/Transactional.hs
+86
-41
Example.hs
src/Gargantext/Database/Transactional/Example.hs
+1
-1
No files found.
gargantext.cabal
View file @
41ad6f5d
...
@@ -546,6 +546,7 @@ library
...
@@ -546,6 +546,7 @@ library
, filepath ^>= 1.4.2.2
, filepath ^>= 1.4.2.2
, fmt
, fmt
, formatting ^>= 7.2.0
, formatting ^>= 7.2.0
, free >= 0.5.0
, fullstop ^>= 0.1.4
, fullstop ^>= 0.1.4
, gargantext-graph-core >= 0.2.0.0
, gargantext-graph-core >= 0.2.0.0
, gargantext-prelude
, gargantext-prelude
...
...
src/Gargantext/Database/Transactional.hs
View file @
41ad6f5d
...
@@ -10,11 +10,14 @@ module Gargantext.Database.Transactional where
...
@@ -10,11 +10,14 @@ module Gargantext.Database.Transactional where
import
Control.Exception
import
Control.Exception
import
Control.Lens
import
Control.Lens
import
Control.Monad.Base
import
Control.Monad.Base
import
Control.Monad.Error.Class
import
Control.Monad.Free
import
Control.Monad.Trans.Control
(
MonadBaseControl
,
control
)
import
Control.Monad.Trans.Control
(
MonadBaseControl
,
control
)
import
Data.Pool
(
withResource
,
Pool
)
import
Data.Pool
(
withResource
,
Pool
)
import
Data.Profunctor.Product.Default
import
Data.Profunctor.Product.Default
import
Data.Text
qualified
as
T
import
Data.Text
qualified
as
T
import
Database.PostgreSQL.Simple
qualified
as
PG
import
Database.PostgreSQL.Simple
qualified
as
PG
import
Database.PostgreSQL.Simple.Transaction
qualified
as
PG
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
import
Gargantext.Database.Query.Table.Node.Error
import
Gargantext.Database.Query.Table.Node.Error
import
Opaleye
import
Opaleye
...
@@ -22,73 +25,115 @@ import Prelude
...
@@ -22,73 +25,115 @@ import Prelude
data
DBOperation
=
DBRead
|
DBWrite
data
DBOperation
=
DBRead
|
DBWrite
type
DBQuery
err
r
a
=
DBTransactionOp
err
r
a
-- | A functor describing a single operation on the database. Each constructor takes a continuation
type
DBUpdate
err
a
=
DBTransactionOp
err
DBWrite
a
-- argument which can be used to derive a sound 'Functor' instance, making this viable to be applied
-- in a monadic/free context.
data
DBTransactionOp
err
(
r
::
DBOperation
)
a
where
data
DBTransactionOp
err
(
r
::
DBOperation
)
next
where
PGQuery
::
(
PG
.
ToRow
q
,
PG
.
FromRow
a
)
=>
PG
.
Query
->
q
->
DBTransactionOp
err
r
[
a
]
-- | A Postgres /read/, returning a list of results. The 'r' in the result is polymorphic
PGUpdate
::
PG
.
ToRow
a
=>
PG
.
Query
->
a
->
DBTransactionOp
err
DBWrite
Int
-- so that reads can be embedded in updates transactions.
OpaQuery
::
Default
FromFields
fields
a
=>
Select
fields
->
DBTransactionOp
err
r
[
a
]
PGQuery
::
(
PG
.
ToRow
q
,
PG
.
FromRow
a
)
=>
PG
.
Query
->
q
->
([
a
]
->
next
)
->
DBTransactionOp
err
r
next
OpaUpdate
::
Insert
a
->
DBTransactionOp
err
DBWrite
a
-- | A Postgres /write/, returning the number of affected rows. It can be used only in
PureOp
::
a
->
DBTransactionOp
err
r
a
-- 'DBWrite' transactions.
BindOp
::
DBTransactionOp
err
r
a
->
(
a
->
DBTransactionOp
err
r
b
)
->
DBTransactionOp
err
r
b
PGUpdate
::
PG
.
ToRow
a
=>
PG
.
Query
->
a
->
(
Int
->
next
)
->
DBTransactionOp
err
DBWrite
next
DBFail
::
err
->
DBTransactionOp
err
r
b
-- | An Opaleye /read/, returning a list of results. The 'r' in the result is polymorphic
-- so that reads can be embedded in updates transactions.
dbFail
::
HasNodeError
err
=>
err
->
DBTransactionOp
err
r
b
OpaQuery
::
Default
FromFields
fields
a
=>
Select
fields
->
([
a
]
->
next
)
->
DBTransactionOp
err
r
next
dbFail
=
DBFail
-- | An Opaleye /write/, returning a result depending on the input 'Insert'. It can be used only in
-- 'DBWrite' transactions.
dbFailWith
::
HasNodeError
err
=>
T
.
Text
->
DBTransactionOp
err
r
b
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
-- | Monadic failure for DB transactions.
DBFail
::
err
->
DBTransactionOp
err
r
next
newtype
DBTx
err
r
a
=
DBTx
{
_DBTx
::
Free
(
DBTransactionOp
err
r
)
a
}
deriving
(
Functor
,
Applicative
,
Monad
)
type
DBQuery
err
r
a
=
DBTx
err
r
a
type
DBUpdate
err
a
=
DBTx
err
DBWrite
a
type
DBReadOnly
err
r
a
=
DBTx
err
DBRead
a
dbFail
::
HasNodeError
err
=>
err
->
DBTx
err
r
b
dbFail
=
DBTx
.
liftF
.
DBFail
dbFailWith
::
HasNodeError
err
=>
T
.
Text
->
DBTx
err
r
b
dbFailWith
x
=
dbFail
$
_NodeError
#
(
NodeError
$
toException
$
userError
$
T
.
unpack
x
)
dbFailWith
x
=
dbFail
$
_NodeError
#
(
NodeError
$
toException
$
userError
$
T
.
unpack
x
)
instance
Functor
(
DBTransactionOp
err
r
)
where
instance
Functor
(
DBTransactionOp
err
r
)
where
fmap
_
_
=
undefined
fmap
f
=
\
case
PGQuery
q
params
cont
->
PGQuery
q
params
(
f
.
cont
)
instance
Applicative
(
DBTransactionOp
err
r
)
where
PGUpdate
q
a
cont
->
PGUpdate
q
a
(
f
.
cont
)
pure
_
=
undefined
OpaQuery
sel
cont
->
OpaQuery
sel
(
f
.
cont
)
_
<*>
_
=
undefined
OpaInsert
ins
cont
->
OpaInsert
ins
(
f
.
cont
)
OpaUpdate
upd
cont
->
OpaUpdate
upd
(
f
.
cont
)
instance
Monad
(
DBTransactionOp
err
r
)
where
DBFail
err
->
DBFail
err
_
>>=
_
=
undefined
-- | Generalised version of 'withResource' to work over any unlifted monad.
-- | Generalised version of 'withResource' to work over any unlifted monad.
-- For some reason 'resource-pool' removed this from version 0.3.0.0 onwards.
-- For some reason 'resource-pool' removed this from version 0.3.0.0 onwards.
withResourceM
::
MonadBaseControl
IO
m
=>
Pool
a
->
(
a
->
m
b
)
->
m
b
withResourceM
::
MonadBaseControl
IO
m
=>
Pool
a
->
(
a
->
m
b
)
->
m
b
withResourceM
pool
func
=
control
$
\
run
->
withResource
pool
(
run
.
func
)
withResourceM
pool
func
=
control
$
\
run
->
withResource
pool
(
run
.
func
)
withTransactionM
::
forall
m
a
.
MonadBaseControl
IO
m
=>
m
a
->
m
a
withTransactionM
withTransactionM
_act
=
undefined
::
forall
m
a
.
MonadBaseControl
IO
m
=>
PG
.
Connection
->
m
a
->
m
a
withTransactionM
conn
action
=
control
$
\
runInIO
->
PG
.
withTransaction
conn
$
runInIO
action
-- | Run a PostgreSQL "read-only" transaction, suitable for read-only queries.
withReadOnlyTransactionM
::
forall
m
a
.
MonadBaseControl
IO
m
=>
PG
.
Connection
->
m
a
->
m
a
withReadOnlyTransactionM
conn
action
=
control
$
\
runInIO
->
PG
.
withTransactionMode
tmode
conn
(
runInIO
action
)
where
tmode
::
PG
.
TransactionMode
tmode
=
PG
.
TransactionMode
PG
.
DefaultIsolationLevel
PG
.
ReadOnly
runDBTx
::
HasNodeError
err
=>
DBUpdate
err
a
->
DBCmd
err
a
runDBTx
::
HasNodeError
err
=>
DBUpdate
err
a
->
DBCmd
err
a
runDBTx
m
=
do
runDBTx
(
DBTx
m
)
=
do
pool
<-
view
connPool
pool
<-
view
connPool
withResourceM
pool
$
\
conn
->
evalOp
conn
m
withResourceM
pool
$
\
conn
->
withTransactionM
conn
$
foldFree
(
evalOp
conn
)
m
runDBQuery
::
HasNodeError
err
=>
DBQuery
err
r
a
->
DBCmd
err
a
-- | /NOTE/ the input type is 'DBReadOnly', i.e. a transaction where /all/
runDBQuery
m
=
do
-- the operations are 'DBRead'. This makes impossible to sneak in updates
-- into otherwise read-only queries.
runDBQuery
::
HasNodeError
err
=>
DBReadOnly
err
r
a
->
DBCmd
err
a
runDBQuery
(
DBTx
m
)
=
do
pool
<-
view
connPool
pool
<-
view
connPool
withResourceM
pool
$
\
conn
->
evalOp
conn
m
withResourceM
pool
$
\
conn
->
withReadOnlyTransactionM
conn
$
foldFree
(
evalOp
conn
)
m
evalOp
::
HasNodeError
err
=>
PG
.
Connection
->
DBTransactionOp
err
r
a
->
DBCmd
err
a
evalOp
::
HasNodeError
err
=>
PG
.
Connection
->
DBTransactionOp
err
r
a
->
DBCmd
err
a
evalOp
conn
=
\
case
evalOp
conn
=
\
case
PGQuery
qr
q
->
liftBase
(
PG
.
query
conn
qr
q
)
PGQuery
qr
q
cc
->
cc
<$>
liftBase
(
PG
.
query
conn
qr
q
)
PGUpdate
qr
a
->
liftBase
(
fromIntegral
<$>
PG
.
execute
conn
qr
a
)
PGUpdate
qr
a
cc
->
cc
<$>
liftBase
(
fromIntegral
<$>
PG
.
execute
conn
qr
a
)
OpaQuery
sel
->
liftBase
(
runSelect
conn
sel
)
OpaQuery
sel
cc
->
cc
<$>
liftBase
(
runSelect
conn
sel
)
OpaUpdate
ins
->
liftBase
(
runInsert
conn
ins
)
OpaInsert
ins
cc
->
cc
<$>
liftBase
(
runInsert
conn
ins
)
_
->
error
"todo"
OpaUpdate
upd
cc
->
cc
<$>
liftBase
(
runUpdate
conn
upd
)
DBFail
err
->
throwError
err
mkPGQuery
::
(
PG
.
ToRow
q
,
PG
.
FromRow
a
)
mkPGQuery
::
(
PG
.
ToRow
q
,
PG
.
FromRow
a
)
=>
PG
.
Query
=>
PG
.
Query
->
q
->
q
->
DBQuery
err
r
[
a
]
->
DBQuery
err
r
[
a
]
mkPGQuery
q
s
=
PGQuery
q
s
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
Int
mkPGUpdate
q
s
=
PGUpdate
q
s
mkPGUpdate
q
a
=
DBTx
$
liftF
(
PGUpdate
q
a
id
)
mkOpaQuery
::
Default
FromFields
fields
a
mkOpaQuery
::
Default
FromFields
fields
a
=>
Select
fields
=>
Select
fields
->
DBQuery
err
x
[
a
]
->
DBQuery
err
x
[
a
]
mkOpaQuery
=
OpaQuery
mkOpaQuery
s
=
DBTx
$
liftF
(
OpaQuery
s
id
)
mkOpaUpdate
::
Update
a
->
DBUpdate
err
a
mkOpaUpdate
a
=
DBTx
$
liftF
(
OpaUpdate
a
id
)
mkOpa
Update
::
Insert
a
->
DBUpdate
err
a
mkOpa
Insert
::
Insert
a
->
DBUpdate
err
a
mkOpa
Update
=
OpaUpdate
mkOpa
Insert
a
=
DBTx
$
liftF
(
OpaInsert
a
id
)
src/Gargantext/Database/Transactional/Example.hs
View file @
41ad6f5d
...
@@ -97,7 +97,7 @@ getRootId u = do
...
@@ -97,7 +97,7 @@ getRootId u = do
Just
r
->
pure
(
_node_id
r
)
Just
r
->
pure
(
_node_id
r
)
insertNodeNode
::
[
GGTX
.
NodeNode
]
->
DBUpdate
err
Int
insertNodeNode
::
[
GGTX
.
NodeNode
]
->
DBUpdate
err
Int
insertNodeNode
ns
=
fromIntegral
<$>
mkOpa
Update
(
Insert
nodeNodeTable
ns'
rCount
(
Just
doNothing
))
insertNodeNode
ns
=
fromIntegral
<$>
mkOpa
Insert
(
Insert
nodeNodeTable
ns'
rCount
(
Just
doNothing
))
where
where
ns'
::
[
GGTX
.
NodeNodeWrite
]
ns'
::
[
GGTX
.
NodeNodeWrite
]
ns'
=
map
(
\
(
NodeNode
n1
n2
x
y
)
ns'
=
map
(
\
(
NodeNode
n1
n2
x
y
)
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment