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
195
Issues
195
List
Board
Labels
Milestones
Merge Requests
12
Merge Requests
12
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
d16dd1e7
Verified
Commit
d16dd1e7
authored
Oct 10, 2023
by
Przemyslaw Kaminski
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[refactor] more typeclass refactorings
FlowCmdM -> DBCmd or HasNodeStory is usually enough
parent
8d3f7def
Pipeline
#5232
failed with stages
in 130 minutes and 25 seconds
Changes
12
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
Showing
12 changed files
with
208 additions
and
226 deletions
+208
-226
Metrics.hs
src/Gargantext/API/Metrics.hs
+83
-83
Ngrams.hs
src/Gargantext/API/Ngrams.hs
+1
-4
Update.hs
src/Gargantext/API/Node/Update.hs
+13
-17
API.hs
src/Gargantext/Core/Viz/Graph/API.hs
+11
-12
Tools.hs
src/Gargantext/Core/Viz/Phylo/API/Tools.hs
+17
-19
Flow.hs
src/Gargantext/Database/Action/Flow.hs
+1
-1
Pairing.hs
src/Gargantext/Database/Action/Flow/Pairing.hs
+11
-7
Metrics.hs
src/Gargantext/Database/Action/Metrics.hs
+17
-28
Lists.hs
src/Gargantext/Database/Action/Metrics/Lists.hs
+24
-24
Node.hs
src/Gargantext/Database/Query/Table/Node.hs
+18
-19
Children.hs
src/Gargantext/Database/Query/Table/Node/Children.hs
+11
-11
NodeContext_NodeContext.hs
...argantext/Database/Query/Table/NodeContext_NodeContext.hs
+1
-1
No files found.
src/Gargantext/API/Metrics.hs
View file @
d16dd1e7
...
...
@@ -26,6 +26,7 @@ import Gargantext.API.HashedResponse
import
Gargantext.API.Ngrams.NgramsTree
import
Gargantext.API.Ngrams.Types
import
Gargantext.API.Prelude
(
GargServer
)
import
Gargantext.Core.NodeStory
(
HasNodeStory
)
import
Gargantext.Core.Text.Metrics
(
Scored
(
..
),
{-normalizeGlobal,-}
normalizeLocal
)
import
Gargantext.Core.Types
(
CorpusId
,
ListId
,
ListType
(
..
))
import
Gargantext.Core.Types.Query
(
Limit
)
...
...
@@ -34,7 +35,6 @@ import Gargantext.Core.Viz.Types
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataList
(
..
),
hl_chart
,
hl_pie
,
hl_scatter
,
hl_tree
)
import
Gargantext.Database.Admin.Types.Metrics
(
ChartMetrics
(
..
),
Metric
(
..
),
Metrics
(
..
))
import
Gargantext.Database.Admin.Types.Node
(
NodeId
)
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Query.Table.Node
(
defaultList
,
getNodeWith
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
...
...
@@ -67,12 +67,12 @@ scatterApi id' = getScatter id'
:<|>
updateScatter
id'
:<|>
getScatterHash
id'
getScatter
::
FlowCmdM
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
Maybe
Limit
->
m
(
HashedResponse
Metrics
)
getScatter
::
HasNodeStory
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
Maybe
Limit
->
m
(
HashedResponse
Metrics
)
getScatter
cId
maybeListId
tabType
_maybeLimit
=
do
listId
<-
case
maybeListId
of
Just
lid
->
pure
lid
...
...
@@ -84,32 +84,35 @@ getScatter cId maybeListId tabType _maybeLimit = do
chart
<-
case
mChart
of
Just
chart
->
pure
chart
Nothing
->
do
updateScatter'
cId
maybeL
istId
tabType
Nothing
updateScatter'
cId
l
istId
tabType
Nothing
pure
$
constructHashedResponse
chart
updateScatter
::
FlowCmdM
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
Maybe
Limit
->
m
()
updateScatter
::
HasNodeStory
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
Maybe
Limit
->
m
()
updateScatter
cId
maybeListId
tabType
maybeLimit
=
do
listId
<-
case
maybeListId
of
Just
lid
->
pure
lid
Nothing
->
defaultList
cId
-- printDebug "[updateScatter] cId" cId
-- printDebug "[updateScatter] maybeListId" maybeListId
-- printDebug "[updateScatter] tabType" tabType
-- printDebug "[updateScatter] maybeLimit" maybeLimit
_
<-
updateScatter'
cId
maybeL
istId
tabType
maybeLimit
_
<-
updateScatter'
cId
l
istId
tabType
maybeLimit
pure
()
updateScatter'
::
FlowCmdM
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
Maybe
Limit
->
m
Metrics
updateScatter'
cId
maybeL
istId
tabType
maybeLimit
=
do
(
ngs'
,
scores
)
<-
Metrics
.
getMetrics
cId
maybeL
istId
tabType
maybeLimit
updateScatter'
::
HasNodeStory
env
err
m
=>
CorpusId
->
ListId
->
TabType
->
Maybe
Limit
->
m
Metrics
updateScatter'
cId
l
istId
tabType
maybeLimit
=
do
(
ngs'
,
scores
)
<-
Metrics
.
getMetrics
cId
l
istId
tabType
maybeLimit
let
metrics
=
fmap
(
\
(
Scored
t
s1
s2
)
->
Metric
{
m_label
=
unNgramsTerm
t
...
...
@@ -120,9 +123,6 @@ updateScatter' cId maybeListId tabType maybeLimit = do
listType
t
m
=
maybe
(
panic
errorMsg
)
fst
$
HashMap
.
lookup
t
m
errorMsg
=
"API.Node.metrics: key absent"
listId
<-
case
maybeListId
of
Just
lid
->
pure
lid
Nothing
->
defaultList
cId
node
<-
getNodeWith
listId
(
Proxy
::
Proxy
HyperdataList
)
let
hl
=
node
^.
node_hyperdata
scatterMap
=
hl
^.
hl_scatter
...
...
@@ -130,11 +130,11 @@ updateScatter' cId maybeListId tabType maybeLimit = do
pure
$
Metrics
metrics
getScatterHash
::
FlowCmdM
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
m
Text
getScatterHash
::
HasNodeStory
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
m
Text
getScatterHash
cId
maybeListId
tabType
=
do
hash
<$>
getScatter
cId
maybeListId
tabType
Nothing
...
...
@@ -163,8 +163,8 @@ chartApi id' = getChart id'
:<|>
getChartHash
id'
-- TODO add start / end
getChart
::
FlowCmdM
env
err
m
=>
CorpusId
getChart
::
HasNodeStory
env
err
m
=>
CorpusId
->
Maybe
UTCTime
->
Maybe
UTCTime
->
Maybe
ListId
...
...
@@ -181,7 +181,7 @@ getChart cId _start _end maybeListId tabType = do
chart
<-
case
mChart
of
Just
chart
->
pure
chart
Nothing
->
do
updateChart'
cId
maybeL
istId
tabType
Nothing
updateChart'
cId
l
istId
tabType
Nothing
pure
$
constructHashedResponse
chart
...
...
@@ -192,23 +192,23 @@ updateChart :: HasNodeError err =>
->
Maybe
Limit
->
DBCmd
err
()
updateChart
cId
maybeListId
tabType
maybeLimit
=
do
listId
<-
case
maybeListId
of
Just
lid
->
pure
lid
Nothing
->
defaultList
cId
printDebug
"[updateChart] cId"
cId
printDebug
"[updateChart]
maybeListId"
maybeL
istId
printDebug
"[updateChart]
listId"
l
istId
printDebug
"[updateChart] tabType"
tabType
printDebug
"[updateChart] maybeLimit"
maybeLimit
_
<-
updateChart'
cId
maybeL
istId
tabType
maybeLimit
_
<-
updateChart'
cId
l
istId
tabType
maybeLimit
pure
()
updateChart'
::
HasNodeError
err
=>
CorpusId
->
Maybe
ListId
->
ListId
->
TabType
->
Maybe
Limit
->
DBCmd
err
(
ChartMetrics
Histo
)
updateChart'
cId
maybeListId
tabType
_maybeLimit
=
do
listId
<-
case
maybeListId
of
Just
lid
->
pure
lid
Nothing
->
defaultList
cId
updateChart'
cId
listId
tabType
_maybeLimit
=
do
node
<-
getNodeWith
listId
(
Proxy
::
Proxy
HyperdataList
)
let
hl
=
node
^.
node_hyperdata
chartMap
=
hl
^.
hl_chart
...
...
@@ -218,11 +218,11 @@ updateChart' cId maybeListId tabType _maybeLimit = do
pure
$
ChartMetrics
h
getChartHash
::
FlowCmdM
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
m
Text
getChartHash
::
HasNodeStory
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
m
Text
getChartHash
cId
maybeListId
tabType
=
do
hash
<$>
getChart
cId
Nothing
Nothing
maybeListId
tabType
...
...
@@ -249,7 +249,7 @@ pieApi id' = getPie id'
:<|>
updatePie
id'
:<|>
getPieHash
id'
getPie
::
FlowCmdM
env
err
m
getPie
::
HasNodeStory
env
err
m
=>
CorpusId
->
Maybe
UTCTime
->
Maybe
UTCTime
...
...
@@ -271,12 +271,12 @@ getPie cId _start _end maybeListId tabType = do
pure
$
constructHashedResponse
chart
updatePie
::
FlowCmdM
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
Maybe
Limit
->
m
()
updatePie
::
HasNodeStory
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
Maybe
Limit
->
m
()
updatePie
cId
maybeListId
tabType
maybeLimit
=
do
printDebug
"[updatePie] cId"
cId
printDebug
"[updatePie] maybeListId"
maybeListId
...
...
@@ -285,12 +285,12 @@ updatePie cId maybeListId tabType maybeLimit = do
_
<-
updatePie'
cId
maybeListId
tabType
maybeLimit
pure
()
updatePie'
::
FlowCmdM
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
Maybe
Limit
->
m
(
ChartMetrics
Histo
)
updatePie'
::
(
HasNodeStory
env
err
m
,
HasNodeError
err
)
=>
CorpusId
->
Maybe
ListId
->
TabType
->
Maybe
Limit
->
m
(
ChartMetrics
Histo
)
updatePie'
cId
maybeListId
tabType
_maybeLimit
=
do
listId
<-
case
maybeListId
of
Just
lid
->
pure
lid
...
...
@@ -304,11 +304,11 @@ updatePie' cId maybeListId tabType _maybeLimit = do
pure
$
ChartMetrics
p
getPieHash
::
FlowCmdM
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
m
Text
getPieHash
::
HasNodeStory
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
m
Text
getPieHash
cId
maybeListId
tabType
=
do
hash
<$>
getPie
cId
Nothing
Nothing
maybeListId
tabType
...
...
@@ -338,7 +338,7 @@ treeApi id' = getTree id'
:<|>
updateTree
id'
:<|>
getTreeHash
id'
getTree
::
FlowCmdM
env
err
m
getTree
::
HasNodeStory
env
err
m
=>
CorpusId
->
Maybe
UTCTime
->
Maybe
UTCTime
...
...
@@ -362,12 +362,12 @@ getTree cId _start _end maybeListId tabType listType = do
pure
$
constructHashedResponse
chart
updateTree
::
FlowCmdM
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
ListType
->
m
()
updateTree
::
HasNodeStory
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
ListType
->
m
()
updateTree
cId
maybeListId
tabType
listType
=
do
printDebug
"[updateTree] cId"
cId
printDebug
"[updateTree] maybeListId"
maybeListId
...
...
@@ -376,12 +376,12 @@ updateTree cId maybeListId tabType listType = do
_
<-
updateTree'
cId
maybeListId
tabType
listType
pure
()
updateTree'
::
FlowCmdM
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
ListType
->
m
(
ChartMetrics
(
Vector
NgramsTree
))
updateTree'
::
HasNodeStory
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
ListType
->
m
(
ChartMetrics
(
Vector
NgramsTree
))
updateTree'
cId
maybeListId
tabType
listType
=
do
listId
<-
case
maybeListId
of
Just
lid
->
pure
lid
...
...
@@ -395,11 +395,11 @@ updateTree' cId maybeListId tabType listType = do
pure
$
ChartMetrics
t
getTreeHash
::
FlowCmdM
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
ListType
->
m
Text
getTreeHash
::
HasNodeStory
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
ListType
->
m
Text
getTreeHash
cId
maybeListId
tabType
listType
=
do
hash
<$>
getTree
cId
Nothing
Nothing
maybeListId
tabType
listType
src/Gargantext/API/Ngrams.hs
View file @
d16dd1e7
...
...
@@ -108,7 +108,6 @@ import Gargantext.Core.NodeStory
import
Gargantext.Core.Types
(
ListType
(
..
),
NodeId
,
ListId
,
DocId
,
TODO
,
assertValid
,
HasInvalidError
,
ContextId
)
import
Gargantext.Core.Types.Query
(
Limit
(
..
),
Offset
(
..
),
MinSize
(
..
),
MaxSize
(
..
))
import
Gargantext.API.Ngrams.Tools
import
Gargantext.Database.Action.Flow.Types
import
Gargantext.Database.Action.Metrics.NgramsByContext
(
getOccByNgramsOnlyFast
)
import
Gargantext.Database.Admin.Config
(
userMaster
)
import
Gargantext.Database.Admin.Types.Node
(
NodeType
(
..
))
...
...
@@ -418,8 +417,6 @@ tableNgramsPut tabType listId (Versioned p_version p_table)
tableNgramsPostChartsAsync
::
(
HasNodeStory
env
err
m
,
FlowCmdM
env
err
m
,
HasNodeError
err
,
HasSettings
env
,
MonadJobStatus
m
)
...
...
@@ -471,7 +468,7 @@ tableNgramsPostChartsAsync utn jobHandle = do
-- printDebug "[tableNgramsPostChartsAsync] Terms, updating Metrics (Histo), cId" cId
markStarted
6
jobHandle
{-
_ <- Metrics.updateChart cId
(Just listId)
tabType Nothing
_ <- Metrics.updateChart cId
listId
tabType Nothing
logRefSuccess
_ <- Metrics.updatePie cId (Just listId) tabType Nothing
logRefSuccess
...
...
src/Gargantext/API/Node/Update.hs
View file @
d16dd1e7
...
...
@@ -16,16 +16,17 @@ Portability : POSIX
module
Gargantext.API.Node.Update
where
--import Gargantext.Core.Types.Individu (User(..))
import
Control.Lens
(
view
)
import
Data.Aeson
import
Data.Maybe
(
Maybe
(
..
),
fromMaybe
)
import
Data.Set
qualified
as
Set
import
Data.Swagger
import
GHC.Generics
(
Generic
)
import
Gargantext.API.Admin.EnvTypes
(
GargJob
(
..
),
Env
)
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
(
..
),
AsyncJobs
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
--import Gargantext.API.Ngrams.Types (TabType(..))
import
Gargantext.API.Metrics
qualified
as
Metrics
import
Gargantext.API.Ngrams.Types
qualified
as
NgramsTypes
import
Gargantext.API.Prelude
(
GargM
,
GargError
,
simuLogs
)
import
Gargantext.Core.Methods.Similarities
(
GraphMetric
(
..
))
import
Gargantext.Core.NodeStory
(
HasNodeStory
)
...
...
@@ -35,10 +36,8 @@ import Gargantext.Core.Viz.Graph.Tools (PartitionMethod(..), BridgenessMethod(..
import
Gargantext.Core.Viz.Graph.Types
(
Strength
)
import
Gargantext.Core.Viz.Phylo
(
PhyloSubConfigAPI
(
..
),
subConfigAPI2config
)
import
Gargantext.Core.Viz.Phylo.API.Tools
(
flowPhyloAPI
)
-- import Gargantext.Database.Action.Mail (sendMail)
import
Gargantext.Database.Action.Flow
(
reIndexWith
)
import
Gargantext.Database.Action.Flow.Pairing
(
pairing
)
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
import
Gargantext.Database.Action.Metrics
(
updateNgramsOccurrences
,
updateContextScore
)
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Node
...
...
@@ -47,15 +46,12 @@ import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import
Gargantext.Database.Schema.Ngrams
(
NgramsType
(
NgramsTerms
))
import
Gargantext.Database.Schema.Node
(
node_parent_id
)
import
Gargantext.Prelude
(
Bool
(
..
),
Ord
,
Eq
,
(
<$>
),
(
$
),
{-printDebug,-}
pure
,
show
,
cs
,
(
<>
),
panic
,
(
<*>
))
import
Gargantext.Utils.Aeson
qualified
as
GUA
import
Gargantext.Utils.Jobs
(
serveJobsAPI
,
MonadJobStatus
(
..
))
import
Prelude
(
Enum
,
Bounded
,
minBound
,
maxBound
)
import
Servant
import
Test.QuickCheck
(
elements
)
import
Test.QuickCheck.Arbitrary
import
qualified
Data.Set
as
Set
import
qualified
Gargantext.API.Metrics
as
Metrics
import
qualified
Gargantext.API.Ngrams.Types
as
NgramsTypes
import
qualified
Gargantext.Utils.Aeson
as
GUA
------------------------------------------------------------------------
type
API
=
Summary
" Update node according to NodeType params"
...
...
@@ -100,12 +96,12 @@ api uId nId =
serveJobsAPI
UpdateNodeJob
$
\
jHandle
p
->
updateNode
uId
nId
p
jHandle
updateNode
::
(
Has
Settings
env
,
FlowCmdM
env
err
m
,
MonadJobStatus
m
)
=>
UserId
->
NodeId
->
UpdateNodeParams
->
JobHandle
m
->
m
()
updateNode
::
(
Has
NodeStory
env
err
m
,
HasSettings
env
,
MonadJobStatus
m
)
=>
UserId
->
NodeId
->
UpdateNodeParams
->
JobHandle
m
->
m
()
updateNode
uId
nId
(
UpdateNodeParamsGraph
metric
partitionMethod
bridgeMethod
strength
nt1
nt2
)
jobHandle
=
do
markStarted
2
jobHandle
...
...
@@ -150,7 +146,7 @@ updateNode _uId lId (UpdateNodeParamsList _mode) jobHandle = do
_
<-
case
corpusId
of
Just
cId
->
do
_
<-
reIndexWith
cId
lId
NgramsTerms
(
Set
.
singleton
MapTerm
)
_
<-
updateNgramsOccurrences
cId
(
Just
lId
)
_
<-
updateNgramsOccurrences
cId
lId
pure
()
Nothing
->
pure
()
...
...
@@ -202,9 +198,9 @@ updateDocs :: (HasNodeStory env err m)
updateDocs
cId
=
do
lId
<-
defaultList
cId
_
<-
reIndexWith
cId
lId
NgramsTerms
(
Set
.
singleton
MapTerm
)
_
<-
updateNgramsOccurrences
cId
(
Just
lId
)
_
<-
updateNgramsOccurrences
cId
lId
_
<-
updateContextScore
cId
lId
_
<-
Metrics
.
updateChart
cId
(
Just
lId
)
NgramsTypes
.
Docs
Nothing
_
<-
Metrics
.
updateChart
'
cId
lId
NgramsTypes
.
Docs
Nothing
-- printDebug "updateContextsScore" (cId, lId, u)
pure
()
...
...
src/Gargantext/Core/Viz/Graph/API.hs
View file @
d16dd1e7
...
...
@@ -34,11 +34,10 @@ import Gargantext.Core.Viz.Graph.GEXF ()
import
Gargantext.Core.Viz.Graph.Tools
-- (cooc2graph)
import
Gargantext.Core.Viz.Graph.Types
import
Gargantext.Database.Action.Metrics.NgramsByContext
(
getContextsByNgramsOnlyUser
)
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
import
Gargantext.Database.Action.Node
(
mkNodeWithParent
)
import
Gargantext.Database.Admin.Config
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Prelude
(
Cmd
)
import
Gargantext.Database.Prelude
(
DB
Cmd
)
import
Gargantext.Database.Query.Table.Node
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Table.Node.Select
...
...
@@ -83,8 +82,8 @@ graphAPI u n = getGraph u n
------------------------------------------------------------------------
--getGraph :: UserId -> NodeId -> GargServer HyperdataGraphAPI
getGraph
::
FlowCmdM
env
err
m
=>
UserId
getGraph
::
HasNodeStory
env
err
m
=>
UserId
->
NodeId
->
m
HyperdataGraphAPI
getGraph
_uId
nId
=
do
...
...
@@ -122,7 +121,7 @@ getGraph _uId nId = do
--recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
recomputeGraph
::
FlowCmdM
env
err
m
recomputeGraph
::
HasNodeStory
env
err
m
=>
UserId
->
NodeId
->
PartitionMethod
...
...
@@ -179,7 +178,7 @@ recomputeGraph _uId nId partitionMethod bridgeMethod maybeSimilarity maybeStreng
-- TODO remove repo
computeGraph
::
FlowCmdM
env
err
m
computeGraph
::
HasNodeError
err
=>
CorpusId
->
PartitionMethod
->
BridgenessMethod
...
...
@@ -187,7 +186,7 @@ computeGraph :: FlowCmdM env err m
->
Strength
->
(
NgramsType
,
NgramsType
)
->
NodeListStory
->
m
Graph
->
DBCmd
err
Graph
computeGraph
corpusId
partitionMethod
bridgeMethod
similarity
strength
(
nt1
,
nt2
)
repo
=
do
-- Getting the Node parameters
lId
<-
defaultList
corpusId
...
...
@@ -230,7 +229,7 @@ defaultGraphMetadata :: HasNodeError err
->
NodeListStory
->
GraphMetric
->
Strength
->
Cmd
err
GraphMetadata
->
DB
Cmd
err
GraphMetadata
defaultGraphMetadata
cId
t
repo
gm
str
=
do
lId
<-
defaultList
cId
...
...
@@ -265,7 +264,7 @@ graphAsync u n =
-- -> (JobLog -> GargNoServer ())
-- -> GargNoServer JobLog
-- TODO get Graph Metadata to recompute
graphRecompute
::
(
FlowCmdM
env
err
m
,
MonadJobStatus
m
)
graphRecompute
::
(
HasNodeStory
env
err
m
,
MonadJobStatus
m
)
=>
UserId
->
NodeId
->
JobHandle
m
...
...
@@ -319,7 +318,7 @@ graphVersions n nId = do
,
gv_repo
=
v
}
--recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
recomputeVersions
::
FlowCmdM
env
err
m
recomputeVersions
::
HasNodeStory
env
err
m
=>
UserId
->
NodeId
->
m
Graph
...
...
@@ -351,8 +350,8 @@ graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
--getGraphGexf :: UserId
-- -> NodeId
-- -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
getGraphGexf
::
FlowCmdM
env
err
m
=>
UserId
getGraphGexf
::
HasNodeStory
env
err
m
=>
UserId
->
NodeId
->
m
(
Headers
'[
S
ervant
.
Header
"Content-Disposition"
Text
]
Graph
)
getGraphGexf
uId
nId
=
do
...
...
src/Gargantext/Core/Viz/Phylo/API/Tools.hs
View file @
d16dd1e7
...
...
@@ -16,35 +16,33 @@ module Gargantext.Core.Viz.Phylo.API.Tools
import
Control.Lens
hiding
(
Context
)
import
Data.Aeson
(
Value
,
decodeFileStrict
,
eitherDecode
,
encode
)
import
Data.ByteString.Lazy
qualified
as
Lazy
import
Data.Map.Strict
(
Map
)
import
Data.
Proxy
import
Data.
Map.Strict
qualified
as
Map
import
Data.Maybe
(
fromMaybe
)
import
Data.Proxy
import
Data.Set
(
Set
)
import
Data.Set
qualified
as
Set
import
Data.Text
(
Text
,
pack
)
import
Data.Time.Calendar
(
fromGregorian
,
diffGregorianDurationClip
,
cdMonths
,
diffDays
,
showGregorian
)
import
Data.Time.Clock.POSIX
(
posixSecondsToUTCTime
)
import
Gargantext.API.Ngrams.Prelude
(
getTermList
)
import
Gargantext.API.Ngrams.Types
(
NgramsTerm
(
..
))
import
Gargantext.API.Prelude
(
GargNoServer
)
import
Gargantext.Core.Text.Terms.WithList
(
Patterns
,
buildPatterns
,
termsInText
)
import
Gargantext.Core
(
withDefaultLanguage
,
Lang
)
import
Gargantext.Core.NodeStory
(
HasNodeStory
)
import
Gargantext.Core.Text.Terms.WithList
(
Patterns
,
buildPatterns
,
termsInText
)
import
Gargantext.Core.Types
(
Context
)
-- import Gargantext.Core.Types.Individu (User(..))
import
Gargantext.Core.Types.Main
(
ListType
(
MapTerm
))
import
Gargantext.Core.Viz.Phylo
(
TimeUnit
(
..
),
Date
,
Document
(
..
),
PhyloConfig
(
..
),
Phylo
)
import
Gargantext.Core.Viz.Phylo.PhyloExport
(
toPhyloExport
,
dotToFile
)
import
Gargantext.Core.Viz.Phylo.PhyloMaker
(
toPhylo
,
toPhyloWithoutLink
)
import
Gargantext.Core.Viz.Phylo.PhyloTools
(
{-printIOMsg, printIOComment,-}
setConfig
)
-- import Gargantext.Database.Action.Flow (getOrMk_RootWithCorpus)
-- import Gargantext.Database.Admin.Config (userMaster)
-- import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
-- import Gargantext.Database.Action.Flow (getOrMk_RootWithCorpus)
-- import Gargantext.Database.Admin.Config (userMaster)
-- import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataPhylo
(
..
),
HyperdataCorpus
(
..
))
import
Gargantext.Database.Admin.Types.Hyperdata.Document
(
HyperdataDocument
(
..
))
import
Gargantext.Database.Admin.Types.Node
(
CorpusId
,
ContextId
,
PhyloId
)
import
Gargantext.Database.Prelude
(
DBCmd
)
import
Gargantext.Database.Query.Table.Node
(
defaultList
,
getNodeWith
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Table.NodeContext
(
selectDocNodes
)
import
Gargantext.Database.Schema.Context
import
Gargantext.Database.Schema.Ngrams
(
NgramsType
(
..
))
...
...
@@ -53,21 +51,19 @@ import Gargantext.Prelude
import
Prelude
hiding
(
map
)
import
System.FilePath
((
</>
))
import
System.IO.Temp
(
withTempDirectory
)
import
System.Process
as
Shell
import
qualified
Data.ByteString.Lazy
as
Lazy
import
qualified
Data.Map.Strict
as
Map
import
qualified
Data.Set
as
Set
import
System.Process
qualified
as
Shell
--------------------------------------------------------------------
getPhyloData
::
PhyloId
->
GargNoServer
(
Maybe
Phylo
)
getPhyloData
::
HasNodeError
err
=>
PhyloId
->
DBCmd
err
(
Maybe
Phylo
)
getPhyloData
phyloId
=
do
nodePhylo
<-
getNodeWith
phyloId
(
Proxy
::
Proxy
HyperdataPhylo
)
pure
$
_hp_data
$
_node_hyperdata
nodePhylo
putPhylo
::
PhyloId
->
GargNoServe
r
Phylo
putPhylo
::
PhyloId
->
DBCmd
er
r
Phylo
putPhylo
=
undefined
savePhylo
::
PhyloId
->
GargNoServe
r
()
savePhylo
::
PhyloId
->
DBCmd
er
r
()
savePhylo
=
undefined
--------------------------------------------------------------------
...
...
@@ -93,7 +89,8 @@ phylo2dot2json phylo = do
Just
v
->
pure
v
flowPhyloAPI
::
PhyloConfig
->
CorpusId
->
GargNoServer
Phylo
flowPhyloAPI
::
(
HasNodeStory
env
err
m
,
HasNodeError
err
)
=>
PhyloConfig
->
CorpusId
->
m
Phylo
flowPhyloAPI
config
cId
=
do
corpus
<-
corpusIdtoDocuments
(
timeUnit
config
)
cId
let
phyloWithCliques
=
toPhyloWithoutLink
corpus
config
...
...
@@ -103,7 +100,8 @@ flowPhyloAPI config cId = do
pure
$
toPhylo
$
setConfig
config
phyloWithCliques
--------------------------------------------------------------------
corpusIdtoDocuments
::
TimeUnit
->
CorpusId
->
GargNoServer
[
Document
]
corpusIdtoDocuments
::
(
HasNodeStory
env
err
m
,
HasNodeError
err
)
=>
TimeUnit
->
CorpusId
->
m
[
Document
]
corpusIdtoDocuments
timeUnit
corpusId
=
do
docs
<-
selectDocNodes
corpusId
lId
<-
defaultList
corpusId
...
...
src/Gargantext/Database/Action/Flow.hs
View file @
d16dd1e7
...
...
@@ -385,7 +385,7 @@ flowCorpusUser l user userCorpusId listId ctype mfslw = do
-- _ <- mkAnnuaire rootUserId userId
_
<-
reIndexWith
userCorpusId
listId
NgramsTerms
(
Set
.
singleton
MapTerm
)
_
<-
updateContextScore
userCorpusId
listId
_
<-
updateNgramsOccurrences
userCorpusId
(
Just
listId
)
_
<-
updateNgramsOccurrences
userCorpusId
listId
pure
userCorpusId
...
...
src/Gargantext/Database/Action/Flow/Pairing.hs
View file @
d16dd1e7
...
...
@@ -25,8 +25,8 @@ import Data.Set (Set)
import
Data.Text
(
Text
)
import
Gargantext.API.Ngrams.Tools
import
Gargantext.API.Ngrams.Types
(
NgramsTerm
(
..
))
import
Gargantext.API.Prelude
(
GargNoServer
)
import
Gargantext.Core
import
Gargantext.Core.NodeStory
(
HasNodeStory
)
import
Gargantext.Core.Text.Metrics.CharByChar
(
levenshtein
)
import
Gargantext.Core.Types
(
TableResult
(
..
))
import
Gargantext.Core.Types.Main
...
...
@@ -38,6 +38,7 @@ import Gargantext.Database.Admin.Types.Node -- (AnnuaireId, CorpusId, ListId, Do
import
Gargantext.Database.Query.Prelude
(
returnA
,
queryNodeNodeTable
)
import
Gargantext.Database.Query.Table.Node
(
defaultList
)
import
Gargantext.Database.Query.Table.Node.Children
(
getAllContacts
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Table.Node.Select
(
selectNodesWithUsername
)
import
Gargantext.Database.Query.Table.NodeContext_NodeContext
(
insertNodeContext_NodeContext
)
import
Gargantext.Database.Query.Table.NodeNode
(
insertNodeNode
)
...
...
@@ -68,7 +69,8 @@ isPairedWith nId nt = runOpaQuery (selectQuery nt nId)
returnA
-<
node
^.
node_id
-----------------------------------------------------------------------
pairing
::
AnnuaireId
->
CorpusId
->
Maybe
ListId
->
GargNoServer
[
Int
]
pairing
::
(
HasNodeStory
env
err
m
,
HasNodeError
err
)
=>
AnnuaireId
->
CorpusId
->
Maybe
ListId
->
m
[
Int
]
pairing
a
c
l'
=
do
l
<-
case
l'
of
Nothing
->
defaultList
c
...
...
@@ -78,9 +80,10 @@ pairing a c l' = do
insertNodeContext_NodeContext
$
prepareInsert
c
a
dataPaired
dataPairing
::
AnnuaireId
dataPairing
::
HasNodeStory
env
err
m
=>
AnnuaireId
->
(
CorpusId
,
ListId
,
NgramsType
)
->
GargNoServer
(
HashMap
ContactId
(
Set
DocId
))
->
m
(
HashMap
ContactId
(
Set
DocId
))
dataPairing
aId
(
cId
,
lId
,
ngt
)
=
do
-- mc :: HM.HashMap ContactName (Set ContactId)
mc
<-
getNgramsContactId
aId
...
...
@@ -164,7 +167,7 @@ getClosest f (NgramsTerm from) candidates = fst <$> head scored
------------------------------------------------------------------------
getNgramsContactId
::
AnnuaireId
->
Cmd
err
(
HashMap
ContactName
(
Set
NodeId
))
->
DB
Cmd
err
(
HashMap
ContactName
(
Set
NodeId
))
getNgramsContactId
aId
=
do
contacts
<-
getAllContacts
aId
-- printDebug "getAllContexts" (tr_count contacts)
...
...
@@ -181,10 +184,11 @@ toName contact = NgramsTerm $ (Text.toTitle firstName) <> " " <> (Text.toTitle l
firstName
=
fromMaybe
""
$
contact
^.
(
node_hyperdata
.
hc_who
.
_Just
.
cw_firstName
)
lastName
=
fromMaybe
""
$
contact
^.
(
node_hyperdata
.
hc_who
.
_Just
.
cw_lastName
)
getNgramsDocId
::
CorpusId
getNgramsDocId
::
HasNodeStory
env
err
m
=>
CorpusId
->
ListId
->
NgramsType
->
GargNoServer
(
HashMap
DocAuthor
(
Set
NodeId
))
->
m
(
HashMap
DocAuthor
(
Set
NodeId
))
getNgramsDocId
cId
lId
nt
=
do
lIds
<-
selectNodesWithUsername
NodeList
userMaster
repo
<-
getRepo
(
lId
:
lIds
)
...
...
src/Gargantext/Database/Action/Metrics.hs
View file @
d16dd1e7
...
...
@@ -36,36 +36,29 @@ import Gargantext.Core.NodeStory hiding (runPGSQuery)
import
Gargantext.Core.Text.Metrics
(
scored
,
Scored
(
..
),
{-localMetrics, toScored-}
)
import
Gargantext.Core.Types
(
ListType
(
..
),
NodeType
(
..
),
ContextId
)
import
Gargantext.Core.Types.Query
(
Limit
(
..
))
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
import
Gargantext.Database.Action.Metrics.NgramsByContext
(
getContextsByNgramsOnlyUser
{-, getTficfWith-}
)
import
Gargantext.Database.Admin.Config
(
userMaster
)
import
Gargantext.Database.Admin.Types.Node
(
ListId
,
CorpusId
)
import
Gargantext.Database.Prelude
(
runPGSQuery
{-, formatPGSQuery-}
)
import
Gargantext.Database.Query.Table.Node
(
defaultList
)
import
Gargantext.Database.Query.Table.Node.Select
import
Gargantext.Prelude
getMetrics
::
FlowCmdM
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
Maybe
Limit
->
m
(
HashMap
NgramsTerm
(
ListType
,
Maybe
NgramsTerm
),
Vector
(
Scored
NgramsTerm
))
getMetrics
cId
maybeL
istId
tabType
maybeLimit
=
do
(
ngs
,
_
,
myCooc
)
<-
getNgramsCooc
cId
maybeL
istId
tabType
maybeLimit
getMetrics
::
(
HasNodeStory
env
err
m
)
=>
CorpusId
->
ListId
->
TabType
->
Maybe
Limit
->
m
(
HashMap
NgramsTerm
(
ListType
,
Maybe
NgramsTerm
),
Vector
(
Scored
NgramsTerm
))
getMetrics
cId
l
istId
tabType
maybeLimit
=
do
(
ngs
,
_
,
myCooc
)
<-
getNgramsCooc
cId
l
istId
tabType
maybeLimit
-- TODO HashMap
pure
(
ngs
,
scored
myCooc
)
getNgramsCooc
::
(
FlowCmdM
env
err
m
)
=>
CorpusId
->
Maybe
ListId
->
TabType
->
Maybe
Limit
->
m
(
HashMap
NgramsTerm
(
ListType
,
Maybe
NgramsTerm
)
,
HashMap
NgramsTerm
(
Maybe
RootTerm
)
,
HashMap
(
NgramsTerm
,
NgramsTerm
)
Int
)
getNgramsCooc
cId
maybeListId
tabType
maybeLimit
=
do
lId
<-
case
maybeListId
of
Nothing
->
defaultList
cId
Just
lId'
->
pure
lId'
getNgramsCooc
::
(
HasNodeStory
env
err
m
)
=>
CorpusId
->
ListId
->
TabType
->
Maybe
Limit
->
m
(
HashMap
NgramsTerm
(
ListType
,
Maybe
NgramsTerm
)
,
HashMap
NgramsTerm
(
Maybe
RootTerm
)
,
HashMap
(
NgramsTerm
,
NgramsTerm
)
Int
)
getNgramsCooc
cId
lId
tabType
maybeLimit
=
do
(
ngs'
,
ngs
)
<-
getNgrams
lId
tabType
lIds
<-
selectNodesWithUsername
NodeList
userMaster
...
...
@@ -81,21 +74,17 @@ getNgramsCooc cId maybeListId tabType maybeLimit = do
------------------------------------------------------------------------
------------------------------------------------------------------------
updateNgramsOccurrences
::
(
HasNodeStory
env
err
m
)
=>
CorpusId
->
Maybe
ListId
=>
CorpusId
->
ListId
->
m
()
updateNgramsOccurrences
cId
m
lId
=
do
_
<-
mapM
(
updateNgramsOccurrences'
cId
m
lId
Nothing
)
[
Terms
,
Sources
,
Authors
,
Institutes
]
updateNgramsOccurrences
cId
lId
=
do
_
<-
mapM
(
updateNgramsOccurrences'
cId
lId
Nothing
)
[
Terms
,
Sources
,
Authors
,
Institutes
]
pure
()
updateNgramsOccurrences'
::
(
HasNodeStory
env
err
m
)
=>
CorpusId
->
Maybe
ListId
->
Maybe
Limit
->
TabType
=>
CorpusId
->
ListId
->
Maybe
Limit
->
TabType
->
m
[
Int
]
updateNgramsOccurrences'
cId
maybeListId
maybeLimit
tabType
=
do
lId
<-
case
maybeListId
of
Nothing
->
defaultList
cId
Just
lId'
->
pure
lId'
updateNgramsOccurrences'
cId
lId
maybeLimit
tabType
=
do
result
<-
getNgramsOccurrences
cId
lId
tabType
maybeLimit
...
...
src/Gargantext/Database/Action/Metrics/Lists.hs
View file @
d16dd1e7
...
...
@@ -19,17 +19,17 @@ Portability : POSIX
module
Gargantext.Database.Action.Metrics.Lists
where
import
Gargantext.API.Ngrams.Types
(
TabType
(
..
))
import
Gargantext.Core.Text.Metrics
(
Scored
(
..
))
import
Gargantext.Core.Types
-- (NodePoly(..), NodeCorpus, ListId)
import
Gargantext.Core.Types.Query
(
Limit
)
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
import
Gargantext.Prelude
hiding
(
sum
,
head
)
import
Prelude
hiding
(
null
,
id
,
map
,
sum
)
import
qualified
Data.HashMap.Strict
as
HashMap
import
qualified
Data.Map.Strict
as
Map
import
qualified
Data.Vector
as
Vec
import
qualified
Gargantext.Database.Action.Metrics
as
Metrics
--
import Gargantext.API.Ngrams.Types (TabType(..))
--
import Gargantext.Core.Text.Metrics (Scored(..))
--
import Gargantext.Core.Types -- (NodePoly(..), NodeCorpus, ListId)
--
import Gargantext.Core.Types.Query (Limit)
--
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
--
import Gargantext.Prelude hiding (sum, head)
--
import Prelude hiding (null, id, map, sum)
--
import qualified Data.HashMap.Strict as HashMap
--
import qualified Data.Map.Strict as Map
--
import qualified Data.Vector as Vec
--
import qualified Gargantext.Database.Action.Metrics as Metrics
{-
trainModel :: FlowCmdM env ServantErr m
=> Username -> m Score
...
...
@@ -42,18 +42,18 @@ trainModel u = do
--}
getMetrics'
::
FlowCmdM
env
err
m
=>
CorpusId
->
Maybe
ListId
->
TabType
->
Maybe
Limit
->
m
(
Map
.
Map
ListType
[
Vec
.
Vector
Double
])
getMetrics'
cId
maybeListId
tabType
maybeLimit
=
do
(
ngs'
,
scores
)
<-
Metrics
.
getMetrics
cId
maybeListId
tabType
maybeLimit
--
getMetrics' :: FlowCmdM env err m
--
=> CorpusId -> Maybe ListId -> TabType -> Maybe Limit
--
-> m (Map.Map ListType [Vec.Vector Double])
--
getMetrics' cId maybeListId tabType maybeLimit = do
--
(ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
let
metrics
=
map
(
\
(
Scored
t
s1
s2
)
->
(
listType
t
ngs'
,
[
Vec
.
fromList
[
s1
,
s2
]]))
scores
listType
t
m
=
maybe
(
panic
errorMsg
)
fst
$
HashMap
.
lookup
t
m
errorMsg
=
"API.Node.metrics: key absent"
--
let
--
metrics = map (\(Scored t s1 s2) -> (listType t ngs', [Vec.fromList [s1,s2]])) scores
--
listType t m = maybe (panic errorMsg) fst $ HashMap.lookup t m
--
errorMsg = "API.Node.metrics: key absent"
{-
_ <- Learn.grid 100 110 metrics' metrics'
--}
pure
$
Map
.
fromListWith
(
<>
)
$
Vec
.
toList
metrics
--
{-
--
_ <- Learn.grid 100 110 metrics' metrics'
--
--}
--
pure $ Map.fromListWith (<>) $ Vec.toList metrics
src/Gargantext/Database/Query/Table/Node.hs
View file @
d16dd1e7
{-|
import Gargantext.Database.Prelude (Cmd, runPGSQuery)
Module : Gargantext.Database.Query.Table.Node
Description : Main Tools of Node to the database
Copyright : (c) CNRS, 2017-Present
...
...
@@ -53,7 +52,7 @@ selectNode id' = proc () -> do
restrict
-<
_node_id
row
.==
id'
returnA
-<
row
runGetNodes
::
Select
NodeRead
->
Cmd
err
[
Node
HyperdataAny
]
runGetNodes
::
Select
NodeRead
->
DB
Cmd
err
[
Node
HyperdataAny
]
runGetNodes
=
runOpaQuery
------------------------------------------------------------------------
...
...
@@ -84,7 +83,7 @@ selectNodesWith' parentId maybeNodeType = proc () -> do
returnA
-<
row
)
-<
()
returnA
-<
node'
deleteNode
::
NodeId
->
Cmd
err
Int
deleteNode
::
NodeId
->
DB
Cmd
err
Int
deleteNode
n
=
mkCmd
$
\
conn
->
fromIntegral
<$>
runDelete_
conn
(
Delete
nodeTable
...
...
@@ -92,7 +91,7 @@ deleteNode n = mkCmd $ \conn ->
rCount
)
deleteNodes
::
[
NodeId
]
->
Cmd
err
Int
deleteNodes
::
[
NodeId
]
->
DB
Cmd
err
Int
deleteNodes
ns
=
mkCmd
$
\
conn
->
fromIntegral
<$>
runDelete_
conn
(
Delete
nodeTable
...
...
@@ -102,7 +101,7 @@ deleteNodes ns = mkCmd $ \conn ->
-- TODO: NodeType should match with `a'
getNodesWith
::
(
JSONB
a
,
HasDBid
NodeType
)
=>
NodeId
->
proxy
a
->
Maybe
NodeType
->
Maybe
Offset
->
Maybe
Limit
->
Cmd
err
[
Node
a
]
->
Maybe
Offset
->
Maybe
Limit
->
DB
Cmd
err
[
Node
a
]
getNodesWith
parentId
_
nodeType
maybeOffset
maybeLimit
=
runOpaQuery
$
selectNodesWith
parentId
nodeType
maybeOffset
maybeLimit
...
...
@@ -110,7 +109,7 @@ getNodesWith parentId _ nodeType maybeOffset maybeLimit =
-- TODO: Why not use getNodesWith?
getNodesWithParentId
::
(
Hyperdata
a
,
JSONB
a
)
=>
Maybe
NodeId
->
Cmd
err
[
Node
a
]
->
DB
Cmd
err
[
Node
a
]
getNodesWithParentId
n
=
runOpaQuery
$
selectNodesWithParentID
n'
where
n'
=
case
n
of
...
...
@@ -124,7 +123,7 @@ getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
getClosestParentIdByType
::
HasDBid
NodeType
=>
NodeId
->
NodeType
->
Cmd
err
(
Maybe
NodeId
)
->
DB
Cmd
err
(
Maybe
NodeId
)
getClosestParentIdByType
nId
nType
=
do
result
<-
runPGSQuery
query
(
PGS
.
Only
nId
)
case
result
of
...
...
@@ -148,7 +147,7 @@ getClosestParentIdByType nId nType = do
getClosestParentIdByType'
::
HasDBid
NodeType
=>
NodeId
->
NodeType
->
Cmd
err
(
Maybe
NodeId
)
->
DB
Cmd
err
(
Maybe
NodeId
)
getClosestParentIdByType'
nId
nType
=
do
result
<-
runPGSQuery
query
(
PGS
.
Only
nId
)
case
result
of
...
...
@@ -185,14 +184,14 @@ getChildrenByType nId nType = do
|]
------------------------------------------------------------------------
getDocumentsV3WithParentId
::
HasDBid
NodeType
=>
NodeId
->
Cmd
err
[
Node
HyperdataDocumentV3
]
getDocumentsV3WithParentId
::
HasDBid
NodeType
=>
NodeId
->
DB
Cmd
err
[
Node
HyperdataDocumentV3
]
getDocumentsV3WithParentId
n
=
runOpaQuery
$
selectNodesWith'
n
(
Just
NodeDocument
)
-- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
getDocumentsWithParentId
::
HasDBid
NodeType
=>
NodeId
->
Cmd
err
[
Node
HyperdataDocument
]
getDocumentsWithParentId
::
HasDBid
NodeType
=>
NodeId
->
DB
Cmd
err
[
Node
HyperdataDocument
]
getDocumentsWithParentId
n
=
runOpaQuery
$
selectNodesWith'
n
(
Just
NodeDocument
)
getListsModelWithParentId
::
HasDBid
NodeType
=>
NodeId
->
Cmd
err
[
Node
HyperdataModel
]
getListsModelWithParentId
::
HasDBid
NodeType
=>
NodeId
->
DB
Cmd
err
[
Node
HyperdataModel
]
getListsModelWithParentId
n
=
runOpaQuery
$
selectNodesWith'
n
(
Just
NodeModel
)
getCorporaWithParentId
::
HasDBid
NodeType
=>
NodeId
->
DBCmd
err
[
Node
HyperdataCorpus
]
...
...
@@ -209,7 +208,7 @@ selectNodesWithParentID n = proc () -> do
------------------------------------------------------------------------
-- | Example of use:
-- runCmdReplEasy (getNodesWithType NodeList (Proxy :: Proxy HyperdataList))
getNodesWithType
::
(
HasNodeError
err
,
JSONB
a
,
HasDBid
NodeType
)
=>
NodeType
->
proxy
a
->
Cmd
err
[
Node
a
]
getNodesWithType
::
(
HasNodeError
err
,
JSONB
a
,
HasDBid
NodeType
)
=>
NodeType
->
proxy
a
->
DB
Cmd
err
[
Node
a
]
getNodesWithType
nt
_
=
runOpaQuery
$
selectNodesWithType
nt
where
selectNodesWithType
::
HasDBid
NodeType
...
...
@@ -223,7 +222,7 @@ getNodeWithType :: (HasNodeError err, JSONB a, HasDBid NodeType)
=>
NodeId
->
NodeType
->
proxy
a
->
Cmd
err
[
Node
a
]
->
DB
Cmd
err
[
Node
a
]
getNodeWithType
nId
nt
_
=
runOpaQuery
$
selectNodeWithType
nId
nt
where
selectNodeWithType
::
HasDBid
NodeType
...
...
@@ -234,7 +233,7 @@ getNodeWithType nId nt _ = runOpaQuery $ selectNodeWithType nId nt
restrict
-<
tn
.==
sqlInt4
(
toDBid
nt'
)
returnA
-<
row
getNodesIdWithType
::
(
HasNodeError
err
,
HasDBid
NodeType
)
=>
NodeType
->
Cmd
err
[
NodeId
]
getNodesIdWithType
::
(
HasNodeError
err
,
HasDBid
NodeType
)
=>
NodeType
->
DB
Cmd
err
[
NodeId
]
getNodesIdWithType
nt
=
do
ns
<-
runOpaQuery
$
selectNodesIdWithType
nt
pure
(
map
NodeId
ns
)
...
...
@@ -248,7 +247,7 @@ selectNodesIdWithType nt = proc () -> do
------------------------------------------------------------------------
nodeExists
::
(
HasNodeError
err
)
=>
NodeId
->
Cmd
err
Bool
nodeExists
::
(
HasNodeError
err
)
=>
NodeId
->
DB
Cmd
err
Bool
nodeExists
nId
=
(
==
[
PGS
.
Only
True
])
<$>
runPGSQuery
[
sql
|
SELECT true FROM nodes WHERE id = ?
|]
(
PGS
.
Only
nId
)
...
...
@@ -317,7 +316,7 @@ insertNodes :: [NodeWrite] -> DBCmd err Int64
insertNodes
ns
=
mkCmd
$
\
conn
->
runInsert_
conn
$
Insert
nodeTable
ns
rCount
Nothing
{-
insertNodes' :: [Node a] -> Cmd err Int64
insertNodes' :: [Node a] ->
DB
Cmd err Int64
insertNodes' ns = mkCmd $ \conn -> runInsert_ conn
$ Insert nodeTable ns' rCount Nothing
where
...
...
@@ -359,11 +358,11 @@ data Node' = Node' { _n_type :: NodeType
,
_n_children
::
[
Node'
]
}
deriving
(
Show
)
mkNodes
::
[
NodeWrite
]
->
Cmd
err
Int64
mkNodes
::
[
NodeWrite
]
->
DB
Cmd
err
Int64
mkNodes
ns
=
mkCmd
$
\
conn
->
runInsert_
conn
$
Insert
nodeTable
ns
rCount
Nothing
mkNodeR
::
[
NodeWrite
]
->
Cmd
err
[
NodeId
]
mkNodeR
::
[
NodeWrite
]
->
DB
Cmd
err
[
NodeId
]
mkNodeR
ns
=
mkCmd
$
\
conn
->
runInsert_
conn
$
Insert
nodeTable
ns
(
rReturning
_node_id
)
Nothing
------------------------------------------------------------------------
...
...
@@ -410,7 +409,7 @@ defaultList :: (HasNodeError err, HasDBid NodeType) => CorpusId -> DBCmd err Lis
defaultList
cId
=
maybe
(
nodeError
(
NoListFound
cId
))
(
pure
.
view
node_id
)
.
headMay
=<<
getListsWithParentId
cId
defaultListMaybe
::
(
HasNodeError
err
,
HasDBid
NodeType
)
=>
CorpusId
->
Cmd
err
(
Maybe
NodeId
)
defaultListMaybe
::
(
HasNodeError
err
,
HasDBid
NodeType
)
=>
CorpusId
->
DB
Cmd
err
(
Maybe
NodeId
)
defaultListMaybe
cId
=
headMay
<$>
map
(
view
node_id
)
<$>
getListsWithParentId
cId
getListsWithParentId
::
HasDBid
NodeType
=>
NodeId
->
DBCmd
err
[
Node
HyperdataList
]
...
...
src/Gargantext/Database/Query/Table/Node/Children.hs
View file @
d16dd1e7
...
...
@@ -36,12 +36,12 @@ import Opaleye
-- TODO getAllTableDocuments
getAllDocuments
::
HasDBid
NodeType
=>
ParentId
->
Cmd
err
(
TableResult
(
Node
HyperdataDocument
))
getAllDocuments
::
HasDBid
NodeType
=>
ParentId
->
DB
Cmd
err
(
TableResult
(
Node
HyperdataDocument
))
getAllDocuments
pId
=
getAllChildren
pId
(
Proxy
::
Proxy
HyperdataDocument
)
(
Just
NodeDocument
)
-- TODO getAllTableContacts
getAllContacts
::
HasDBid
NodeType
=>
ParentId
->
Cmd
err
(
TableResult
(
Node
HyperdataContact
))
getAllContacts
::
HasDBid
NodeType
=>
ParentId
->
DB
Cmd
err
(
TableResult
(
Node
HyperdataContact
))
getAllContacts
pId
=
getAllChildren
pId
(
Proxy
::
Proxy
HyperdataContact
)
(
Just
NodeContact
)
...
...
@@ -49,7 +49,7 @@ getAllChildren :: (JSONB a, HasDBid NodeType)
=>
ParentId
->
proxy
a
->
Maybe
NodeType
->
Cmd
err
(
NodeTableResult
a
)
->
DB
Cmd
err
(
NodeTableResult
a
)
getAllChildren
pId
p
maybeNodeType
=
getChildren
pId
p
maybeNodeType
Nothing
Nothing
...
...
@@ -59,7 +59,7 @@ getChildren :: (JSONB a, HasDBid NodeType)
->
Maybe
NodeType
->
Maybe
Offset
->
Maybe
Limit
->
Cmd
err
(
NodeTableResult
a
)
->
DB
Cmd
err
(
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
...
...
@@ -71,7 +71,7 @@ getChildrenNode :: (JSONB a, HasDBid NodeType)
->
Maybe
NodeType
->
Maybe
Offset
->
Maybe
Limit
->
Cmd
err
(
NodeTableResult
a
)
->
DB
Cmd
err
(
NodeTableResult
a
)
getChildrenNode
pId
_
maybeNodeType
maybeOffset
maybeLimit
=
do
-- printDebug "getChildrenNode" (pId, maybeNodeType)
let
query
=
selectChildrenNode
pId
maybeNodeType
...
...
@@ -97,12 +97,12 @@ selectChildrenNode parentId maybeNodeType = proc () -> do
getChildrenContext
::
(
JSONB
a
,
HasDBid
NodeType
)
=>
ParentId
->
proxy
a
->
Maybe
NodeType
->
Maybe
Offset
->
Maybe
Limit
->
Cmd
err
(
NodeTableResult
a
)
=>
ParentId
->
proxy
a
->
Maybe
NodeType
->
Maybe
Offset
->
Maybe
Limit
->
DB
Cmd
err
(
NodeTableResult
a
)
getChildrenContext
pId
_
maybeNodeType
maybeOffset
maybeLimit
=
do
-- printDebug "getChildrenContext" (pId, maybeNodeType)
let
query
=
selectChildren'
pId
maybeNodeType
...
...
src/Gargantext/Database/Query/Table/NodeContext_NodeContext.hs
View file @
d16dd1e7
...
...
@@ -32,7 +32,7 @@ queryNodeContext_NodeContextTable :: Select NodeContext_NodeContextRead
queryNodeContext_NodeContextTable = selectTable nodeContext_NodeContextTable
-}
insertNodeContext_NodeContext
::
[(
CorpusId
,
DocId
,
AnnuaireId
,
ContactId
)]
->
Cmd
err
[
Int
]
insertNodeContext_NodeContext
::
[(
CorpusId
,
DocId
,
AnnuaireId
,
ContactId
)]
->
DB
Cmd
err
[
Int
]
insertNodeContext_NodeContext
contexts
=
do
let
fields
=
map
(
\
t
->
QualifiedIdentifier
Nothing
t
)
$
snd
fields_name
...
...
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