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
119
Issues
119
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
91a2d6e2
Commit
91a2d6e2
authored
Sep 02, 2022
by
Przemyslaw Kaminski
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[nodeStory] insert/delete/update seems to work, needs more verification
parent
e1dbfd70
Pipeline
#3135
passed with stage
in 93 minutes and 41 seconds
Changes
2
Pipelines
1
Show whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
83 additions
and
51 deletions
+83
-51
NodeStory.hs
src/Gargantext/Core/NodeStory.hs
+75
-43
Node.hs
src/Gargantext/Database/Admin/Types/Node.hs
+8
-8
No files found.
src/Gargantext/Core/NodeStory.hs
View file @
91a2d6e2
...
@@ -67,11 +67,16 @@ module Gargantext.Core.NodeStory
...
@@ -67,11 +67,16 @@ module Gargantext.Core.NodeStory
,
getNodeArchiveHistory
,
getNodeArchiveHistory
,
Archive
(
..
)
,
Archive
(
..
)
,
initArchive
,
initArchive
,
insertArchiveList
,
deleteArchiveList
,
updateArchiveList
,
a_history
,
a_history
,
a_state
,
a_state
,
a_version
,
a_version
,
nodeExists
,
nodeExists
,
runPGSQuery
,
runPGSQuery
,
runPGSAdvisoryLock
,
runPGSAdvisoryUnlock
,
runPGSAdvisoryXactLock
,
runPGSAdvisoryXactLock
,
getNodesIdWithType
,
getNodesIdWithType
,
readNodeStoryEnv
,
readNodeStoryEnv
...
@@ -84,7 +89,7 @@ where
...
@@ -84,7 +89,7 @@ where
-- import Debug.Trace (traceShow)
-- import Debug.Trace (traceShow)
import
Control.Debounce
(
mkDebounce
,
defaultDebounceSettings
,
debounceFreq
,
debounceAction
)
import
Control.Debounce
(
mkDebounce
,
defaultDebounceSettings
,
debounceFreq
,
debounceAction
)
import
Codec.Serialise.Class
import
Codec.Serialise.Class
import
Control.Concurrent
(
MVar
(),
withMVar
,
newMVar
,
modifyMVar_
)
import
Control.Concurrent
(
MVar
(),
newMVar
,
modifyMVar_
)
import
Control.Exception
(
catch
,
throw
,
SomeException
(
..
))
import
Control.Exception
(
catch
,
throw
,
SomeException
(
..
))
import
Control.Lens
(
makeLenses
,
Getter
,
(
^.
),
(
.~
),
(
%~
),
_Just
,
at
,
traverse
,
view
)
import
Control.Lens
(
makeLenses
,
Getter
,
(
^.
),
(
.~
),
(
%~
),
_Just
,
at
,
traverse
,
view
)
import
Control.Monad.Except
import
Control.Monad.Except
...
@@ -275,6 +280,14 @@ type ArchiveList = Archive NgramsState' NgramsStatePatch'
...
@@ -275,6 +280,14 @@ type ArchiveList = Archive NgramsState' NgramsStatePatch'
-- DB stuff
-- DB stuff
runPGSExecute
::
(
PGS
.
ToRow
q
)
=>
PGS
.
Connection
->
PGS
.
Query
->
q
->
IO
Int64
runPGSExecute
c
qs
a
=
catch
(
PGS
.
execute
c
qs
a
)
printError
where
printError
(
SomeException
e
)
=
do
--q' <- PGS.formatQuery c qs a
--hPutStrLn stderr q'
throw
(
SomeException
e
)
runPGSExecuteMany
::
(
PGS
.
ToRow
q
)
=>
PGS
.
Connection
->
PGS
.
Query
->
[
q
]
->
IO
Int64
runPGSExecuteMany
::
(
PGS
.
ToRow
q
)
=>
PGS
.
Connection
->
PGS
.
Query
->
[
q
]
->
IO
Int64
runPGSExecuteMany
c
qs
a
=
catch
(
PGS
.
executeMany
c
qs
a
)
printError
runPGSExecuteMany
c
qs
a
=
catch
(
PGS
.
executeMany
c
qs
a
)
printError
where
where
...
@@ -291,9 +304,19 @@ runPGSQuery c q a = catch (PGS.query c q a) printError
...
@@ -291,9 +304,19 @@ runPGSQuery c q a = catch (PGS.query c q a) printError
hPutStrLn
stderr
q'
hPutStrLn
stderr
q'
throw
(
SomeException
e
)
throw
(
SomeException
e
)
runPGSAdvisoryLock
::
PGS
.
Connection
->
Int
->
IO
()
runPGSAdvisoryLock
c
id
=
do
_
<-
runPGSQuery
c
[
sql
|
SELECT pg_advisory_lock(?)
|]
(
PGS
.
Only
id
)
::
IO
[
PGS
.
Only
()
]
pure
()
runPGSAdvisoryUnlock
::
PGS
.
Connection
->
Int
->
IO
()
runPGSAdvisoryUnlock
c
id
=
do
_
<-
runPGSQuery
c
[
sql
|
SELECT pg_advisory_unlock(?)
|]
(
PGS
.
Only
id
)
::
IO
[
PGS
.
Only
Bool
]
pure
()
runPGSAdvisoryXactLock
::
PGS
.
Connection
->
Int
->
IO
()
runPGSAdvisoryXactLock
::
PGS
.
Connection
->
Int
->
IO
()
runPGSAdvisoryXactLock
c
id
=
do
runPGSAdvisoryXactLock
c
id
=
do
_
<-
runPGSQuery
c
[
sql
|
SELECT pg_advisory_xact_lock(?)
|]
(
PGS
.
Only
id
)
::
IO
[
PGS
.
Only
Bool
]
_
<-
runPGSQuery
c
[
sql
|
SELECT pg_advisory_xact_lock(?)
|]
(
PGS
.
Only
id
)
::
IO
[
PGS
.
Only
()
]
pure
()
pure
()
nodeExists
::
PGS
.
Connection
->
NodeId
->
IO
Bool
nodeExists
::
PGS
.
Connection
->
NodeId
->
IO
Bool
...
@@ -404,8 +427,7 @@ archiveStateFromList l = Map.fromListWith (<>) $ (\(nt, t, nre) -> (nt, Map.sing
...
@@ -404,8 +427,7 @@ archiveStateFromList l = Map.fromListWith (<>) $ (\(nt, t, nre) -> (nt, Map.sing
-- | This function inserts whole new node story and archive for given node_id.
-- | This function inserts whole new node story and archive for given node_id.
insertNodeStory
::
PGS
.
Connection
->
NodeId
->
ArchiveList
->
IO
()
insertNodeStory
::
PGS
.
Connection
->
NodeId
->
ArchiveList
->
IO
()
insertNodeStory
c
nodeId
@
(
NodeId
nId
)
a
=
do
insertNodeStory
c
(
NodeId
nId
)
a
=
do
printDebug
"[insertNodeStory] _a_state"
$
a
^.
a_state
_
<-
mapM
(
\
(
ngramsType
,
ngrams
,
ngramsRepoElement
)
->
do
_
<-
mapM
(
\
(
ngramsType
,
ngrams
,
ngramsRepoElement
)
->
do
termIdM
<-
runPGSQuery
c
ngramsIdQuery
(
PGS
.
Only
ngrams
)
::
IO
[
PGS
.
Only
Int64
]
termIdM
<-
runPGSQuery
c
ngramsIdQuery
(
PGS
.
Only
ngrams
)
::
IO
[
PGS
.
Only
Int64
]
case
headMay
termIdM
of
case
headMay
termIdM
of
...
@@ -413,9 +435,6 @@ insertNodeStory c nodeId@(NodeId nId) a = do
...
@@ -413,9 +435,6 @@ insertNodeStory c nodeId@(NodeId nId) a = do
Just
(
PGS
.
Only
termId
)
->
runPGSExecuteMany
c
query
[(
nId
,
a
^.
a_version
,
ngramsType
,
termId
,
ngramsRepoElement
)])
$
archiveStateAsList
$
a
^.
a_state
Just
(
PGS
.
Only
termId
)
->
runPGSExecuteMany
c
query
[(
nId
,
a
^.
a_version
,
ngramsType
,
termId
,
ngramsRepoElement
)])
$
archiveStateAsList
$
a
^.
a_state
-- runInsert c $ insert ngramsType ngrams ngramsRepoElement) $ archiveStateAsList _a_state
-- runInsert c $ insert ngramsType ngrams ngramsRepoElement) $ archiveStateAsList _a_state
-- NOTE: It is assumed that the most recent change is the first in the
-- list, so we save these in reverse order
insertNodeArchiveHistory
c
nodeId
$
reverse
$
a
^.
a_history
pure
()
pure
()
where
where
query
::
PGS
.
Query
query
::
PGS
.
Query
...
@@ -431,8 +450,8 @@ insertNodeStory c nodeId@(NodeId nId) a = do
...
@@ -431,8 +450,8 @@ insertNodeStory c nodeId@(NodeId nId) a = do
-- , iReturning = rCount
-- , iReturning = rCount
-- , iOnConflict = Nothing }
-- , iOnConflict = Nothing }
insertArchive
::
PGS
.
Connection
->
NodeId
->
ArchiveList
->
IO
()
insertArchive
List
::
PGS
.
Connection
->
NodeId
->
ArchiveList
->
IO
()
insertArchive
c
nodeId
a
=
do
insertArchive
List
c
nodeId
a
=
do
_
<-
runPGSExecuteMany
c
query
$
(
\
(
nt
,
n
,
nre
)
->
(
nodeId
,
a
^.
a_version
,
nt
,
nre
,
n
))
<$>
(
archiveStateAsList
$
a
^.
a_state
)
_
<-
runPGSExecuteMany
c
query
$
(
\
(
nt
,
n
,
nre
)
->
(
nodeId
,
a
^.
a_version
,
nt
,
nre
,
n
))
<$>
(
archiveStateAsList
$
a
^.
a_state
)
pure
()
pure
()
where
where
...
@@ -440,8 +459,8 @@ insertArchive c nodeId a = do
...
@@ -440,8 +459,8 @@ insertArchive c nodeId a = do
query
=
[
sql
|
INSERT INTO node_stories(node_id, version, ngrams_type_id, ngrams_id, ngrams_repo_element)
query
=
[
sql
|
INSERT INTO node_stories(node_id, version, ngrams_type_id, ngrams_id, ngrams_repo_element)
SELECT ?, ?, ?, ngrams.id, ? FROM ngrams WHERE terms = ?
|]
SELECT ?, ?, ?, ngrams.id, ? FROM ngrams WHERE terms = ?
|]
deleteArchive
::
PGS
.
Connection
->
NodeId
->
ArchiveList
->
IO
()
deleteArchive
List
::
PGS
.
Connection
->
NodeId
->
ArchiveList
->
IO
()
deleteArchive
c
nodeId
a
=
do
deleteArchive
List
c
nodeId
a
=
do
_
<-
runPGSExecuteMany
c
query
$
(
\
(
nt
,
n
,
_
)
->
(
nodeId
,
nt
,
n
))
<$>
(
archiveStateAsList
$
a
^.
a_state
)
_
<-
runPGSExecuteMany
c
query
$
(
\
(
nt
,
n
,
_
)
->
(
nodeId
,
nt
,
n
))
<$>
(
archiveStateAsList
$
a
^.
a_state
)
pure
()
pure
()
where
where
...
@@ -450,9 +469,12 @@ deleteArchive c nodeId a = do
...
@@ -450,9 +469,12 @@ deleteArchive c nodeId a = do
DELETE FROM node_stories
DELETE FROM node_stories
WHERE node_id = ? AND ngrams_type_id = ? AND ngrams_id IN (SELECT id FROM ngrams WHERE terms = ?)
|]
WHERE node_id = ? AND ngrams_type_id = ? AND ngrams_id IN (SELECT id FROM ngrams WHERE terms = ?)
|]
updateArchive
::
PGS
.
Connection
->
NodeId
->
ArchiveList
->
IO
()
updateArchiveList
::
PGS
.
Connection
->
NodeId
->
ArchiveList
->
IO
()
updateArchive
c
nodeId
a
=
do
updateArchiveList
c
nodeId
a
=
do
_
<-
runPGSExecuteMany
c
query
$
(
\
(
nt
,
n
,
nre
)
->
(
nre
,
nodeId
,
nt
,
n
))
<$>
(
archiveStateAsList
$
a
^.
a_state
)
let
params
=
(
\
(
nt
,
n
,
nre
)
->
(
nre
,
nodeId
,
nt
,
n
))
<$>
(
archiveStateAsList
$
a
^.
a_state
)
--q <- PGS.format c query params
--printDebug "[updateArchiveList] query" q
_
<-
mapM
(
\
p
->
runPGSExecute
c
query
p
)
params
pure
()
pure
()
where
where
query
::
PGS
.
Query
query
::
PGS
.
Query
...
@@ -483,22 +505,22 @@ updateNodeStory c nodeId@(NodeId _nId) currentArchive newArchive = do
...
@@ -483,22 +505,22 @@ updateNodeStory c nodeId@(NodeId _nId) currentArchive newArchive = do
printDebug
"[updateNodeStory] updates"
$
Text
.
unlines
$
(
Text
.
pack
.
show
)
<$>
updates
printDebug
"[updateNodeStory] updates"
$
Text
.
unlines
$
(
Text
.
pack
.
show
)
<$>
updates
-- 2. Perform inserts/deletes/updates
-- 2. Perform inserts/deletes/updates
insertArchive
c
nodeId
$
Archive
{
_a_version
=
newArchive
^.
a_version
insertArchive
List
c
nodeId
$
Archive
{
_a_version
=
newArchive
^.
a_version
,
_a_history
=
[]
,
_a_history
=
[]
,
_a_state
=
archiveStateFromList
inserts
}
,
_a_state
=
archiveStateFromList
inserts
}
printDebug
"[updateNodeStory] insert applied"
()
-- TODO Use currentArchive ^. a_version in delete and report error
-- TODO Use currentArchive ^. a_version in delete and report error
-- if entries with (node_id, ngrams_type_id, ngrams_id) but
-- if entries with (node_id, ngrams_type_id, ngrams_id) but
-- different version are found.
-- different version are found.
deleteArchive
c
nodeId
$
Archive
{
_a_version
=
newArchive
^.
a_version
deleteArchive
List
c
nodeId
$
Archive
{
_a_version
=
newArchive
^.
a_version
,
_a_history
=
[]
,
_a_history
=
[]
,
_a_state
=
archiveStateFromList
deletes
}
,
_a_state
=
archiveStateFromList
deletes
}
updateArchive
c
nodeId
$
Archive
{
_a_version
=
newArchive
^.
a_version
printDebug
"[updateNodeStory] delete applied"
()
updateArchiveList
c
nodeId
$
Archive
{
_a_version
=
newArchive
^.
a_version
,
_a_history
=
[]
,
_a_history
=
[]
,
_a_state
=
archiveStateFromList
updates
}
,
_a_state
=
archiveStateFromList
updates
}
printDebug
"[updateNodeStory] update applied"
()
-- NOTE: It is assumed that the most recent change is the first in the
-- list, so we save these in reverse order
insertNodeArchiveHistory
c
nodeId
$
reverse
$
newArchive
^.
a_history
pure
()
pure
()
-- where
-- where
-- update = Update { uTable = nodeStoryTable
-- update = Update { uTable = nodeStoryTable
...
@@ -519,8 +541,15 @@ updateNodeStory c nodeId@(NodeId _nId) currentArchive newArchive = do
...
@@ -519,8 +541,15 @@ updateNodeStory c nodeId@(NodeId _nId) currentArchive newArchive = do
upsertNodeStories
::
PGS
.
Connection
->
NodeId
->
ArchiveList
->
IO
()
upsertNodeStories
::
PGS
.
Connection
->
NodeId
->
ArchiveList
->
IO
()
upsertNodeStories
c
nodeId
@
(
NodeId
nId
)
newArchive
=
do
upsertNodeStories
c
nodeId
@
(
NodeId
nId
)
newArchive
=
do
printDebug
"[upsertNodeStories] START nId"
nId
printDebug
"[upsertNodeStories] START nId"
nId
PGS
.
begin
c
PGS
.
withTransaction
c
$
do
--runPGSAdvisoryXactLock c nId
printDebug
"[upsertNodeStories] locking nId"
nId
runPGSAdvisoryXactLock
c
nId
-- whether it's insert or update, we can insert node archive history already
-- NOTE: It is assumed that the most recent change is the first in the
-- list, so we save these in reverse order
insertNodeArchiveHistory
c
nodeId
$
reverse
$
newArchive
^.
a_history
(
NodeStory
m
)
<-
getNodeStory
c
nodeId
(
NodeStory
m
)
<-
getNodeStory
c
nodeId
case
Map
.
lookup
nodeId
m
of
case
Map
.
lookup
nodeId
m
of
Nothing
->
do
Nothing
->
do
...
@@ -529,7 +558,7 @@ upsertNodeStories c nodeId@(NodeId nId) newArchive = do
...
@@ -529,7 +558,7 @@ upsertNodeStories c nodeId@(NodeId nId) newArchive = do
Just
currentArchive
->
do
Just
currentArchive
->
do
_
<-
updateNodeStory
c
nodeId
currentArchive
newArchive
_
<-
updateNodeStory
c
nodeId
currentArchive
newArchive
pure
()
pure
()
PGS
.
commit
c
printDebug
"[upsertNodeStories] STOP nId"
nId
printDebug
"[upsertNodeStories] STOP nId"
nId
writeNodeStories
::
PGS
.
Connection
->
NodeListStory
->
IO
()
writeNodeStories
::
PGS
.
Connection
->
NodeListStory
->
IO
()
...
@@ -595,12 +624,15 @@ mkNodeStorySaver pool mvns = mkDebounce settings
...
@@ -595,12 +624,15 @@ mkNodeStorySaver pool mvns = mkDebounce settings
where
where
settings
=
defaultDebounceSettings
settings
=
defaultDebounceSettings
{
debounceAction
=
do
{
debounceAction
=
do
-- NOTE: Lock MVar first, then use resource pool.
-- Otherwise we could wait for MVar, while
-- blocking the pool connection.
modifyMVar_
mvns
$
\
ns
->
do
withResource
pool
$
\
c
->
do
withResource
pool
$
\
c
->
do
withMVar
mvns
$
\
ns
->
do
--printDebug "[mkNodeStorySaver] will call writeNodeStories, ns" ns
--printDebug "[mkNodeStorySaver] will call writeNodeStories, ns" ns
writeNodeStories
c
ns
writeNodeStories
c
ns
withMVar
mvns
(
\
ns
->
printDebug
"[mkNodeStorySaver] debounce nodestory"
ns
)
pure
$
clearHistory
ns
modifyMVar_
mvns
$
\
ns
->
pure
$
clearHistory
ns
--withMVar mvns (\ns -> printDebug "[mkNodeStorySaver] debounce nodestory" ns)
,
debounceFreq
=
1
*
minute
,
debounceFreq
=
1
*
minute
}
}
minute
=
60
*
second
minute
=
60
*
second
...
...
src/Gargantext/Database/Admin/Types/Node.hs
View file @
91a2d6e2
...
@@ -211,14 +211,6 @@ pgContextId = pgNodeId
...
@@ -211,14 +211,6 @@ pgContextId = pgNodeId
------------------------------------------------------------------------
------------------------------------------------------------------------
newtype
NodeId
=
NodeId
Int
newtype
NodeId
=
NodeId
Int
deriving
(
Read
,
Generic
,
Num
,
Eq
,
Ord
,
Enum
,
ToJSONKey
,
FromJSONKey
,
ToJSON
,
FromJSON
,
Hashable
,
Csv
.
ToField
)
deriving
(
Read
,
Generic
,
Num
,
Eq
,
Ord
,
Enum
,
ToJSONKey
,
FromJSONKey
,
ToJSON
,
FromJSON
,
Hashable
,
Csv
.
ToField
)
-- TODO make another type
type
ContextId
=
NodeId
newtype
NodeContextId
=
NodeContextId
Int
deriving
(
Read
,
Generic
,
Num
,
Eq
,
Ord
,
Enum
,
ToJSONKey
,
FromJSONKey
,
ToJSON
,
FromJSON
,
Hashable
,
Csv
.
ToField
)
instance
GQLType
NodeId
instance
GQLType
NodeId
instance
Show
NodeId
where
instance
Show
NodeId
where
show
(
NodeId
n
)
=
"nodeId-"
<>
show
n
show
(
NodeId
n
)
=
"nodeId-"
<>
show
n
...
@@ -232,6 +224,14 @@ instance FromField NodeId where
...
@@ -232,6 +224,14 @@ instance FromField NodeId where
then
return
$
NodeId
n
then
return
$
NodeId
n
else
mzero
else
mzero
instance
ToSchema
NodeId
instance
ToSchema
NodeId
-- TODO make another type
type
ContextId
=
NodeId
newtype
NodeContextId
=
NodeContextId
Int
deriving
(
Read
,
Generic
,
Num
,
Eq
,
Ord
,
Enum
,
ToJSONKey
,
FromJSONKey
,
ToJSON
,
FromJSON
,
Hashable
,
Csv
.
ToField
)
--instance Csv.ToField NodeId where
--instance Csv.ToField NodeId where
-- toField (NodeId nodeId) = Csv.toField nodeId
-- toField (NodeId nodeId) = Csv.toField nodeId
...
...
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