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
160
Issues
160
List
Board
Labels
Milestones
Merge Requests
8
Merge Requests
8
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
e79541d7
Commit
e79541d7
authored
May 05, 2025
by
Alfredo Di Napoli
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Almost there?
parent
5f157876
Changes
16
Hide whitespace changes
Inline
Side-by-side
Showing
16 changed files
with
234 additions
and
188 deletions
+234
-188
Context.hs
src/Gargantext/API/GraphQL/Context.hs
+5
-5
Node.hs
src/Gargantext/API/GraphQL/Node.hs
+10
-8
Team.hs
src/Gargantext/API/GraphQL/Team.hs
+16
-14
TreeFirstLevel.hs
src/Gargantext/API/GraphQL/TreeFirstLevel.hs
+8
-7
User.hs
src/Gargantext/API/GraphQL/User.hs
+6
-6
UserInfo.hs
src/Gargantext/API/GraphQL/UserInfo.hs
+8
-7
Members.hs
src/Gargantext/API/Members.hs
+2
-1
Metrics.hs
src/Gargantext/API/Metrics.hs
+108
-82
Export.hs
src/Gargantext/API/Node/Corpus/Export.hs
+32
-27
Export.hs
src/Gargantext/API/Node/Document/Export.hs
+8
-6
Export.hs
src/Gargantext/API/Node/Phylo/Export.hs
+3
-2
Search.hs
src/Gargantext/API/Search.hs
+3
-2
Table.hs
src/Gargantext/API/Table.hs
+7
-7
Chart.hs
src/Gargantext/Core/Viz/Chart.hs
+3
-3
API.hs
src/Gargantext/Core/Viz/Phylo/API.hs
+9
-5
Learn.hs
src/Gargantext/Database/Action/Learn.hs
+6
-6
No files found.
src/Gargantext/API/GraphQL/Context.hs
View file @
e79541d7
...
...
@@ -33,7 +33,7 @@ import Gargantext.API.Prelude (GargM)
import
Gargantext.Core.Types.Search
(
HyperdataRow
(
..
),
toHyperdataRow
)
import
Gargantext.Database.Admin.Types.Hyperdata.Document
(
HyperdataDocument
)
import
Gargantext.Database.Admin.Types.Node
(
ContextTitle
,
NodeId
(
..
),
NodeTypeId
,
UserId
,
unNodeId
,
ContextId
(
..
))
import
Gargantext.Database.Prelude
(
IsDBEnvExtra
)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Query.Table.NodeContext
(
getNodeContext
,
getContextsForNgramsTerms
,
ContextForNgramsTerms
(
..
),
{- getContextNgrams, -}
getContextNgramsMatchingFTS
)
import
Gargantext.Database.Query.Table.NodeContext
qualified
as
DNC
import
Gargantext.Database.Schema.NodeContext
(
NodeContext
,
NodeContextPoly
(
..
))
...
...
@@ -147,7 +147,7 @@ dbNodeContext context_id node_id = do
-- user <- getUsersWithId user_id
-- hyperdata <- getUserHyperdata user_id
-- lift (map toUser <$> zip user hyperdata)
c
<-
lift
$
getNodeContext
(
UnsafeMkContextId
context_id
)
(
UnsafeMkNodeId
node_id
)
c
<-
lift
$
runDBQuery
$
getNodeContext
(
UnsafeMkContextId
context_id
)
(
UnsafeMkNodeId
node_id
)
pure
$
toNodeContextGQL
<$>
[
c
]
-- | Returns list of `ContextGQL` for given ngrams in given corpus id.
...
...
@@ -155,7 +155,7 @@ dbContextForNgrams
::
(
IsDBEnvExtra
env
)
=>
Int
->
[
Text
]
->
Text
->
GqlM
e
env
[
ContextGQL
]
dbContextForNgrams
node_id
ngrams_terms
and_logic
=
do
contextsForNgramsTerms
<-
lift
$
getContextsForNgramsTerms
(
UnsafeMkNodeId
node_id
)
ngrams_terms
(
readMaybe
$
unpack
$
Text
.
toTitle
and_logic
)
contextsForNgramsTerms
<-
lift
$
runDBQuery
$
getContextsForNgramsTerms
(
UnsafeMkNodeId
node_id
)
ngrams_terms
(
readMaybe
$
unpack
$
Text
.
toTitle
and_logic
)
--lift $ printDebug "[dbContextForNgrams] contextsForNgramsTerms" contextsForNgramsTerms
pure
$
toContextGQL
<$>
contextsForNgramsTerms
...
...
@@ -164,7 +164,7 @@ dbContextNgrams
::
(
IsDBEnvExtra
env
)
=>
Int
->
Int
->
GqlM
e
env
[
Text
]
dbContextNgrams
context_id
list_id
=
do
lift
$
getContextNgramsMatchingFTS
(
UnsafeMkContextId
context_id
)
(
UnsafeMkNodeId
list_id
)
lift
$
runDBQuery
$
getContextNgramsMatchingFTS
(
UnsafeMkContextId
context_id
)
(
UnsafeMkNodeId
list_id
)
-- Conversion functions
...
...
@@ -228,5 +228,5 @@ updateNodeContextCategory :: (IsDBEnvExtra env)
->
GqlM'
e
env
[
Int
]
updateNodeContextCategory
autUser
mgr
NodeContextCategoryMArgs
{
context_id
,
node_id
,
category
}
=
withPolicy
autUser
mgr
(
nodeWriteChecks
$
UnsafeMkNodeId
node_id
)
$
do
void
$
lift
$
DNC
.
updateNodeContextCategory
(
UnsafeMkContextId
context_id
)
(
UnsafeMkNodeId
node_id
)
category
void
$
lift
$
runDBTx
$
DNC
.
updateNodeContextCategory
(
UnsafeMkContextId
context_id
)
(
UnsafeMkNodeId
node_id
)
category
pure
[
1
]
src/Gargantext/API/GraphQL/Node.hs
View file @
e79541d7
...
...
@@ -24,7 +24,7 @@ import Gargantext.API.GraphQL.Types ( GqlM )
import
Gargantext.Core
(
HasDBid
(
lookupDBid
)
)
import
Gargantext.Database.Admin.Types.Node
(
NodeType
)
import
Gargantext.Database.Admin.Types.Node
qualified
as
NN
import
Gargantext.Database.Prelude
(
IsDBEnvExtra
)
-- , JSONB)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Query.Table.Node
(
getClosestChildrenByType
,
getClosestParentIdByType
,
getNode
)
import
Gargantext.Database.Schema.Node
qualified
as
N
import
Gargantext.Prelude
...
...
@@ -74,14 +74,14 @@ dbNodes
::
(
IsDBEnvExtra
env
)
=>
Int
->
GqlM
e
env
[
Node
]
dbNodes
node_id
=
do
node
<-
lift
$
getNode
$
NN
.
UnsafeMkNodeId
node_id
node
<-
lift
$
runDBQuery
$
getNode
$
NN
.
UnsafeMkNodeId
node_id
pure
[
toNode
node
]
dbNodesCorpus
::
(
IsDBEnvExtra
env
)
=>
Int
->
GqlM
e
env
[
Corpus
]
dbNodesCorpus
corpus_id
=
do
corpus
<-
lift
$
getNode
$
NN
.
UnsafeMkNodeId
corpus_id
corpus
<-
lift
$
runDBQuery
$
getNode
$
NN
.
UnsafeMkNodeId
corpus_id
pure
[
toCorpus
corpus
]
data
NodeParentArgs
...
...
@@ -116,19 +116,21 @@ dbParentNodes node_id parentType = do
-- lift $ printDebug "[dbParentNodes] error reading parent type" (T.pack err)
-- pure []
-- Right parentType -> do
mNodeId
<-
lift
$
getClosestParentIdByType
(
NN
.
UnsafeMkNodeId
node_id
)
parentType
-- (fromNodeTypeId parent_type_id)
lift
$
runDBQuery
$
do
mNodeId
<-
getClosestParentIdByType
(
NN
.
UnsafeMkNodeId
node_id
)
parentType
-- (fromNodeTypeId parent_type_id)
case
mNodeId
of
Nothing
->
pure
[]
Just
id
->
do
node
<-
lift
$
getNode
id
node
<-
getNode
id
pure
[
toNode
node
]
dbChildNodes
::
(
IsDBEnvExtra
env
)
=>
Int
->
NodeType
->
GqlM
e
env
[
Node
]
dbChildNodes
node_id
childType
=
do
childIds
<-
lift
$
getClosestChildrenByType
(
NN
.
UnsafeMkNodeId
node_id
)
childType
-- (fromNodeTypeId parent_type_id)
children
<-
lift
$
mapM
getNode
childIds
pure
$
toNode
<$>
children
lift
$
runDBQuery
$
do
childIds
<-
getClosestChildrenByType
(
NN
.
UnsafeMkNodeId
node_id
)
childType
-- (fromNodeTypeId parent_type_id)
children
<-
mapM
getNode
childIds
pure
$
toNode
<$>
children
toNode
::
NN
.
Node
json
->
Node
toNode
N
.
Node
{
..
}
=
Node
{
id
=
nid
...
...
src/Gargantext/API/GraphQL/Team.hs
View file @
e79541d7
...
...
@@ -25,7 +25,7 @@ import Gargantext.Core.Config (HasJWTSettings)
import
Gargantext.Core.Types
(
NodeId
(
..
),
unNodeId
)
import
Gargantext.Core.Types.Individu
qualified
as
Individu
import
Gargantext.Database.Action.Share
(
membersOf
,
deleteMemberShip
)
import
Gargantext.Database.Prelude
(
IsDBEnvExtra
)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Query.Table.Node
(
getNode
)
import
Gargantext.Database.Query.Table.User
(
getUsersWithNodeHyperdata
)
import
Gargantext.Database.Schema.Node
(
NodePoly
(
Node
,
_node_id
),
_node_user_id
)
...
...
@@ -60,13 +60,14 @@ dbTeam :: (IsDBEnvExtra env) =>
Int
->
GqlM
e
env
Team
dbTeam
nodeId
=
do
let
nId
=
UnsafeMkNodeId
nodeId
res
<-
lift
$
membersOf
nId
teamNode
<-
lift
$
getNode
nId
userNodes
<-
lift
$
getUsersWithNodeHyperdata
$
Individu
.
UserDBId
$
uId
teamNode
let
username
=
getUsername
userNodes
pure
$
Team
{
team_owner_username
=
username
,
team_members
=
map
toTeamMember
res
}
lift
$
runDBQuery
$
do
res
<-
membersOf
nId
teamNode
<-
getNode
nId
userNodes
<-
getUsersWithNodeHyperdata
$
Individu
.
UserDBId
$
uId
teamNode
let
username
=
getUsername
userNodes
pure
$
Team
{
team_owner_username
=
username
,
team_members
=
map
toTeamMember
res
}
where
toTeamMember
::
(
Text
,
NodeId
)
->
TeamMember
toTeamMember
(
username
,
fId
)
=
TeamMember
{
...
...
@@ -81,18 +82,19 @@ dbTeam nodeId = do
deleteTeamMembership
::
(
IsDBEnvExtra
env
,
HasJWTSettings
env
)
=>
TeamDeleteMArgs
->
GqlM'
e
env
[
Int
]
deleteTeamMembership
TeamDeleteMArgs
{
token
,
shared_folder_id
,
team_node_id
}
=
do
teamNode
<-
lift
$
getNode
$
UnsafeMkNodeId
team_node_id
userNodes
<-
lift
(
getUsersWithNodeHyperdata
$
Individu
.
UserDBId
$
uId
teamNode
)
userNodes
<-
lift
$
runDBTx
$
do
teamNode
<-
getNode
$
UnsafeMkNodeId
team_node_id
getUsersWithNodeHyperdata
$
Individu
.
UserDBId
$
uId
teamNode
case
userNodes
of
[]
->
panicTrace
$
"[deleteTeamMembership] User with id "
<>
T
.
pack
(
show
$
uId
teamNode
)
<>
" doesn't exist."
[]
->
panicTrace
$
"[deleteTeamMembership] User with id "
<>
T
.
pack
(
show
$
team_node_id
)
<>
" doesn't exist."
((
_
,
node_u
)
:
_
)
->
do
testAuthUser
<-
lift
$
authUser
(
nId
node_u
)
token
lift
$
case
testAuthUser
of
case
testAuthUser
of
-- Invalid -> panicTrace "[deleteTeamMembership] failed to validate user"
Invalid
->
do
throwError
$
InternalAuthenticationError
$
UserNotAuthorized
(
uId
node_u
)
"This user is not team owner"
lift
$
throwError
$
InternalAuthenticationError
$
UserNotAuthorized
(
uId
node_u
)
"This user is not team owner"
Valid
->
do
deleteMemberShip
[(
UnsafeMkNodeId
shared_folder_id
,
UnsafeMkNodeId
team_node_id
)]
lift
$
runDBTx
$
deleteMemberShip
[(
UnsafeMkNodeId
shared_folder_id
,
UnsafeMkNodeId
team_node_id
)]
where
uId
Node
{
_node_user_id
}
=
_node_user_id
nId
Node
{
_node_id
}
=
_node_id
src/Gargantext/API/GraphQL/TreeFirstLevel.hs
View file @
e79541d7
...
...
@@ -25,7 +25,7 @@ import Gargantext.Core.Types.Main ( Tree(..), _tn_node, _tn_children, NodeTree(.
import
Gargantext.Database.Admin.Config
()
import
Gargantext.Database.Admin.Types.Node
(
allNodeTypes
,
NodeId
(
..
),
NodeType
)
import
Gargantext.Database.Admin.Types.Node
qualified
as
NN
import
Gargantext.Database.Prelude
(
IsDBEnvExtra
)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Query.Table.Node
(
getNode
)
import
Gargantext.Database.Query.Tree
qualified
as
T
import
Gargantext.Database.Schema.Node
(
NodePoly
(
_node_parent_id
))
...
...
@@ -77,10 +77,11 @@ dbTree :: (IsDBEnvExtra env) =>
NN
.
UserId
->
Int
->
GqlM
e
env
(
TreeFirstLevel
(
GqlM
e
env
))
dbTree
loggedInUserId
root_id
=
do
let
rId
=
UnsafeMkNodeId
root_id
t
<-
lift
$
T
.
tree
loggedInUserId
T
.
TreeFirstLevel
rId
allNodeTypes
n
<-
lift
$
getNode
$
UnsafeMkNodeId
root_id
let
pId
=
toParentId
n
pure
$
toTree
rId
pId
t
lift
$
runDBQuery
$
do
t
<-
T
.
tree
loggedInUserId
T
.
TreeFirstLevel
rId
allNodeTypes
n
<-
getNode
$
UnsafeMkNodeId
root_id
let
pId
=
toParentId
n
pure
$
toTree
rId
pId
t
where
toParentId
N
.
Node
{
_node_parent_id
}
=
_node_parent_id
...
...
@@ -100,7 +101,7 @@ childrenToTreeNodes (TreeN {_tn_node}, rId) = toTreeNode (Just rId) _tn_node
resolveParent
::
(
IsDBEnvExtra
env
)
=>
Maybe
NodeId
->
GqlM
e
env
(
Maybe
TreeNode
)
resolveParent
(
Just
pId
)
=
do
node
<-
lift
$
getNode
pId
node
<-
lift
$
runDBQuery
$
getNode
pId
pure
$
nodeToTreeNode
node
resolveParent
Nothing
=
pure
Nothing
...
...
@@ -133,6 +134,6 @@ convertDbTreeToTreeNode T.DbTreeNode { _dt_name, _dt_nodeId, _dt_typeId, _dt_par
dbRecursiveParents
::
(
IsDBEnvExtra
env
)
=>
Int
->
GqlM
e
env
BreadcrumbInfo
dbRecursiveParents
nodeId
=
do
let
nId
=
UnsafeMkNodeId
nodeId
dbParents
<-
lift
$
T
.
recursiveParents
nId
allNodeTypes
dbParents
<-
lift
$
runDBQuery
$
T
.
recursiveParents
nId
allNodeTypes
let
treeNodes
=
map
convertDbTreeToTreeNode
dbParents
pure
$
BreadcrumbInfo
{
parents
=
treeNodes
}
src/Gargantext/API/GraphQL/User.hs
View file @
e79541d7
...
...
@@ -22,7 +22,7 @@ import Gargantext.API.GraphQL.Types (GqlM, GqlM')
import
Gargantext.Core.Types
(
NodeId
(
..
),
UserId
)
import
Gargantext.Core.Types.Individu
qualified
as
Individu
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataUser
(
..
))
import
Gargantext.Database.Prelude
(
IsDBEnvExtra
)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Query.Table.User
qualified
as
DBUser
import
Gargantext.Database.Schema.User
(
UserLight
(
..
))
import
Gargantext.Prelude
...
...
@@ -72,7 +72,7 @@ resolveUsers autUser mgr UserArgs { user_id } = do
-- | Inner function to fetch the user from DB.
dbUsers
::
(
IsDBEnvExtra
env
)
=>
Int
->
GqlM
e
env
[
User
(
GqlM
e
env
)]
dbUsers
user_id
=
lift
(
map
toUser
<$>
DBUser
.
getUsersWithId
(
Individu
.
RootId
$
UnsafeMkNodeId
user_id
))
dbUsers
user_id
=
lift
(
map
toUser
<$>
runDBQuery
(
DBUser
.
getUsersWithId
(
Individu
.
RootId
$
UnsafeMkNodeId
user_id
)
))
toUser
::
(
IsDBEnvExtra
env
)
...
...
@@ -85,25 +85,25 @@ toUser (UserLight { .. }) = User { u_email = userLight_email
resolveHyperdata
::
(
IsDBEnvExtra
env
)
=>
UserId
->
GqlM
e
env
(
Maybe
HyperdataUser
)
resolveHyperdata
userid
=
lift
(
listToMaybe
<$>
DBUser
.
getUserHyperdata
(
Individu
.
UserDBId
userid
))
resolveHyperdata
userid
=
lift
(
listToMaybe
<$>
runDBQuery
(
DBUser
.
getUserHyperdata
(
Individu
.
UserDBId
userid
)
))
updateUserPubmedAPIKey
::
(
IsDBEnvExtra
env
)
=>
UserPubmedAPIKeyMArgs
->
GqlM'
e
env
Int
updateUserPubmedAPIKey
UserPubmedAPIKeyMArgs
{
user_id
,
api_key
}
=
do
_
<-
lift
$
DBUser
.
updateUserPubmedAPIKey
(
Individu
.
RootId
$
UnsafeMkNodeId
user_id
)
api_key
_
<-
lift
$
runDBTx
$
DBUser
.
updateUserPubmedAPIKey
(
Individu
.
RootId
$
UnsafeMkNodeId
user_id
)
api_key
pure
1
updateUserEPOAPIUser
::
(
IsDBEnvExtra
env
)
=>
UserEPOAPIUserMArgs
->
GqlM'
e
env
Int
updateUserEPOAPIUser
UserEPOAPIUserMArgs
{
user_id
,
api_user
}
=
do
_
<-
lift
$
DBUser
.
updateUserEPOAPIUser
(
Individu
.
RootId
$
UnsafeMkNodeId
user_id
)
api_user
_
<-
lift
$
runDBTx
$
DBUser
.
updateUserEPOAPIUser
(
Individu
.
RootId
$
UnsafeMkNodeId
user_id
)
api_user
pure
1
updateUserEPOAPIToken
::
(
IsDBEnvExtra
env
)
=>
UserEPOAPITokenMArgs
->
GqlM'
e
env
Int
updateUserEPOAPIToken
UserEPOAPITokenMArgs
{
user_id
,
api_token
}
=
do
_
<-
lift
$
DBUser
.
updateUserEPOAPIToken
(
Individu
.
RootId
$
UnsafeMkNodeId
user_id
)
api_token
_
<-
lift
$
runDBTx
$
DBUser
.
updateUserEPOAPIToken
(
Individu
.
RootId
$
UnsafeMkNodeId
user_id
)
api_token
pure
1
src/Gargantext/API/GraphQL/UserInfo.hs
View file @
e79541d7
...
...
@@ -49,7 +49,7 @@ import Gargantext.API.GraphQL.Utils (AuthStatus(Invalid, Valid), authUser)
import
Gargantext.Core.Config
(
HasJWTSettings
)
import
Gargantext.Core.Types
(
UserId
(
..
))
import
Gargantext.Core.Types.Individu
qualified
as
Individu
import
Gargantext.Database.Prelude
(
IsDBEnvExtra
)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
import
Gargantext.Database.Query.Table.User
(
getUsersWithHyperdata
,
getUsersWithNodeHyperdata
,
updateUserEmail
)
import
Gargantext.Database.Schema.Node
(
node_id
,
node_hyperdata
,
NodePoly
(
Node
,
_node_id
))
...
...
@@ -124,7 +124,7 @@ updateUserInfo
=>
UserInfoMArgs
->
GqlM'
e
env
Int
updateUserInfo
(
UserInfoMArgs
{
ui_id
,
..
})
=
do
-- lift $ printDebug "[updateUserInfo] ui_id" ui_id
users
<-
lift
(
getUsersWithNodeHyperdata
(
Individu
.
UserDBId
$
UnsafeMkUserId
ui_id
)
)
users
<-
lift
$
runDBQuery
$
getUsersWithNodeHyperdata
(
Individu
.
UserDBId
$
UnsafeMkUserId
ui_id
)
case
users
of
[]
->
panicTrace
$
"[updateUserInfo] User with id "
<>
(
T
.
pack
$
show
ui_id
)
<>
" doesn't exist."
((
UserLight
{
..
},
node_u
)
:
_
)
->
do
...
...
@@ -155,10 +155,11 @@ updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
let
u'
=
UserLight
{
userLight_email
=
fromMaybe
userLight_email
$
view
ui_cwTouchMailL
u_hyperdata'
,
..
}
-- lift $ printDebug "[updateUserInfo] with firstName" u_hyperdata'
_
<-
lift
$
updateHyperdata
(
node_u
^.
node_id
)
u_hyperdata'
_
<-
lift
$
updateUserEmail
u'
--let _newUser = toUser (u, u_hyperdata')
pure
1
lift
$
runDBTx
$
do
_
<-
updateHyperdata
(
node_u
^.
node_id
)
u_hyperdata'
_
<-
updateUserEmail
u'
--let _newUser = toUser (u, u_hyperdata')
pure
1
where
uh
_
Nothing
u_hyperdata
=
u_hyperdata
uh
lens'
(
Just
val
)
u_hyperdata
=
u_hyperdata
&
lens'
?~
val
...
...
@@ -175,7 +176,7 @@ dbUsers user_id = do
-- user <- getUsersWithId user_id
-- hyperdata <- getUserHyperdata user_id
-- lift (map toUser <$> zip user hyperdata)
lift
(
map
toUser
<$>
getUsersWithHyperdata
(
Individu
.
UserDBId
user_id
))
lift
(
map
toUser
<$>
runDBQuery
(
getUsersWithHyperdata
(
Individu
.
UserDBId
user_id
)
))
toUser
::
(
UserLight
,
HyperdataUser
)
->
UserInfo
toUser
(
UserLight
{
..
},
u_hyperdata
)
=
...
...
src/Gargantext/API/Members.hs
View file @
e79541d7
...
...
@@ -15,6 +15,7 @@ import Gargantext.API.Routes.Named.Private qualified as Named
import
Gargantext.Database.Action.Share
(
membersOf
)
import
Gargantext.Database.Admin.Types.Node
(
NodeType
(
NodeTeam
))
import
Gargantext.Database.Query.Table.Node
(
getNodesIdWithType
)
import
Gargantext.Database.Prelude
import
Gargantext.Prelude
import
Servant.Server.Generic
(
AsServerT
)
...
...
@@ -22,7 +23,7 @@ members :: IsGargServer err env m => Named.MembersAPI (AsServerT m)
members
=
Named
.
MembersAPI
getMembers
getMembers
::
IsGargServer
err
env
m
=>
m
[
Text
]
getMembers
=
do
getMembers
=
runDBQuery
$
do
teamNodeIds
<-
getNodesIdWithType
NodeTeam
m
<-
concatMapM
membersOf
teamNodeIds
pure
$
map
fst
m
src/Gargantext/API/Metrics.hs
View file @
e79541d7
...
...
@@ -24,7 +24,7 @@ import Gargantext.API.Ngrams.NgramsTree (NgramsTree)
import
Gargantext.API.Ngrams.Types
(
QueryParamR
,
TabType
,
ngramsTypeFromTabType
,
unNgramsTerm
)
import
Gargantext.API.Prelude
(
IsGargServer
)
import
Gargantext.API.Routes.Named.Metrics
qualified
as
Named
import
Gargantext.Core.NodeStory
(
HasNodeStory
)
import
Gargantext.Core.NodeStory
(
HasNodeStory
,
NodeStoryEnv
,
HasNodeStoryEnv
(
..
)
)
import
Gargantext.Core.Text.Metrics
(
Scored
(
..
),
{-normalizeGlobal,-}
normalizeLocal
)
import
Gargantext.Core.Types
(
CorpusId
,
ListId
,
ListType
(
..
))
import
Gargantext.Core.Types.Query
(
Limit
)
...
...
@@ -34,7 +34,7 @@ import Gargantext.Database.Action.Metrics qualified as Metrics
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.Prelude
(
DBCmd
)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Query.Table.Node
(
defaultList
,
getNodeWith
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
...
...
@@ -42,22 +42,28 @@ import Gargantext.Database.Schema.Node (node_hyperdata)
import
Gargantext.Prelude
hiding
(
hash
)
import
Servant
import
Servant.Server.Generic
(
AsServerT
)
import
Control.Lens
(
view
)
-------------------------------------------------------------
scatterApi
::
IsGargServer
err
env
m
=>
NodeId
->
Named
.
ScatterAPI
(
AsServerT
m
)
scatterApi
id'
=
Named
.
ScatterAPI
{
sepGenEp
=
getScatter
id'
{
sepGenEp
=
\
lid
tt
lm
->
do
env
<-
view
hasNodeStory
runDBTx
$
getScatter
env
id'
lid
tt
lm
,
scatterUpdateEp
=
updateScatter
id'
,
scatterHashEp
=
getScatterHash
id'
,
scatterHashEp
=
\
a
b
->
do
env
<-
view
hasNodeStory
runDBTx
$
getScatterHash
env
id'
a
b
}
getScatter
::
HasNodeStory
env
err
m
=>
CorpusId
getScatter
::
HasNodeError
err
=>
NodeStoryEnv
err
->
CorpusId
->
Maybe
ListId
->
TabType
->
Maybe
Limit
->
m
(
HashedResponse
Metrics
)
getScatter
cId
maybeListId
tabType
_maybeLimit
=
do
->
DBUpdate
err
(
HashedResponse
Metrics
)
getScatter
env
cId
maybeListId
tabType
_maybeLimit
=
do
listId
<-
case
maybeListId
of
Just
lid
->
pure
lid
Nothing
->
defaultList
cId
...
...
@@ -68,7 +74,7 @@ getScatter cId maybeListId tabType _maybeLimit = do
chart
<-
case
mChart
of
Just
chart
->
pure
chart
Nothing
->
do
updateScatter'
cId
listId
tabType
Nothing
updateScatter'
env
cId
listId
tabType
Nothing
pure
$
constructHashedResponse
chart
...
...
@@ -79,24 +85,26 @@ updateScatter :: HasNodeStory env err m
->
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
listId
tabType
maybeLimit
pure
()
updateScatter'
::
HasNodeStory
env
err
m
=>
CorpusId
env
<-
view
hasNodeStory
runDBTx
$
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
void
$
updateScatter'
env
cId
listId
tabType
maybeLimit
updateScatter'
::
HasNodeError
err
=>
NodeStoryEnv
err
->
CorpusId
->
ListId
->
TabType
->
Maybe
Limit
->
m
Metrics
updateScatter'
cId
listId
tabType
maybeLimit
=
do
(
ngs'
,
scores
)
<-
Metrics
.
getMetrics
cId
listId
tabType
maybeLimit
->
DBUpdate
err
Metrics
updateScatter'
env
cId
listId
tabType
maybeLimit
=
do
(
ngs'
,
scores
)
<-
Metrics
.
getMetrics
env
cId
listId
tabType
maybeLimit
let
metrics
=
fmap
(
\
(
Scored
t
s1
s2
)
->
Metric
{
m_label
=
unNgramsTerm
t
...
...
@@ -114,31 +122,34 @@ updateScatter' cId listId tabType maybeLimit = do
pure
$
Metrics
metrics
getScatterHash
::
HasNodeStory
env
err
m
=>
CorpusId
getScatterHash
::
HasNodeError
err
=>
NodeStoryEnv
err
->
CorpusId
->
Maybe
ListId
->
TabType
->
m
Text
getScatterHash
cId
maybeListId
tabType
=
do
hash
<$>
getScatter
cId
maybeListId
tabType
Nothing
->
DBUpdate
err
Text
getScatterHash
env
cId
maybeListId
tabType
=
do
hash
<$>
getScatter
env
cId
maybeListId
tabType
Nothing
-------------------------------------------------------------
chartApi
::
IsGargServer
err
env
m
=>
NodeId
->
Named
.
ChartAPI
(
AsServerT
m
)
chartApi
id'
=
Named
.
ChartAPI
{
getChartEp
=
getChart
id'
{
getChartEp
=
\
st
end
ll
tt
->
do
runDBTx
$
getChart
id'
st
end
ll
tt
,
updateChartEp
=
updateChart
id'
,
chartHashEp
=
getChartHash
id'
,
chartHashEp
=
\
a
b
->
do
runDBTx
$
getChartHash
id'
a
b
}
-- TODO add start / end
getChart
::
HasNode
Story
env
err
m
getChart
::
HasNode
Error
err
=>
CorpusId
->
Maybe
UTCTime
->
Maybe
UTCTime
->
Maybe
ListId
->
TabType
->
m
(
HashedResponse
(
ChartMetrics
Histo
))
->
DBUpdate
err
(
HashedResponse
(
ChartMetrics
Histo
))
getChart
cId
_start
_end
maybeListId
tabType
=
do
listId
<-
case
maybeListId
of
Just
lid
->
pure
lid
...
...
@@ -154,21 +165,21 @@ getChart cId _start _end maybeListId tabType = do
pure
$
constructHashedResponse
chart
updateChart
::
HasNodeError
err
updateChart
::
(
HasNodeError
err
,
IsDBCmd
env
err
m
)
=>
CorpusId
->
Maybe
ListId
->
TabType
->
Maybe
Limit
->
DBCmd
err
()
->
m
()
updateChart
cId
maybeListId
tabType
maybeLimit
=
do
listId
<-
case
maybeListId
of
Just
lid
->
pure
lid
Nothing
->
defaultList
cId
Nothing
->
runDBQuery
$
defaultList
cId
printDebug
"[updateChart] cId"
cId
printDebug
"[updateChart] listId"
listId
printDebug
"[updateChart] tabType"
tabType
printDebug
"[updateChart] maybeLimit"
maybeLimit
_
<-
updateChart'
cId
listId
tabType
maybeLimit
_
<-
runDBTx
$
updateChart'
cId
listId
tabType
maybeLimit
pure
()
updateChart'
::
HasNodeError
err
...
...
@@ -176,7 +187,7 @@ updateChart' :: HasNodeError err
->
ListId
->
TabType
->
Maybe
Limit
->
DB
Cmd
err
(
ChartMetrics
Histo
)
->
DB
Update
err
(
ChartMetrics
Histo
)
updateChart'
cId
listId
tabType
_maybeLimit
=
do
node
<-
getNodeWith
listId
(
Proxy
::
Proxy
HyperdataList
)
let
hl
=
node
^.
node_hyperdata
...
...
@@ -187,11 +198,11 @@ updateChart' cId listId tabType _maybeLimit = do
pure
$
ChartMetrics
h
getChartHash
::
HasNode
Story
env
err
m
getChartHash
::
HasNode
Error
err
=>
CorpusId
->
Maybe
ListId
->
TabType
->
m
Text
->
DBUpdate
err
Text
getChartHash
cId
maybeListId
tabType
=
do
hash
<$>
getChart
cId
Nothing
Nothing
maybeListId
tabType
...
...
@@ -215,19 +226,24 @@ type PieApi = Summary "Pie Chart"
pieApi
::
IsGargServer
err
env
m
=>
NodeId
->
Named
.
PieAPI
(
AsServerT
m
)
pieApi
id'
=
Named
.
PieAPI
{
getPieChartEp
=
getPie
id'
{
getPieChartEp
=
\
st
end
mlt
tt
->
do
env
<-
view
hasNodeStory
runDBTx
$
getPie
env
id'
st
end
mlt
tt
,
pieChartUpdateEp
=
updatePie
id'
,
pieHashEp
=
getPieHash
id'
,
pieHashEp
=
\
a
b
->
do
env
<-
view
hasNodeStory
runDBTx
$
getPieHash
env
id'
a
b
}
getPie
::
HasNodeStory
env
err
m
=>
CorpusId
getPie
::
HasNodeError
err
=>
NodeStoryEnv
err
->
CorpusId
->
Maybe
UTCTime
->
Maybe
UTCTime
->
Maybe
ListId
->
TabType
->
m
(
HashedResponse
(
ChartMetrics
Histo
))
getPie
cId
_start
_end
maybeListId
tabType
=
do
->
DBUpdate
err
(
HashedResponse
(
ChartMetrics
Histo
))
getPie
env
cId
_start
_end
maybeListId
tabType
=
do
listId
<-
case
maybeListId
of
Just
lid
->
pure
lid
Nothing
->
defaultList
cId
...
...
@@ -238,7 +254,7 @@ getPie cId _start _end maybeListId tabType = do
chart
<-
case
mChart
of
Just
chart
->
pure
chart
Nothing
->
do
updatePie'
cId
listId
tabType
Nothing
updatePie'
env
cId
listId
tabType
Nothing
pure
$
constructHashedResponse
chart
...
...
@@ -249,58 +265,66 @@ updatePie :: HasNodeStory env err m
->
Maybe
Limit
->
m
()
updatePie
cId
maybeListId
tabType
maybeLimit
=
do
listId
<-
case
maybeListId
of
Just
lid
->
pure
lid
Nothing
->
defaultList
cId
printDebug
"[updatePie] cId"
cId
printDebug
"[updatePie] maybeListId"
maybeListId
printDebug
"[updatePie] tabType"
tabType
printDebug
"[updatePie] maybeLimit"
maybeLimit
_
<-
updatePie'
cId
listId
tabType
maybeLimit
pure
()
updatePie'
::
(
HasNodeStory
env
err
m
)
=>
CorpusId
env
<-
view
hasNodeStory
runDBTx
$
do
listId
<-
case
maybeListId
of
Just
lid
->
pure
lid
Nothing
->
defaultList
cId
void
$
updatePie'
env
cId
listId
tabType
maybeLimit
updatePie'
::
HasNodeError
err
=>
NodeStoryEnv
err
->
CorpusId
->
ListId
->
TabType
->
Maybe
Limit
->
m
(
ChartMetrics
Histo
)
updatePie'
cId
listId
tabType
_maybeLimit
=
do
->
DBUpdate
err
(
ChartMetrics
Histo
)
updatePie'
env
cId
listId
tabType
_maybeLimit
=
do
node
<-
getNodeWith
listId
(
Proxy
::
Proxy
HyperdataList
)
let
hl
=
node
^.
node_hyperdata
pieMap
=
hl
^.
hl_pie
p
<-
chartData
cId
(
ngramsTypeFromTabType
tabType
)
MapTerm
p
<-
chartData
env
cId
(
ngramsTypeFromTabType
tabType
)
MapTerm
_
<-
updateHyperdata
listId
$
hl
{
_hl_pie
=
HashMap
.
insert
tabType
(
ChartMetrics
p
)
pieMap
}
pure
$
ChartMetrics
p
getPieHash
::
HasNodeStory
env
err
m
=>
CorpusId
getPieHash
::
HasNodeError
err
=>
NodeStoryEnv
err
->
CorpusId
->
Maybe
ListId
->
TabType
->
m
Text
getPieHash
cId
maybeListId
tabType
=
do
hash
<$>
getPie
cId
Nothing
Nothing
maybeListId
tabType
->
DBUpdate
err
Text
getPieHash
env
cId
maybeListId
tabType
=
do
hash
<$>
getPie
env
cId
Nothing
Nothing
maybeListId
tabType
-------------------------------------------------------------
-- | Tree metrics API
treeApi
::
IsGargServer
err
env
m
=>
NodeId
->
Named
.
TreeAPI
(
AsServerT
m
)
treeApi
id'
=
Named
.
TreeAPI
{
treeChartEp
=
getTree
id'
{
treeChartEp
=
\
st
end
mlid
tt
lt
->
do
env
<-
view
hasNodeStory
runDBTx
$
getTree
env
id'
st
end
mlid
tt
lt
,
treeChartUpdateEp
=
updateTree
id'
,
treeHashEp
=
getTreeHash
id'
,
treeHashEp
=
\
a
b
c
->
do
env
<-
view
hasNodeStory
runDBTx
$
getTreeHash
env
id'
a
b
c
}
getTree
::
HasNodeStory
env
err
m
=>
CorpusId
getTree
::
HasNodeError
err
=>
NodeStoryEnv
err
->
CorpusId
->
Maybe
UTCTime
->
Maybe
UTCTime
->
Maybe
ListId
->
TabType
->
ListType
->
m
(
HashedResponse
(
ChartMetrics
(
Vector
NgramsTree
)))
getTree
cId
_start
_end
maybeListId
tabType
listType
=
do
->
DBUpdate
err
(
HashedResponse
(
ChartMetrics
(
Vector
NgramsTree
)))
getTree
env
cId
_start
_end
maybeListId
tabType
listType
=
do
listId
<-
case
maybeListId
of
Just
lid
->
pure
lid
Nothing
->
defaultList
cId
...
...
@@ -311,8 +335,7 @@ getTree cId _start _end maybeListId tabType listType = do
chart
<-
case
mChart
of
Just
chart
->
pure
chart
Nothing
->
do
updateTree'
cId
maybeListId
tabType
listType
Nothing
->
updateTree'
env
cId
maybeListId
tabType
listType
pure
$
constructHashedResponse
chart
...
...
@@ -327,16 +350,18 @@ updateTree cId maybeListId tabType listType = do
printDebug
"[updateTree] maybeListId"
maybeListId
printDebug
"[updateTree] tabType"
tabType
printDebug
"[updateTree] listType"
listType
_
<-
updateTree'
cId
maybeListId
tabType
listType
env
<-
view
hasNodeStory
_
<-
runDBTx
$
updateTree'
env
cId
maybeListId
tabType
listType
pure
()
updateTree'
::
HasNodeStory
env
err
m
=>
CorpusId
updateTree'
::
HasNodeError
err
=>
NodeStoryEnv
err
->
CorpusId
->
Maybe
ListId
->
TabType
->
ListType
->
m
(
ChartMetrics
(
Vector
NgramsTree
))
updateTree'
cId
maybeListId
tabType
listType
=
do
->
DBUpdate
err
(
ChartMetrics
(
Vector
NgramsTree
))
updateTree'
env
cId
maybeListId
tabType
listType
=
do
listId
<-
case
maybeListId
of
Just
lid
->
pure
lid
Nothing
->
defaultList
cId
...
...
@@ -344,16 +369,17 @@ updateTree' cId maybeListId tabType listType = do
node
<-
getNodeWith
listId
(
Proxy
::
Proxy
HyperdataList
)
let
hl
=
node
^.
node_hyperdata
treeMap
=
hl
^.
hl_tree
t
<-
treeData
cId
(
ngramsTypeFromTabType
tabType
)
listType
t
<-
treeData
env
cId
(
ngramsTypeFromTabType
tabType
)
listType
_
<-
updateHyperdata
listId
$
hl
{
_hl_tree
=
HashMap
.
insert
tabType
(
ChartMetrics
t
)
treeMap
}
pure
$
ChartMetrics
t
getTreeHash
::
HasNodeStory
env
err
m
=>
CorpusId
getTreeHash
::
HasNodeError
err
=>
NodeStoryEnv
err
->
CorpusId
->
Maybe
ListId
->
TabType
->
ListType
->
m
Text
getTreeHash
cId
maybeListId
tabType
listType
=
do
hash
<$>
getTree
cId
Nothing
Nothing
maybeListId
tabType
listType
->
DBUpdate
err
Text
getTreeHash
env
cId
maybeListId
tabType
listType
=
do
hash
<$>
getTree
env
cId
Nothing
Nothing
maybeListId
tabType
listType
src/Gargantext/API/Node/Corpus/Export.hs
View file @
e79541d7
...
...
@@ -17,6 +17,7 @@ module Gargantext.API.Node.Corpus.Export
where
import
Control.Exception.Safe
qualified
as
CES
import
Control.Lens
(
view
)
import
Data.List
qualified
as
List
import
Data.Map.Strict
qualified
as
Map
import
Data.Set
qualified
as
Set
...
...
@@ -27,10 +28,12 @@ import Gargantext.API.Node.Corpus.Export.Types ( Corpus(..), CorpusSQLite(..) )
import
Gargantext.API.Node.Corpus.Export.Utils
(
getContextNgrams
,
mkCorpusSQLite
,
mkCorpusSQLiteData
)
import
Gargantext.API.Node.Document.Export.Types
qualified
as
DocumentExport
import
Gargantext.API.Prelude
(
IsGargServer
)
import
Gargantext.Core.NodeStory
import
Gargantext.Core.Text.Ngrams
(
NgramsType
(
..
))
import
Gargantext.Core.Types.Main
(
ListType
(
MapTerm
)
)
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Admin.Types.Hyperdata.Document
(
HyperdataDocument
(
..
)
)
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Prelude
import
Gargantext.Database.Query.Table.Node
(
defaultList
)
import
Gargantext.Database.Query.Table.NodeContext
(
selectDocNodes
)
import
Gargantext.Database.Schema.Context
(
_context_id
)
...
...
@@ -56,35 +59,37 @@ getCorpus cId = Named.CorpusExportAPI {
->
Maybe
NgramsType
->
m
(
Headers
'[
H
eader
"Content-Disposition"
Text
]
Corpus
)
get_corpus
lId
nt'
=
do
let
nt
=
fromMaybe
NgramsTerms
nt'
env
<-
view
hasNodeStory
runDBQuery
$
do
let
nt
=
fromMaybe
NgramsTerms
nt'
listId
<-
case
lId
of
Nothing
->
defaultList
cId
Just
l
->
pure
l
listId
<-
case
lId
of
Nothing
->
defaultList
cId
Just
l
->
pure
l
-- FIXME(adn) Audit the usage of this, we are converting from a node
-- to a context id.
ns
<-
Map
.
fromList
<$>
map
(
\
n
->
(
nodeId2ContextId
$
_context_id
n
,
n
))
<$>
selectDocNodes
cId
-- FIXME(adn) Audit the usage of this, we are converting from a node
-- to a context id.
ns
<-
Map
.
fromList
<$>
map
(
\
n
->
(
nodeId2ContextId
$
_context_id
n
,
n
))
<$>
selectDocNodes
cId
repo
<-
getRepo
[
listId
]
ngs
<-
getContextNgrams
cId
listId
MapTerm
nt
repo
let
-- uniqId is hash computed already for each document imported in database
r
=
Map
.
intersectionWith
(
\
a
b
->
DocumentExport
.
Document
{
_d_document
=
context2node
a
,
_d_ngrams
=
DocumentExport
.
Ngrams
(
Set
.
toList
b
)
(
hash
b
)
,
_d_hash
=
d_hash
a
b
}
)
ns
(
Map
.
map
(
Set
.
map
unNgramsTerm
)
ngs
)
where
d_hash
::
Context
HyperdataDocument
->
Set
Text
->
Text
d_hash
_a
b
=
hash
[
-- fromMaybe "" (_hd_uniqId $ _context_hyperdata a),
hash
b
]
pure
$
addHeader
(
"attachment; filename=GarganText_corpus-"
<>
pack
(
show
cId
)
<>
".json"
)
$
Corpus
{
_c_corpus
=
Map
.
elems
r
,
_c_hash
=
hash
$
List
.
map
DocumentExport
.
_d_hash
$
Map
.
elems
r
}
repo
<-
getRepo
env
[
listId
]
ngs
<-
getContextNgrams
cId
listId
MapTerm
nt
repo
let
-- uniqId is hash computed already for each document imported in database
r
=
Map
.
intersectionWith
(
\
a
b
->
DocumentExport
.
Document
{
_d_document
=
context2node
a
,
_d_ngrams
=
DocumentExport
.
Ngrams
(
Set
.
toList
b
)
(
hash
b
)
,
_d_hash
=
d_hash
a
b
}
)
ns
(
Map
.
map
(
Set
.
map
unNgramsTerm
)
ngs
)
where
d_hash
::
Context
HyperdataDocument
->
Set
Text
->
Text
d_hash
_a
b
=
hash
[
-- fromMaybe "" (_hd_uniqId $ _context_hyperdata a),
hash
b
]
pure
$
addHeader
(
"attachment; filename=GarganText_corpus-"
<>
pack
(
show
cId
)
<>
".json"
)
$
Corpus
{
_c_corpus
=
Map
.
elems
r
,
_c_hash
=
hash
$
List
.
map
DocumentExport
.
_d_hash
$
Map
.
elems
r
}
getCorpusSQLite
::
(
CES
.
MonadMask
m
...
...
src/Gargantext/API/Node/Document/Export.hs
View file @
e79541d7
...
...
@@ -28,6 +28,7 @@ import Gargantext.API.Prelude (IsGargServer)
import
Gargantext.API.Routes.Named.Document
qualified
as
Named
import
Gargantext.Core
(
toDBid
)
import
Gargantext.Database.Admin.Types.Node
(
DocId
,
NodeId
,
NodeType
(
..
))
import
Gargantext.Database.Prelude
import
Gargantext.Database.Query.Facet
(
runViewDocuments
,
Facet
(
..
))
import
Gargantext.Database.Query.Table.Node
(
getClosestParentIdByType
)
import
Gargantext.Database.Query.Table.Node.User
(
getNodeUser
)
...
...
@@ -64,12 +65,13 @@ getDocumentsJSON nodeUserId pId = do
get_document_json
::
IsGargServer
err
env
m
=>
NodeId
->
DocId
->
m
DocumentExport
get_document_json
nodeUserId
pId
=
do
uId
<-
view
node_user_id
<$>
getNodeUser
nodeUserId
mcId
<-
getClosestParentIdByType
pId
NodeCorpus
let
cId
=
maybe
(
panicTrace
"[G.A.N.D.Export] Node has no parent"
)
identity
mcId
docs
<-
runViewDocuments
cId
False
Nothing
Nothing
Nothing
Nothing
Nothing
pure
DocumentExport
{
_de_documents
=
mapFacetDoc
uId
<$>
docs
,
_de_garg_version
=
T
.
pack
$
showVersion
PG
.
version
}
runDBQuery
$
do
uId
<-
view
node_user_id
<$>
getNodeUser
nodeUserId
mcId
<-
getClosestParentIdByType
pId
NodeCorpus
let
cId
=
maybe
(
panicTrace
"[G.A.N.D.Export] Node has no parent"
)
identity
mcId
docs
<-
runViewDocuments
cId
False
Nothing
Nothing
Nothing
Nothing
Nothing
pure
DocumentExport
{
_de_documents
=
mapFacetDoc
uId
<$>
docs
,
_de_garg_version
=
T
.
pack
$
showVersion
PG
.
version
}
where
mapFacetDoc
uId
(
FacetDoc
{
..
})
=
Document
{
_d_document
=
...
...
src/Gargantext/API/Node/Phylo/Export.hs
View file @
e79541d7
...
...
@@ -18,6 +18,7 @@ import Gargantext.API.Routes.Named.Viz qualified as Named
import
Gargantext.Core.Viz.Phylo.API.Tools
(
getPhyloData
,
phylo2dot
,
phylo2dot2json
)
import
Gargantext.Core.Viz.Phylo.Example
(
phyloCleopatre
)
import
Gargantext.Database.Admin.Types.Node
(
PhyloId
,
NodeId
)
import
Gargantext.Database.Prelude
import
Gargantext.Prelude
import
Servant
import
Servant.Server.Generic
(
AsServerT
)
...
...
@@ -37,7 +38,7 @@ getPhyloJson :: NodeId
->
PhyloId
->
GargNoServer
(
Headers
'[
H
eader
"Content-Disposition"
T
.
Text
]
Value
)
getPhyloJson
_
pId
=
do
maybePhyloData
<-
getPhyloData
pId
maybePhyloData
<-
runDBQuery
$
getPhyloData
pId
let
phyloData
=
fromMaybe
phyloCleopatre
maybePhyloData
phyloJson
<-
liftBase
$
phylo2dot2json
phyloData
pure
$
addHeader
(
T
.
concat
[
"attachment; filename="
...
...
@@ -51,7 +52,7 @@ getPhyloDot :: NodeId
->
PhyloId
->
GargNoServer
(
Headers
'[
H
eader
"Content-Disposition"
T
.
Text
]
T
.
Text
)
getPhyloDot
_
pId
=
do
maybePhyloData
<-
getPhyloData
pId
maybePhyloData
<-
runDBQuery
$
getPhyloData
pId
let
phyloData
=
fromMaybe
phyloCleopatre
maybePhyloData
phyloDot
<-
liftBase
$
phylo2dot
phyloData
pure
$
addHeader
(
T
.
concat
[
"attachment; filename="
...
...
src/Gargantext/API/Search.hs
View file @
e79541d7
...
...
@@ -28,6 +28,7 @@ import Gargantext.Core.Types.Search (toRow)
import
Gargantext.Database.Action.Flow.Pairing
(
isPairedWith
)
import
Gargantext.Database.Action.Search
(
searchInCorpus
,
searchInCorpusWithContacts
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
,
NodeType
(
..
))
import
Gargantext.Database.Prelude
import
Gargantext.Prelude
import
Gargantext.System.Logging
(
logLocM
,
LogLevel
(
..
))
import
Servant.Server.Generic
(
AsServerT
)
...
...
@@ -44,10 +45,10 @@ api nId = Named.SearchAPI $ \query o l order -> case query of
$
(
logLocM
)
DEBUG
$
T
.
pack
"New search started with query = "
<>
(
getRawQuery
rawQuery
)
SearchResult
<$>
SearchResultDoc
<$>
map
(
toRow
nId
)
<$>
searchInCorpus
nId
False
q
o
l
order
<$>
runDBQuery
(
searchInCorpus
nId
False
q
o
l
order
)
(
SearchQuery
rawQuery
SearchContact
)
->
case
parseQuery
rawQuery
of
Left
err
->
pure
$
SearchResult
$
SearchNoResult
(
T
.
pack
err
)
Right
q
->
do
Right
q
->
runDBQuery
$
do
-- printDebug "isPairedWith" nId
aIds
<-
isPairedWith
nId
NodeAnnuaire
-- TODO if paired with several corpus
...
...
src/Gargantext/API/Table.hs
View file @
e79541d7
...
...
@@ -41,7 +41,7 @@ import Gargantext.Core.Types.Query (Offset, Limit)
import
Gargantext.Database.Action.Learn
(
FavOrTrash
(
..
),
moreLike
)
import
Gargantext.Database.Action.Search
(
searchCountInCorpus
,
searchInCorpus
)
import
Gargantext.Database.Admin.Types.Node
(
ContactId
,
CorpusId
,
NodeId
)
import
Gargantext.Database.Prelude
(
IsDBCmdExtra
,
IsDBCmd
,
DBCmd
)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Query.Facet
(
FacetDoc
,
runViewDocuments
,
runCountDocuments
,
OrderBy
(
..
),
runViewAuthorsDoc
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Prelude
...
...
@@ -81,7 +81,7 @@ getTableApi cId tabType mLimit mOffset mOrderBy mQuery mYear =
where
get_table
=
do
$
(
logLocM
)
DEBUG
$
"getTable cId = "
<>
T
.
pack
(
show
cId
)
t
<-
getTable
cId
tabType
mOffset
mLimit
mOrderBy
mQuery
mYear
t
<-
runDBQuery
$
getTable
cId
tabType
mOffset
mLimit
mOrderBy
mQuery
mYear
pure
$
constructHashedResponse
t
postTableApi
::
(
IsDBCmdExtra
env
err
m
,
MonadLogger
m
,
HasNodeError
err
)
...
...
@@ -91,7 +91,7 @@ postTableApi :: (IsDBCmdExtra env err m, MonadLogger m, HasNodeError err)
postTableApi
cId
tq
=
case
tq
of
TableQuery
o
l
order
ft
""
->
do
$
(
logLocM
)
DEBUG
$
"New search with no query"
getTable
cId
(
Just
ft
)
(
Just
o
)
(
Just
l
)
(
Just
order
)
Nothing
Nothing
runDBQuery
$
getTable
cId
(
Just
ft
)
(
Just
o
)
(
Just
l
)
(
Just
order
)
Nothing
Nothing
TableQuery
o
l
order
ft
q
->
case
ft
of
Docs
->
do
$
(
logLocM
)
DEBUG
$
"New search with query "
<>
getRawQuery
q
...
...
@@ -121,7 +121,7 @@ searchInCorpus' cId t q o l order = do
Left
noParseErr
->
do
$
(
logLocM
)
ERROR
$
"Invalid input query "
<>
(
getRawQuery
q
)
<>
" , error = "
<>
(
T
.
pack
noParseErr
)
pure
$
TableResult
0
[]
Right
boolQuery
->
do
Right
boolQuery
->
runDBQuery
$
do
docs
<-
searchInCorpus
cId
t
boolQuery
o
l
order
countAllDocs
<-
searchCountInCorpus
cId
t
(
Just
boolQuery
)
pure
$
TableResult
{
tr_docs
=
docs
...
...
@@ -136,7 +136,7 @@ getTable :: HasNodeError err
->
Maybe
OrderBy
->
Maybe
RawQuery
->
Maybe
Text
->
DB
Cmd
err
FacetTableResult
->
DB
Query
err
x
FacetTableResult
getTable
cId
ft
o
l
order
raw_query
year
=
do
docs
<-
getTable'
cId
ft
o
l
order
query
year
docsCount
<-
runCountDocuments
cId
(
ft
==
Just
Trash
)
query
year
...
...
@@ -152,7 +152,7 @@ getTable' :: HasNodeError err
->
Maybe
OrderBy
->
Maybe
Text
->
Maybe
Text
->
DB
Cmd
err
[
FacetDoc
]
->
DB
Query
err
x
[
FacetDoc
]
getTable'
cId
ft
o
l
order
query
year
=
case
ft
of
(
Just
Docs
)
->
runViewDocuments
cId
False
o
l
order
query
year
...
...
@@ -164,7 +164,7 @@ getTable' cId ft o l order query year =
getPair
::
ContactId
->
Maybe
TabType
->
Maybe
Offset
->
Maybe
Limit
->
Maybe
OrderBy
->
DB
Cmd
err
[
FacetDoc
]
->
Maybe
OrderBy
->
DB
Query
err
x
[
FacetDoc
]
getPair
cId
ft
o
l
order
=
case
ft
of
(
Just
Docs
)
->
runViewAuthorsDoc
cId
False
o
l
order
...
...
src/Gargantext/Core/Viz/Chart.hs
View file @
e79541d7
...
...
@@ -28,7 +28,7 @@ import Gargantext.Database.Admin.Types.Node ( NodeType(NodeList), CorpusId, cont
import
Gargantext.Core.Viz.Types
(
Histo
(
Histo
)
)
import
Gargantext.Database.Action.Metrics.NgramsByContext
(
countContextsByNgramsWith
,
getContextsByNgramsOnlyUser
)
import
Gargantext.Database.Admin.Config
(
userMaster
)
import
Gargantext.Database.Prelude
(
DB
Cmd
,
DBQuery
,
runDB
Query
)
import
Gargantext.Database.Prelude
(
DBQuery
)
import
Gargantext.Database.Query.Table.Node
(
getListsWithParentId
)
import
Gargantext.Database.Query.Table.Node.Select
(
selectNodesWithUsername
)
import
Gargantext.Database.Query.Table.NodeContext
(
selectDocsDates
)
...
...
@@ -36,9 +36,9 @@ import Gargantext.Database.Schema.Node ( NodePoly(_node_id) )
import
Gargantext.Prelude
hiding
(
toList
)
histoData
::
CorpusId
->
DB
Cmd
err
Histo
histoData
::
CorpusId
->
DB
Query
err
x
Histo
histoData
cId
=
do
dates
<-
runDBQuery
$
selectDocsDates
cId
dates
<-
selectDocsDates
cId
let
(
ls
,
css
)
=
V
.
unzip
$
V
.
fromList
$
sortOn
fst
-- TODO Vector.sortOn
...
...
src/Gargantext/Core/Viz/Phylo/API.hs
View file @
e79541d7
...
...
@@ -28,6 +28,7 @@ import Gargantext.Core.Types.Phylo (GraphData(..))
import
Gargantext.Core.Viz.LegacyPhylo
hiding
(
Phylo
(
..
))
import
Gargantext.Core.Viz.Phylo
(
PhyloConfig
(
..
),
defaultConfig
,
_phylo_param
,
_phyloParam_config
)
import
Gargantext.Core.Viz.Phylo.API.Tools
import
Gargantext.Database.Prelude
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Node
-- (PhyloId, ListId, CorpusId, UserId, NodeId(..))
import
Gargantext.Database.Query.Table.Node
(
getClosestParentIdByType
,
defaultList
)
...
...
@@ -50,12 +51,13 @@ phyloAPI n = Named.PhyloAPI
-- Add real text processing
-- Fix Filter parameters
-- TODO fix parameters to default config that should be in Node
-- NOTE(adn) this is not DB-tx safe in regards to reads.
getPhylo
::
IsGargServer
err
env
m
=>
PhyloId
->
Named
.
GetPhylo
(
AsServerT
m
)
getPhylo
phyloId
=
Named
.
GetPhylo
$
\
lId
_level
_minSizeBranch
->
do
corpusId
<-
maybe
(
nodeLookupError
$
NodeParentDoesNotExist
phyloId
)
pure
=<<
getClosestParentIdByType
phyloId
NodeCorpus
=<<
(
runDBQuery
$
getClosestParentIdByType
phyloId
NodeCorpus
)
listId
<-
case
lId
of
Nothing
->
defaultList
corpusId
Nothing
->
runDBQuery
$
defaultList
corpusId
Just
ld
->
pure
ld
pd
<-
getPhyloDataJson
phyloId
-- printDebug "getPhylo" theData
...
...
@@ -68,7 +70,7 @@ getPhylo phyloId = Named.GetPhylo $ \lId _level _minSizeBranch -> do
getPhyloDataJson
::
PhyloId
->
GargNoServer
(
Maybe
(
GraphData
,
PhyloConfig
))
getPhyloDataJson
phyloId
=
do
phyloData
<-
getPhyloData
phyloId
phyloData
<-
runDBQuery
$
getPhyloData
phyloId
phyloJson
<-
liftBase
$
maybePhylo2dot2json
phyloData
case
phyloJson
of
Nothing
->
pure
Nothing
...
...
@@ -92,6 +94,8 @@ getPhyloDataJson phyloId = do
-- pure (SVG p)
-- FIXME(adn) This handler mixes DB reads with updates outside of the same
-- transaction, due to the call to 'flowPhyloAPI' in the middle.
postPhylo
::
IsGargServer
err
env
m
=>
PhyloId
->
Named
.
PostPhylo
(
AsServerT
m
)
postPhylo
phyloId
=
Named
.
PostPhylo
$
\
_lId
->
do
-- TODO get Reader settings
...
...
@@ -100,12 +104,12 @@ postPhylo phyloId = Named.PostPhylo $ \_lId -> do
-- _vrs = Just ("1" :: Text)
-- _sft = Just (Software "Gargantext" "4")
-- _prm = initPhyloParam vrs sft (Just q)
corpusId
<-
getClosestParentIdByType
phyloId
NodeCorpus
corpusId
<-
runDBQuery
$
getClosestParentIdByType
phyloId
NodeCorpus
-- Being the first time we ask for the Phylo, there is no historical data
-- available about computing time, so we pass 'Nothing'.
phy
<-
flowPhyloAPI
defaultConfig
Nothing
(
fromMaybe
(
panicTrace
"[G.C.V.P.API] no corpus ID found"
)
corpusId
)
-- params
-- phyloId <- insertNodes [node NodePhylo "Phylo" (HyperdataPhylo Nothing (Just phy)) (Just corpusId) userId]
_
<-
updateHyperdata
phyloId
(
HyperdataPhylo
Nothing
(
Just
phy
))
_
<-
runDBTx
$
updateHyperdata
phyloId
(
HyperdataPhylo
Nothing
(
Just
phy
))
pure
phyloId
------------------------------------------------------------------------
...
...
src/Gargantext/Database/Action/Learn.hs
View file @
e79541d7
...
...
@@ -34,21 +34,21 @@ data FavOrTrash = IsFav | IsTrash
moreLike
::
(
HasDBid
NodeType
,
HasNodeError
err
)
=>
CorpusId
->
Maybe
Offset
->
Maybe
Limit
->
Maybe
OrderBy
->
FavOrTrash
->
DB
Cmd
err
[
FacetDoc
]
->
FavOrTrash
->
DB
Query
err
x
[
FacetDoc
]
moreLike
cId
o
_l
order
ft
=
do
priors
<-
getPriors
ft
cId
moreLikeWith
cId
o
(
Just
3
)
order
ft
priors
---------------------------------------------------------------------------
getPriors
::
(
HasDBid
NodeType
,
HasNodeError
err
)
=>
FavOrTrash
->
CorpusId
->
DB
Cmd
err
(
Events
Bool
)
=>
FavOrTrash
->
CorpusId
->
DB
Query
err
x
(
Events
Bool
)
getPriors
ft
cId
=
do
docs_fav
<-
filter
(
\
(
FacetDoc
_
_
_
_
f
_
_
)
->
f
==
Just
2
)
<$>
run
DBQuery
(
runViewDocuments
cId
False
Nothing
Nothing
Nothing
Nothing
Nothing
)
<$>
run
ViewDocuments
cId
False
Nothing
Nothing
Nothing
Nothing
Nothing
docs_trash
<-
List
.
take
(
List
.
length
docs_fav
)
<$>
run
DBQuery
(
runViewDocuments
cId
True
Nothing
Nothing
Nothing
Nothing
Nothing
)
<$>
run
ViewDocuments
cId
True
Nothing
Nothing
Nothing
Nothing
Nothing
let
priors
=
priorEventsWith
text
(
fav2bool
ft
)
(
List
.
zip
(
repeat
False
)
docs_fav
...
...
@@ -59,11 +59,11 @@ getPriors ft cId = do
moreLikeWith
::
(
HasDBid
NodeType
,
HasNodeError
err
)
=>
CorpusId
->
Maybe
Offset
->
Maybe
Limit
->
Maybe
OrderBy
->
FavOrTrash
->
Events
Bool
->
DB
Cmd
err
[
FacetDoc
]
->
FavOrTrash
->
Events
Bool
->
DB
Query
err
x
[
FacetDoc
]
moreLikeWith
cId
o
l
order
ft
priors
=
do
docs_test
<-
filter
(
\
(
FacetDoc
_
_
_
_
f
_
_
)
->
f
==
Just
1
)
<$>
run
DBQuery
(
runViewDocuments
cId
False
o
Nothing
order
Nothing
Nothing
)
<$>
run
ViewDocuments
cId
False
o
Nothing
order
Nothing
Nothing
let
results
=
map
fst
$
filter
((
==
)
(
Just
$
not
$
fav2bool
ft
)
.
snd
)
...
...
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