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
0
Issues
0
List
Board
Labels
Milestones
Merge Requests
0
Merge Requests
0
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
Christian Merten
haskell-gargantext
Commits
4ef66cea
Commit
4ef66cea
authored
Oct 12, 2023
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Plain Diff
Merge remote-tracking branch 'origin/dev-typeclasses-refactoring' into dev
parents
aa230640
a2e7a40c
Changes
63
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
63 changed files
with
500 additions
and
495 deletions
+500
-495
API.hs
src/Gargantext/API.hs
+3
-5
Auth.hs
src/Gargantext/API/Admin/Auth.hs
+8
-8
Context.hs
src/Gargantext/API/Context.hs
+1
-1
Dev.hs
src/Gargantext/API/Dev.hs
+5
-5
Context.hs
src/Gargantext/API/GraphQL/Context.hs
+2
-2
PolicyCheck.hs
src/Gargantext/API/GraphQL/PolicyCheck.hs
+1
-1
User.hs
src/Gargantext/API/GraphQL/User.hs
+8
-12
Metrics.hs
src/Gargantext/API/Metrics.hs
+20
-20
Ngrams.hs
src/Gargantext/API/Ngrams.hs
+50
-53
List.hs
src/Gargantext/API/Ngrams/List.hs
+16
-17
Prelude.hs
src/Gargantext/API/Ngrams/Prelude.hs
+1
-1
Tools.hs
src/Gargantext/API/Ngrams/Tools.hs
+2
-2
Node.hs
src/Gargantext/API/Node.hs
+10
-10
Export.hs
src/Gargantext/API/Node/Corpus/Export.hs
+11
-12
File.hs
src/Gargantext/API/Node/Corpus/New/File.hs
+1
-1
Searx.hs
src/Gargantext/API/Node/Corpus/Searx.hs
+33
-24
Update.hs
src/Gargantext/API/Node/Corpus/Update.hs
+1
-1
New.hs
src/Gargantext/API/Node/New.hs
+1
-1
Share.hs
src/Gargantext/API/Node/Share.hs
+1
-1
Prelude.hs
src/Gargantext/API/Prelude.hs
+8
-8
Public.hs
src/Gargantext/API/Public.hs
+2
-2
Table.hs
src/Gargantext/API/Table.hs
+10
-11
Mail.hs
src/Gargantext/Core/Mail.hs
+3
-3
NodeStoryFile.hs
src/Gargantext/Core/NodeStoryFile.hs
+2
-2
List.hs
src/Gargantext/Core/Text/List.hs
+12
-14
Social.hs
src/Gargantext/Core/Text/List/Social.hs
+24
-36
Find.hs
src/Gargantext/Core/Text/List/Social/Find.hs
+5
-3
Chart.hs
src/Gargantext/Core/Viz/Chart.hs
+1
-1
API.hs
src/Gargantext/Core/Viz/Graph/API.hs
+19
-23
LegacyMain.hs
src/Gargantext/Core/Viz/Phylo/Legacy/LegacyMain.hs
+11
-19
Database.hs
src/Gargantext/Database.hs
+3
-3
Flow.hs
src/Gargantext/Database/Action/Flow.hs
+55
-20
List.hs
src/Gargantext/Database/Action/Flow/List.hs
+14
-15
Pairing.hs
src/Gargantext/Database/Action/Flow/Pairing.hs
+8
-8
Learn.hs
src/Gargantext/Database/Action/Learn.hs
+7
-7
Mail.hs
src/Gargantext/Database/Action/Mail.hs
+1
-1
Metrics.hs
src/Gargantext/Database/Action/Metrics.hs
+2
-4
NgramsByContext.hs
src/Gargantext/Database/Action/Metrics/NgramsByContext.hs
+5
-5
TFICF.hs
src/Gargantext/Database/Action/Metrics/TFICF.hs
+5
-5
Node.hs
src/Gargantext/Database/Action/Node.hs
+1
-1
Share.hs
src/Gargantext/Database/Action/Share.hs
+2
-2
TSQuery.hs
src/Gargantext/Database/Action/TSQuery.hs
+16
-3
New.hs
src/Gargantext/Database/Action/User/New.hs
+3
-3
Prelude.hs
src/Gargantext/Database/Prelude.hs
+7
-11
Facet.hs
src/Gargantext/Database/Query/Facet.hs
+5
-5
Context.hs
src/Gargantext/Database/Query/Table/Context.hs
+9
-7
Ngrams.hs
src/Gargantext/Database/Query/Table/Ngrams.hs
+7
-7
NgramsPostag.hs
src/Gargantext/Database/Query/Table/NgramsPostag.hs
+3
-3
Node.hs
src/Gargantext/Database/Query/Table/Node.hs
+4
-6
Children.hs
src/Gargantext/Database/Query/Table/Node/Children.hs
+3
-7
Add.hs
src/Gargantext/Database/Query/Table/Node/Document/Add.hs
+3
-3
Select.hs
src/Gargantext/Database/Query/Table/Node/Select.hs
+4
-6
Update.hs
src/Gargantext/Database/Query/Table/Node/Update.hs
+2
-2
UpdateOpaleye.hs
src/Gargantext/Database/Query/Table/Node/UpdateOpaleye.hs
+4
-4
User.hs
src/Gargantext/Database/Query/Table/Node/User.hs
+2
-2
NodeContext.hs
src/Gargantext/Database/Query/Table/NodeContext.hs
+6
-8
NodeContext_NodeContext.hs
...argantext/Database/Query/Table/NodeContext_NodeContext.hs
+2
-2
NodeNgrams.hs
src/Gargantext/Database/Query/Table/NodeNgrams.hs
+4
-6
NodeNode.hs
src/Gargantext/Database/Query/Table/NodeNode.hs
+4
-4
NodeNodeNgrams.hs
src/Gargantext/Database/Query/Table/NodeNodeNgrams.hs
+3
-3
User.hs
src/Gargantext/Database/Query/Table/User.hs
+16
-16
Tree.hs
src/Gargantext/Database/Query/Tree.hs
+17
-17
Types.hs
test/Test/Database/Types.hs
+1
-0
No files found.
src/Gargantext/API.hs
View file @
4ef66cea
...
...
@@ -56,9 +56,9 @@ import Gargantext.API.Ngrams (saveNodeStoryImmediate)
import
Gargantext.API.Routes
import
Gargantext.API.Server
(
server
)
import
Gargantext.Core.NodeStory
-- import Gargantext.Database.Prelude (Cmd)
-- import Gargantext.Database.Action.Metrics.NgramsByContext (refreshNgramsMaterialized)
import
Gargantext.Database.Prelude
qualified
as
DB
import
Gargantext.Prelude
hiding
(
putStrLn
)
import
Gargantext.System.Logging
import
Network.HTTP.Types
hiding
(
Query
)
import
Network.Wai
import
Network.Wai.Handler.Warp
hiding
(
defaultSettings
)
...
...
@@ -66,10 +66,8 @@ import Network.Wai.Middleware.Cors
import
Network.Wai.Middleware.RequestLogger
import
Paths_gargantext
(
getDataDir
)
import
Servant
import
System.Cron.Schedule
qualified
as
Cron
import
System.FilePath
import
qualified
Gargantext.Database.Prelude
as
DB
import
qualified
System.Cron.Schedule
as
Cron
import
Gargantext.System.Logging
-- | startGargantext takes as parameters port number and Ini file.
startGargantext
::
Mode
->
PortNumber
->
FilePath
->
IO
()
...
...
src/Gargantext/API/Admin/Auth.hs
View file @
4ef66cea
...
...
@@ -58,7 +58,7 @@ import Gargantext.Core.Mail.Types (mailSettings)
import
Gargantext.Core.Types.Individu
(
User
(
..
),
Username
,
GargPassword
(
..
))
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
(
..
))
import
Gargantext.Database.Prelude
(
Cmd
'
,
Cmd
M
,
CmdCommon
)
import
Gargantext.Database.Prelude
(
Cmd
'
,
Cmd
Common
,
DbCmd
'
)
import
Gargantext.Database.Query.Table.User
import
Gargantext.Database.Query.Tree
(
isDescendantOf
,
isIn
)
import
Gargantext.Database.Query.Tree.Root
(
getRoot
)
...
...
@@ -79,7 +79,8 @@ import Gargantext.API.Auth.PolicyCheck
-- | Main functions of authorization
makeTokenForUser
::
(
HasSettings
env
,
HasJoseError
err
)
makeTokenForUser
::
(
HasSettings
env
,
HasJoseError
err
)
=>
NodeId
->
Cmd'
env
err
Token
makeTokenForUser
uid
=
do
jwtS
<-
view
$
settings
.
jwtSettings
...
...
@@ -88,10 +89,10 @@ makeTokenForUser uid = do
either
joseError
(
pure
.
toStrict
.
LE
.
decodeUtf8
)
e
-- TODO not sure about the encoding...
checkAuthRequest
::
(
HasSettings
env
,
CmdCommon
env
,
HasJoseError
err
)
checkAuthRequest
::
(
HasSettings
env
,
HasJoseError
err
,
DbCmd'
env
err
m
)
=>
Username
->
GargPassword
->
Cmd'
env
err
CheckAuth
->
m
CheckAuth
checkAuthRequest
couldBeEmail
(
GargPassword
p
)
=
do
-- Sometimes user put email instead of username
-- hence we have to check before
...
...
@@ -113,8 +114,8 @@ checkAuthRequest couldBeEmail (GargPassword p) = do
token
<-
makeTokenForUser
uid
pure
$
Valid
token
uid
userLight_id
auth
::
(
HasSettings
env
,
CmdCommon
env
,
HasJoseError
err
)
=>
AuthRequest
->
Cmd'
env
err
AuthResponse
auth
::
(
HasSettings
env
,
HasJoseError
err
,
DbCmd'
env
err
m
)
=>
AuthRequest
->
m
AuthResponse
auth
(
AuthRequest
u
p
)
=
do
checkAuthRequest'
<-
checkAuthRequest
u
p
case
checkAuthRequest'
of
...
...
@@ -135,7 +136,7 @@ authCheck _env (BasicAuthData login password) = pure $
maybe Indefinite Authenticated $ TODO
-}
withAccessM
::
(
CmdM
env
err
m
,
HasServerError
err
)
withAccessM
::
(
DbCmd'
env
err
m
)
=>
AuthenticatedUser
->
PathId
->
m
a
...
...
@@ -143,7 +144,6 @@ withAccessM :: (CmdM env err m, HasServerError err)
withAccessM
(
AuthenticatedUser
uId
)
(
PathNode
id
)
m
=
do
d
<-
id
`
isDescendantOf
`
uId
if
d
then
m
else
m
-- serverError err401
withAccessM
(
AuthenticatedUser
uId
)
(
PathNodeNode
cId
docId
)
m
=
do
_a
<-
isIn
cId
docId
-- TODO use one query for all ?
_d
<-
cId
`
isDescendantOf
`
uId
...
...
src/Gargantext/API/Context.hs
View file @
4ef66cea
...
...
@@ -25,7 +25,7 @@ import Gargantext.API.Admin.Auth (withAccess)
import
Gargantext.API.Admin.Auth.Types
(
PathId
(
..
),
AuthenticatedUser
)
import
Gargantext.API.Prelude
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Prelude
-- (Cmd, CmdM
)
import
Gargantext.Database.Prelude
(
JSONB
)
import
Gargantext.Database.Query.Table.Context
-------------------------------------------------------------------
...
...
src/Gargantext/API/Dev.hs
View file @
4ef66cea
...
...
@@ -14,22 +14,22 @@ module Gargantext.API.Dev where
import
Control.Exception
(
finally
)
import
Control.Monad
(
fail
)
import
Control.Monad.Reader
(
runReaderT
)
import
Control.Monad.Except
(
runExceptT
)
import
Control.Monad.Reader
(
runReaderT
)
import
Gargantext.API.Admin.EnvTypes
import
Gargantext.API.Admin.Settings
import
Gargantext.API.Ngrams
(
saveNodeStoryImmediate
)
import
Gargantext.API.Prelude
import
Gargantext.Core.NLP
(
nlpServerMap
)
import
Gargantext.Core.NodeStory
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
Cmd
'
,
Cmd
''
,
databaseParameters
,
runCmd
)
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
(
readConfig
)
import
qualified
Gargantext.Prelude.Mail
as
Mail
import
qualified
Gargantext.Prelude.NLP
as
NLP
import
Gargantext.Prelude.Mail
qualified
as
Mail
import
Gargantext.Prelude.NLP
qualified
as
NLP
import
Gargantext.System.Logging
import
Servant
import
System.IO
(
FilePath
)
import
Gargantext.System.Logging
type
IniPath
=
FilePath
-------------------------------------------------------------------
...
...
src/Gargantext/API/GraphQL/Context.hs
View file @
4ef66cea
...
...
@@ -211,8 +211,8 @@ toHyperdataRowDocumentGQL hyperdata =
}
HyperdataRowContact
{
}
->
Nothing
updateNodeContextCategory
::
(
CmdCommon
env
,
HasSettings
env
)
=>
NodeContextCategoryMArgs
->
GqlM'
e
env
[
Int
]
updateNodeContextCategory
::
(
CmdCommon
env
,
HasSettings
env
)
=>
NodeContextCategoryMArgs
->
GqlM'
e
env
[
Int
]
updateNodeContextCategory
NodeContextCategoryMArgs
{
context_id
,
node_id
,
category
}
=
do
_
<-
lift
$
DNC
.
updateNodeContextCategory
(
NodeId
context_id
)
(
NodeId
node_id
)
category
...
...
src/Gargantext/API/GraphQL/PolicyCheck.hs
View file @
4ef66cea
...
...
@@ -8,7 +8,7 @@ import Gargantext.API.Admin.Auth.Types
import
Gargantext.API.Auth.PolicyCheck
import
Gargantext.API.GraphQL.Types
import
Gargantext.API.Prelude
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
HasConnectionPool
,
HasConfig
)
withPolicy
::
(
HasConnectionPool
env
,
HasConfig
env
)
=>
AuthenticatedUser
...
...
src/Gargantext/API/GraphQL/User.hs
View file @
4ef66cea
...
...
@@ -4,24 +4,21 @@
module
Gargantext.API.GraphQL.User
where
import
Data.Maybe
(
listToMaybe
)
import
Data.Morpheus.Types
(
GQLType
,
lift
)
import
Data.Morpheus.Types
(
GQLType
,
lift
)
import
Data.Text
(
Text
)
import
GHC.Generics
(
Generic
)
import
Gargantext.API.Admin.Auth.Types
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Auth.PolicyCheck
import
Gargantext.API.GraphQL.PolicyCheck
import
Gargantext.API.GraphQL.Types
import
Gargantext.Core.Types.Individu
qualified
as
Individu
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataUser
(
..
))
import
Gargantext.Database.Admin.Types.Node
(
NodeId
(
..
))
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
Gargantext.Database.Query.Table.User
qualified
as
DBUser
import
Gargantext.Database.Schema.User
(
UserLight
(
..
))
import
Gargantext.Prelude
import
qualified
Gargantext.Core.Types.Individu
as
Individu
import
qualified
Gargantext.Database.Query.Table.User
as
DBUser
import
Gargantext.API.Admin.Auth.Types
import
Gargantext.API.Auth.PolicyCheck
import
Gargantext.API.GraphQL.PolicyCheck
data
User
m
=
User
{
u_email
::
Text
...
...
@@ -54,9 +51,8 @@ resolveUsers autUser mgr UserArgs { user_id } = do
withPolicy
autUser
mgr
alwaysAllow
$
dbUsers
user_id
-- | Inner function to fetch the user from DB.
dbUsers
::
(
CmdCommon
env
)
=>
Int
->
GqlM
e
env
[
User
(
GqlM
e
env
)]
dbUsers
::
(
CmdCommon
env
)
=>
Int
->
GqlM
e
env
[
User
(
GqlM
e
env
)]
dbUsers
user_id
=
lift
(
map
toUser
<$>
DBUser
.
getUsersWithId
(
Individu
.
RootId
$
NodeId
user_id
))
toUser
...
...
src/Gargantext/API/Metrics.hs
View file @
4ef66cea
...
...
@@ -35,7 +35,7 @@ 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.Prelude
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.Node.UpdateOpaleye
(
updateHyperdata
)
...
...
@@ -185,12 +185,12 @@ getChart cId _start _end maybeListId tabType = do
pure
$
constructHashedResponse
chart
updateChart
::
HasNodeError
err
=>
CorpusId
->
Maybe
ListId
->
TabType
->
Maybe
Limit
->
DBCmd
err
()
updateChart
::
HasNodeError
err
=>
CorpusId
->
Maybe
ListId
->
TabType
->
Maybe
Limit
->
DBCmd
err
()
updateChart
cId
maybeListId
tabType
maybeLimit
=
do
listId
<-
case
maybeListId
of
Just
lid
->
pure
lid
...
...
@@ -202,12 +202,12 @@ updateChart cId maybeListId tabType maybeLimit = do
_
<-
updateChart'
cId
listId
tabType
maybeLimit
pure
()
updateChart'
::
HasNodeError
err
=>
CorpusId
->
ListId
->
TabType
->
Maybe
Limit
->
DBCmd
err
(
ChartMetrics
Histo
)
updateChart'
::
HasNodeError
err
=>
CorpusId
->
ListId
->
TabType
->
Maybe
Limit
->
DBCmd
err
(
ChartMetrics
Histo
)
updateChart'
cId
listId
tabType
_maybeLimit
=
do
node
<-
getNodeWith
listId
(
Proxy
::
Proxy
HyperdataList
)
let
hl
=
node
^.
node_hyperdata
...
...
@@ -267,7 +267,7 @@ getPie cId _start _end maybeListId tabType = do
chart
<-
case
mChart
of
Just
chart
->
pure
chart
Nothing
->
do
updatePie'
cId
maybeL
istId
tabType
Nothing
updatePie'
cId
l
istId
tabType
Nothing
pure
$
constructHashedResponse
chart
...
...
@@ -278,23 +278,23 @@ 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
maybeL
istId
tabType
maybeLimit
_
<-
updatePie'
cId
l
istId
tabType
maybeLimit
pure
()
updatePie'
::
(
HasNodeStory
env
err
m
,
HasNodeError
err
)
=>
CorpusId
->
Maybe
ListId
->
ListId
->
TabType
->
Maybe
Limit
->
m
(
ChartMetrics
Histo
)
updatePie'
cId
maybeListId
tabType
_maybeLimit
=
do
listId
<-
case
maybeListId
of
Just
lid
->
pure
lid
Nothing
->
defaultList
cId
updatePie'
cId
listId
tabType
_maybeLimit
=
do
node
<-
getNodeWith
listId
(
Proxy
::
Proxy
HyperdataList
)
let
hl
=
node
^.
node_hyperdata
pieMap
=
hl
^.
hl_pie
...
...
src/Gargantext/API/Ngrams.hs
View file @
4ef66cea
This diff is collapsed.
Click to expand it.
src/Gargantext/API/Ngrams/List.hs
View file @
4ef66cea
...
...
@@ -16,12 +16,18 @@ Portability : POSIX
module
Gargantext.API.Ngrams.List
where
import
Data.ByteString.Lazy
qualified
as
BSL
import
Data.Csv
qualified
as
Csv
import
Data.Either
(
Either
(
..
))
import
Data.HashMap.Strict
(
HashMap
)
import
Data.HashMap.Strict
qualified
as
HashMap
import
Data.Map.Strict
(
Map
,
toList
)
import
Data.Map.Strict
qualified
as
Map
import
Data.Maybe
(
fromMaybe
)
import
Data.Set
qualified
as
Set
import
Data.Text
(
Text
,
concat
,
pack
,
splitOn
)
import
Data.Vector
(
Vector
)
import
Data.Vector
qualified
as
Vec
import
Gargantext.API.Admin.EnvTypes
(
Env
,
GargJob
(
..
))
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Ngrams
(
setListNgrams
)
...
...
@@ -34,25 +40,18 @@ import Gargantext.Core.NodeStory
import
Gargantext.Core.Types.Main
(
ListType
(
..
))
import
Gargantext.Database.Action.Flow
(
reIndexWith
)
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
-- import Gargantext.Database.Action.Metrics.NgramsByContext (refreshNgramsMaterialized)
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Query.Table.Ngrams
qualified
as
TableNgrams
import
Gargantext.Database.Query.Table.Node
(
getNode
)
import
Gargantext.Database.Schema.Ngrams
import
Gargantext.Database.Schema.Node
(
_node_parent_id
)
import
Gargantext.Database.Types
(
Indexed
(
..
))
import
Gargantext.Prelude
import
Gargantext.Utils.Jobs
(
serveJobsAPI
,
MonadJobStatus
(
..
))
import
Gargantext.Utils.Servant
qualified
as
GUS
import
Prelude
qualified
import
Protolude
qualified
as
P
import
Servant
import
qualified
Data.ByteString.Lazy
as
BSL
import
qualified
Data.Csv
as
Csv
import
qualified
Data.HashMap.Strict
as
HashMap
import
qualified
Data.Map.Strict
as
Map
import
qualified
Data.Set
as
Set
import
qualified
Data.Vector
as
Vec
import
qualified
Gargantext.Database.Query.Table.Ngrams
as
TableNgrams
import
qualified
Gargantext.Utils.Servant
as
GUS
import
qualified
Prelude
import
qualified
Protolude
as
P
------------------------------------------------------------------------
type
GETAPI
=
Summary
"Get List"
:>
"lists"
...
...
@@ -120,10 +119,10 @@ getCsv lId = do
------------------------------------------------------------------------
-- TODO : purge list
-- TODO talk
setList
::
FlowCmdM
env
err
m
=>
ListId
->
NgramsList
->
m
Bool
setList
::
HasNodeStory
env
err
m
=>
ListId
->
NgramsList
->
m
Bool
setList
l
m
=
do
-- TODO check with Version for optim
-- printDebug "New list as file" l
...
...
@@ -197,7 +196,7 @@ parseCsvData lst = Map.fromList $ conv <$> lst
}
)
csvPost
::
FlowCmdM
env
err
m
csvPost
::
HasNodeStory
env
err
m
=>
ListId
->
Text
->
m
(
Either
Text
()
)
...
...
@@ -236,7 +235,7 @@ csvPostAsync lId =
-- | This is for debugging the CSV parser in the REPL
importCsvFile
::
FlowCmdM
env
err
m
importCsvFile
::
(
HasNodeStory
env
err
m
)
=>
ListId
->
P
.
FilePath
->
m
(
Either
Text
()
)
importCsvFile
lId
fp
=
do
contents
<-
liftBase
$
P
.
readFile
fp
...
...
src/Gargantext/API/Ngrams/Prelude.hs
View file @
4ef66cea
...
...
@@ -36,7 +36,7 @@ import qualified Data.Text as Text
------------------------------------------------------------------------
getNgramsList
::
HasNodeStory
env
err
m
=>
ListId
->
m
NgramsList
=>
ListId
->
m
NgramsList
getNgramsList
lId
=
fromList
<$>
zip
ngramsTypes
<$>
mapM
(
getNgramsTableMap
lId
)
ngramsTypes
...
...
src/Gargantext/API/Ngrams/Tools.hs
View file @
4ef66cea
...
...
@@ -25,7 +25,7 @@ import Data.Validity
import
Gargantext.API.Ngrams.Types
import
Gargantext.Core.NodeStory
import
Gargantext.Core.Types
(
ListType
(
..
),
NodeId
,
NodeType
(
..
),
ListId
)
import
Gargantext.Database.Prelude
(
CmdM
,
HasConnectionPool
(
..
))
import
Gargantext.Database.Prelude
(
HasConnectionPool
(
..
))
import
Gargantext.Database.Schema.Ngrams
(
NgramsType
)
import
Gargantext.Prelude
import
qualified
Data.HashMap.Strict
as
HM
...
...
@@ -229,7 +229,7 @@ getCoocByNgrams'' (Diagonal diag) (f1,f2) (m1,m2) =
------------------------------------------
migrateFromDirToDb
::
(
CmdM
env
err
m
)
-- , HasNodeStory env err m)
migrateFromDirToDb
::
(
HasNodeStory
env
err
m
)
-- , HasNodeStory env err m)
=>
m
()
migrateFromDirToDb
=
do
pool
<-
view
connPool
...
...
src/Gargantext/API/Node.hs
View file @
4ef66cea
...
...
@@ -37,12 +37,19 @@ import GHC.Generics (Generic)
import
Gargantext.API.Admin.Auth
(
withAccess
,
withPolicy
)
import
Gargantext.API.Admin.Auth.Types
(
PathId
(
..
),
AuthenticatedUser
(
..
))
import
Gargantext.API.Admin.EnvTypes
import
Gargantext.API.Auth.PolicyCheck
import
Gargantext.API.Metrics
import
Gargantext.API.Ngrams
(
TableNgramsApi
,
apiNgramsTableCorpus
)
import
Gargantext.API.Ngrams.Types
(
TabType
(
..
))
import
Gargantext.API.Node.DocumentUpload
qualified
as
DocumentUpload
import
Gargantext.API.Node.DocumentsFromWriteNodes
qualified
as
DocumentsFromWriteNodes
import
Gargantext.API.Node.File
import
Gargantext.API.Node.FrameCalcUpload
qualified
as
FrameCalcUpload
import
Gargantext.API.Node.New
import
Gargantext.API.Node.Share
qualified
as
Share
import
Gargantext.API.Node.Update
qualified
as
Update
import
Gargantext.API.Prelude
import
Gargantext.API.Search
qualified
as
Search
import
Gargantext.API.Table
import
Gargantext.Core.Types
(
NodeTableResult
)
import
Gargantext.Core.Types.Individu
(
User
(
..
))
...
...
@@ -50,15 +57,17 @@ import Gargantext.Core.Types.Main (Tree, NodeTree)
import
Gargantext.Core.Types.Query
(
Limit
,
Offset
)
import
Gargantext.Core.Utils.Prefix
(
unPrefix
)
import
Gargantext.Core.Viz.Phylo.API
(
PhyloAPI
,
phyloAPI
)
import
Gargantext.Database.Action.Delete
qualified
as
Action
(
deleteNode
)
import
Gargantext.Database.Action.Flow.Pairing
(
pairing
)
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Prelude
-- (Cmd, CmdM
)
import
Gargantext.Database.Prelude
(
Cmd
,
JSONB
)
import
Gargantext.Database.Query.Facet
(
FacetDoc
,
OrderBy
(
..
))
import
Gargantext.Database.Query.Table.Node
import
Gargantext.Database.Query.Table.Node.Children
(
getChildren
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
(
..
))
import
Gargantext.Database.Query.Table.Node.Update
(
Update
(
..
),
update
)
import
Gargantext.Database.Query.Table.Node.Update
qualified
as
U
(
update
,
Update
(
..
))
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
import
Gargantext.Database.Query.Table.NodeContext
(
nodeContextsCategory
,
nodeContextsScore
)
import
Gargantext.Database.Query.Table.NodeNode
...
...
@@ -67,15 +76,6 @@ import Gargantext.Prelude
import
Servant
import
Test.QuickCheck
(
elements
)
import
Test.QuickCheck.Arbitrary
(
Arbitrary
,
arbitrary
)
import
qualified
Gargantext.API.Node.DocumentUpload
as
DocumentUpload
import
qualified
Gargantext.API.Node.DocumentsFromWriteNodes
as
DocumentsFromWriteNodes
import
qualified
Gargantext.API.Node.FrameCalcUpload
as
FrameCalcUpload
import
qualified
Gargantext.API.Node.Share
as
Share
import
qualified
Gargantext.API.Node.Update
as
Update
import
qualified
Gargantext.API.Search
as
Search
import
qualified
Gargantext.Database.Action.Delete
as
Action
(
deleteNode
)
import
qualified
Gargantext.Database.Query.Table.Node.Update
as
U
(
update
,
Update
(
..
))
import
Gargantext.API.Auth.PolicyCheck
-- | Admin NodesAPI
...
...
src/Gargantext/API/Node/Corpus/Export.hs
View file @
4ef66cea
...
...
@@ -16,24 +16,21 @@ Main exports of Gargantext:
module
Gargantext.API.Node.Corpus.Export
where
import
Data.HashMap.Strict
qualified
as
HashMap
import
Data.List
qualified
as
List
import
Data.Map.Strict
(
Map
)
import
Data.Map.Strict
qualified
as
Map
import
Data.Maybe
(
fromMaybe
)
import
Data.Set
(
Set
)
import
Data.Set
qualified
as
Set
import
Data.Text
(
Text
,
pack
)
import
qualified
Data.List
as
List
import
qualified
Data.Map.Strict
as
Map
import
qualified
Data.Set
as
Set
import
qualified
Data.HashMap.Strict
as
HashMap
import
Servant
(
Headers
,
Header
,
addHeader
)
import
Gargantext.API.Node.Corpus.Export.Types
import
qualified
Gargantext.API.Node.Document.Export.Types
as
DocumentExport
import
Gargantext.API.Ngrams.Types
import
Gargantext.API.Ngrams.Tools
(
filterListWithRoot
,
mapTermListRoot
,
getRepo
)
import
Gargantext.API.Ngrams.Types
import
Gargantext.API.Node.Corpus.Export.Types
import
Gargantext.API.Node.Document.Export.Types
qualified
as
DocumentExport
import
Gargantext.API.Prelude
(
GargNoServer
)
import
Gargantext.Prelude.Crypto.Hash
(
hash
)
import
Gargantext.Core.Types
import
Gargantext.Core.NodeStory
import
Gargantext.Core.Types
import
Gargantext.Database.Action.Metrics.NgramsByContext
(
getNgramsByContextOnlyUser
)
import
Gargantext.Database.Admin.Config
(
userMaster
)
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataDocument
(
..
))
...
...
@@ -42,9 +39,11 @@ import Gargantext.Database.Query.Table.Node
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Table.Node.Select
(
selectNodesWithUsername
)
import
Gargantext.Database.Query.Table.NodeContext
(
selectDocNodes
)
import
Gargantext.Database.Schema.Ngrams
(
NgramsType
(
..
))
import
Gargantext.Database.Schema.Context
(
_context_id
,
_context_hyperdata
)
import
Gargantext.Database.Schema.Ngrams
(
NgramsType
(
..
))
import
Gargantext.Prelude
import
Gargantext.Prelude.Crypto.Hash
(
hash
)
import
Servant
(
Headers
,
Header
,
addHeader
)
--------------------------------------------------
-- | Hashes are ordered by Set
...
...
src/Gargantext/API/Node/Corpus/New/File.hs
View file @
4ef66cea
...
...
@@ -32,7 +32,7 @@ import Servant.Swagger.Internal
import
Gargantext.API.Node.Corpus.New.Types
import
Gargantext.Core.Types
(
TODO
)
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Prelude
-- (Cmd, CmdM
)
import
Gargantext.Database.Prelude
(
Cmd
)
import
Gargantext.Prelude
import
Gargantext.Prelude.Crypto.Hash
(
hash
)
...
...
src/Gargantext/API/Node/Corpus/Searx.hs
View file @
4ef66cea
...
...
@@ -3,43 +3,46 @@
module
Gargantext.API.Node.Corpus.Searx
where
import
Control.Lens
(
view
)
import
Data.Aeson
qualified
as
Aeson
import
Data.Aeson.TH
(
deriveJSON
)
import
Data.Either
(
Either
(
..
))
import
Data.HashMap.Strict
qualified
as
HashMap
import
Data.Text
qualified
as
T
import
Data.Text
qualified
as
Text
import
Data.Time.Calendar
(
Day
,
toGregorian
)
import
Data.Time.Format
(
defaultTimeLocale
,
formatTime
,
parseTimeM
)
import
Data.Tuple.Select
(
sel1
,
sel2
,
sel3
)
import
GHC.Generics
(
Generic
)
import
Gargantext.Core
(
Lang
(
..
))
import
Gargantext.Core.NLP
(
nlpServerGet
)
import
Gargantext.Core.NLP
(
HasNLPServer
,
nlpServerGet
)
import
Gargantext.Core.NodeStory
(
HasNodeStory
)
import
Gargantext.Core.Text.Corpus.API
qualified
as
API
import
Gargantext.Core.Text.List
(
buildNgramsLists
)
import
Gargantext.Core.Text.List.Group.WithStem
(
{-StopSize(..),-}
GroupParams
(
..
))
import
Gargantext.Core.Text.Terms
(
TermType
(
..
))
import
Gargantext.Core.Types
(
HasInvalidError
)
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Core.Utils.Prefix
(
unPrefix
)
import
Gargantext.Database.Action.Flow
(
addDocumentsToHyperCorpus
)
--, DataText(..))
import
Gargantext.Database.Action.Flow.List
(
flowList_DbRepo
)
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
import
Gargantext.Database.Action.User
(
getUserId
)
import
Gargantext.Database.Admin.Config
(
userMaster
)
import
Gargantext.Database.Query.Table.Node
(
insertDefaultNodeIfNotExists
)
import
Gargantext.Database.Admin.Types.Hyperdata.Corpus
(
HyperdataCorpus
)
import
Gargantext.Database.Admin.Types.Hyperdata.Document
(
HyperdataDocument
(
..
))
import
Gargantext.Database.Admin.Types.Node
(
CorpusId
,
ListId
,
NodeType
(
NodeTexts
))
import
Gargantext.Database.Prelude
(
hasConfig
)
import
Gargantext.Database.Query.Table.Node
(
defaultListMaybe
,
getOrMkList
)
import
Gargantext.Database.Query.Table.Node
(
getOrMkList
)
import
Gargantext.Database.Query.Table.Node
(
insertDefaultNodeIfNotExists
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Tree.Error
(
HasTreeError
)
import
Gargantext.Database.Query.Tree.Root
(
getOrMk_RootWithCorpus
)
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
import
Gargantext.Utils.Jobs
(
JobHandle
,
MonadJobStatus
(
..
))
import
Network.HTTP.Client
import
Network.HTTP.Client.TLS
import
Prelude
qualified
import
Protolude
(
catMaybes
,
encodeUtf8
,
rightToMaybe
,
Text
,
void
)
import
qualified
Data.Aeson
as
Aeson
import
qualified
Data.HashMap.Strict
as
HashMap
import
qualified
Data.Text
as
T
import
qualified
Data.Text
as
Text
import
qualified
Gargantext.Core.Text.Corpus.API
as
API
import
qualified
Prelude
langToSearx
::
Lang
->
Text
langToSearx
All
=
"en-US"
...
...
@@ -108,7 +111,12 @@ fetchSearxPage (FetchSearxParams { _fsp_language
let
dec
=
Aeson
.
eitherDecode
$
responseBody
res
::
(
Either
Prelude
.
String
SearxResponse
)
pure
dec
insertSearxResponse
::
(
MonadBase
IO
m
,
FlowCmdM
env
err
m
)
insertSearxResponse
::
(
MonadBase
IO
m
,
HasNodeStory
env
err
m
,
HasNLPServer
env
,
HasNodeError
err
,
HasTreeError
err
,
HasInvalidError
err
)
=>
User
->
CorpusId
->
ListId
...
...
@@ -145,13 +153,19 @@ insertSearxResponse user cId listId l (Right (SearxResponse { _srs_results })) =
pure
()
-- TODO Make an async task out of this?
triggerSearxSearch
::
(
MonadBase
IO
m
,
FlowCmdM
env
err
m
,
MonadJobStatus
m
)
=>
User
->
CorpusId
->
API
.
RawQuery
->
Lang
->
JobHandle
m
->
m
()
triggerSearxSearch
::
(
MonadBase
IO
m
,
HasNodeStory
env
err
m
,
HasNLPServer
env
,
HasNodeError
err
,
HasTreeError
err
,
HasInvalidError
err
,
MonadJobStatus
m
)
=>
User
->
CorpusId
->
API
.
RawQuery
->
Lang
->
JobHandle
m
->
m
()
triggerSearxSearch
user
cId
q
l
jobHandle
=
do
userId
<-
getUserId
user
...
...
@@ -167,12 +181,7 @@ triggerSearxSearch user cId q l jobHandle = do
uId
<-
getUserId
user
let
surl
=
_gc_frame_searx_url
cfg
-- printDebug "[triggerSearxSearch] surl" surl
mListId
<-
defaultListMaybe
cId
listId
<-
case
mListId
of
Nothing
->
do
listId
<-
getOrMkList
cId
uId
pure
listId
Just
listId
->
pure
listId
listId
<-
getOrMkList
cId
uId
-- printDebug "[triggerSearxSearch] listId" listId
...
...
src/Gargantext/API/Node/Corpus/Update.hs
View file @
4ef66cea
...
...
@@ -9,7 +9,7 @@ import Data.Proxy
import
Gargantext.Core
import
Gargantext.Database.Admin.Types.Hyperdata.Corpus
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
DbCmd
'
)
import
Gargantext.Database.Query.Table.Node
import
Gargantext.Database.Query.Table.Node.Error
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
...
...
src/Gargantext/API/Node/New.hs
View file @
4ef66cea
...
...
@@ -36,7 +36,7 @@ import Gargantext.API.Prelude
import
Gargantext.Database.Action.Flow.Types
import
Gargantext.Database.Action.Node
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
Cmd
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
(
..
))
import
Gargantext.Database.Query.Table.Node.User
import
Gargantext.Database.Schema.Node
...
...
src/Gargantext/API/Node/Share.hs
View file @
4ef66cea
...
...
@@ -27,7 +27,7 @@ import Gargantext.Database.Action.Share as DB (shareNodeWith, unPublish)
import
Gargantext.Database.Action.User
import
Gargantext.Database.Action.User.New
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
CmdRandom
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
(
..
))
import
Gargantext.Database.Query.Tree
(
findNodesWithType
)
import
Gargantext.Prelude
...
...
src/Gargantext/API/Prelude.hs
View file @
4ef66cea
...
...
@@ -25,31 +25,31 @@ import Control.Exception (Exception)
import
Control.Lens
(
Prism
'
,
(
#
))
import
Control.Lens.TH
(
makePrisms
)
import
Control.Monad
(
mapM_
)
import
Control.Monad.Error.Class
(
MonadError
(
..
))
import
Control.Monad.Except
(
ExceptT
)
import
Control.Monad.Reader
(
ReaderT
)
import
Control.Monad.Error.Class
(
MonadError
(
..
))
import
Crypto.JOSE.Error
as
Jose
import
Data.Aeson.Types
import
qualified
Data.Text
as
Text
import
Data.Typeable
import
Data.Validity
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Admin.Types
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.NLP
(
HasNLPServer
)
import
Gargantext.Core.NodeStory
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.Types
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
CmdM
,
CmdRandom
,
HasConnectionPool
,
HasConfig
)
import
Gargantext.Database.Query.Table.Node.Error
(
NodeError
(
..
),
HasNodeError
(
..
))
import
Gargantext.Database.Query.Tree
import
Gargantext.Prelude
import
Gargantext.Utils.Jobs.Monad
(
MonadJobStatus
(
..
),
JobHandle
)
import
qualified
Gargantext.Utils.Jobs.Monad
as
Jobs
import
Gargantext.System.Logging
import
Gargantext.Utils.Jobs.Monad
(
MonadJobStatus
(
..
),
JobHandle
)
import
Gargantext.Utils.Jobs.Monad
qualified
as
Jobs
import
Servant
import
Servant.Job.Async
import
Servant.Job.Core
(
HasServerError
(
..
),
serverError
)
import
qualified
Servant.Job.Types
as
SJ
import
Gargantext.System.Logging
import
Servant.Job.Types
qualified
as
SJ
import
qualified
Data.Text
as
Text
class
HasJoseError
e
where
_JoseError
::
Prism'
e
Jose
.
Error
...
...
src/Gargantext/API/Public.hs
View file @
4ef66cea
...
...
@@ -34,7 +34,7 @@ import qualified Data.Set as Set
import
Gargantext.API.Prelude
import
Gargantext.API.Node.File
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
(
..
))
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
Cmd
,
DBCmd
)
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Hyperdata.CorpusField
import
Gargantext.Database.Admin.Types.Node
...
...
@@ -79,7 +79,7 @@ api_node nId = do
selectPublic
::
HasNodeError
err
=>
Cmd
err
[(
Node
HyperdataFolder
,
Maybe
Int
)]
=>
DB
Cmd
err
[(
Node
HyperdataFolder
,
Maybe
Int
)]
selectPublic
=
selectPublicNodes
-- For tests only
...
...
src/Gargantext/API/Table.hs
View file @
4ef66cea
...
...
@@ -35,12 +35,8 @@ import Data.Aeson.TH (deriveJSON)
import
Data.Maybe
import
Data.Swagger
import
Data.Text
(
Text
())
import
Data.Text
qualified
as
T
import
GHC.Generics
(
Generic
)
import
Prelude
import
Servant
import
Test.QuickCheck
(
elements
)
import
Test.QuickCheck.Arbitrary
(
Arbitrary
,
arbitrary
)
import
Gargantext.API.HashedResponse
import
Gargantext.API.Ngrams.Types
(
TabType
(
..
))
import
Gargantext.API.Prelude
(
GargServer
)
...
...
@@ -51,12 +47,15 @@ import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import
Gargantext.Database.Action.Learn
(
FavOrTrash
(
..
),
moreLike
)
import
Gargantext.Database.Action.Search
import
Gargantext.Database.Admin.Types.Node
hiding
(
ERROR
,
DEBUG
)
import
Gargantext.Database.Prelude
-- (Cmd, CmdM
)
import
Gargantext.Database.Prelude
(
CmdM
,
DbCmd
'
,
DBCmd
)
import
Gargantext.Database.Query.Facet
(
FacetDoc
,
runViewDocuments
,
runCountDocuments
,
OrderBy
(
..
),
runViewAuthorsDoc
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Prelude
import
Gargantext.System.Logging
import
qualified
Data.Text
as
T
import
Prelude
import
Servant
import
Test.QuickCheck
(
elements
)
import
Test.QuickCheck.Arbitrary
(
Arbitrary
,
arbitrary
)
------------------------------------------------------------------------
...
...
@@ -156,7 +155,7 @@ getTableHashApi cId tabType = do
HashedResponse
{
hash
=
h
}
<-
getTableApi
cId
tabType
Nothing
Nothing
Nothing
Nothing
Nothing
pure
h
searchInCorpus'
::
(
CmdM
env
err
m
,
MonadLogger
m
)
searchInCorpus'
::
(
DbCmd'
env
err
m
,
MonadLogger
m
)
=>
CorpusId
->
Bool
->
RawQuery
...
...
@@ -185,7 +184,7 @@ getTable :: HasNodeError err
->
Maybe
OrderBy
->
Maybe
RawQuery
->
Maybe
Text
->
Cmd
err
FacetTableResult
->
DB
Cmd
err
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
...
...
@@ -201,7 +200,7 @@ getTable' :: HasNodeError err
->
Maybe
OrderBy
->
Maybe
Text
->
Maybe
Text
->
Cmd
err
[
FacetDoc
]
->
DB
Cmd
err
[
FacetDoc
]
getTable'
cId
ft
o
l
order
query
year
=
case
ft
of
(
Just
Docs
)
->
runViewDocuments
cId
False
o
l
order
query
year
...
...
@@ -213,7 +212,7 @@ getTable' cId ft o l order query year =
getPair
::
ContactId
->
Maybe
TabType
->
Maybe
Offset
->
Maybe
Limit
->
Maybe
OrderBy
->
Cmd
err
[
FacetDoc
]
->
Maybe
OrderBy
->
DB
Cmd
err
[
FacetDoc
]
getPair
cId
ft
o
l
order
=
case
ft
of
(
Just
Docs
)
->
runViewAuthorsDoc
cId
False
o
l
order
...
...
src/Gargantext/Core/Mail.hs
View file @
4ef66cea
...
...
@@ -14,16 +14,16 @@ module Gargantext.Core.Mail where
import
Control.Lens
(
view
)
import
Control.Monad.Reader
(
MonadReader
)
import
Control.Monad.Trans.Control
(
MonadBaseControl
)
import
Network.URI.Encode
(
encodeText
)
import
Data.List
qualified
as
List
import
Data.Text
(
Text
,
unlines
,
splitOn
)
import
Gargantext.Core.Types.Individu
import
Gargantext.Database.Prelude
(
HasConfig
(
..
))
import
Gargantext.Database.Schema.User
(
UserLight
(
..
))
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
(
gc_url
,
gc_backend_name
)
import
Gargantext.Database.Prelude
import
Gargantext.Prelude.Mail
(
gargMail
,
GargMail
(
..
))
import
Gargantext.Prelude.Mail.Types
(
MailConfig
)
import
qualified
Data.List
as
List
import
Network.URI.Encode
(
encodeText
)
-- | Tool to put elsewhere
...
...
src/Gargantext/Core/NodeStoryFile.hs
View file @
4ef66cea
...
...
@@ -23,7 +23,7 @@ import Control.Concurrent (MVar(), modifyMVar_, newMVar, readMVar, withMVar)
import
Control.Debounce
(
mkDebounce
,
defaultDebounceSettings
,
debounceFreq
,
debounceAction
)
import
Gargantext.Core.NodeStory
hiding
(
readNodeStoryEnv
)
import
Gargantext.Core.Types
(
ListId
,
NodeId
(
..
))
import
Gargantext.Database.Prelude
(
CmdM
,
hasConfig
)
import
Gargantext.Database.Prelude
(
hasConfig
)
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
(
gc_repofilepath
)
import
System.Directory
(
renameFile
,
createDirectoryIfMissing
,
doesFileExist
,
removeFile
)
...
...
@@ -46,7 +46,7 @@ getRepo listIds = do
-- v' <- liftBase $ readMVar v
-- pure $ v'
getRepoReadConfig
::
(
CmdM
env
err
m
)
getRepoReadConfig
::
(
HasNodeStory
env
err
m
)
=>
[
ListId
]
->
m
NodeListStory
getRepoReadConfig
listIds
=
do
repoFP
<-
view
$
hasConfig
.
gc_repofilepath
...
...
src/Gargantext/Core/Text/List.hs
View file @
4ef66cea
...
...
@@ -18,14 +18,19 @@ module Gargantext.Core.Text.List
import
Control.Lens
hiding
(
both
)
-- ((^.), view, over, set, (_1), (_2))
import
Data.HashMap.Strict
(
HashMap
)
import
Data.HashMap.Strict
qualified
as
HashMap
import
Data.HashSet
(
HashSet
)
import
Data.HashSet
qualified
as
HashSet
import
Data.List
qualified
as
List
import
Data.Map.Strict
(
Map
)
import
Data.Map.Strict
qualified
as
Map
import
Data.Monoid
(
mempty
)
import
Data.Ord
(
Down
(
..
))
import
Data.Set
(
Set
)
-- import Data.Text (Text)
import
Data.Set
qualified
as
Set
import
Data.Tuple.Extra
(
both
)
import
Gargantext.API.Ngrams.Types
(
NgramsElement
,
NgramsTerm
(
..
))
import
Gargantext.Core.NLP
(
HasNLPServer
)
import
Gargantext.Core.NodeStory
import
Gargantext.Core.Text
(
size
)
import
Gargantext.Core.Text.List.Group
...
...
@@ -36,10 +41,11 @@ import Gargantext.Core.Text.List.Social.Prelude
import
Gargantext.Core.Text.Metrics
(
scored'
,
Scored
(
..
),
scored_speExc
,
scored_genInc
,
normalizeGlobal
,
normalizeLocal
,
scored_terms
)
import
Gargantext.Core.Types
(
ListType
(
..
),
MasterCorpusId
,
UserCorpusId
)
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Data.HashMap.Strict.Utils
qualified
as
HashMap
import
Gargantext.Database.Action.Metrics.NgramsByContext
(
getContextsByNgramsUser
,
getContextsByNgramsOnlyUser
)
import
Gargantext.Database.Action.Metrics.TFICF
(
getTficf_withSample
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
)
import
Gargantext.Database.Prelude
(
CmdM
)
import
Gargantext.Database.Prelude
(
DBCmd
)
import
Gargantext.Database.Query.Table.Ngrams
(
text2ngrams
)
import
Gargantext.Database.Query.Table.NgramsPostag
(
selectLems
)
import
Gargantext.Database.Query.Table.Node
(
defaultList
)
...
...
@@ -47,12 +53,6 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
import
Gargantext.Database.Query.Tree.Error
(
HasTreeError
)
import
Gargantext.Database.Schema.Ngrams
(
NgramsType
(
..
),
Ngrams
(
..
))
import
Gargantext.Prelude
import
qualified
Data.HashMap.Strict
as
HashMap
import
qualified
Data.HashSet
as
HashSet
import
qualified
Data.List
as
List
import
qualified
Data.Map.Strict
as
Map
import
qualified
Data.Set
as
Set
import
qualified
Gargantext.Data.HashMap.Strict.Utils
as
HashMap
{-
-- TODO maybe useful for later
...
...
@@ -65,7 +65,7 @@ isStopTerm (StopSize n) x = Text.length x < n || any isStopChar (Text.unpack x)
-- | TODO improve grouping functions of Authors, Sources, Institutes..
buildNgramsLists
::
(
HasNodeStory
env
err
m
,
CmdM
env
err
m
,
HasNLPServer
env
,
HasTreeError
err
,
HasNodeError
err
)
...
...
@@ -90,7 +90,7 @@ data MapListSize = MapListSize { unMapListSize :: !Int }
data
MaxListSize
=
MaxListSize
{
unMaxListSize
::
!
Int
}
buildNgramsOthersList
::
(
HasNodeError
err
,
CmdM
env
err
m
,
HasNLPServer
env
,
HasNodeStory
env
err
m
,
HasTreeError
err
)
...
...
@@ -134,11 +134,9 @@ buildNgramsOthersList user uCid mfslw _groupParams (nt, MapListSize mapListSize,
getGroupParams
::
(
HasNodeError
err
,
CmdM
env
err
m
,
HasNodeStory
env
err
m
,
HasTreeError
err
)
=>
GroupParams
->
HashSet
Ngrams
->
m
GroupParams
=>
GroupParams
->
HashSet
Ngrams
->
DBCmd
err
GroupParams
getGroupParams
gp
@
(
GroupWithPosTag
l
nsc
_m
)
ng
=
do
!
hashMap
<-
HashMap
.
fromList
<$>
selectLems
l
nsc
(
HashSet
.
toList
ng
)
-- printDebug "hashMap" hashMap
...
...
@@ -148,7 +146,7 @@ getGroupParams gp _ = pure gp
-- TODO use ListIds
buildNgramsTermsList
::
(
HasNodeError
err
,
CmdM
env
err
m
,
HasNLPServer
env
,
HasNodeStory
env
err
m
,
HasTreeError
err
)
...
...
src/Gargantext/Core/Text/List/Social.hs
View file @
4ef66cea
...
...
@@ -17,29 +17,29 @@ import Control.Lens (view)
import
Control.Monad
(
mzero
)
import
Data.Aeson
import
Data.HashMap.Strict
(
HashMap
)
import
Data.List
qualified
as
List
import
Data.Map.Strict
(
Map
)
import
Data.Map.Strict
qualified
as
Map
import
Data.Monoid
(
mconcat
)
import
Data.Pool
import
Data.Swagger
import
Data.Text
qualified
as
T
import
Data.Vector
qualified
as
V
import
GHC.Generics
import
Gargantext.API.Ngrams.Types
(
NgramsTerm
,
NgramsPatch
)
import
Gargantext.Core.NodeStory
(
HasNodeStory
,
getNodesArchiveHistory
)
import
Gargantext.Core.NodeStory
(
getNodesArchiveHistory
)
import
Gargantext.Core.Text.List.Social.Find
(
findListsId
)
import
Gargantext.Core.Text.List.Social.Patch
(
addScorePatches
)
import
Gargantext.Core.Text.List.Social.Prelude
(
FlowCont
,
FlowListScores
)
import
Gargantext.Core.Types.Individu
(
User
)
import
Gargantext.Database.Admin.Types.Node
(
ListId
,
NodeId
(
..
))
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
DBCmd
,
connPool
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Tree
(
NodeMode
(
Private
),
HasTreeError
)
import
Gargantext.Database.Schema.Ngrams
(
NgramsType
)
import
Gargantext.Prelude
import
Test.QuickCheck
import
Web.Internal.HttpApiData
(
ToHttpApiData
,
FromHttpApiData
,
parseUrlPiece
,
toUrlPiece
)
import
qualified
Data.List
as
List
import
qualified
Data.Map.Strict
as
Map
import
qualified
Data.Text
as
T
import
qualified
Data.Vector
as
V
------------------------------------------------------------------------
------------------------------------------------------------------------
-- | Main parameters
...
...
@@ -116,84 +116,72 @@ keepAllParents _ = KeepAllParents True
-}
------------------------------------------------------------------------
flowSocialList
::
(
HasNodeStory
env
err
m
,
CmdM
env
err
m
,
HasNodeError
err
,
HasTreeError
err
)
=>
Maybe
FlowSocialListWith
->
User
->
NgramsType
->
FlowCont
NgramsTerm
FlowListScores
->
m
(
FlowCont
NgramsTerm
FlowListScores
)
flowSocialList
::
(
HasNodeError
err
,
HasTreeError
err
)
=>
Maybe
FlowSocialListWith
->
User
->
NgramsType
->
FlowCont
NgramsTerm
FlowListScores
->
DBCmd
err
(
FlowCont
NgramsTerm
FlowListScores
)
flowSocialList
Nothing
u
=
flowSocialList'
MySelfFirst
u
flowSocialList
(
Just
(
FlowSocialListWithPriority
p
))
u
=
flowSocialList'
p
u
flowSocialList
(
Just
(
FlowSocialListWithLists
ls
))
_
=
getHistoryScores
ls
flowSocialList
(
Just
(
NoList
_
))
_u
=
panic
"[G.C.T.L.Social] Should not be executed"
flowSocialList'
::
(
HasNodeStory
env
err
m
,
CmdM
env
err
m
,
HasNodeError
err
flowSocialList'
::
(
HasNodeError
err
,
HasTreeError
err
)
=>
FlowSocialListPriority
->
User
->
NgramsType
->
FlowCont
NgramsTerm
FlowListScores
->
m
(
FlowCont
NgramsTerm
FlowListScores
)
->
DBCmd
err
(
FlowCont
NgramsTerm
FlowListScores
)
flowSocialList'
flowPriority
user
nt
flc
=
mconcat
<$>
mapM
(
flowSocialListByMode'
user
nt
flc
)
(
flowSocialListPriority
flowPriority
)
where
flowSocialListByMode'
::
(
HasNodeStory
env
err
m
,
CmdM
env
err
m
,
HasNodeError
err
flowSocialListByMode'
::
(
HasNodeError
err
,
HasTreeError
err
)
=>
User
->
NgramsType
->
FlowCont
NgramsTerm
FlowListScores
->
NodeMode
->
m
(
FlowCont
NgramsTerm
FlowListScores
)
->
DBCmd
err
(
FlowCont
NgramsTerm
FlowListScores
)
flowSocialListByMode'
user'
nt'
flc'
mode
=
findListsId
user'
mode
>>=
flowSocialListByModeWith
nt'
flc'
flowSocialListByModeWith
::
(
HasNodeStory
env
err
m
,
CmdM
env
err
m
,
HasNodeError
err
flowSocialListByModeWith
::
(
HasNodeError
err
,
HasTreeError
err
)
=>
NgramsType
->
FlowCont
NgramsTerm
FlowListScores
->
[
ListId
]
->
m
(
FlowCont
NgramsTerm
FlowListScores
)
->
DBCmd
err
(
FlowCont
NgramsTerm
FlowListScores
)
flowSocialListByModeWith
nt''
flc''
listes
=
getHistoryScores
listes
nt''
flc''
-----------------------------------------------------------------
getHistoryScores
::
(
HasNodeStory
env
err
m
,
CmdM
env
err
m
,
HasNodeError
err
getHistoryScores
::
(
HasNodeError
err
,
HasTreeError
err
)
=>
[
ListId
]
->
NgramsType
->
FlowCont
NgramsTerm
FlowListScores
->
m
(
FlowCont
NgramsTerm
FlowListScores
)
->
DBCmd
err
(
FlowCont
NgramsTerm
FlowListScores
)
getHistoryScores
lists
nt
fl
=
addScorePatches
nt
lists
fl
<$>
getHistory
[
nt
]
lists
getHistory
::
(
HasNodeStory
env
err
m
,
CmdM
env
err
m
,
HasNodeError
err
getHistory
::
(
HasNodeError
err
,
HasTreeError
err
)
=>
[
NgramsType
]
->
[
ListId
]
->
m
(
Map
ListId
(
Map
NgramsType
[
HashMap
NgramsTerm
NgramsPatch
]))
->
DBCmd
err
(
Map
ListId
(
Map
NgramsType
[
HashMap
NgramsTerm
NgramsPatch
]))
getHistory
types
listsId
=
do
pool
<-
view
connPool
nsp
<-
liftBase
$
withResource
pool
$
\
c
->
getNodesArchiveHistory
c
listsId
...
...
src/Gargantext/Core/Text/List/Social/Find.hs
View file @
4ef66cea
...
...
@@ -17,7 +17,7 @@ import Control.Lens (view)
import
Gargantext.Core.Types.Individu
import
Gargantext.Database.Admin.Config
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
DBCmd
)
import
Gargantext.Database.Query.Table.Node.Error
import
Gargantext.Database.Query.Tree
import
Gargantext.Database.Query.Tree.Root
(
getRootId
)
...
...
@@ -25,7 +25,7 @@ import Gargantext.Prelude
------------------------------------------------------------------------
findListsId
::
(
HasNodeError
err
,
HasTreeError
err
)
=>
User
->
NodeMode
->
Cmd
err
[
NodeId
]
=>
User
->
NodeMode
->
DB
Cmd
err
[
NodeId
]
findListsId
u
mode
=
do
rootId
<-
getRootId
u
ns
<-
map
(
view
dt_nodeId
)
<$>
filter
((
==
nodeTypeId
NodeList
)
.
(
view
dt_typeId
))
...
...
@@ -40,7 +40,7 @@ findListsId u mode = do
findNodes'
::
(
HasTreeError
err
,
HasNodeError
err
)
=>
RootId
->
NodeMode
->
Cmd
err
[
DbTreeNode
]
->
DB
Cmd
err
[
DbTreeNode
]
findNodes'
r
Private
=
do
pv
<-
(
findNodes
r
Private
$
[
NodeFolderPrivate
]
<>
commonNodes
)
sh
<-
(
findNodes'
r
Shared
)
...
...
@@ -52,3 +52,5 @@ findNodes' r PublicDirect = findNodes r Public $ [NodeFolderPublic ] <
commonNodes
::
[
NodeType
]
commonNodes
=
[
NodeFolder
,
NodeCorpus
,
NodeList
,
NodeFolderShared
,
NodeTeam
]
src/Gargantext/Core/Viz/Chart.hs
View file @
4ef66cea
...
...
@@ -25,7 +25,7 @@ import Gargantext.Core.NodeStory (HasNodeStory)
import
Gargantext.Core.Text.Metrics.Count
(
occurrencesWith
)
import
Gargantext.Core.Types.Main
import
Gargantext.Database.Admin.Config
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
DBCmd
)
import
Gargantext.Database.Query.Table.Node
import
Gargantext.Database.Query.Table.Node.Select
import
Gargantext.Database.Query.Table.NodeContext
(
selectDocsDates
)
...
...
src/Gargantext/Core/Viz/Graph/API.hs
View file @
4ef66cea
...
...
@@ -108,7 +108,7 @@ getGraph _uId nId = do
let
defaultEdgesStrength
=
Strong
let
defaultBridgenessMethod
=
BridgenessMethod_Basic
graph'
<-
computeGraph
cId
defaultPartitionMethod
defaultBridgenessMethod
(
withMetric
defaultMetric
)
defaultEdgesStrength
(
NgramsTerms
,
NgramsTerms
)
repo
mt
<-
defaultGraphMetadata
cId
"Title"
repo
defaultMetric
defaultEdgesStrength
mt
<-
defaultGraphMetadata
cId
listId
"Title"
repo
defaultMetric
defaultEdgesStrength
let
graph''
=
set
graph_metadata
(
Just
mt
)
graph'
hg
=
HyperdataGraphAPI
graph''
camera
...
...
@@ -167,7 +167,7 @@ recomputeGraph _uId nId partitionMethod bridgeMethod maybeSimilarity maybeStreng
case
graph
of
Nothing
->
do
mt
<-
defaultGraphMetadata
cId
"Title"
repo
(
fromMaybe
Order1
maybeSimilarity
)
strength
mt
<-
defaultGraphMetadata
cId
listId
"Title"
repo
(
fromMaybe
Order1
maybeSimilarity
)
strength
g
<-
computeG
$
Just
mt
pure
$
trace
"[G.V.G.API.recomputeGraph] Graph empty, computed"
g
Just
graph'
->
if
(
listVersion
==
Just
v
)
&&
(
not
force
)
...
...
@@ -225,14 +225,13 @@ computeGraph corpusId partitionMethod bridgeMethod similarity strength (nt1,nt2)
defaultGraphMetadata
::
HasNodeError
err
=>
CorpusId
->
ListId
->
Text
->
NodeListStory
->
GraphMetric
->
Strength
->
DBCmd
err
GraphMetadata
defaultGraphMetadata
cId
t
repo
gm
str
=
do
lId
<-
defaultList
cId
defaultGraphMetadata
cId
lId
t
repo
gm
str
=
do
pure
$
GraphMetadata
{
_gm_title
=
t
,
_gm_metric
=
gm
,
_gm_edgesStrength
=
Just
str
...
...
@@ -282,11 +281,14 @@ type GraphVersionsAPI = Summary "Graph versions"
graphVersionsAPI
::
UserId
->
NodeId
->
GargServer
GraphVersionsAPI
graphVersionsAPI
u
n
=
graphVersions
0
n
graphVersions
u
n
:<|>
recomputeVersions
u
n
graphVersions
::
Int
->
NodeId
->
GargNoServer
GraphVersions
graphVersions
n
nId
=
do
graphVersions
::
(
HasNodeStory
env
err
m
)
=>
UserId
->
NodeId
->
m
GraphVersions
graphVersions
u
nId
=
do
nodeGraph
<-
getNodeWith
nId
(
Proxy
::
Proxy
HyperdataGraph
)
let
graph
=
nodeGraph
...
...
@@ -303,21 +305,14 @@ graphVersions n nId = do
mcId
<-
getClosestParentIdByType
nId
NodeCorpus
let
cId
=
maybe
(
panic
"[G.V.G.API] Node has no parent"
)
identity
mcId
maybeListId
<-
defaultListMaybe
cId
case
maybeListId
of
Nothing
->
if
n
<=
2
then
graphVersions
(
n
+
1
)
cId
else
panic
"[G.V.G.API] list not found after iterations"
Just
listId
->
do
repo
<-
getRepo
[
listId
]
let
v
=
repo
^.
unNodeStory
.
at
listId
.
_Just
.
a_version
-- printDebug "graphVersions" v
listId
<-
getOrMkList
cId
u
repo
<-
getRepo
[
listId
]
let
v
=
repo
^.
unNodeStory
.
at
listId
.
_Just
.
a_version
-- printDebug "graphVersions" v
pure
$
GraphVersions
{
gv_graph
=
listVersion
,
gv_repo
=
v
}
pure
$
GraphVersions
{
gv_graph
=
listVersion
,
gv_repo
=
v
}
--recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
recomputeVersions
::
HasNodeStory
env
err
m
=>
UserId
->
NodeId
...
...
@@ -325,10 +320,11 @@ recomputeVersions :: HasNodeStory env err m
recomputeVersions
uId
nId
=
recomputeGraph
uId
nId
Spinglass
BridgenessMethod_Basic
Nothing
Nothing
NgramsTerms
NgramsTerms
False
------------------------------------------------------------
graphClone
::
UserId
graphClone
::
HasNodeError
err
=>
UserId
->
NodeId
->
HyperdataGraphAPI
->
GargNoServe
r
NodeId
->
DBCmd
er
r
NodeId
graphClone
uId
pId
(
HyperdataGraphAPI
{
_hyperdataAPIGraph
=
graph
,
_hyperdataAPICamera
=
camera
})
=
do
let
nodeType
=
NodeGraph
...
...
src/Gargantext/Core/Viz/Phylo/Legacy/LegacyMain.hs
View file @
4ef66cea
...
...
@@ -16,42 +16,34 @@ Portability : POSIX
module
Gargantext.Core.Viz.Phylo.Legacy.LegacyMain
where
-- import Data.GraphViz
-- import qualified Data.ByteString as DB
import
Control.Lens
hiding
(
Level
)
import
qualified
Data.List
as
List
import
Data.HashMap.Strict
qualified
as
HashMap
import
Data.List
qualified
as
List
import
Data.Maybe
import
Data.Proxy
import
Data.Set
qualified
as
Set
import
Data.Text
(
Text
)
import
Data.Text
qualified
as
Text
import
Debug.Trace
(
trace
)
import
GHC.IO
(
FilePath
)
import
Gargantext.API.Ngrams.Tools
(
getTermsWith
)
import
Gargantext.API.Ngrams.Types
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Core
(
HasDBid
,
withDefaultLanguage
)
import
Gargantext.Core.NodeStory
(
HasNodeStory
)
import
Gargantext.Core.Text.Context
(
TermList
)
import
Gargantext.Core.Text.Terms.WithList
import
Gargantext.Database.Query.Table.Node
(
defaultList
,
getNodeWith
)
import
Gargantext.Prelude
import
Gargantext.Database.Action.Flow.Types
import
Gargantext.Core.Types
import
Gargantext.Core.Viz.LegacyPhylo
hiding
(
Svg
,
Dot
)
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Query.Table.Node
(
defaultList
,
getNodeWith
)
import
Gargantext.Database.Query.Table.NodeContext
(
selectDocs
)
import
Gargantext.Database.Schema.Ngrams
(
NgramsType
(
..
))
import
Gargantext.Database.Schema.Node
import
Gargantext.Database.Query.Table.NodeContext
(
selectDocs
)
import
Gargantext.Core.Types
import
Gargantext.Core
(
HasDBid
,
withDefaultLanguage
)
-- import Gargantext.Core.Viz.Phylo.LevelMaker (toPhylo)
-- import Gargantext.Core.Viz.Phylo.Tools
-- import Gargantext.Core.Viz.Phylo.View.Export
-- import Gargantext.Core.Viz.Phylo.View.ViewMaker -- TODO Just Maker is fine
import
qualified
Data.HashMap.Strict
as
HashMap
import
qualified
Data.Set
as
Set
import
qualified
Data.Text
as
Text
import
Gargantext.Prelude
type
MinSizeBranch
=
Int
flowPhylo
::
(
FlowCmdM
env
err
m
,
HasDBid
NodeType
)
flowPhylo
::
(
HasNodeStory
env
err
m
,
HasDBid
NodeType
)
=>
CorpusId
->
m
Phylo
flowPhylo
cId
=
do
...
...
src/Gargantext/Database.hs
View file @
4ef66cea
...
...
@@ -26,7 +26,7 @@ module Gargantext.Database ( module Gargantext.Database.Prelude
where
import
Gargantext.Prelude
import
Gargantext.Database.Prelude
-- (connectGargandb)
import
Gargantext.Database.Prelude
(
DBCmd
)
-- (connectGargandb)
-- import Gargantext.Database.Schema.Node
-- import Gargantext.Database.Query.Table.Node
...
...
@@ -36,11 +36,11 @@ import Gargantext.Database.Query.Table.NodeNode
class
InsertDB
a
where
insertDB
::
a
->
Cmd
err
Int
insertDB
::
a
->
DB
Cmd
err
Int
{-
class DeleteDB a where
deleteDB :: a -> Cmd err Int
deleteDB :: a ->
DB
Cmd err Int
-}
instance
InsertDB
[
NodeNode
]
where
...
...
src/Gargantext/Database/Action/Flow.hs
View file @
4ef66cea
...
...
@@ -77,7 +77,7 @@ import Gargantext.Core (Lang(..), PosTagAlgo(..), NLPServerConfig)
import
Gargantext.Core
(
withDefaultLanguage
)
import
Gargantext.Core.Ext.IMTUser
(
readFile_Annuaire
)
import
Gargantext.Core.Flow.Types
import
Gargantext.Core.NLP
(
nlpServerGet
)
import
Gargantext.Core.NLP
(
HasNLPServer
,
nlpServerGet
)
import
Gargantext.Core.NodeStory
(
HasNodeStory
)
import
Gargantext.Core.Text
import
Gargantext.Core.Text.Corpus.API
qualified
as
API
...
...
@@ -88,7 +88,7 @@ import Gargantext.Core.Text.List.Social (FlowSocialListWith(..))
import
Gargantext.Core.Text.Terms
import
Gargantext.Core.Text.Terms.Mono.Stem.En
(
stemIt
)
import
Gargantext.Core.Text.Terms.WithList
(
MatchedText
,
buildPatternsWith
,
termsInText
)
import
Gargantext.Core.Types
(
POS
(
NP
),
TermsCount
)
import
Gargantext.Core.Types
(
HasInvalidError
,
POS
(
NP
),
TermsCount
)
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Core.Types.Main
import
Gargantext.Core.Types.Query
(
Limit
)
...
...
@@ -103,7 +103,7 @@ import Gargantext.Database.Action.Search (searchDocInDatabase)
import
Gargantext.Database.Admin.Config
(
userMaster
,
corpusMasterName
)
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Node
hiding
(
DEBUG
)
-- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
DbCmd
'
,
DBCmd
)
import
Gargantext.Database.Query.Table.ContextNodeNgrams2
import
Gargantext.Database.Query.Table.Ngrams
import
Gargantext.Database.Query.Table.Node
...
...
@@ -127,7 +127,7 @@ import PUBMED.Types qualified as PUBMED
------------------------------------------------------------------------
-- Imports for upgrade function
import
Gargantext.Database.Query.Tree.Root
(
getRootId
)
import
Gargantext.Database.Query.Tree
(
findNodesId
)
import
Gargantext.Database.Query.Tree
(
findNodesId
,
HasTreeError
)
------------------------------------------------------------------------
-- TODO use internal with API name (could be old data)
...
...
@@ -157,13 +157,13 @@ printDataText (DataNew (maybeInt, conduitData)) = do
putText
$
show
(
maybeInt
,
res
)
-- TODO use the split parameter in config file
getDataText
::
FlowCmdM
env
err
m
getDataText
::
(
HasNodeError
err
)
=>
DataOrigin
->
TermType
Lang
->
API
.
RawQuery
->
Maybe
PUBMED
.
APIKey
->
Maybe
API
.
Limit
->
m
(
Either
API
.
GetCorpusError
DataText
)
->
DBCmd
err
(
Either
API
.
GetCorpusError
DataText
)
getDataText
(
ExternalOrigin
api
)
la
q
mPubmedAPIKey
li
=
do
eRes
<-
liftBase
$
API
.
get
api
(
_tt_lang
la
)
q
mPubmedAPIKey
li
pure
$
DataNew
<$>
eRes
...
...
@@ -175,12 +175,12 @@ getDataText (InternalOrigin _) _la q _ _li = do
ids
<-
map
fst
<$>
searchDocInDatabase
cId
(
stemIt
$
API
.
getRawQuery
q
)
pure
$
Right
$
DataOld
ids
getDataText_Debug
::
FlowCmdM
env
err
m
=>
DataOrigin
->
TermType
Lang
->
API
.
RawQuery
->
Maybe
API
.
Limit
->
m
()
getDataText_Debug
::
(
HasNodeError
err
)
=>
DataOrigin
->
TermType
Lang
->
API
.
RawQuery
->
Maybe
API
.
Limit
->
DBCmd
err
()
getDataText_Debug
a
l
q
li
=
do
result
<-
getDataText
a
l
q
Nothing
li
case
result
of
...
...
@@ -190,7 +190,12 @@ getDataText_Debug a l q li = do
-------------------------------------------------------------------------------
flowDataText
::
forall
env
err
m
.
(
FlowCmdM
env
err
m
(
DbCmd'
env
err
m
,
HasNodeStory
env
err
m
,
MonadLogger
m
,
HasNLPServer
env
,
HasTreeError
err
,
HasInvalidError
err
,
MonadJobStatus
m
)
=>
User
...
...
@@ -214,7 +219,13 @@ flowDataText u (DataNew (mLen, txtC)) tt cid mfslw jobHandle = do
------------------------------------------------------------------------
-- TODO use proxy
flowAnnuaire
::
(
FlowCmdM
env
err
m
,
MonadJobStatus
m
)
flowAnnuaire
::
(
DbCmd'
env
err
m
,
HasNodeStory
env
err
m
,
MonadLogger
m
,
HasNLPServer
env
,
HasTreeError
err
,
HasInvalidError
err
,
MonadJobStatus
m
)
=>
User
->
Either
CorpusName
[
CorpusId
]
->
(
TermType
Lang
)
...
...
@@ -227,7 +238,13 @@ flowAnnuaire u n l filePath jobHandle = do
flow
(
Nothing
::
Maybe
HyperdataAnnuaire
)
u
n
l
Nothing
(
fromIntegral
$
length
docs
,
yieldMany
docs
)
jobHandle
------------------------------------------------------------------------
flowCorpusFile
::
(
FlowCmdM
env
err
m
,
MonadJobStatus
m
)
flowCorpusFile
::
(
DbCmd'
env
err
m
,
HasNodeStory
env
err
m
,
MonadLogger
m
,
HasNLPServer
env
,
HasTreeError
err
,
HasInvalidError
err
,
MonadJobStatus
m
)
=>
User
->
Either
CorpusName
[
CorpusId
]
->
Limit
-- Limit the number of docs (for dev purpose)
...
...
@@ -250,7 +267,14 @@ flowCorpusFile u n _l la ft ff fp mfslw jobHandle = do
------------------------------------------------------------------------
-- | TODO improve the needed type to create/update a corpus
-- (For now, Either is enough)
flowCorpus
::
(
FlowCmdM
env
err
m
,
FlowCorpus
a
,
MonadJobStatus
m
)
flowCorpus
::
(
DbCmd'
env
err
m
,
HasNodeStory
env
err
m
,
MonadLogger
m
,
HasNLPServer
env
,
HasTreeError
err
,
HasInvalidError
err
,
FlowCorpus
a
,
MonadJobStatus
m
)
=>
User
->
Either
CorpusName
[
CorpusId
]
->
TermType
Lang
...
...
@@ -262,7 +286,12 @@ flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
flow
::
forall
env
err
m
a
c
.
(
FlowCmdM
env
err
m
(
DbCmd'
env
err
m
,
HasNodeStory
env
err
m
,
MonadLogger
m
,
HasNLPServer
env
,
HasTreeError
err
,
HasInvalidError
err
,
FlowCorpus
a
,
MkCorpus
c
,
MonadJobStatus
m
...
...
@@ -338,7 +367,11 @@ createNodes user corpusName ctype = do
pure
(
userId
,
userCorpusId
,
listId
)
flowCorpusUser
::
(
FlowCmdM
env
err
m
flowCorpusUser
::
(
HasNodeError
err
,
HasInvalidError
err
,
HasNLPServer
env
,
HasTreeError
err
,
HasNodeStory
env
err
m
,
MkCorpus
c
)
=>
Lang
...
...
@@ -589,7 +622,8 @@ instance HasText a => HasText (Node a)
-- | TODO putelsewhere
-- | Upgrade function
-- Suppose all documents are English (this is the case actually)
indexAllDocumentsWithPosTag
::
FlowCmdM
env
err
m
indexAllDocumentsWithPosTag
::
(
HasNodeStory
env
err
m
,
HasNLPServer
env
)
=>
m
()
indexAllDocumentsWithPosTag
=
do
rootId
<-
getRootId
(
UserName
userMaster
)
...
...
@@ -598,7 +632,8 @@ indexAllDocumentsWithPosTag = do
_
<-
mapM
extractInsert
(
splitEvery
1000
docs
)
pure
()
extractInsert
::
FlowCmdM
env
err
m
extractInsert
::
(
HasNodeStory
env
err
m
,
HasNLPServer
env
)
=>
[
Node
HyperdataDocument
]
->
m
()
extractInsert
docs
=
do
let
documentsWithId
=
map
(
\
doc
->
Indexed
(
doc
^.
node_id
)
doc
)
docs
...
...
src/Gargantext/Database/Action/Flow/List.hs
View file @
4ef66cea
...
...
@@ -17,27 +17,26 @@ Portability : POSIX
module
Gargantext.Database.Action.Flow.List
where
-- import Gargantext.Database.Query.Table.Node_NodeNgramsNodeNgrams
import
Control.Concurrent
import
Control.Lens
((
^.
),
(
+~
),
(
%~
),
at
,
(
.~
),
_Just
)
import
Control.Monad.Reader
import
Data.List
qualified
as
List
import
Data.Map.Strict
(
Map
,
toList
)
import
Data.Map.Strict
qualified
as
Map
import
Data.Map.Strict.Patch
qualified
as
PM
import
Data.Text
(
Text
)
import
Gargantext.API.Ngrams
(
saveNodeStory
)
import
Gargantext.API.Ngrams.Tools
(
getNodeStoryVar
)
import
Gargantext.API.Ngrams.Types
import
Gargantext.Core.NodeStory
import
Gargantext.Core.Types
(
HasInvalidError
(
..
),
assertValid
)
import
Gargantext.Core.Types.Main
(
ListType
(
CandidateTerm
))
import
Gargantext.Core.NodeStory
import
Gargantext.Database.Action.Flow.Types
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Query.Table.Ngrams
qualified
as
TableNgrams
import
Gargantext.Database.Query.Table.NodeNgrams
(
NodeNgramsPoly
(
..
),
NodeNgramsW
,
listInsertDb
,
{- getCgramsId -}
)
-- import Gargantext.Database.Query.Table.Node_NodeNgramsNodeNgrams
import
Gargantext.Database.Schema.Ngrams
(
NgramsType
(
..
))
import
Gargantext.Prelude
import
qualified
Data.List
as
List
import
qualified
Data.Map.Strict
as
Map
import
qualified
Data.Map.Strict.Patch
as
PM
import
qualified
Gargantext.Database.Query.Table.Ngrams
as
TableNgrams
-- FLOW LIST
-- 1. select specific terms of the corpus when compared with others langs
...
...
@@ -82,10 +81,10 @@ flowList_Tficf' u m nt f = do
------------------------------------------------------------------------
flowList_DbRepo
::
FlowCmdM
env
err
m
=>
ListId
->
Map
NgramsType
[
NgramsElement
]
->
m
ListId
flowList_DbRepo
::
(
HasInvalidError
err
,
HasNodeStory
env
err
m
)
=>
ListId
->
Map
NgramsType
[
NgramsElement
]
->
m
ListId
flowList_DbRepo
lId
ngs
=
do
-- printDebug "listId flowList" lId
_mapCgramsId
<-
listInsertDb
lId
toNodeNgramsW
(
Map
.
toList
ngs
)
...
...
@@ -157,10 +156,10 @@ toNodeNgramsW' l'' ngs = [ NodeNgrams { _nng_id = Nothing
]
listInsert
::
FlowCmdM
env
err
m
=>
ListId
->
Map
NgramsType
[
NgramsElement
]
->
m
()
listInsert
::
(
HasInvalidError
err
,
HasNodeStory
env
err
m
)
=>
ListId
->
Map
NgramsType
[
NgramsElement
]
->
m
()
listInsert
lId
ngs
=
mapM_
(
\
(
typeList
,
ngElmts
)
->
putListNgrams
lId
typeList
ngElmts
)
(
toList
ngs
)
...
...
src/Gargantext/Database/Action/Flow/Pairing.hs
View file @
4ef66cea
...
...
@@ -16,13 +16,18 @@ module Gargantext.Database.Action.Flow.Pairing
-- (pairing)
where
import
Debug.Trace
(
trace
)
import
Control.Lens
(
_Just
,
(
^.
),
view
)
import
Data.Hashable
(
Hashable
)
import
Data.HashMap.Strict
(
HashMap
)
import
Data.HashMap.Strict
qualified
as
HM
import
Data.HashMap.Strict
qualified
as
HashMap
import
Data.Hashable
(
Hashable
)
import
Data.List
qualified
as
List
import
Data.Maybe
(
fromMaybe
,
catMaybes
)
import
Data.Set
(
Set
)
import
Data.Set
qualified
as
Set
import
Data.Text
(
Text
)
import
Data.Text
qualified
as
Text
import
Debug.Trace
(
trace
)
import
Gargantext.API.Ngrams.Tools
import
Gargantext.API.Ngrams.Types
(
NgramsTerm
(
..
))
import
Gargantext.Core
...
...
@@ -42,16 +47,11 @@ 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
)
import
Gargantext.Database.Prelude
(
Cmd
,
runOpaQuery
)
import
Gargantext.Database.Schema.Ngrams
-- (NgramsType(..))
import
Gargantext.Database.Schema.Node
-- import Gargantext.Database.Schema.Context
import
qualified
Data.HashMap.Strict
as
HM
import
Gargantext.Prelude
hiding
(
sum
)
import
Opaleye
import
qualified
Data.HashMap.Strict
as
HashMap
import
qualified
Data.List
as
List
import
qualified
Data.Set
as
Set
import
qualified
Data.Text
as
Text
-- | isPairedWith
-- All NodeAnnuaire paired with a Corpus of NodeId nId:
...
...
src/Gargantext/Database/Action/Learn.hs
View file @
4ef66cea
...
...
@@ -15,19 +15,19 @@ Portability : POSIX
module
Gargantext.Database.Action.Learn
where
import
Data.List
qualified
as
List
import
Data.Maybe
import
Data.Text
(
Text
)
import
Data.Text
qualified
as
Text
import
Gargantext.Core
import
Gargantext.Core.Text.Learn
import
Gargantext.Core.Types.Query
(
Offset
,
Limit
(
..
))
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Prelude
(
DBCmd
)
import
Gargantext.Database.Query.Facet
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Prelude
(
Cmd
)
import
Gargantext.Prelude
import
Gargantext.Core.Text.Learn
import
qualified
Data.List
as
List
import
qualified
Data.Text
as
Text
data
FavOrTrash
=
IsFav
|
IsTrash
deriving
(
Eq
)
...
...
@@ -35,14 +35,14 @@ data FavOrTrash = IsFav | IsTrash
moreLike
::
(
HasDBid
NodeType
,
HasNodeError
err
)
=>
CorpusId
->
Maybe
Offset
->
Maybe
Limit
->
Maybe
OrderBy
->
FavOrTrash
->
Cmd
err
[
FacetDoc
]
->
FavOrTrash
->
DB
Cmd
err
[
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
->
Cmd
err
(
Events
Bool
)
=>
FavOrTrash
->
CorpusId
->
DB
Cmd
err
(
Events
Bool
)
getPriors
ft
cId
=
do
docs_fav
<-
filter
(
\
(
FacetDoc
_
_
_
_
f
_
_
)
->
f
==
Just
2
)
...
...
@@ -60,7 +60,7 @@ getPriors ft cId = do
moreLikeWith
::
(
HasDBid
NodeType
,
HasNodeError
err
)
=>
CorpusId
->
Maybe
Offset
->
Maybe
Limit
->
Maybe
OrderBy
->
FavOrTrash
->
Events
Bool
->
Cmd
err
[
FacetDoc
]
->
FavOrTrash
->
Events
Bool
->
DB
Cmd
err
[
FacetDoc
]
moreLikeWith
cId
o
l
order
ft
priors
=
do
docs_test
<-
filter
(
\
(
FacetDoc
_
_
_
_
f
_
_
)
->
f
==
Just
1
)
...
...
src/Gargantext/Database/Action/Mail.hs
View file @
4ef66cea
...
...
@@ -18,7 +18,7 @@ import Gargantext.Core.Mail (mail, MailModel(..))
import
Gargantext.Core.Mail.Types
(
mailSettings
)
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Database.Action.User
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
CmdM
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
(
..
))
import
Gargantext.Database.Schema.User
import
Gargantext.Prelude
...
...
src/Gargantext/Database/Action/Metrics.hs
View file @
4ef66cea
...
...
@@ -184,15 +184,13 @@ updateContextScore cId lId = do
-- Used for scores in Doc Table
getContextsNgramsScore
::
--(FlowCmdM env err m)
(
HasNodeStory
env
err
m
)
getContextsNgramsScore
::
(
HasNodeStory
env
err
m
)
=>
CorpusId
->
ListId
->
TabType
->
ListType
->
Maybe
Limit
->
m
(
Map
ContextId
Int
)
getContextsNgramsScore
cId
lId
tabType
listType
maybeLimit
=
Map
.
map
Set
.
size
<$>
getContextsNgrams
cId
lId
tabType
listType
maybeLimit
getContextsNgrams
::
--(FlowCmdM env err m)
(
HasNodeStory
env
err
m
)
getContextsNgrams
::
(
HasNodeStory
env
err
m
)
=>
CorpusId
->
ListId
->
TabType
->
ListType
->
Maybe
Limit
->
m
(
Map
ContextId
(
Set
NgramsTerm
))
getContextsNgrams
cId
lId
tabType
listType
maybeLimit
=
do
...
...
src/Gargantext/Database/Action/Metrics/NgramsByContext.hs
View file @
4ef66cea
...
...
@@ -249,11 +249,11 @@ queryNgramsOccurrencesOnlyByContextUser_withSample' = [sql|
------------------------------------------------------------------------
getContextsByNgramsOnlyUser
::
HasDBid
NodeType
=>
CorpusId
->
[
ListId
]
->
NgramsType
->
[
NgramsTerm
]
->
DBCmd
err
(
HashMap
NgramsTerm
(
Set
NodeId
))
=>
CorpusId
->
[
ListId
]
->
NgramsType
->
[
NgramsTerm
]
->
DBCmd
err
(
HashMap
NgramsTerm
(
Set
NodeId
))
getContextsByNgramsOnlyUser
cId
ls
nt
ngs
=
HM
.
unionsWith
(
<>
)
.
map
(
HM
.
fromListWith
(
<>
)
...
...
src/Gargantext/Database/Action/Metrics/TFICF.hs
View file @
4ef66cea
...
...
@@ -23,7 +23,7 @@ import Gargantext.Core
import
Gargantext.Core.Text.Metrics.TFICF
import
Gargantext.Database.Action.Metrics.NgramsByContext
(
getContextsByNgramsUser
,
{-getOccByNgramsOnlyFast,-}
getOccByNgramsOnlyFast_withSample
)
import
Gargantext.Database.Admin.Types.Node
-- (ListId, CorpusId, NodeId)
import
Gargantext.Database.Prelude
(
Cmd
)
import
Gargantext.Database.Prelude
(
DB
Cmd
)
import
Gargantext.Database.Query.Table.NodeContext
(
selectCountDocs
)
import
Gargantext.Database.Schema.Ngrams
(
NgramsType
(
..
))
import
Gargantext.API.Ngrams.Types
...
...
@@ -58,10 +58,10 @@ getTficf cId mId nt = do
-}
getTficf_withSample
::
HasDBid
NodeType
=>
UserCorpusId
->
MasterCorpusId
->
NgramsType
->
Cmd
err
(
HashMap
NgramsTerm
Double
)
=>
UserCorpusId
->
MasterCorpusId
->
NgramsType
->
DB
Cmd
err
(
HashMap
NgramsTerm
Double
)
getTficf_withSample
cId
mId
nt
=
do
mapTextDoubleLocal
<-
HM
.
filter
(
>
1
)
<$>
HM
.
map
(
fromIntegral
.
Set
.
size
)
...
...
src/Gargantext/Database/Action/Node.hs
View file @
4ef66cea
...
...
@@ -30,7 +30,7 @@ import Gargantext.Database.Query.Table.Node.Error
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
import
Gargantext.Prelude
import
Gargantext.Prelude.Crypto.Hash
(
hash
)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
DBCmd
,
HasConfig
(
..
))
import
Control.Lens
(
view
)
import
Gargantext.Prelude.Config
(
GargConfig
(
..
))
...
...
src/Gargantext/Database/Action/Share.hs
View file @
4ef66cea
...
...
@@ -25,17 +25,17 @@ import Gargantext.Database.Action.User (getUserId)
import
Gargantext.Database.Admin.Config
(
hasNodeType
,
isInNodeTypes
)
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataAny
(
..
))
import
Gargantext.Database.Admin.Types.Node
-- import Gargantext.Database.Query.Join (leftJoin3')
import
Gargantext.Database.Query.Table.Node
(
getNode
,
getNodesWith
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
,
errorWith
)
import
Gargantext.Database.Query.Table.NodeNode
(
deleteNodeNode
,
queryNodeNodeTable
)
import
Gargantext.Database.Query.Table.User
import
Gargantext.Database.Query.Tree.Root
(
getRootId
)
import
Gargantext.Database.Prelude
(
Cmd
,
runOpaQuery
)
import
Gargantext.Database.Schema.Node
import
Gargantext.Prelude
import
Gargantext.Utils.Tuple
(
uncurryMaybe
)
import
Opaleye
hiding
(
not
)
import
qualified
Opaleye
as
O
import
Opaleye
qualified
as
O
-- | TODO move in PhyloConfig of Gargantext
publicNodeTypes
::
[
NodeType
]
...
...
src/Gargantext/Database/Action/TSQuery.hs
View file @
4ef66cea
{-|
Module : Gargantext.Database.Action.TSQuery
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Here is a longer description of this module, containing some
commentary with @some markup@.
-}
module
Gargantext.Database.Action.TSQuery
where
import
Data.Aeson
...
...
@@ -8,11 +21,11 @@ import Data.Text (Text, words)
import
Database.PostgreSQL.Simple
(
Query
)
import
Database.PostgreSQL.Simple.ToField
import
Gargantext.Core
import
Gargantext.Core.Text.Terms.Mono.Stem.En
(
stemIt
)
import
Gargantext.Core.Types
import
Gargantext.Core.Types.Query
(
Limit
,
Offset
)
import
Gargantext.Database.Prelude
(
Cmd
,
runPGSQuery
)
import
Gargantext.Database.Prelude
(
DB
Cmd
,
runPGSQuery
)
import
Gargantext.Prelude
import
Gargantext.Core.Text.Terms.Mono.Stem.En
(
stemIt
)
newtype
TSQuery
=
UnsafeTSQuery
[
Text
]
...
...
@@ -71,7 +84,7 @@ textSearchQuery = "SELECT n.id, n.hyperdata->'publication_year' \
textSearch
::
HasDBid
NodeType
=>
TSQuery
->
ParentId
->
Limit
->
Offset
->
Order
->
Cmd
err
[(
Int
,
Value
,
Value
,
Value
,
Value
,
Maybe
Int
)]
->
DB
Cmd
err
[(
Int
,
Value
,
Value
,
Value
,
Value
,
Maybe
Int
)]
textSearch
q
p
l
o
ord
=
runPGSQuery
textSearchQuery
(
q
,
p
,
p
,
typeId
,
ord
,
o
,
l
)
where
typeId
=
toDBid
NodeDocument
src/Gargantext/Database/Action/User/New.hs
View file @
4ef66cea
...
...
@@ -29,7 +29,7 @@ import Gargantext.Core.Mail.Types (HasMail, mailSettings)
import
Gargantext.Core.Types.Individu
import
Gargantext.Database.Action.Flow
(
getOrMkRoot
)
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
Cmd
,
DBCmd
,
CmdM
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
(
..
),
nodeError
,
NodeError
(
..
))
import
Gargantext.Database.Query.Table.User
import
Gargantext.Prelude
...
...
@@ -135,12 +135,12 @@ _updateUsersPassword us = do
pure
1
------------------------------------------------------------------------
_rmUser
::
HasNodeError
err
=>
User
->
Cmd
err
Int64
_rmUser
::
HasNodeError
err
=>
User
->
DB
Cmd
err
Int64
_rmUser
(
UserName
un
)
=
deleteUsers
[
un
]
_rmUser
_
=
nodeError
NotImplYet
------------------------------------------------------------------------
-- TODO
_rmUsers
::
HasNodeError
err
=>
[
User
]
->
Cmd
err
Int64
_rmUsers
::
HasNodeError
err
=>
[
User
]
->
DB
Cmd
err
Int64
_rmUsers
[]
=
pure
0
_rmUsers
_
=
undefined
src/Gargantext/Database/Prelude.hs
View file @
4ef66cea
...
...
@@ -144,17 +144,15 @@ runCountOpaQuery q = do
-- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
pure
$
fromInt64ToInt
$
DL
.
head
counts
formatPGSQuery
::
PGS
.
ToRow
a
=>
PGS
.
Query
->
a
->
Cmd
err
DB
.
ByteString
formatPGSQuery
::
PGS
.
ToRow
a
=>
PGS
.
Query
->
a
->
DB
Cmd
err
DB
.
ByteString
formatPGSQuery
q
a
=
mkCmd
$
\
conn
->
PGS
.
formatQuery
conn
q
a
-- TODO use runPGSQueryDebug everywhere
runPGSQuery'
::
(
PGS
.
ToRow
a
,
PGS
.
FromRow
b
)
=>
PGS
.
Query
->
a
->
Cmd
err
[
b
]
runPGSQuery'
::
(
PGS
.
ToRow
a
,
PGS
.
FromRow
b
)
=>
PGS
.
Query
->
a
->
DB
Cmd
err
[
b
]
runPGSQuery'
q
a
=
mkCmd
$
\
conn
->
PGS
.
query
conn
q
a
runPGSQuery
::
(
DbCmd'
env
err
m
,
PGS
.
FromRow
r
,
PGS
.
ToRow
q
)
=>
PGS
.
Query
->
q
->
m
[
r
]
runPGSQuery
::
(
PGS
.
FromRow
r
,
PGS
.
ToRow
q
)
=>
PGS
.
Query
->
q
->
DBCmd
err
[
r
]
runPGSQuery
q
a
=
mkCmd
$
\
conn
->
catch
(
PGS
.
query
conn
q
a
)
(
printError
conn
)
where
printError
c
(
SomeException
e
)
=
do
...
...
@@ -179,10 +177,8 @@ runPGSQueryFold q initialState consume = mkCmd $ \conn -> catch (PGS.fold_ conn
-- | TODO catch error
runPGSQuery_
::
(
CmdM
env
err
m
,
PGS
.
FromRow
r
)
=>
PGS
.
Query
->
m
[
r
]
runPGSQuery_
::
(
PGS
.
FromRow
r
)
=>
PGS
.
Query
->
DBCmd
err
[
r
]
runPGSQuery_
q
=
mkCmd
$
\
conn
->
catch
(
PGS
.
query_
conn
q
)
printError
where
printError
(
SomeException
e
)
=
do
...
...
@@ -227,7 +223,7 @@ fromField' field mb = do
printSqlOpa
::
Default
Unpackspec
a
a
=>
Select
a
->
IO
()
printSqlOpa
=
putStrLn
.
maybe
"Empty query"
identity
.
showSql
dbCheck
::
CmdM
env
err
m
=>
m
Bool
dbCheck
::
DBCmd
err
Bool
dbCheck
=
do
r
::
[
PGS
.
Only
Text
]
<-
runPGSQuery_
"select username from public.auth_user"
case
r
of
...
...
src/Gargantext/Database/Query/Facet.hs
View file @
4ef66cea
...
...
@@ -43,7 +43,7 @@ import Data.Text qualified as T
import
Gargantext.Core
import
Gargantext.Core.Types
import
Gargantext.Core.Types.Query
(
Limit
,
Offset
,
IsTrash
)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
DBCmd
,
runCountOpaQuery
,
runOpaQuery
)
import
Gargantext.Database.Query.Facet.Types
import
Gargantext.Database.Query.Filter
import
Gargantext.Database.Query.Table.Context
...
...
@@ -70,7 +70,7 @@ runViewAuthorsDoc :: HasDBid NodeType
->
Maybe
Offset
->
Maybe
Limit
->
Maybe
OrderBy
->
Cmd
err
[
FacetDoc
]
->
DB
Cmd
err
[
FacetDoc
]
runViewAuthorsDoc
cId
t
o
l
order
=
runOpaQuery
$
filterWith
o
l
order
$
viewAuthorsDoc
cId
t
ntId
where
ntId
=
NodeDocument
...
...
@@ -125,11 +125,11 @@ runViewDocuments :: (HasDBid NodeType, HasNodeError err)
->
Maybe
OrderBy
->
Maybe
Text
->
Maybe
Text
->
Cmd
err
[
FacetDoc
]
->
DB
Cmd
err
[
FacetDoc
]
runViewDocuments
cId
t
o
l
order
query
year
=
do
listId
<-
defaultList
cId
res
<-
runOpaQuery
$
filterWith'
o
l
order
(
sqlQuery
listId
)
::
Cmd
err
[
FacetDocAgg'
]
res
<-
runOpaQuery
$
filterWith'
o
l
order
(
sqlQuery
listId
)
::
DB
Cmd
err
[
FacetDocAgg'
]
pure
$
remapNgramsCount
<$>
res
where
sqlQuery
lId
=
viewDocuments
cId
lId
t
(
toDBid
NodeDocument
)
query
year
...
...
@@ -140,7 +140,7 @@ runViewDocuments cId t o l order query year = do
,
..
}
runCountDocuments
::
(
HasDBid
NodeType
,
HasNodeError
err
)
=>
CorpusId
->
IsTrash
->
Maybe
Text
->
Maybe
Text
->
Cmd
err
Int
=>
CorpusId
->
IsTrash
->
Maybe
Text
->
Maybe
Text
->
DB
Cmd
err
Int
runCountDocuments
cId
t
mQuery
mYear
=
do
listId
<-
defaultList
cId
runCountOpaQuery
(
sqlQuery
listId
)
...
...
src/Gargantext/Database/Query/Table/Context.hs
View file @
4ef66cea
...
...
@@ -25,7 +25,7 @@ import Gargantext.Core
import
Gargantext.Core.Types
import
Gargantext.Core.Types.Query
(
Limit
,
Offset
)
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
DBCmd
,
JSONB
,
runOpaQuery
)
import
Gargantext.Database.Query.Filter
(
limit'
,
offset'
)
import
Gargantext.Database.Query.Table.Node.Error
import
Gargantext.Database.Schema.Context
...
...
@@ -35,7 +35,7 @@ import Prelude hiding (null, id, map, sum)
getContextWith
::
(
HasNodeError
err
,
JSONB
a
)
=>
ContextId
->
proxy
a
->
Cmd
err
(
Node
a
)
=>
ContextId
->
proxy
a
->
DB
Cmd
err
(
Node
a
)
getContextWith
nId
_
=
do
maybeContext
<-
headMay
<$>
runOpaQuery
(
selectContext
(
pgNodeId
nId
))
case
maybeContext
of
...
...
@@ -51,7 +51,7 @@ selectContext id' = proc () -> do
restrict
-<
_context_id
row
.==
id'
returnA
-<
row
runGetContexts
::
Select
ContextRead
->
Cmd
err
[
Context
HyperdataAny
]
runGetContexts
::
Select
ContextRead
->
DB
Cmd
err
[
Context
HyperdataAny
]
runGetContexts
=
runOpaQuery
------------------------------------------------------------------------
...
...
@@ -84,11 +84,11 @@ selectContextsWith' parentId maybeContextType = proc () -> do
------------------------------------------------------------------------
getDocumentsV3WithParentId
::
HasDBid
NodeType
=>
NodeId
->
Cmd
err
[
Context
HyperdataDocumentV3
]
getDocumentsV3WithParentId
::
HasDBid
NodeType
=>
NodeId
->
DB
Cmd
err
[
Context
HyperdataDocumentV3
]
getDocumentsV3WithParentId
n
=
runOpaQuery
$
selectContextsWith'
n
(
Just
NodeDocument
)
-- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
getDocumentsWithParentId
::
HasDBid
NodeType
=>
NodeId
->
Cmd
err
[
Context
HyperdataDocument
]
getDocumentsWithParentId
::
HasDBid
NodeType
=>
NodeId
->
DB
Cmd
err
[
Context
HyperdataDocument
]
getDocumentsWithParentId
n
=
runOpaQuery
$
selectContextsWith'
n
(
Just
NodeDocument
)
------------------------------------------------------------------------
...
...
@@ -102,7 +102,8 @@ selectContextsWithParentID n = proc () -> do
------------------------------------------------------------------------
-- | Example of use:
-- runCmdReplEasy (getNodesWithType NodeList (Proxy :: Proxy HyperdataList))
getContextsWithType
::
(
HasNodeError
err
,
JSONB
a
,
HasDBid
NodeType
)
=>
NodeType
->
proxy
a
->
Cmd
err
[
Context
a
]
getContextsWithType
::
(
HasNodeError
err
,
JSONB
a
,
HasDBid
NodeType
)
=>
NodeType
->
proxy
a
->
DBCmd
err
[
Context
a
]
getContextsWithType
nt
_
=
runOpaQuery
$
selectContextsWithType
nt
where
selectContextsWithType
::
HasDBid
NodeType
...
...
@@ -112,7 +113,8 @@ getContextsWithType nt _ = runOpaQuery $ selectContextsWithType nt
restrict
-<
tn
.==
(
sqlInt4
$
toDBid
nt'
)
returnA
-<
row
getContextsIdWithType
::
(
HasNodeError
err
,
HasDBid
NodeType
)
=>
NodeType
->
Cmd
err
[
ContextId
]
getContextsIdWithType
::
(
HasNodeError
err
,
HasDBid
NodeType
)
=>
NodeType
->
DBCmd
err
[
ContextId
]
getContextsIdWithType
nt
=
do
ns
<-
runOpaQuery
$
selectContextsIdWithType
nt
pure
(
map
NodeId
ns
)
...
...
src/Gargantext/Database/Query/Table/Ngrams.hs
View file @
4ef66cea
...
...
@@ -28,7 +28,7 @@ import Data.HashMap.Strict (HashMap)
import
Data.Map.Strict
(
Map
)
import
Data.Text
(
Text
)
import
Gargantext.Core.Types
import
Gargantext.Database.Prelude
(
runOpaQuery
,
Cmd
,
formatPGSQuery
,
runPGSQuery
,
DBCmd
)
import
Gargantext.Database.Prelude
(
runOpaQuery
,
formatPGSQuery
,
runPGSQuery
,
DBCmd
)
import
Gargantext.Database.Query.Join
(
leftJoin3
)
import
Gargantext.Database.Query.Table.ContextNodeNgrams2
import
Gargantext.Database.Query.Table.NodeNgrams
(
queryNodeNgramsTable
)
...
...
@@ -45,7 +45,7 @@ import qualified Database.PostgreSQL.Simple as PGS
queryNgramsTable
::
Select
NgramsRead
queryNgramsTable
=
selectTable
ngramsTable
selectNgramsByDoc
::
[
ListId
]
->
DocId
->
NgramsType
->
Cmd
err
[
Text
]
selectNgramsByDoc
::
[
ListId
]
->
DocId
->
NgramsType
->
DB
Cmd
err
[
Text
]
selectNgramsByDoc
lIds
dId
nt
=
runOpaQuery
(
query
lIds
dId
nt
)
where
...
...
@@ -65,10 +65,10 @@ selectNgramsByDoc lIds dId nt = runOpaQuery (query lIds dId nt)
returnA
-<
ng
^.
ngrams_terms
_postNgrams
::
CorpusId
->
DocId
->
[
Text
]
->
Cmd
err
Int
_postNgrams
::
CorpusId
->
DocId
->
[
Text
]
->
DB
Cmd
err
Int
_postNgrams
=
undefined
_dbGetNgramsDb
::
Cmd
err
[
NgramsDB
]
_dbGetNgramsDb
::
DB
Cmd
err
[
NgramsDB
]
_dbGetNgramsDb
=
runOpaQuery
queryNgramsTable
...
...
@@ -85,7 +85,7 @@ insertNgrams' ns = runPGSQuery queryInsertNgrams (PGS.Only $ Values fields ns)
where
fields
=
map
(
\
t
->
QualifiedIdentifier
Nothing
t
)
[
"text"
,
"int4"
]
_insertNgrams_Debug
::
[(
Text
,
Size
)]
->
Cmd
err
ByteString
_insertNgrams_Debug
::
[(
Text
,
Size
)]
->
DB
Cmd
err
ByteString
_insertNgrams_Debug
ns
=
formatPGSQuery
queryInsertNgrams
(
PGS
.
Only
$
Values
fields
ns
)
where
fields
=
map
(
\
t
->
QualifiedIdentifier
Nothing
t
)
[
"text"
,
"int4"
]
...
...
@@ -111,13 +111,13 @@ queryInsertNgrams = [sql|
--------------------------------------------------------------------------
selectNgramsId
::
[
Text
]
->
Cmd
err
(
Map
NgramsId
Text
)
selectNgramsId
::
[
Text
]
->
DB
Cmd
err
(
Map
NgramsId
Text
)
selectNgramsId
ns
=
if
List
.
null
ns
then
pure
Map
.
empty
else
Map
.
fromList
<$>
map
(
\
(
Indexed
i
t
)
->
(
i
,
t
))
<$>
(
selectNgramsId'
ns
)
selectNgramsId'
::
[
Text
]
->
Cmd
err
[
Indexed
Int
Text
]
selectNgramsId'
::
[
Text
]
->
DB
Cmd
err
[
Indexed
Int
Text
]
selectNgramsId'
ns
=
runPGSQuery
querySelectNgramsId
(
PGS
.
Only
$
Values
fields
ns
)
...
...
src/Gargantext/Database/Query/Table/NgramsPostag.hs
View file @
4ef66cea
...
...
@@ -24,7 +24,7 @@ import Data.Hashable (Hashable)
import
Data.Text
(
Text
)
import
Gargantext.Core
import
Gargantext.Core.Types
import
Gargantext.Database.Prelude
(
Cmd
,
runPGSQuery
,
runPGSQuery_
,
DBCmd
)
import
Gargantext.Database.Prelude
(
runPGSQuery
,
runPGSQuery_
,
DBCmd
)
import
Gargantext.Database.Schema.Ngrams
import
Gargantext.Database.Schema.Prelude
import
Gargantext.Database.Query.Table.Ngrams
...
...
@@ -155,7 +155,7 @@ SELECT terms,id FROM ins_form_ret
-- TODO add lang and postag algo
-- TODO remove when form == lem in insert
selectLems
::
Lang
->
NLPServerConfig
->
[
Ngrams
]
->
Cmd
err
[(
Form
,
Lem
)]
selectLems
::
Lang
->
NLPServerConfig
->
[
Ngrams
]
->
DB
Cmd
err
[(
Form
,
Lem
)]
selectLems
l
(
NLPServerConfig
{
server
})
ns
=
runPGSQuery
querySelectLems
(
PGS
.
Only
$
Values
fields
datas
)
where
fields
=
map
(
\
t
->
QualifiedIdentifier
Nothing
t
)
[
"int4"
,
"int4"
,
"text"
,
"int4"
]
...
...
@@ -180,7 +180,7 @@ querySelectLems = [sql|
|]
-- | Insert Table
createTable_NgramsPostag
::
Cmd
err
[
Int
]
createTable_NgramsPostag
::
DB
Cmd
err
[
Int
]
createTable_NgramsPostag
=
map
(
\
(
PGS
.
Only
a
)
->
a
)
<$>
runPGSQuery_
queryCreateTable
where
...
...
src/Gargantext/Database/Query/Table/Node.hs
View file @
4ef66cea
...
...
@@ -25,22 +25,20 @@ import Control.Lens (set, view)
import
Data.Aeson
import
Data.Maybe
(
fromMaybe
)
import
Data.Text
(
Text
)
import
Database.PostgreSQL.Simple
qualified
as
PGS
import
Database.PostgreSQL.Simple.SqlQQ
(
sql
)
import
Opaleye
hiding
(
FromField
)
import
Prelude
hiding
(
null
,
id
,
map
,
sum
)
import
Gargantext.Core
import
Gargantext.Core.Types
import
Gargantext.Core.Types.Query
(
Limit
,
Offset
)
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Hyperdata.Default
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
DBCmd
,
JSONB
,
mkCmd
,
runPGSQuery
,
runOpaQuery
)
import
Gargantext.Database.Query.Filter
(
limit'
,
offset'
)
import
Gargantext.Database.Query.Table.Node.Error
import
Gargantext.Database.Schema.Node
import
Gargantext.Prelude
hiding
(
sum
,
head
)
import
qualified
Database.PostgreSQL.Simple
as
PGS
import
Opaleye
hiding
(
FromField
)
import
Prelude
hiding
(
null
,
id
,
map
,
sum
)
queryNodeSearchTable
::
Select
NodeSearchRead
...
...
src/Gargantext/Database/Query/Table/Node/Children.hs
View file @
4ef66cea
...
...
@@ -22,15 +22,11 @@ import Gargantext.Core
import
Gargantext.Core.Types
import
Gargantext.Core.Types.Query
(
Limit
,
Offset
)
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataDocument
,
HyperdataContact
)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
DBCmd
,
JSONB
,
runCountOpaQuery
,
runOpaQuery
)
import
Gargantext.Database.Query.Filter
import
Gargantext.Database.Schema.Node
import
Gargantext.Database.Schema.Context
import
Gargantext.Database.Schema.NodeContext
import
Gargantext.Database.Query.Table.NodeContext
import
Gargantext.Database.Schema.Context
import
Gargantext.Database.Schema.Node
import
Gargantext.Prelude
import
Opaleye
...
...
src/Gargantext/Database/Query/Table/Node/Document/Add.hs
View file @
4ef66cea
...
...
@@ -28,7 +28,7 @@ import Database.PostgreSQL.Simple.ToRow (ToRow(..))
import
Database.PostgreSQL.Simple.Types
(
Values
(
..
),
QualifiedIdentifier
(
..
))
import
GHC.Generics
(
Generic
)
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Prelude
(
Cmd
,
runPGSQuery
,
formatPGSQuery
,
DBCmd
)
import
Gargantext.Database.Prelude
(
runPGSQuery
,
formatPGSQuery
,
DBCmd
)
import
Gargantext.Prelude
---------------------------------------------------------------------------
...
...
@@ -41,12 +41,12 @@ add pId ns = runPGSQuery queryAdd (Only $ Values fields inputData)
-- | Adds a single document. Useful for debugging purposes, but
-- not as efficient as adding documents in bulk via 'add'.
add_one
::
CorpusId
->
ContextId
->
Cmd
err
[
Only
Int
]
add_one
::
CorpusId
->
ContextId
->
DB
Cmd
err
[
Only
Int
]
add_one
pId
ctxId
=
runPGSQuery
queryAdd
(
Only
$
Values
fields
[
InputData
pId
ctxId
])
where
fields
=
map
(
\
t
->
QualifiedIdentifier
Nothing
t
)
inputSqlTypes
add_debug
::
CorpusId
->
[
ContextId
]
->
Cmd
err
ByteString
add_debug
::
CorpusId
->
[
ContextId
]
->
DB
Cmd
err
ByteString
add_debug
pId
ns
=
formatPGSQuery
queryAdd
(
Only
$
Values
fields
inputData
)
where
fields
=
map
(
\
t
->
QualifiedIdentifier
Nothing
t
)
inputSqlTypes
...
...
src/Gargantext/Database/Query/Table/Node/Select.hs
View file @
4ef66cea
...
...
@@ -16,16 +16,14 @@ module Gargantext.Database.Query.Table.Node.Select
where
import
Control.Arrow
(
returnA
)
import
Opaleye
import
Protolude
import
Gargantext.Core
import
Gargantext.Core.Types
import
Gargantext.Core.Types.Individu
(
Username
)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Schema.Node
import
Gargantext.Database.Schema.User
import
Gargantext.Database.Prelude
(
DBCmd
,
runOpaQuery
)
import
Gargantext.Database.Query.Table.User
import
Gargantext.Database.Schema.Node
import
Opaleye
import
Protolude
selectNodesWithUsername
::
(
HasDBid
NodeType
)
=>
NodeType
->
Username
->
DBCmd
err
[
NodeId
]
selectNodesWithUsername
nt
u
=
runOpaQuery
$
proc
()
->
do
...
...
src/Gargantext/Database/Query/Table/Node/Update.hs
View file @
4ef66cea
...
...
@@ -19,7 +19,7 @@ import Database.PostgreSQL.Simple
import
Gargantext.Prelude
import
Gargantext.Core.Types
(
Name
)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
DBCmd
,
runPGSQuery
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
,
ParentId
)
-- import Data.ByteString
...
...
@@ -39,7 +39,7 @@ unOnly :: Only a -> a
unOnly
(
Only
a
)
=
a
-- TODO-ACCESS
update
::
Update
->
Cmd
err
[
Int
]
update
::
Update
->
DB
Cmd
err
[
Int
]
update
(
Rename
nId
name
)
=
map
unOnly
<$>
runPGSQuery
"UPDATE nodes SET name=? where id=? returning id"
(
DT
.
take
255
name
,
nId
)
update
(
Move
nId
pId
)
=
map
unOnly
<$>
runPGSQuery
"UPDATE nodes SET parent_id= ? where id=? returning id"
...
...
src/Gargantext/Database/Query/Table/Node/UpdateOpaleye.hs
View file @
4ef66cea
...
...
@@ -22,7 +22,7 @@ import Gargantext.Prelude
import
Gargantext.Database.Schema.Node
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Prelude
(
Cmd
,
mkCmd
,
DBCmd
)
import
Gargantext.Database.Prelude
(
mkCmd
,
DBCmd
)
import
Gargantext.Database.Query.Table.Node
import
Gargantext.Database.Query.Table.Node.Error
...
...
@@ -49,7 +49,7 @@ updateHyperdataQuery i h = seq h' $ {- trace "updateHyperdataQuery: encoded JSON
updateNodesWithType
::
(
HasNodeError
err
,
HasDBid
NodeType
,
HyperdataC
a
)
=>
NodeType
->
proxy
a
->
(
a
->
a
)
->
Cmd
err
[
Int64
]
)
=>
NodeType
->
proxy
a
->
(
a
->
a
)
->
DB
Cmd
err
[
Int64
]
updateNodesWithType
nt
p
f
=
do
ns
<-
getNodesWithType
nt
p
mapM
(
\
n
->
updateHyperdata
(
_node_id
n
)
(
f
$
_node_hyperdata
n
))
ns
...
...
@@ -61,7 +61,7 @@ updateNodeWithType :: ( HasNodeError err
->
NodeType
->
proxy
a
->
(
a
->
a
)
->
Cmd
err
[
Int64
]
->
DB
Cmd
err
[
Int64
]
updateNodeWithType
nId
nt
p
f
=
do
ns
<-
getNodeWithType
nId
nt
p
mapM
(
\
n
->
updateHyperdata
(
_node_id
n
)
(
f
$
_node_hyperdata
n
))
ns
...
...
@@ -71,7 +71,7 @@ updateNodeWithType nId nt p f = do
updateNodesWithType_
::
(
HasNodeError
err
,
HyperdataC
a
,
HasDBid
NodeType
)
=>
NodeType
->
a
->
Cmd
err
[
Int64
]
)
=>
NodeType
->
a
->
DB
Cmd
err
[
Int64
]
updateNodesWithType_
nt
h
=
do
ns
<-
getNodesIdWithType
nt
mapM
(
\
n
->
updateHyperdata
n
h
)
ns
src/Gargantext/Database/Query/Table/Node/User.hs
View file @
4ef66cea
...
...
@@ -17,14 +17,14 @@ import Gargantext.Core
import
Gargantext.Core.Types
(
Name
)
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataUser
(
..
),
defaultHyperdataUser
)
import
Gargantext.Database.Admin.Types.Node
(
Node
,
NodeId
(
..
),
UserId
,
NodeType
(
..
),
pgNodeId
)
import
Gargantext.Database.Prelude
-- (fromField', Cmd
)
import
Gargantext.Database.Prelude
(
DBCmd
,
runOpaQuery
)
import
Gargantext.Database.Query.Table.Node
import
Gargantext.Database.Schema.Node
-- (Node(..))
import
Gargantext.Prelude
import
Opaleye
(
limit
)
getNodeUser
::
NodeId
->
Cmd
err
(
Node
HyperdataUser
)
getNodeUser
::
NodeId
->
DB
Cmd
err
(
Node
HyperdataUser
)
getNodeUser
nId
=
do
fromMaybe
(
panic
$
"Node does not exist: "
<>
(
cs
$
show
nId
))
.
headMay
<$>
runOpaQuery
(
limit
1
$
selectNode
(
pgNodeId
nId
))
...
...
src/Gargantext/Database/Query/Table/NodeContext.hs
View file @
4ef66cea
...
...
@@ -46,25 +46,23 @@ module Gargantext.Database.Query.Table.NodeContext
import
Control.Arrow
(
returnA
)
import
Control.Lens
(
view
,
(
^.
))
import
Data.Maybe
(
catMaybes
)
import
Data.Time
(
UTCTime
)
import
Data.Text
(
Text
,
splitOn
)
import
Data.Time
(
UTCTime
)
import
Database.PostgreSQL.Simple
qualified
as
PGS
(
In
(
..
),
Query
,
Only
(
..
))
import
Database.PostgreSQL.Simple.SqlQQ
(
sql
)
import
Database.PostgreSQL.Simple.Types
(
Values
(
..
),
QualifiedIdentifier
(
..
))
import
Opaleye
import
qualified
Database.PostgreSQL.Simple
as
PGS
(
In
(
..
),
Query
,
Only
(
..
))
import
qualified
Opaleye
as
O
import
Gargantext.Core
import
Gargantext.Core.Types
-- import Gargantext.Core.Types.Search (HyperdataRow(..), toHyperdataRow)
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Prelude
(
DBCmd
,
execPGSQuery
,
mkCmd
,
restrictMaybe
,
runCountOpaQuery
,
runPGSQuery
,
runOpaQuery
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
,
NodeError
(
DoesNotExist
),
nodeError
)
import
Gargantext.Database.Prelude
import
Gargantext.Prelude.Crypto.Hash
(
Hash
)
import
Gargantext.Database.Schema.Context
import
Gargantext.Database.Schema.Node
import
Gargantext.Database.Schema.NodeContext
import
Gargantext.Prelude
import
Gargantext.Prelude.Crypto.Hash
(
Hash
)
import
Opaleye
import
Opaleye
qualified
as
O
queryNodeContextTable
::
Select
NodeContextRead
queryNodeContextTable
=
selectTable
nodeContextTable
...
...
src/Gargantext/Database/Query/Table/NodeContext_NodeContext.hs
View file @
4ef66cea
...
...
@@ -20,12 +20,12 @@ module Gargantext.Database.Query.Table.NodeContext_NodeContext
where
import
Data.Text
(
Text
)
import
Database.PostgreSQL.Simple
qualified
as
PGS
import
Gargantext.Core.Types
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
DBCmd
,
runPGSQuery
)
import
Gargantext.Database.Schema.NodeContext_NodeContext
import
Gargantext.Database.Schema.Prelude
hiding
(
sum
)
import
Gargantext.Prelude
import
qualified
Database.PostgreSQL.Simple
as
PGS
{-
queryNodeContext_NodeContextTable :: Select NodeContext_NodeContextRead
...
...
src/Gargantext/Database/Query/Table/NodeNgrams.hs
View file @
4ef66cea
...
...
@@ -26,20 +26,20 @@ module Gargantext.Database.Query.Table.NodeNgrams
)
where
import
Data.List
qualified
as
List
import
Data.List.Extra
(
nubOrd
)
import
Data.Map.Strict
(
Map
)
import
Data.Map.Strict
qualified
as
Map
import
Data.Maybe
(
fromMaybe
)
import
Data.Text
(
Text
)
import
Database.PostgreSQL.Simple
qualified
as
PGS
(
Query
,
Only
(
..
))
import
Gargantext.Core
import
Gargantext.Core.Types
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
DBCmd
,
runPGSQuery
)
import
Gargantext.Database.Schema.Ngrams
(
NgramsType
,
ngramsTypeId
,
fromNgramsTypeId
)
import
Gargantext.Database.Schema.NodeNgrams
import
Gargantext.Database.Schema.Prelude
(
Select
,
FromRow
,
sql
,
fromRow
,
toField
,
field
,
Values
(
..
),
QualifiedIdentifier
(
..
),
selectTable
)
import
Gargantext.Prelude
import
qualified
Data.List
as
List
import
qualified
Data.Map.Strict
as
Map
import
qualified
Database.PostgreSQL.Simple
as
PGS
(
Query
,
Only
(
..
))
queryNodeNgramsTable
::
Select
NodeNgramsRead
...
...
@@ -62,11 +62,9 @@ getCgramsId mapId nt t = case Map.lookup nt mapId of
Just
mapId'
->
Map
.
lookup
t
mapId'
-- insertDb :: ListId -> Map NgramsType [NgramsElement] -> Cmd err [Result]
listInsertDb
::
Show
a
=>
ListId
->
(
ListId
->
a
->
[
NodeNgramsW
])
->
a
-- -> Cmd err [Returning]
->
DBCmd
err
(
Map
NgramsType
(
Map
Text
Int
))
listInsertDb
l
f
ngs
=
Map
.
map
Map
.
fromList
<$>
Map
.
fromListWith
(
<>
)
...
...
src/Gargantext/Database/Query/Table/NodeNode.hs
View file @
4ef66cea
...
...
@@ -35,20 +35,20 @@ module Gargantext.Database.Query.Table.NodeNode
import
Control.Arrow
(
returnA
)
import
Control.Lens
((
^.
),
view
)
import
Data.Text
(
Text
,
splitOn
)
import
Data.Maybe
(
catMaybes
)
import
Data.Text
(
Text
,
splitOn
)
import
Database.PostgreSQL.Simple
qualified
as
PGS
import
Database.PostgreSQL.Simple.SqlQQ
(
sql
)
import
Database.PostgreSQL.Simple.Types
(
Values
(
..
),
QualifiedIdentifier
(
..
))
import
Gargantext.Core
import
Gargantext.Core.Types
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
DBCmd
,
mkCmd
,
runPGSQuery
,
runCountOpaQuery
,
runOpaQuery
)
import
Gargantext.Database.Schema.Node
import
Gargantext.Database.Schema.NodeNode
import
Gargantext.Prelude
import
Opaleye
import
qualified
Database.PostgreSQL.Simple
as
PGS
import
qualified
Opaleye
as
O
import
Opaleye
qualified
as
O
queryNodeNodeTable
::
Select
NodeNodeRead
queryNodeNodeTable
=
selectTable
nodeNodeTable
...
...
src/Gargantext/Database/Query/Table/NodeNodeNgrams.hs
View file @
4ef66cea
...
...
@@ -23,7 +23,7 @@ module Gargantext.Database.Query.Table.NodeNodeNgrams
where
import
Gargantext.Database.Admin.Types.Node
(
pgNodeId
)
import
Gargantext.Database.Prelude
(
Cmd
,
mkCmd
)
import
Gargantext.Database.Prelude
(
DB
Cmd
,
mkCmd
)
import
Gargantext.Database.Schema.Ngrams
(
pgNgramsTypeId
)
import
Gargantext.Database.Schema.NodeNodeNgrams
import
Gargantext.Database.Schema.Prelude
...
...
@@ -34,7 +34,7 @@ queryNodeNodeNgramsTable :: Query NodeNodeNgramsRead
queryNodeNodeNgramsTable
=
selectTable
nodeNodeNgramsTable
-- | Insert utils
insertNodeNodeNgrams
::
[
NodeNodeNgrams
]
->
Cmd
err
Int
insertNodeNodeNgrams
::
[
NodeNodeNgrams
]
->
DB
Cmd
err
Int
insertNodeNodeNgrams
=
insertNodeNodeNgramsW
.
map
(
\
(
NodeNodeNgrams
n1
n2
ng
nt
w
)
->
NodeNodeNgrams
(
pgNodeId
n1
)
...
...
@@ -44,7 +44,7 @@ insertNodeNodeNgrams = insertNodeNodeNgramsW
(
sqlDouble
w
)
)
insertNodeNodeNgramsW
::
[
NodeNodeNgramsWrite
]
->
Cmd
err
Int
insertNodeNodeNgramsW
::
[
NodeNodeNgramsWrite
]
->
DB
Cmd
err
Int
insertNodeNodeNgramsW
nnnw
=
mkCmd
$
\
c
->
fromIntegral
<$>
runInsert_
c
insertNothing
where
...
...
src/Gargantext/Database/Query/Table/User.hs
View file @
4ef66cea
...
...
@@ -58,7 +58,7 @@ import Gargantext.Core.Types.Individu
import
qualified
Gargantext.Prelude.Crypto.Auth
as
Auth
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataUser
(
..
),
hu_pubmed_api_key
)
import
Gargantext.Database.Admin.Types.Node
(
NodeType
(
NodeUser
),
Node
,
NodeId
(
..
),
pgNodeId
)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
(
DBCmd
,
mkCmd
,
runOpaQuery
)
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateNodeWithType
)
import
Gargantext.Database.Schema.Node
(
NodeRead
,
node_hyperdata
,
queryNodeTable
,
node_id
,
node_user_id
,
node_typename
)
import
Gargantext.Database.Schema.User
...
...
@@ -76,14 +76,14 @@ insertUsers us = mkCmd $ \c -> runInsert c insert
where
insert
=
Insert
userTable
us
rCount
Nothing
deleteUsers
::
[
Username
]
->
Cmd
err
Int64
deleteUsers
::
[
Username
]
->
DB
Cmd
err
Int64
deleteUsers
us
=
mkCmd
$
\
c
->
runDelete_
c
$
Delete
userTable
(
\
user
->
in_
(
map
sqlStrictText
us
)
(
user_username
user
))
rCount
-- Updates email or password only (for now)
updateUserDB
::
UserWrite
->
Cmd
err
Int64
updateUserDB
::
UserWrite
->
DB
Cmd
err
Int64
updateUserDB
us
=
mkCmd
$
\
c
->
runUpdate_
c
(
updateUserQuery
us
)
where
updateUserQuery
::
UserWrite
->
Update
Int64
...
...
@@ -119,7 +119,7 @@ toUserWrite (NewUser u m (Auth.PasswordHash p)) =
,
user_forgot_password_uuid
=
Nothing
}
------------------------------------------------------------------
getUsersWith
::
Username
->
Cmd
err
[
UserLight
]
getUsersWith
::
Username
->
DB
Cmd
err
[
UserLight
]
getUsersWith
u
=
map
toUserLight
<$>
runOpaQuery
(
selectUsersLightWith
u
)
selectUsersLightWith
::
Username
->
Select
UserRead
...
...
@@ -128,7 +128,7 @@ selectUsersLightWith u = proc () -> do
restrict
-<
user_username
row
.==
sqlStrictText
u
returnA
-<
row
getUsersWithEmail
::
Text
->
Cmd
err
[
UserLight
]
getUsersWithEmail
::
Text
->
DB
Cmd
err
[
UserLight
]
getUsersWithEmail
e
=
map
toUserLight
<$>
runOpaQuery
(
selectUsersLightWithEmail
e
)
selectUsersLightWithEmail
::
Text
->
Select
UserRead
...
...
@@ -137,7 +137,7 @@ selectUsersLightWithEmail e = proc () -> do
restrict
-<
user_email
row
.==
sqlStrictText
e
returnA
-<
row
getUsersWithForgotPasswordUUID
::
UUID
.
UUID
->
Cmd
err
[
UserLight
]
getUsersWithForgotPasswordUUID
::
UUID
.
UUID
->
DB
Cmd
err
[
UserLight
]
getUsersWithForgotPasswordUUID
uuid
=
map
toUserLight
<$>
runOpaQuery
(
selectUsersLightWithForgotPasswordUUID
uuid
)
selectUsersLightWithForgotPasswordUUID
::
UUID
.
UUID
->
Select
UserRead
...
...
@@ -173,7 +173,7 @@ queryUserTable = selectTable userTable
----------------------------------------------------------------------
-- | Get hyperdata associated with user node.
getUserHyperdata
::
User
->
Cmd
err
[
HyperdataUser
]
getUserHyperdata
::
User
->
DB
Cmd
err
[
HyperdataUser
]
getUserHyperdata
(
RootId
uId
)
=
do
runOpaQuery
(
selectUserHyperdataWithId
uId
)
where
...
...
@@ -195,7 +195,7 @@ getUserHyperdata _ = undefined
-- | Same as `getUserHyperdata` but returns a `Node` type.
getUserNodeHyperdata
::
User
->
Cmd
err
[
Node
HyperdataUser
]
getUserNodeHyperdata
::
User
->
DB
Cmd
err
[
Node
HyperdataUser
]
getUserNodeHyperdata
(
RootId
uId
)
=
do
runOpaQuery
(
selectUserHyperdataWithId
uId
)
where
...
...
@@ -215,14 +215,14 @@ getUserNodeHyperdata (UserDBId uId) = do
returnA
-<
row
getUserNodeHyperdata
_
=
undefined
getUsersWithHyperdata
::
User
->
Cmd
err
[(
UserLight
,
HyperdataUser
)]
getUsersWithHyperdata
::
User
->
DB
Cmd
err
[(
UserLight
,
HyperdataUser
)]
getUsersWithHyperdata
i
=
do
u
<-
getUsersWithId
i
h
<-
getUserHyperdata
i
-- printDebug "[getUsersWithHyperdata]" (u,h)
pure
$
zip
u
h
getUsersWithNodeHyperdata
::
User
->
Cmd
err
[(
UserLight
,
Node
HyperdataUser
)]
getUsersWithNodeHyperdata
::
User
->
DB
Cmd
err
[(
UserLight
,
Node
HyperdataUser
)]
getUsersWithNodeHyperdata
i
=
do
u
<-
getUsersWithId
i
h
<-
getUserNodeHyperdata
i
...
...
@@ -230,7 +230,7 @@ getUsersWithNodeHyperdata i = do
pure
$
zip
u
h
updateUserEmail
::
UserLight
->
Cmd
err
Int64
updateUserEmail
::
UserLight
->
DB
Cmd
err
Int64
updateUserEmail
(
UserLight
{
..
})
=
mkCmd
$
\
c
->
runUpdate_
c
updateUserQuery
where
updateUserQuery
::
Update
Int64
...
...
@@ -240,7 +240,7 @@ updateUserEmail (UserLight { .. }) = mkCmd $ \c -> runUpdate_ c updateUserQuery
,
uWhere
=
(
\
row
->
user_id
row
.==
(
sqlInt4
userLight_id
))
,
uReturning
=
rCount
}
updateUserPassword
::
UserLight
->
Cmd
err
Int64
updateUserPassword
::
UserLight
->
DB
Cmd
err
Int64
updateUserPassword
(
UserLight
{
userLight_password
=
GargPassword
password
,
..
})
=
mkCmd
$
\
c
->
runUpdate_
c
updateUserQuery
where
updateUserQuery
::
Update
Int64
...
...
@@ -250,7 +250,7 @@ updateUserPassword (UserLight { userLight_password = GargPassword password, .. }
,
uWhere
=
\
row
->
user_id
row
.==
sqlInt4
userLight_id
,
uReturning
=
rCount
}
updateUserForgotPasswordUUID
::
UserLight
->
Cmd
err
Int64
updateUserForgotPasswordUUID
::
UserLight
->
DB
Cmd
err
Int64
updateUserForgotPasswordUUID
(
UserLight
{
..
})
=
mkCmd
$
\
c
->
runUpdate_
c
updateUserQuery
where
pass
=
sqlStrictText
$
fromMaybe
""
userLight_forgot_password_uuid
...
...
@@ -261,7 +261,7 @@ updateUserForgotPasswordUUID (UserLight { .. }) = mkCmd $ \c -> runUpdate_ c upd
,
uWhere
=
\
row
->
user_id
row
.==
sqlInt4
userLight_id
,
uReturning
=
rCount
}
getUserPubmedAPIKey
::
User
->
Cmd
err
(
Maybe
PUBMED
.
APIKey
)
getUserPubmedAPIKey
::
User
->
DB
Cmd
err
(
Maybe
PUBMED
.
APIKey
)
getUserPubmedAPIKey
user
=
do
hs
<-
getUserHyperdata
user
case
hs
of
...
...
@@ -269,7 +269,7 @@ getUserPubmedAPIKey user = do
(
x
:
_
)
->
pure
$
_hu_pubmed_api_key
x
updateUserPubmedAPIKey
::
(
HasDBid
NodeType
,
HasNodeError
err
)
=>
User
->
PUBMED
.
APIKey
->
Cmd
err
Int64
=>
User
->
PUBMED
.
APIKey
->
DB
Cmd
err
Int64
updateUserPubmedAPIKey
(
RootId
uId
)
apiKey
=
do
_
<-
updateNodeWithType
uId
NodeUser
(
Proxy
::
Proxy
HyperdataUser
)
(
\
h
->
h
&
hu_pubmed_api_key
?~
apiKey
)
pure
1
...
...
@@ -303,7 +303,7 @@ getUser :: Username -> DBCmd err (Maybe UserLight)
getUser
u
=
userLightWithUsername
u
<$>
usersLight
----------------------------------------------------------------------
insertNewUsers
::
[
NewUser
GargPassword
]
->
Cmd
err
Int64
insertNewUsers
::
[
NewUser
GargPassword
]
->
DB
Cmd
err
Int64
insertNewUsers
newUsers
=
do
users'
<-
liftBase
$
mapM
toUserHash
newUsers
insertUsers
$
map
toUserWrite
users'
...
...
src/Gargantext/Database/Query/Tree.hs
View file @
4ef66cea
...
...
@@ -60,7 +60,7 @@ import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
import
Gargantext.Database.Admin.Config
(
fromNodeTypeId
,
nodeTypeId
,
fromNodeTypeId
)
import
Gargantext.Database.Admin.Types.Hyperdata.Any
(
HyperdataAny
)
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Prelude
(
Cmd
,
runPGSQuery
,
DBCmd
)
import
Gargantext.Database.Prelude
(
runPGSQuery
,
DBCmd
)
import
Gargantext.Database.Query.Table.Node
(
getNodeWith
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Table.NodeNode
(
getNodeNode
)
...
...
@@ -89,7 +89,7 @@ tree :: (HasTreeError err, HasNodeError err)
=>
TreeMode
->
RootId
->
[
NodeType
]
->
Cmd
err
(
Tree
NodeTree
)
->
DB
Cmd
err
(
Tree
NodeTree
)
tree
TreeBasic
=
tree_basic
tree
TreeAdvanced
=
tree_advanced
tree
TreeFirstLevel
=
tree_first_level
...
...
@@ -100,7 +100,7 @@ tree TreeFirstLevel = tree_first_level
tree_basic
::
(
HasTreeError
err
,
HasNodeError
err
)
=>
RootId
->
[
NodeType
]
->
Cmd
err
(
Tree
NodeTree
)
->
DB
Cmd
err
(
Tree
NodeTree
)
tree_basic
r
nodeTypes
=
(
dbTree
r
nodeTypes
<&>
toTreeParent
)
>>=
toTree
-- Same as (but easier to read) :
...
...
@@ -110,7 +110,7 @@ tree_basic r nodeTypes =
tree_advanced
::
(
HasTreeError
err
,
HasNodeError
err
)
=>
RootId
->
[
NodeType
]
->
Cmd
err
(
Tree
NodeTree
)
->
DB
Cmd
err
(
Tree
NodeTree
)
tree_advanced
r
nodeTypes
=
do
-- let rPrefix s = "[tree_advanced] root = " <> show r <> " " <> s
mainRoot
<-
findNodes
r
Private
nodeTypes
...
...
@@ -128,7 +128,7 @@ tree_advanced r nodeTypes = do
tree_first_level
::
(
HasTreeError
err
,
HasNodeError
err
)
=>
RootId
->
[
NodeType
]
->
Cmd
err
(
Tree
NodeTree
)
->
DB
Cmd
err
(
Tree
NodeTree
)
tree_first_level
r
nodeTypes
=
do
-- let rPrefix s = mconcat [ "[tree_first_level] root = "
-- , show r
...
...
@@ -151,7 +151,7 @@ tree_flat :: (HasTreeError err, HasNodeError err)
=>
RootId
->
[
NodeType
]
->
Maybe
Text
->
Cmd
err
[
NodeTree
]
->
DB
Cmd
err
[
NodeTree
]
tree_flat
r
nodeTypes
q
=
do
mainRoot
<-
findNodes
r
Private
nodeTypes
publicRoots
<-
findNodes
r
Public
nodeTypes
...
...
@@ -169,7 +169,7 @@ findNodes :: (HasTreeError err, HasNodeError err)
=>
RootId
->
NodeMode
->
[
NodeType
]
->
Cmd
err
[
DbTreeNode
]
->
DB
Cmd
err
[
DbTreeNode
]
findNodes
r
Private
nt
=
dbTree
r
nt
findNodes
r
Shared
nt
=
findShared
r
NodeFolderShared
nt
sharedTreeUpdate
findNodes
r
SharedDirect
nt
=
findSharedDirect
r
NodeFolderShared
nt
sharedTreeUpdate
...
...
@@ -181,7 +181,7 @@ findNodes r PublicDirect nt = findSharedDirect r NodeFolderPublic nt publicTree
-- Queries the `nodes_nodes` table.
findShared
::
HasTreeError
err
=>
RootId
->
NodeType
->
[
NodeType
]
->
UpdateTree
err
->
Cmd
err
[
DbTreeNode
]
->
DB
Cmd
err
[
DbTreeNode
]
findShared
r
nt
nts
fun
=
do
foldersSharedId
<-
findNodesId
r
[
nt
]
trees
<-
mapM
(
updateTree
nts
fun
)
foldersSharedId
...
...
@@ -192,7 +192,7 @@ findShared r nt nts fun = do
-- and get the tree for its parent.
findSharedDirect
::
(
HasTreeError
err
,
HasNodeError
err
)
=>
RootId
->
NodeType
->
[
NodeType
]
->
UpdateTree
err
->
Cmd
err
[
DbTreeNode
]
->
DB
Cmd
err
[
DbTreeNode
]
findSharedDirect
r
nt
nts
fun
=
do
-- let rPrefix s = mconcat [ "[findSharedDirect] r = "
-- , show r
...
...
@@ -214,11 +214,11 @@ findSharedDirect r nt nts fun = do
pure
$
concat
trees
type
UpdateTree
err
=
ParentId
->
[
NodeType
]
->
NodeId
->
Cmd
err
[
DbTreeNode
]
type
UpdateTree
err
=
ParentId
->
[
NodeType
]
->
NodeId
->
DB
Cmd
err
[
DbTreeNode
]
updateTree
::
HasTreeError
err
=>
[
NodeType
]
->
UpdateTree
err
->
RootId
->
Cmd
err
[
DbTreeNode
]
->
DB
Cmd
err
[
DbTreeNode
]
updateTree
nts
fun
r
=
do
folders
<-
getNodeNode
r
nodesSharedId
<-
mapM
(
fun
r
nts
)
...
...
@@ -245,12 +245,12 @@ publicTreeUpdate p nt n = dbTree n nt
-- | findNodesId returns all nodes matching nodeType but the root (Nodeuser)
findNodesId
::
RootId
->
[
NodeType
]
->
Cmd
err
[
NodeId
]
findNodesId
::
RootId
->
[
NodeType
]
->
DB
Cmd
err
[
NodeId
]
findNodesId
r
nt
=
tail
<$>
map
_dt_nodeId
<$>
dbTree
r
nt
findNodesWithType
::
RootId
->
[
NodeType
]
->
[
NodeType
]
->
Cmd
err
[
DbTreeNode
]
findNodesWithType
::
RootId
->
[
NodeType
]
->
[
NodeType
]
->
DB
Cmd
err
[
DbTreeNode
]
findNodesWithType
root
target
through
=
filter
isInTarget
<$>
dbTree
root
through
where
...
...
@@ -331,7 +331,7 @@ toSubtreeParent r ns = fromListWith (\a b -> nub $ a <> b) . map (\n -> (_dt_par
-- | Main DB Tree function
dbTree
::
RootId
->
[
NodeType
]
->
Cmd
err
[
DbTreeNode
]
->
DB
Cmd
err
[
DbTreeNode
]
dbTree
rootId
nodeTypes
=
map
(
\
(
nId
,
tId
,
pId
,
n
)
->
DbTreeNode
nId
tId
pId
n
)
<$>
runPGSQuery
[
sql
|
WITH RECURSIVE
...
...
@@ -383,7 +383,7 @@ isDescendantOf childId rootId = (== [Only True])
|]
(
childId
,
rootId
)
-- TODO should we check the category?
isIn
::
NodeId
->
DocId
->
Cmd
err
Bool
isIn
::
NodeId
->
DocId
->
DB
Cmd
err
Bool
isIn
cId
docId
=
(
==
[
Only
True
])
<$>
runPGSQuery
[
sql
|
SELECT COUNT(*) = 1
FROM nodes_nodes nn
...
...
@@ -393,8 +393,8 @@ isIn cId docId = ( == [Only True])
-- Recursive parents function to construct a breadcrumb
recursiveParents
::
NodeId
->
[
NodeType
]
->
Cmd
err
[
DbTreeNode
]
->
[
NodeType
]
->
DB
Cmd
err
[
DbTreeNode
]
recursiveParents
nodeId
nodeTypes
=
map
(
\
(
nId
,
tId
,
pId
,
n
)
->
DbTreeNode
nId
tId
pId
n
)
<$>
runPGSQuery
[
sql
|
WITH RECURSIVE recursiveParents AS
...
...
test/Test/Database/Types.hs
View file @
4ef66cea
...
...
@@ -34,6 +34,7 @@ import Gargantext.API.Prelude
import
Gargantext.Core.Mail.Types
(
HasMail
(
..
))
import
Gargantext.Core.NLP
(
HasNLPServer
(
..
))
import
Gargantext.Database.Query.Table.Node.Error
import
Gargantext.Database.Prelude
(
HasConfig
(
..
),
HasConnectionPool
(
..
))
import
Gargantext.Prelude.Config
import
Gargantext.Prelude.Mail.Types
(
MailConfig
(
..
),
LoginType
(
NoAuth
))
import
Gargantext.System.Logging
(
HasLogger
(
..
),
Logger
,
MonadLogger
(
..
))
...
...
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