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
148
Issues
148
List
Board
Labels
Milestones
Merge Requests
7
Merge Requests
7
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
gargantext
haskell-gargantext
Commits
a050a009
Commit
a050a009
authored
Mar 16, 2023
by
Przemyslaw Kaminski
Committed by
Alexandre Delanoë
Mar 23, 2023
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[NLP] implement NLP server selection in INI file
parent
678043f6
Changes
38
Hide whitespace changes
Inline
Side-by-side
Showing
38 changed files
with
250 additions
and
183 deletions
+250
-183
Main.hs
bin/gargantext-invitations/Main.hs
+7
-15
gargantext.cabal
gargantext.cabal
+2
-0
gargantext.ini_toModify
gargantext.ini_toModify
+5
-0
package.yaml
package.yaml
+1
-0
Auth.hs
src/Gargantext/API/Admin/Auth.hs
+9
-9
EnvTypes.hs
src/Gargantext/API/Admin/EnvTypes.hs
+9
-0
Settings.hs
src/Gargantext/API/Admin/Settings.hs
+4
-0
Dev.hs
src/Gargantext/API/Dev.hs
+5
-1
GraphQL.hs
src/Gargantext/API/GraphQL.hs
+4
-5
Annuaire.hs
src/Gargantext/API/GraphQL/Annuaire.hs
+3
-4
Context.hs
src/Gargantext/API/GraphQL/Context.hs
+6
-7
Node.hs
src/Gargantext/API/GraphQL/Node.hs
+5
-6
Team.hs
src/Gargantext/API/GraphQL/Team.hs
+6
-6
TreeFirstLevel.hs
src/Gargantext/API/GraphQL/TreeFirstLevel.hs
+14
-15
User.hs
src/Gargantext/API/GraphQL/User.hs
+5
-6
UserInfo.hs
src/Gargantext/API/GraphQL/UserInfo.hs
+4
-5
Members.hs
src/Gargantext/API/Members.hs
+3
-3
Ngrams.hs
src/Gargantext/API/Ngrams.hs
+10
-16
Searx.hs
src/Gargantext/API/Node/Corpus/Searx.hs
+8
-7
Share.hs
src/Gargantext/API/Node/Share.hs
+4
-3
Prelude.hs
src/Gargantext/API/Prelude.hs
+2
-0
Core.hs
src/Gargantext/Core.hs
+6
-2
Mail.hs
src/Gargantext/Core/Mail.hs
+0
-1
NLP.hs
src/Gargantext/Core/NLP.hs
+46
-0
List.hs
src/Gargantext/Core/Text/List.hs
+2
-2
WithStem.hs
src/Gargantext/Core/Text/List/Group/WithStem.hs
+4
-4
Management.sh
src/Gargantext/Core/Text/List/Management.sh
+2
-4
Terms.hs
src/Gargantext/Core/Text/Terms.hs
+8
-8
Multi.hs
src/Gargantext/Core/Text/Terms/Multi.hs
+13
-12
PosTagging.hs
src/Gargantext/Core/Text/Terms/Multi/PosTagging.hs
+11
-10
Delete.hs
src/Gargantext/Database/Action/Delete.hs
+4
-5
Flow.hs
src/Gargantext/Database/Action/Flow.hs
+5
-2
Mail.hs
src/Gargantext/Database/Action/Mail.hs
+1
-2
Prelude.hs
src/Gargantext/Database/Prelude.hs
+11
-6
NgramsPostag.hs
src/Gargantext/Database/Query/Table/NgramsPostag.hs
+3
-5
SpacyNLP.hs
src/Gargantext/Utils/SpacyNLP.hs
+10
-9
Tuple.hs
src/Gargantext/Utils/Tuple.hs
+4
-0
stack.yaml
stack.yaml
+4
-3
No files found.
bin/gargantext-invitations/Main.hs
View file @
a050a009
...
@@ -14,25 +14,17 @@ Portability : POSIX
...
@@ -14,25 +14,17 @@ Portability : POSIX
module
Main
where
module
Main
where
import
Data.Either
(
Either
(
..
))
import
Gargantext.API.Dev
(
withDevEnv
,
runCmdDev
)
import
Gargantext.API.Dev
(
withDevEnv
,
runCmdDev
)
import
Gargantext.API.Node
()
-- instances only
import
Gargantext.API.Node
()
-- instances only
import
Gargantext.API.Prelude
(
GargError
)
import
Gargantext.API.Prelude
(
GargError
)
import
Gargantext.Core.Types.Individu
(
User
(
..
),
arbitraryNewUsers
,
NewUser
(
..
),
arbitraryUsername
,
GargPassword
(
..
))
import
Gargantext.Core.NLP
(
HasNLPServer
)
import
Gargantext.Database.Action.Flow
(
getOrMkRoot
,
getOrMk_RootWithCorpus
)
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Database.Admin.Config
(
userMaster
,
corpusMasterName
)
import
Gargantext.Database.Admin.Trigger.Init
(
initFirstTriggers
,
initLastTriggers
)
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataCorpus
)
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Prelude
(
CmdR
)
import
Gargantext.Database.Prelude
(
CmdRandom
)
import
Gargantext.Database.Query.Table.Node
(
getOrMkList
)
import
Gargantext.Database.Query.Table.User
(
insertNewUsers
,
)
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
(
GargConfig
(
..
),
readConfig
)
import
Gargantext.Prelude.Config
(
readConfig
)
import
Prelude
(
getLine
,
read
)
import
Prelude
(
read
)
import
System.Environment
(
getArgs
)
import
System.Environment
(
getArgs
)
import
Gargantext.Database.Action.User.New
(
newUsers
)
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
qualified
Gargantext.API.Node.Share
as
Share
import
qualified
Gargantext.API.Node.Share
as
Share
main
::
IO
()
main
::
IO
()
...
@@ -43,9 +35,9 @@ main = do
...
@@ -43,9 +35,9 @@ main = do
then
panic
"USAGE: ./gargantext-init gargantext.ini username node_id student@university.edu"
then
panic
"USAGE: ./gargantext-init gargantext.ini username node_id student@university.edu"
else
pure
()
else
pure
()
cfg
<-
readConfig
iniPath
_
cfg
<-
readConfig
iniPath
let
invite
::
CmdR
GargError
Int
let
invite
::
(
CmdRandom
env
GargError
m
,
HasNLPServer
env
)
=>
m
Int
invite
=
Share
.
api
(
UserName
$
cs
user
)
(
NodeId
$
(
read
node_id
::
Int
))
(
Share
.
ShareTeamParams
$
cs
email
)
invite
=
Share
.
api
(
UserName
$
cs
user
)
(
NodeId
$
(
read
node_id
::
Int
))
(
Share
.
ShareTeamParams
$
cs
email
)
withDevEnv
iniPath
$
\
env
->
do
withDevEnv
iniPath
$
\
env
->
do
...
...
gargantext.cabal
View file @
a050a009
...
@@ -46,6 +46,7 @@ library
...
@@ -46,6 +46,7 @@ library
Gargantext.API.Prelude
Gargantext.API.Prelude
Gargantext.Core
Gargantext.Core
Gargantext.Core.Methods.Similarities
Gargantext.Core.Methods.Similarities
Gargantext.Core.NLP
Gargantext.Core.NodeStory
Gargantext.Core.NodeStory
Gargantext.Core.Text
Gargantext.Core.Text
Gargantext.Core.Text.Context
Gargantext.Core.Text.Context
...
@@ -438,6 +439,7 @@ library
...
@@ -438,6 +439,7 @@ library
, morpheus-graphql-subscriptions
, morpheus-graphql-subscriptions
, mtl
, mtl
, natural-transformation
, natural-transformation
, network-uri
, opaleye
, opaleye
, pandoc
, pandoc
, parallel
, parallel
...
...
gargantext.ini_toModify
View file @
a050a009
...
@@ -84,3 +84,8 @@ MAIL_PASSWORD =
...
@@ -84,3 +84,8 @@ MAIL_PASSWORD =
MAIL_FROM =
MAIL_FROM =
# NoAuth | Normal | SSL | TLS | STARTTLS
# NoAuth | Normal | SSL | TLS | STARTTLS
MAIL_LOGIN_TYPE = Normal
MAIL_LOGIN_TYPE = Normal
[nlp]
EN = corenlp://localhost:9000
FR = spacy://localhost:8001
All = corenlp://localhost:9000
package.yaml
View file @
a050a009
...
@@ -222,6 +222,7 @@ library:
...
@@ -222,6 +222,7 @@ library:
-
morpheus-graphql-subscriptions
-
morpheus-graphql-subscriptions
-
mtl
-
mtl
-
natural-transformation
-
natural-transformation
-
network-uri
-
opaleye
-
opaleye
-
pandoc
-
pandoc
-
parallel
-
parallel
...
...
src/Gargantext/API/Admin/Auth.hs
View file @
a050a009
...
@@ -52,11 +52,11 @@ import Gargantext.API.Admin.Types
...
@@ -52,11 +52,11 @@ import Gargantext.API.Admin.Types
import
Gargantext.API.Job
(
jobLogSuccess
)
import
Gargantext.API.Job
(
jobLogSuccess
)
import
Gargantext.API.Prelude
(
HasJoseError
(
..
),
joseError
,
HasServerError
,
GargServerC
,
GargServer
,
_ServerError
,
GargM
,
GargError
)
import
Gargantext.API.Prelude
(
HasJoseError
(
..
),
joseError
,
HasServerError
,
GargServerC
,
GargServer
,
_ServerError
,
GargM
,
GargError
)
import
Gargantext.Core.Mail
(
MailModel
(
..
),
mail
)
import
Gargantext.Core.Mail
(
MailModel
(
..
),
mail
)
import
Gargantext.Core.Mail.Types
(
HasMail
,
mailSettings
)
import
Gargantext.Core.Mail.Types
(
mailSettings
)
import
Gargantext.Core.Types.Individu
(
User
(
..
),
Username
,
GargPassword
(
..
))
import
Gargantext.Core.Types.Individu
(
User
(
..
),
Username
,
GargPassword
(
..
))
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
(
..
),
UserId
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
(
..
),
UserId
)
import
Gargantext.Database.Prelude
(
Cmd
'
,
CmdM
,
HasConnectionPool
,
HasConfig
)
import
Gargantext.Database.Prelude
(
Cmd
'
,
CmdM
,
CmdCommon
)
import
Gargantext.Database.Query.Table.User
import
Gargantext.Database.Query.Table.User
import
Gargantext.Database.Query.Tree
(
isDescendantOf
,
isIn
)
import
Gargantext.Database.Query.Tree
(
isDescendantOf
,
isIn
)
import
Gargantext.Database.Query.Tree.Root
(
getRoot
)
import
Gargantext.Database.Query.Tree.Root
(
getRoot
)
...
@@ -83,7 +83,7 @@ makeTokenForUser uid = do
...
@@ -83,7 +83,7 @@ makeTokenForUser uid = do
either
joseError
(
pure
.
toStrict
.
LE
.
decodeUtf8
)
e
either
joseError
(
pure
.
toStrict
.
LE
.
decodeUtf8
)
e
-- TODO not sure about the encoding...
-- TODO not sure about the encoding...
checkAuthRequest
::
(
HasSettings
env
,
HasConnectionPool
env
,
HasJoseError
err
,
HasConfig
env
,
HasMail
env
)
checkAuthRequest
::
(
HasSettings
env
,
CmdCommon
env
,
HasJoseError
err
)
=>
Username
=>
Username
->
GargPassword
->
GargPassword
->
Cmd'
env
err
CheckAuth
->
Cmd'
env
err
CheckAuth
...
@@ -102,7 +102,7 @@ checkAuthRequest u (GargPassword p) = do
...
@@ -102,7 +102,7 @@ checkAuthRequest u (GargPassword p) = do
token
<-
makeTokenForUser
uid
token
<-
makeTokenForUser
uid
pure
$
Valid
token
uid
userLight_id
pure
$
Valid
token
uid
userLight_id
auth
::
(
HasSettings
env
,
HasConnectionPool
env
,
HasJoseError
err
,
HasConfig
env
,
HasMail
env
)
auth
::
(
HasSettings
env
,
CmdCommon
env
,
HasJoseError
err
)
=>
AuthRequest
->
Cmd'
env
err
AuthResponse
=>
AuthRequest
->
Cmd'
env
err
AuthResponse
auth
(
AuthRequest
u
p
)
=
do
auth
(
AuthRequest
u
p
)
=
do
checkAuthRequest'
<-
checkAuthRequest
u
p
checkAuthRequest'
<-
checkAuthRequest
u
p
...
@@ -177,7 +177,7 @@ forgotPassword :: GargServer ForgotPasswordAPI
...
@@ -177,7 +177,7 @@ forgotPassword :: GargServer ForgotPasswordAPI
-- => ForgotPasswordRequest -> Cmd' env err ForgotPasswordResponse
-- => ForgotPasswordRequest -> Cmd' env err ForgotPasswordResponse
forgotPassword
=
forgotPasswordPost
:<|>
forgotPasswordGet
forgotPassword
=
forgotPasswordPost
:<|>
forgotPasswordGet
forgotPasswordPost
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
forgotPasswordPost
::
(
CmdCommon
env
)
=>
ForgotPasswordRequest
->
Cmd'
env
err
ForgotPasswordResponse
=>
ForgotPasswordRequest
->
Cmd'
env
err
ForgotPasswordResponse
forgotPasswordPost
(
ForgotPasswordRequest
email
)
=
do
forgotPasswordPost
(
ForgotPasswordRequest
email
)
=
do
us
<-
getUsersWithEmail
(
Text
.
toLower
email
)
us
<-
getUsersWithEmail
(
Text
.
toLower
email
)
...
@@ -189,7 +189,7 @@ forgotPasswordPost (ForgotPasswordRequest email) = do
...
@@ -189,7 +189,7 @@ forgotPasswordPost (ForgotPasswordRequest email) = do
-- users' emails
-- users' emails
pure
$
ForgotPasswordResponse
"ok"
pure
$
ForgotPasswordResponse
"ok"
forgotPasswordGet
::
(
HasSettings
env
,
HasConnectionPool
env
,
HasJoseError
err
,
HasConfig
env
,
HasMail
env
,
HasServerError
err
)
forgotPasswordGet
::
(
HasSettings
env
,
CmdCommon
env
,
HasJoseError
err
,
HasServerError
err
)
=>
Maybe
Text
->
Cmd'
env
err
ForgotPasswordGet
=>
Maybe
Text
->
Cmd'
env
err
ForgotPasswordGet
forgotPasswordGet
Nothing
=
pure
$
ForgotPasswordGet
""
forgotPasswordGet
Nothing
=
pure
$
ForgotPasswordGet
""
forgotPasswordGet
(
Just
uuid
)
=
do
forgotPasswordGet
(
Just
uuid
)
=
do
...
@@ -205,7 +205,7 @@ forgotPasswordGet (Just uuid) = do
...
@@ -205,7 +205,7 @@ forgotPasswordGet (Just uuid) = do
---------------------
---------------------
forgotPasswordGetUser
::
(
HasSettings
env
,
HasConnectionPool
env
,
HasJoseError
err
,
HasConfig
env
,
HasMail
env
,
HasServerError
err
)
forgotPasswordGetUser
::
(
HasSettings
env
,
CmdCommon
env
,
HasJoseError
err
,
HasServerError
err
)
=>
UserLight
->
Cmd'
env
err
ForgotPasswordGet
=>
UserLight
->
Cmd'
env
err
ForgotPasswordGet
forgotPasswordGetUser
(
UserLight
{
..
})
=
do
forgotPasswordGetUser
(
UserLight
{
..
})
=
do
-- pick some random password
-- pick some random password
...
@@ -224,7 +224,7 @@ forgotPasswordGetUser (UserLight { .. }) = do
...
@@ -224,7 +224,7 @@ forgotPasswordGetUser (UserLight { .. }) = do
pure
$
ForgotPasswordGet
password
pure
$
ForgotPasswordGet
password
forgotUserPassword
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
forgotUserPassword
::
(
CmdCommon
env
)
=>
UserLight
->
Cmd'
env
err
()
=>
UserLight
->
Cmd'
env
err
()
forgotUserPassword
(
UserLight
{
..
})
=
do
forgotUserPassword
(
UserLight
{
..
})
=
do
--printDebug "[forgotUserPassword] userLight_id" userLight_id
--printDebug "[forgotUserPassword] userLight_id" userLight_id
...
@@ -249,7 +249,7 @@ forgotUserPassword (UserLight { .. }) = do
...
@@ -249,7 +249,7 @@ forgotUserPassword (UserLight { .. }) = do
--------------------------
--------------------------
-- Generate a unique (in whole DB) UUID for passwords.
-- Generate a unique (in whole DB) UUID for passwords.
generateForgotPasswordUUID
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
generateForgotPasswordUUID
::
(
CmdCommon
env
)
=>
Cmd'
env
err
UUID
=>
Cmd'
env
err
UUID
generateForgotPasswordUUID
=
do
generateForgotPasswordUUID
=
do
uuid
<-
liftBase
$
nextRandom
uuid
<-
liftBase
$
nextRandom
...
...
src/Gargantext/API/Admin/EnvTypes.hs
View file @
a050a009
...
@@ -22,6 +22,7 @@ import Gargantext.API.Admin.Orchestrator.Types
...
@@ -22,6 +22,7 @@ import Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Prelude
(
GargError
)
import
Gargantext.API.Prelude
(
GargError
)
import
Gargantext.Core.NodeStory
import
Gargantext.Core.NodeStory
import
Gargantext.Core.Mail.Types
(
HasMail
,
mailSettings
)
import
Gargantext.Core.Mail.Types
(
HasMail
,
mailSettings
)
import
Gargantext.Core.NLP
(
NLPServerMap
,
HasNLPServer
(
..
))
import
Gargantext.Database.Prelude
(
HasConnectionPool
(
..
),
HasConfig
(
..
))
import
Gargantext.Database.Prelude
(
HasConnectionPool
(
..
),
HasConfig
(
..
))
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
(
GargConfig
(
..
))
import
Gargantext.Prelude.Config
(
GargConfig
(
..
))
...
@@ -59,6 +60,7 @@ data Env = Env
...
@@ -59,6 +60,7 @@ data Env = Env
,
_env_jobs
::
!
(
Jobs
.
JobEnv
GargJob
(
Dual
[
JobLog
])
JobLog
)
,
_env_jobs
::
!
(
Jobs
.
JobEnv
GargJob
(
Dual
[
JobLog
])
JobLog
)
,
_env_config
::
!
GargConfig
,
_env_config
::
!
GargConfig
,
_env_mail
::
!
MailConfig
,
_env_mail
::
!
MailConfig
,
_env_nlp
::
!
NLPServerMap
}
}
deriving
(
Generic
)
deriving
(
Generic
)
...
@@ -91,6 +93,9 @@ instance HasSettings Env where
...
@@ -91,6 +93,9 @@ instance HasSettings Env where
instance
HasMail
Env
where
instance
HasMail
Env
where
mailSettings
=
env_mail
mailSettings
=
env_mail
instance
HasNLPServer
Env
where
nlpServer
=
env_nlp
instance
Servant
.
Job
.
Core
.
HasEnv
Env
(
Job
JobLog
JobLog
)
where
instance
Servant
.
Job
.
Core
.
HasEnv
Env
(
Job
JobLog
JobLog
)
where
_env
=
env_scrapers
.
Servant
.
Job
.
Core
.
_env
_env
=
env_scrapers
.
Servant
.
Job
.
Core
.
_env
...
@@ -115,6 +120,7 @@ data DevEnv = DevEnv
...
@@ -115,6 +120,7 @@ data DevEnv = DevEnv
,
_dev_env_pool
::
!
(
Pool
Connection
)
,
_dev_env_pool
::
!
(
Pool
Connection
)
,
_dev_env_nodeStory
::
!
NodeStoryEnv
,
_dev_env_nodeStory
::
!
NodeStoryEnv
,
_dev_env_mail
::
!
MailConfig
,
_dev_env_mail
::
!
MailConfig
,
_dev_env_nlp
::
!
NLPServerMap
}
}
makeLenses
''
D
evEnv
makeLenses
''
D
evEnv
...
@@ -146,3 +152,6 @@ instance HasNodeArchiveStoryImmediateSaver DevEnv where
...
@@ -146,3 +152,6 @@ instance HasNodeArchiveStoryImmediateSaver DevEnv where
instance
HasMail
DevEnv
where
instance
HasMail
DevEnv
where
mailSettings
=
dev_env_mail
mailSettings
=
dev_env_mail
instance
HasNLPServer
DevEnv
where
nlpServer
=
dev_env_nlp
src/Gargantext/API/Admin/Settings.hs
View file @
a050a009
...
@@ -43,10 +43,12 @@ import qualified Data.ByteString.Lazy as L
...
@@ -43,10 +43,12 @@ import qualified Data.ByteString.Lazy as L
import
Gargantext.API.Admin.EnvTypes
import
Gargantext.API.Admin.EnvTypes
import
Gargantext.API.Admin.Types
import
Gargantext.API.Admin.Types
-- import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
-- import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
import
Gargantext.Core.NLP
(
nlpServerMap
)
import
Gargantext.Database.Prelude
(
databaseParameters
,
hasConfig
)
import
Gargantext.Database.Prelude
(
databaseParameters
,
hasConfig
)
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
(
gc_js_job_timeout
,
gc_js_id_timeout
)
import
Gargantext.Prelude.Config
(
gc_js_job_timeout
,
gc_js_id_timeout
)
import
qualified
Gargantext.Prelude.Mail
as
Mail
import
qualified
Gargantext.Prelude.Mail
as
Mail
import
qualified
Gargantext.Prelude.NLP
as
NLP
import
qualified
Gargantext.Utils.Jobs
as
Jobs
import
qualified
Gargantext.Utils.Jobs
as
Jobs
import
qualified
Gargantext.Utils.Jobs.Monad
as
Jobs
import
qualified
Gargantext.Utils.Jobs.Monad
as
Jobs
import
qualified
Gargantext.Utils.Jobs.Queue
as
Jobs
import
qualified
Gargantext.Utils.Jobs.Queue
as
Jobs
...
@@ -199,6 +201,7 @@ newEnv port file = do
...
@@ -199,6 +201,7 @@ newEnv port file = do
jobs_env
<-
Jobs
.
newJobEnv
jobs_settings
prios'
manager_env
jobs_env
<-
Jobs
.
newJobEnv
jobs_settings
prios'
manager_env
logger
<-
newStderrLoggerSet
defaultBufSize
logger
<-
newStderrLoggerSet
defaultBufSize
config_mail
<-
Mail
.
readConfig
file
config_mail
<-
Mail
.
readConfig
file
config_nlp
<-
NLP
.
readConfig
file
pure
$
Env
pure
$
Env
{
_env_settings
=
settings'
{
_env_settings
=
settings'
...
@@ -211,6 +214,7 @@ newEnv port file = do
...
@@ -211,6 +214,7 @@ newEnv port file = do
,
_env_self_url
=
self_url_env
,
_env_self_url
=
self_url_env
,
_env_config
=
config_env
,
_env_config
=
config_env
,
_env_mail
=
config_mail
,
_env_mail
=
config_mail
,
_env_nlp
=
nlpServerMap
config_nlp
}
}
newPool
::
ConnectInfo
->
IO
(
Pool
Connection
)
newPool
::
ConnectInfo
->
IO
(
Pool
Connection
)
...
...
src/Gargantext/API/Dev.hs
View file @
a050a009
...
@@ -19,11 +19,13 @@ import Gargantext.API.Admin.EnvTypes
...
@@ -19,11 +19,13 @@ import Gargantext.API.Admin.EnvTypes
import
Gargantext.API.Admin.Settings
import
Gargantext.API.Admin.Settings
import
Gargantext.API.Ngrams
(
saveNodeStoryImmediate
)
import
Gargantext.API.Ngrams
(
saveNodeStoryImmediate
)
import
Gargantext.API.Prelude
import
Gargantext.API.Prelude
import
Gargantext.Core.NLP
(
nlpServerMap
)
import
Gargantext.Core.NodeStory
import
Gargantext.Core.NodeStory
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
(
readConfig
)
import
Gargantext.Prelude.Config
(
readConfig
)
import
qualified
Gargantext.Prelude.Mail
as
Mail
import
qualified
Gargantext.Prelude.Mail
as
Mail
import
qualified
Gargantext.Prelude.NLP
as
NLP
import
Servant
import
Servant
import
System.IO
(
FilePath
)
import
System.IO
(
FilePath
)
...
@@ -43,12 +45,14 @@ withDevEnv iniPath k = do
...
@@ -43,12 +45,14 @@ withDevEnv iniPath k = do
nodeStory_env
<-
readNodeStoryEnv
pool
nodeStory_env
<-
readNodeStoryEnv
pool
setts
<-
devSettings
devJwkFile
setts
<-
devSettings
devJwkFile
mail
<-
Mail
.
readConfig
iniPath
mail
<-
Mail
.
readConfig
iniPath
nlp_config
<-
NLP
.
readConfig
iniPath
pure
$
DevEnv
pure
$
DevEnv
{
_dev_env_pool
=
pool
{
_dev_env_pool
=
pool
,
_dev_env_nodeStory
=
nodeStory_env
,
_dev_env_nodeStory
=
nodeStory_env
,
_dev_env_settings
=
setts
,
_dev_env_settings
=
setts
,
_dev_env_config
=
cfg
,
_dev_env_config
=
cfg
,
_dev_env_mail
=
mail
,
_dev_env_mail
=
mail
,
_dev_env_nlp
=
nlpServerMap
nlp_config
}
}
-- | Run Cmd Sugar for the Repl (GHCI)
-- | Run Cmd Sugar for the Repl (GHCI)
...
...
src/Gargantext/API/GraphQL.hs
View file @
a050a009
...
@@ -45,8 +45,7 @@ import qualified Gargantext.API.GraphQL.TreeFirstLevel as GQLTree
...
@@ -45,8 +45,7 @@ import qualified Gargantext.API.GraphQL.TreeFirstLevel as GQLTree
import
qualified
Gargantext.API.GraphQL.Team
as
GQLTeam
import
qualified
Gargantext.API.GraphQL.Team
as
GQLTeam
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.API.Types
import
Gargantext.API.Types
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
Gargantext.Database.Prelude
(
HasConnectionPool
,
HasConfig
)
import
Gargantext.Prelude
import
Gargantext.Prelude
import
GHC.Generics
(
Generic
)
import
GHC.Generics
(
Generic
)
import
Servant
import
Servant
...
@@ -104,7 +103,7 @@ data Contet m
...
@@ -104,7 +103,7 @@ data Contet m
-- | The main GraphQL resolver: how queries, mutations and
-- | The main GraphQL resolver: how queries, mutations and
-- subscriptions are handled.
-- subscriptions are handled.
rootResolver
rootResolver
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
,
HasJobEnv'
env
,
HasSettings
env
)
::
(
CmdCommon
env
,
HasJobEnv'
env
,
HasSettings
env
)
=>
RootResolver
(
GargM
env
GargError
)
e
Query
Mutation
Undefined
=>
RootResolver
(
GargM
env
GargError
)
e
Query
Mutation
Undefined
rootResolver
=
rootResolver
=
RootResolver
RootResolver
...
@@ -126,7 +125,7 @@ rootResolver =
...
@@ -126,7 +125,7 @@ rootResolver =
-- | Main GraphQL "app".
-- | Main GraphQL "app".
app
app
::
(
Typeable
env
,
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
,
HasJobEnv'
env
,
HasSettings
env
)
::
(
Typeable
env
,
CmdCommon
env
,
HasJobEnv'
env
,
HasSettings
env
)
=>
App
(
EVENT
(
GargM
env
GargError
))
(
GargM
env
GargError
)
=>
App
(
EVENT
(
GargM
env
GargError
))
(
GargM
env
GargError
)
app
=
deriveApp
rootResolver
app
=
deriveApp
rootResolver
...
@@ -163,7 +162,7 @@ gqapi = Proxy
...
@@ -163,7 +162,7 @@ gqapi = Proxy
-- | Implementation of our API.
-- | Implementation of our API.
--api :: Server API
--api :: Server API
api
api
::
(
Typeable
env
,
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
,
HasJobEnv'
env
,
HasSettings
env
)
::
(
Typeable
env
,
CmdCommon
env
,
HasJobEnv'
env
,
HasSettings
env
)
=>
ServerT
API
(
GargM
env
GargError
)
=>
ServerT
API
(
GargM
env
GargError
)
api
(
SAS
.
Authenticated
_auser
)
=
httpPubApp
[]
app
:<|>
pure
httpPlayground
api
(
SAS
.
Authenticated
_auser
)
=
httpPubApp
[]
app
:<|>
pure
httpPlayground
api
_
=
panic
"401 in graphql"
-- SAS.throwAll (_ServerError # err401)
api
_
=
panic
"401 in graphql"
-- SAS.throwAll (_ServerError # err401)
src/Gargantext/API/GraphQL/Annuaire.hs
View file @
a050a009
...
@@ -13,7 +13,6 @@ import Data.Morpheus.Types
...
@@ -13,7 +13,6 @@ import Data.Morpheus.Types
import
Data.Proxy
import
Data.Proxy
import
Data.Text
(
Text
)
import
Data.Text
(
Text
)
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Database.Admin.Types.Hyperdata.Contact
import
Gargantext.Database.Admin.Types.Hyperdata.Contact
(
HyperdataContact
(
HyperdataContact
,
ContactWho
,
ContactWho
...
@@ -21,7 +20,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact
...
@@ -21,7 +20,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact
,
cw_lastName
,
cw_lastName
,
hc_who
,
ContactWhere
,
hc_where
,
cw_organization
,
cw_labTeamDepts
,
cw_role
,
cw_office
,
cw_country
,
cw_city
,
cw_touch
,
ct_mail
,
ct_phone
,
ct_url
,
hc_title
,
hc_source
)
,
hc_who
,
ContactWhere
,
hc_where
,
cw_organization
,
cw_labTeamDepts
,
cw_role
,
cw_office
,
cw_country
,
cw_city
,
cw_touch
,
ct_mail
,
ct_phone
,
ct_url
,
hc_title
,
hc_source
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
(
..
))
import
Gargantext.Database.Admin.Types.Node
(
NodeId
(
..
))
import
Gargantext.Database.Prelude
(
HasConnectionPool
,
HasConfig
)
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
Gargantext.Database.Query.Table.Context
(
getContextWith
)
import
Gargantext.Database.Query.Table.Context
(
getContextWith
)
import
Gargantext.Database.Schema.Node
(
node_hyperdata
)
import
Gargantext.Database.Schema.Node
(
node_hyperdata
)
import
Gargantext.Prelude
import
Gargantext.Prelude
...
@@ -55,13 +54,13 @@ type GqlM e env = Resolver QUERY e (GargM env GargError)
...
@@ -55,13 +54,13 @@ type GqlM e env = Resolver QUERY e (GargM env GargError)
-- | Function to resolve user from a query.
-- | Function to resolve user from a query.
resolveAnnuaireContacts
resolveAnnuaireContacts
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
::
(
CmdCommon
env
)
=>
AnnuaireContactArgs
->
GqlM
e
env
[
AnnuaireContact
]
=>
AnnuaireContactArgs
->
GqlM
e
env
[
AnnuaireContact
]
resolveAnnuaireContacts
AnnuaireContactArgs
{
contact_id
}
=
dbAnnuaireContacts
contact_id
resolveAnnuaireContacts
AnnuaireContactArgs
{
contact_id
}
=
dbAnnuaireContacts
contact_id
-- | Inner function to fetch the user from DB.
-- | Inner function to fetch the user from DB.
dbAnnuaireContacts
dbAnnuaireContacts
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
::
CmdCommon
env
=>
Int
->
GqlM
e
env
[
AnnuaireContact
]
=>
Int
->
GqlM
e
env
[
AnnuaireContact
]
dbAnnuaireContacts
contact_id
=
do
dbAnnuaireContacts
contact_id
=
do
-- lift $ printDebug "[dbUsers]" user_id
-- lift $ printDebug "[dbUsers]" user_id
...
...
src/Gargantext/API/GraphQL/Context.hs
View file @
a050a009
...
@@ -17,10 +17,9 @@ import Data.Time.Format.ISO8601 (iso8601Show)
...
@@ -17,10 +17,9 @@ import Data.Time.Format.ISO8601 (iso8601Show)
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.Core.Types.Search
(
HyperdataRow
(
..
),
toHyperdataRow
)
import
Gargantext.Core.Types.Search
(
HyperdataRow
(
..
),
toHyperdataRow
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataDocument
)
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataDocument
)
import
Gargantext.Database.Admin.Types.Node
(
ContextTitle
,
NodeId
(
..
),
NodeTypeId
,
UserId
,
unNodeId
)
import
Gargantext.Database.Admin.Types.Node
(
ContextTitle
,
NodeId
(
..
),
NodeTypeId
,
UserId
,
unNodeId
)
import
Gargantext.Database.Prelude
(
HasConnectionPool
,
HasConfig
)
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
Gargantext.Database.Query.Table.NodeContext
(
getNodeContext
,
getContextsForNgramsTerms
,
ContextForNgramsTerms
(
..
))
import
Gargantext.Database.Query.Table.NodeContext
(
getNodeContext
,
getContextsForNgramsTerms
,
ContextForNgramsTerms
(
..
))
import
qualified
Gargantext.Database.Query.Table.NodeContext
as
DNC
import
qualified
Gargantext.Database.Query.Table.NodeContext
as
DNC
import
Gargantext.Database.Schema.NodeContext
(
NodeContext
,
NodeContextPoly
(
..
))
import
Gargantext.Database.Schema.NodeContext
(
NodeContext
,
NodeContextPoly
(
..
))
...
@@ -102,13 +101,13 @@ type GqlM' e env a = ResolverM e (GargM env GargError) a
...
@@ -102,13 +101,13 @@ type GqlM' e env a = ResolverM e (GargM env GargError) a
-- | Function to resolve context from a query.
-- | Function to resolve context from a query.
resolveNodeContext
resolveNodeContext
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
::
(
CmdCommon
env
)
=>
NodeContextArgs
->
GqlM
e
env
[
NodeContextGQL
]
=>
NodeContextArgs
->
GqlM
e
env
[
NodeContextGQL
]
resolveNodeContext
NodeContextArgs
{
context_id
,
node_id
}
=
resolveNodeContext
NodeContextArgs
{
context_id
,
node_id
}
=
dbNodeContext
context_id
node_id
dbNodeContext
context_id
node_id
resolveContextsForNgrams
resolveContextsForNgrams
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
::
(
CmdCommon
env
)
=>
ContextsForNgramsArgs
->
GqlM
e
env
[
ContextGQL
]
=>
ContextsForNgramsArgs
->
GqlM
e
env
[
ContextGQL
]
resolveContextsForNgrams
ContextsForNgramsArgs
{
corpus_id
,
ngrams_terms
}
=
resolveContextsForNgrams
ContextsForNgramsArgs
{
corpus_id
,
ngrams_terms
}
=
dbContextForNgrams
corpus_id
ngrams_terms
dbContextForNgrams
corpus_id
ngrams_terms
...
@@ -117,7 +116,7 @@ resolveContextsForNgrams ContextsForNgramsArgs { corpus_id, ngrams_terms } =
...
@@ -117,7 +116,7 @@ resolveContextsForNgrams ContextsForNgramsArgs { corpus_id, ngrams_terms } =
-- | Inner function to fetch the node context DB.
-- | Inner function to fetch the node context DB.
dbNodeContext
dbNodeContext
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
::
(
CmdCommon
env
)
=>
Int
->
Int
->
GqlM
e
env
[
NodeContextGQL
]
=>
Int
->
Int
->
GqlM
e
env
[
NodeContextGQL
]
dbNodeContext
context_id
node_id
=
do
dbNodeContext
context_id
node_id
=
do
-- lift $ printDebug "[dbUsers]" user_id
-- lift $ printDebug "[dbUsers]" user_id
...
@@ -128,7 +127,7 @@ dbNodeContext context_id node_id = do
...
@@ -128,7 +127,7 @@ dbNodeContext context_id node_id = do
pure
$
toNodeContextGQL
<$>
[
c
]
pure
$
toNodeContextGQL
<$>
[
c
]
dbContextForNgrams
dbContextForNgrams
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
::
(
CmdCommon
env
)
=>
Int
->
[
Text
]
->
GqlM
e
env
[
ContextGQL
]
=>
Int
->
[
Text
]
->
GqlM
e
env
[
ContextGQL
]
dbContextForNgrams
node_id
ngrams_terms
=
do
dbContextForNgrams
node_id
ngrams_terms
=
do
contextsForNgramsTerms
<-
lift
$
getContextsForNgramsTerms
(
NodeId
node_id
)
ngrams_terms
contextsForNgramsTerms
<-
lift
$
getContextsForNgramsTerms
(
NodeId
node_id
)
ngrams_terms
...
@@ -192,7 +191,7 @@ toHyperdataRowDocumentGQL hyperdata =
...
@@ -192,7 +191,7 @@ toHyperdataRowDocumentGQL hyperdata =
}
}
HyperdataRowContact
{
}
->
Nothing
HyperdataRowContact
{
}
->
Nothing
updateNodeContextCategory
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
,
HasSettings
env
)
=>
updateNodeContextCategory
::
(
CmdCommon
env
,
HasSettings
env
)
=>
NodeContextCategoryMArgs
->
GqlM'
e
env
[
Int
]
NodeContextCategoryMArgs
->
GqlM'
e
env
[
Int
]
updateNodeContextCategory
NodeContextCategoryMArgs
{
context_id
,
node_id
,
category
}
=
do
updateNodeContextCategory
NodeContextCategoryMArgs
{
context_id
,
node_id
,
category
}
=
do
_
<-
lift
$
DNC
.
updateNodeContextCategory
(
NodeId
context_id
)
(
NodeId
node_id
)
category
_
<-
lift
$
DNC
.
updateNodeContextCategory
(
NodeId
context_id
)
(
NodeId
node_id
)
category
...
...
src/Gargantext/API/GraphQL/Node.hs
View file @
a050a009
...
@@ -13,11 +13,10 @@ import Data.Morpheus.Types
...
@@ -13,11 +13,10 @@ import Data.Morpheus.Types
import
Data.Text
(
Text
)
import
Data.Text
(
Text
)
import
qualified
Data.Text
as
T
import
qualified
Data.Text
as
T
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
(
..
),
NodeType
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
(
..
),
NodeType
)
import
qualified
Gargantext.Database.Admin.Types.Node
as
NN
import
qualified
Gargantext.Database.Admin.Types.Node
as
NN
import
Gargantext.Database.Query.Table.Node
(
getClosestParentIdByType
,
getNode
)
import
Gargantext.Database.Query.Table.Node
(
getClosestParentIdByType
,
getNode
)
import
Gargantext.Database.Prelude
(
HasConnectionPool
,
HasConfig
)
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
qualified
Gargantext.Database.Schema.Node
as
N
import
qualified
Gargantext.Database.Schema.Node
as
N
import
Gargantext.Prelude
import
Gargantext.Prelude
import
GHC.Generics
(
Generic
)
import
GHC.Generics
(
Generic
)
...
@@ -40,12 +39,12 @@ type GqlM e env = Resolver QUERY e (GargM env GargError)
...
@@ -40,12 +39,12 @@ type GqlM e env = Resolver QUERY e (GargM env GargError)
-- | Function to resolve user from a query.
-- | Function to resolve user from a query.
resolveNodes
resolveNodes
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
::
(
CmdCommon
env
)
=>
NodeArgs
->
GqlM
e
env
[
Node
]
=>
NodeArgs
->
GqlM
e
env
[
Node
]
resolveNodes
NodeArgs
{
node_id
}
=
dbNodes
node_id
resolveNodes
NodeArgs
{
node_id
}
=
dbNodes
node_id
dbNodes
dbNodes
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
::
(
CmdCommon
env
)
=>
Int
->
GqlM
e
env
[
Node
]
=>
Int
->
GqlM
e
env
[
Node
]
dbNodes
node_id
=
do
dbNodes
node_id
=
do
node
<-
lift
$
getNode
$
NodeId
node_id
node
<-
lift
$
getNode
$
NodeId
node_id
...
@@ -58,12 +57,12 @@ data NodeParentArgs
...
@@ -58,12 +57,12 @@ data NodeParentArgs
}
deriving
(
Generic
,
GQLType
)
}
deriving
(
Generic
,
GQLType
)
resolveNodeParent
resolveNodeParent
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
::
(
CmdCommon
env
)
=>
NodeParentArgs
->
GqlM
e
env
[
Node
]
=>
NodeParentArgs
->
GqlM
e
env
[
Node
]
resolveNodeParent
NodeParentArgs
{
node_id
,
parent_type
}
=
dbParentNodes
node_id
parent_type
resolveNodeParent
NodeParentArgs
{
node_id
,
parent_type
}
=
dbParentNodes
node_id
parent_type
dbParentNodes
dbParentNodes
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
::
(
CmdCommon
env
)
=>
Int
->
Text
->
GqlM
e
env
[
Node
]
=>
Int
->
Text
->
GqlM
e
env
[
Node
]
dbParentNodes
node_id
parent_type
=
do
dbParentNodes
node_id
parent_type
=
do
let
mParentType
=
readEither
(
T
.
unpack
parent_type
)
::
Either
Prelude
.
String
NodeType
let
mParentType
=
readEither
(
T
.
unpack
parent_type
)
::
Either
Prelude
.
String
NodeType
...
...
src/Gargantext/API/GraphQL/Team.hs
View file @
a050a009
...
@@ -10,11 +10,9 @@ import Data.Text ( Text )
...
@@ -10,11 +10,9 @@ import Data.Text ( Text )
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.GraphQL.Utils
(
authUser
,
AuthStatus
(
Invalid
,
Valid
))
import
Gargantext.API.GraphQL.Utils
(
authUser
,
AuthStatus
(
Invalid
,
Valid
))
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.Types
(
NodeId
(
..
),
unNodeId
)
import
Gargantext.Core.Types
(
NodeId
(
..
),
unNodeId
)
import
Gargantext.Database
(
HasConfig
)
import
Gargantext.Database.Action.Share
(
membersOf
,
deleteMemberShip
)
import
Gargantext.Database.Action.Share
(
membersOf
,
deleteMemberShip
)
import
Gargantext.Database.Prelude
(
HasConnectionPool
)
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
Gargantext.Database.Query.Table.Node
(
getNode
)
import
Gargantext.Database.Query.Table.Node
(
getNode
)
import
Gargantext.Database.Query.Table.User
(
getUsersWithNodeHyperdata
)
import
Gargantext.Database.Query.Table.User
(
getUsersWithNodeHyperdata
)
import
Gargantext.Database.Schema.Node
(
NodePoly
(
Node
,
_node_id
),
_node_user_id
)
import
Gargantext.Database.Schema.Node
(
NodePoly
(
Node
,
_node_id
),
_node_user_id
)
...
@@ -45,10 +43,11 @@ type GqlM e env = Resolver QUERY e (GargM env GargError)
...
@@ -45,10 +43,11 @@ type GqlM e env = Resolver QUERY e (GargM env GargError)
type
GqlM'
e
env
a
=
ResolverM
e
(
GargM
env
GargError
)
a
type
GqlM'
e
env
a
=
ResolverM
e
(
GargM
env
GargError
)
a
resolveTeam
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
TeamArgs
->
GqlM
e
env
Team
resolveTeam
::
(
CmdCommon
env
)
=>
TeamArgs
->
GqlM
e
env
Team
resolveTeam
TeamArgs
{
team_node_id
}
=
dbTeam
team_node_id
resolveTeam
TeamArgs
{
team_node_id
}
=
dbTeam
team_node_id
dbTeam
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
Int
->
GqlM
e
env
Team
dbTeam
::
(
CmdCommon
env
)
=>
Int
->
GqlM
e
env
Team
dbTeam
nodeId
=
do
dbTeam
nodeId
=
do
let
nId
=
NodeId
nodeId
let
nId
=
NodeId
nodeId
res
<-
lift
$
membersOf
nId
res
<-
lift
$
membersOf
nId
...
@@ -69,7 +68,8 @@ dbTeam nodeId = do
...
@@ -69,7 +68,8 @@ dbTeam nodeId = do
getUsername
((
UserLight
{
userLight_username
},
_
)
:
_
)
=
userLight_username
getUsername
((
UserLight
{
userLight_username
},
_
)
:
_
)
=
userLight_username
-- TODO: list as argument
-- TODO: list as argument
deleteTeamMembership
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
,
HasSettings
env
)
=>
TeamDeleteMArgs
->
GqlM'
e
env
[
Int
]
deleteTeamMembership
::
(
CmdCommon
env
,
HasSettings
env
)
=>
TeamDeleteMArgs
->
GqlM'
e
env
[
Int
]
deleteTeamMembership
TeamDeleteMArgs
{
token
,
shared_folder_id
,
team_node_id
}
=
do
deleteTeamMembership
TeamDeleteMArgs
{
token
,
shared_folder_id
,
team_node_id
}
=
do
teamNode
<-
lift
$
getNode
$
NodeId
team_node_id
teamNode
<-
lift
$
getNode
$
NodeId
team_node_id
userNodes
<-
lift
(
getUsersWithNodeHyperdata
$
uId
teamNode
)
userNodes
<-
lift
(
getUsersWithNodeHyperdata
$
uId
teamNode
)
...
...
src/Gargantext/API/GraphQL/TreeFirstLevel.hs
View file @
a050a009
...
@@ -3,23 +3,21 @@
...
@@ -3,23 +3,21 @@
module
Gargantext.API.GraphQL.TreeFirstLevel
where
module
Gargantext.API.GraphQL.TreeFirstLevel
where
import
Gargantext.Prelude
import
Data.Morpheus.Types
(
GQLType
,
lift
,
Resolver
,
QUERY
)
import
Data.Morpheus.Types
(
GQLType
,
lift
,
Resolver
,
QUERY
)
import
GHC.Generics
(
Generic
)
import
Data.Text
(
Text
)
import
Data.Text
(
Text
)
import
GHC.Generics
(
Generic
)
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.Database.Prelude
(
HasConnectionPool
,
HasConfig
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
qualified
Gargantext.Database.Query.Tree
as
T
import
qualified
Gargantext.Database.Schema.Node
as
N
import
qualified
Gargantext.Database.Admin.Types.Node
as
NN
import
Gargantext.Database.Admin.Types.Node
(
allNodeTypes
,
NodeId
(
NodeId
))
import
Gargantext.Core.Types
(
Tree
,
NodeTree
,
NodeType
)
import
Gargantext.Core.Types
(
Tree
,
NodeTree
,
NodeType
)
import
Gargantext.Core.Types.Main
import
Gargantext.Core.Types.Main
(
Tree
(
TreeN
),
_tn_node
,
_tn_children
,
NodeTree
(
NodeTree
,
_nt_id
,
_nt_type
),
_nt_name
)
(
Tree
(
TreeN
),
_tn_node
,
_tn_children
,
NodeTree
(
NodeTree
,
_nt_id
,
_nt_type
),
_nt_name
)
import
Gargantext.Database.Query.Table.Node
(
getNode
)
import
Gargantext.Database.Admin.Config
(
fromNodeTypeId
)
import
Gargantext.Database.Admin.Config
(
fromNodeTypeId
)
import
Gargantext.Database.Admin.Types.Node
(
allNodeTypes
,
NodeId
(
NodeId
))
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
Gargantext.Database.Query.Table.Node
(
getNode
)
import
Gargantext.Database.Schema.Node
(
NodePoly
(
_node_parent_id
))
import
Gargantext.Database.Schema.Node
(
NodePoly
(
_node_parent_id
))
import
Gargantext.Prelude
import
qualified
Gargantext.Database.Admin.Types.Node
as
NN
import
qualified
Gargantext.Database.Query.Tree
as
T
import
qualified
Gargantext.Database.Schema.Node
as
N
data
TreeArgs
=
TreeArgs
data
TreeArgs
=
TreeArgs
{
{
...
@@ -45,10 +43,11 @@ type GqlM e env = Resolver QUERY e (GargM env GargError)
...
@@ -45,10 +43,11 @@ type GqlM e env = Resolver QUERY e (GargM env GargError)
type
ParentId
=
Maybe
NodeId
type
ParentId
=
Maybe
NodeId
resolveTree
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
TreeArgs
->
GqlM
e
env
(
TreeFirstLevel
(
GqlM
e
env
))
resolveTree
::
(
CmdCommon
env
)
=>
TreeArgs
->
GqlM
e
env
(
TreeFirstLevel
(
GqlM
e
env
))
resolveTree
TreeArgs
{
root_id
}
=
dbTree
root_id
resolveTree
TreeArgs
{
root_id
}
=
dbTree
root_id
dbTree
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
Int
->
GqlM
e
env
(
TreeFirstLevel
(
GqlM
e
env
))
dbTree
::
(
CmdCommon
env
)
=>
Int
->
GqlM
e
env
(
TreeFirstLevel
(
GqlM
e
env
))
dbTree
root_id
=
do
dbTree
root_id
=
do
let
rId
=
NodeId
root_id
let
rId
=
NodeId
root_id
t
<-
lift
$
T
.
tree
T
.
TreeFirstLevel
rId
allNodeTypes
t
<-
lift
$
T
.
tree
T
.
TreeFirstLevel
rId
allNodeTypes
...
@@ -59,7 +58,7 @@ dbTree root_id = do
...
@@ -59,7 +58,7 @@ dbTree root_id = do
toParentId
N
.
Node
{
_node_parent_id
}
=
_node_parent_id
toParentId
N
.
Node
{
_node_parent_id
}
=
_node_parent_id
toTree
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
NodeId
->
ParentId
->
Tree
NodeTree
->
TreeFirstLevel
(
GqlM
e
env
)
toTree
::
(
CmdCommon
env
)
=>
NodeId
->
ParentId
->
Tree
NodeTree
->
TreeFirstLevel
(
GqlM
e
env
)
toTree
rId
pId
TreeN
{
_tn_node
,
_tn_children
}
=
TreeFirstLevel
toTree
rId
pId
TreeN
{
_tn_node
,
_tn_children
}
=
TreeFirstLevel
{
parent
=
resolveParent
pId
{
parent
=
resolveParent
pId
,
root
=
toTreeNode
pId
_tn_node
,
root
=
toTreeNode
pId
_tn_node
...
@@ -75,7 +74,7 @@ toTreeNode pId NodeTree { _nt_name, _nt_id, _nt_type } = TreeNode { name = _nt_n
...
@@ -75,7 +74,7 @@ toTreeNode pId NodeTree { _nt_name, _nt_id, _nt_type } = TreeNode { name = _nt_n
childrenToTreeNodes
::
(
Tree
NodeTree
,
NodeId
)
->
TreeNode
childrenToTreeNodes
::
(
Tree
NodeTree
,
NodeId
)
->
TreeNode
childrenToTreeNodes
(
TreeN
{
_tn_node
},
rId
)
=
toTreeNode
(
Just
rId
)
_tn_node
childrenToTreeNodes
(
TreeN
{
_tn_node
},
rId
)
=
toTreeNode
(
Just
rId
)
_tn_node
resolveParent
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
Maybe
NodeId
->
GqlM
e
env
(
Maybe
TreeNode
)
resolveParent
::
(
CmdCommon
env
)
=>
Maybe
NodeId
->
GqlM
e
env
(
Maybe
TreeNode
)
resolveParent
(
Just
pId
)
=
do
resolveParent
(
Just
pId
)
=
do
node
<-
lift
$
getNode
pId
node
<-
lift
$
getNode
pId
pure
$
nodeToTreeNode
node
pure
$
nodeToTreeNode
node
...
...
src/Gargantext/API/GraphQL/User.hs
View file @
a050a009
...
@@ -10,9 +10,8 @@ import Data.Morpheus.Types
...
@@ -10,9 +10,8 @@ import Data.Morpheus.Types
)
)
import
Data.Text
(
Text
)
import
Data.Text
(
Text
)
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataUser
(
..
))
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataUser
(
..
))
import
Gargantext.Database.Prelude
(
HasConnectionPool
,
HasConfig
)
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
Gargantext.Database.Query.Table.User
(
getUsersWithId
,
getUserHyperdata
)
import
Gargantext.Database.Query.Table.User
(
getUsersWithId
,
getUserHyperdata
)
import
Gargantext.Database.Schema.User
(
UserLight
(
..
))
import
Gargantext.Database.Schema.User
(
UserLight
(
..
))
import
Gargantext.Prelude
import
Gargantext.Prelude
...
@@ -35,18 +34,18 @@ type GqlM e env = Resolver QUERY e (GargM env GargError)
...
@@ -35,18 +34,18 @@ type GqlM e env = Resolver QUERY e (GargM env GargError)
-- | Function to resolve user from a query.
-- | Function to resolve user from a query.
resolveUsers
resolveUsers
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
::
(
CmdCommon
env
)
=>
UserArgs
->
GqlM
e
env
[
User
(
GqlM
e
env
)]
=>
UserArgs
->
GqlM
e
env
[
User
(
GqlM
e
env
)]
resolveUsers
UserArgs
{
user_id
}
=
dbUsers
user_id
resolveUsers
UserArgs
{
user_id
}
=
dbUsers
user_id
-- | Inner function to fetch the user from DB.
-- | Inner function to fetch the user from DB.
dbUsers
dbUsers
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
::
(
CmdCommon
env
)
=>
Int
->
GqlM
e
env
[
User
(
GqlM
e
env
)]
=>
Int
->
GqlM
e
env
[
User
(
GqlM
e
env
)]
dbUsers
user_id
=
lift
(
map
toUser
<$>
getUsersWithId
user_id
)
dbUsers
user_id
=
lift
(
map
toUser
<$>
getUsersWithId
user_id
)
toUser
toUser
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
::
(
CmdCommon
env
)
=>
UserLight
->
User
(
GqlM
e
env
)
=>
UserLight
->
User
(
GqlM
e
env
)
toUser
(
UserLight
{
..
})
=
User
{
u_email
=
userLight_email
toUser
(
UserLight
{
..
})
=
User
{
u_email
=
userLight_email
,
u_hyperdata
=
resolveHyperdata
userLight_id
,
u_hyperdata
=
resolveHyperdata
userLight_id
...
@@ -54,6 +53,6 @@ toUser (UserLight { .. }) = User { u_email = userLight_email
...
@@ -54,6 +53,6 @@ toUser (UserLight { .. }) = User { u_email = userLight_email
,
u_username
=
userLight_username
}
,
u_username
=
userLight_username
}
resolveHyperdata
resolveHyperdata
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
::
(
CmdCommon
env
)
=>
Int
->
GqlM
e
env
(
Maybe
HyperdataUser
)
=>
Int
->
GqlM
e
env
(
Maybe
HyperdataUser
)
resolveHyperdata
userid
=
lift
(
listToMaybe
<$>
getUserHyperdata
userid
)
resolveHyperdata
userid
=
lift
(
listToMaybe
<$>
getUserHyperdata
userid
)
src/Gargantext/API/GraphQL/UserInfo.hs
View file @
a050a009
...
@@ -16,7 +16,6 @@ import Data.Morpheus.Types
...
@@ -16,7 +16,6 @@ import Data.Morpheus.Types
import
Data.Text
(
Text
)
import
Data.Text
(
Text
)
import
qualified
Data.Text
as
T
import
qualified
Data.Text
as
T
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Hyperdata
(
HyperdataUser
(
..
)
(
HyperdataUser
(
..
)
,
hc_source
,
hc_source
...
@@ -40,7 +39,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact
...
@@ -40,7 +39,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact
,
ct_phone
,
ct_phone
,
hc_who
,
hc_who
,
hc_where
)
,
hc_where
)
import
Gargantext.Database.Prelude
(
HasConnectionPool
,
HasConfig
)
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
import
Gargantext.Database.Query.Table.User
(
getUsersWithHyperdata
,
getUsersWithNodeHyperdata
,
updateUserEmail
)
import
Gargantext.Database.Query.Table.User
(
getUsersWithHyperdata
,
getUsersWithNodeHyperdata
,
updateUserEmail
)
import
Gargantext.Database.Schema.User
(
UserLight
(
..
))
import
Gargantext.Database.Schema.User
(
UserLight
(
..
))
...
@@ -105,13 +104,13 @@ type GqlM' e env err = ResolverM e (GargM env err) Int
...
@@ -105,13 +104,13 @@ type GqlM' e env err = ResolverM e (GargM env err) Int
-- | Function to resolve user from a query.
-- | Function to resolve user from a query.
resolveUserInfos
resolveUserInfos
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
::
(
CmdCommon
env
)
=>
UserInfoArgs
->
GqlM
e
env
[
UserInfo
]
=>
UserInfoArgs
->
GqlM
e
env
[
UserInfo
]
resolveUserInfos
UserInfoArgs
{
user_id
}
=
dbUsers
user_id
resolveUserInfos
UserInfoArgs
{
user_id
}
=
dbUsers
user_id
-- | Mutation for user info
-- | Mutation for user info
updateUserInfo
updateUserInfo
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
,
HasSettings
env
)
::
(
CmdCommon
env
,
HasSettings
env
)
-- => UserInfoMArgs -> ResolverM e (GargM env err) Int
-- => UserInfoMArgs -> ResolverM e (GargM env err) Int
=>
UserInfoMArgs
->
GqlM'
e
env
err
=>
UserInfoMArgs
->
GqlM'
e
env
err
updateUserInfo
(
UserInfoMArgs
{
ui_id
,
..
})
=
do
updateUserInfo
(
UserInfoMArgs
{
ui_id
,
..
})
=
do
...
@@ -160,7 +159,7 @@ updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
...
@@ -160,7 +159,7 @@ updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
-- | Inner function to fetch the user from DB.
-- | Inner function to fetch the user from DB.
dbUsers
dbUsers
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
::
(
CmdCommon
env
)
=>
Int
->
GqlM
e
env
[
UserInfo
]
=>
Int
->
GqlM
e
env
[
UserInfo
]
dbUsers
user_id
=
do
dbUsers
user_id
=
do
-- lift $ printDebug "[dbUsers]" user_id
-- lift $ printDebug "[dbUsers]" user_id
...
...
src/Gargantext/API/Members.hs
View file @
a050a009
...
@@ -9,8 +9,7 @@ import Gargantext.Core.Types (UserId)
...
@@ -9,8 +9,7 @@ import Gargantext.Core.Types (UserId)
import
Gargantext.Database.Admin.Types.Node
(
NodeType
(
NodeTeam
))
import
Gargantext.Database.Admin.Types.Node
(
NodeType
(
NodeTeam
))
import
Gargantext.Database.Query.Table.Node
(
getNodesIdWithType
)
import
Gargantext.Database.Query.Table.Node
(
getNodesIdWithType
)
import
Gargantext.Database.Action.Share
(
membersOf
)
import
Gargantext.Database.Action.Share
(
membersOf
)
import
Gargantext.Database.Prelude
(
HasConnectionPool
,
HasConfig
)
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Control.Monad.Extra
(
concatMapM
)
import
Control.Monad.Extra
(
concatMapM
)
type
MembersAPI
=
Get
'[
J
SON
]
[
Text
]
type
MembersAPI
=
Get
'[
J
SON
]
[
Text
]
...
@@ -19,7 +18,8 @@ members :: UserId -> ServerT MembersAPI (GargM Env GargError)
...
@@ -19,7 +18,8 @@ members :: UserId -> ServerT MembersAPI (GargM Env GargError)
members
_
=
do
members
_
=
do
getMembers
getMembers
getMembers
::
(
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
GargM
env
GargError
[
Text
]
getMembers
::
(
CmdCommon
env
)
=>
GargM
env
GargError
[
Text
]
getMembers
=
do
getMembers
=
do
teamNodeIds
<-
getNodesIdWithType
NodeTeam
teamNodeIds
<-
getNodesIdWithType
NodeTeam
m
<-
concatMapM
membersOf
teamNodeIds
m
<-
concatMapM
membersOf
teamNodeIds
...
...
src/Gargantext/API/Ngrams.hs
View file @
a050a009
...
@@ -105,14 +105,13 @@ import Gargantext.API.Job
...
@@ -105,14 +105,13 @@ import Gargantext.API.Job
import
Gargantext.API.Ngrams.Types
import
Gargantext.API.Ngrams.Types
import
Gargantext.API.Prelude
import
Gargantext.API.Prelude
import
Gargantext.Core.NodeStory
import
Gargantext.Core.NodeStory
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.Types
(
ListType
(
..
),
NodeId
,
ListId
,
DocId
,
Limit
,
Offset
,
TODO
,
assertValid
,
HasInvalidError
)
import
Gargantext.Core.Types
(
ListType
(
..
),
NodeId
,
ListId
,
DocId
,
Limit
,
Offset
,
TODO
,
assertValid
,
HasInvalidError
)
import
Gargantext.API.Ngrams.Tools
import
Gargantext.API.Ngrams.Tools
import
Gargantext.Database.Action.Flow.Types
import
Gargantext.Database.Action.Flow.Types
import
Gargantext.Database.Action.Metrics.NgramsByContext
(
getOccByNgramsOnlyFast
)
import
Gargantext.Database.Action.Metrics.NgramsByContext
(
getOccByNgramsOnlyFast
)
import
Gargantext.Database.Admin.Config
(
userMaster
)
import
Gargantext.Database.Admin.Config
(
userMaster
)
import
Gargantext.Database.Admin.Types.Node
(
NodeType
(
..
))
import
Gargantext.Database.Admin.Types.Node
(
NodeType
(
..
))
import
Gargantext.Database.Prelude
(
HasConnectionPool
(
..
),
HasConfig
)
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
Gargantext.Database.Query.Table.Ngrams
hiding
(
NgramsType
(
..
),
ngramsType
,
ngrams_terms
)
import
Gargantext.Database.Query.Table.Ngrams
hiding
(
NgramsType
(
..
),
ngramsType
,
ngrams_terms
)
import
Gargantext.Database.Query.Table.Node
(
getNode
)
import
Gargantext.Database.Query.Table.Node
(
getNode
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
...
@@ -295,7 +294,7 @@ newNgramsFromNgramsStatePatch p =
...
@@ -295,7 +294,7 @@ newNgramsFromNgramsStatePatch p =
commitStatePatch
::
(
HasNodeStory
env
err
m
commitStatePatch
::
(
HasNodeStory
env
err
m
,
HasNodeStoryImmediateSaver
env
,
HasNodeStoryImmediateSaver
env
,
HasNodeArchiveStoryImmediateSaver
env
,
HasNodeArchiveStoryImmediateSaver
env
,
HasMail
env
)
,
CmdCommon
env
)
=>
ListId
=>
ListId
->
Versioned
NgramsStatePatch'
->
Versioned
NgramsStatePatch'
->
m
(
Versioned
NgramsStatePatch'
)
->
m
(
Versioned
NgramsStatePatch'
)
...
@@ -394,8 +393,7 @@ tableNgramsPut :: ( HasNodeStory env err m
...
@@ -394,8 +393,7 @@ tableNgramsPut :: ( HasNodeStory env err m
,
HasNodeStoryImmediateSaver
env
,
HasNodeStoryImmediateSaver
env
,
HasNodeArchiveStoryImmediateSaver
env
,
HasNodeArchiveStoryImmediateSaver
env
,
HasInvalidError
err
,
HasInvalidError
err
,
HasSettings
env
,
CmdCommon
env
,
HasMail
env
)
)
=>
TabType
=>
TabType
->
ListId
->
ListId
...
@@ -542,7 +540,7 @@ type MaxSize = Int
...
@@ -542,7 +540,7 @@ type MaxSize = Int
getTableNgrams
::
forall
env
err
m
.
getTableNgrams
::
forall
env
err
m
.
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
CmdCommon
env
)
=>
NodeType
->
NodeId
->
TabType
=>
NodeType
->
NodeId
->
TabType
->
ListId
->
Limit
->
Maybe
Offset
->
ListId
->
Limit
->
Maybe
Offset
->
Maybe
ListType
->
Maybe
ListType
...
@@ -639,9 +637,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
...
@@ -639,9 +637,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
getNgramsTable'
::
forall
env
err
m
.
getNgramsTable'
::
forall
env
err
m
.
(
HasNodeStory
env
err
m
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
HasNodeError
err
,
HasConnectionPool
env
,
CmdCommon
env
)
,
HasConfig
env
,
HasMail
env
)
=>
NodeId
=>
NodeId
->
ListId
->
ListId
->
TableNgrams
.
NgramsType
->
TableNgrams
.
NgramsType
...
@@ -656,9 +652,7 @@ setNgramsTableScores :: forall env err m t.
...
@@ -656,9 +652,7 @@ setNgramsTableScores :: forall env err m t.
(
Each
t
t
NgramsElement
NgramsElement
(
Each
t
t
NgramsElement
NgramsElement
,
HasNodeStory
env
err
m
,
HasNodeStory
env
err
m
,
HasNodeError
err
,
HasNodeError
err
,
HasConnectionPool
env
,
CmdCommon
env
)
,
HasConfig
env
,
HasMail
env
)
=>
NodeId
=>
NodeId
->
ListId
->
ListId
->
TableNgrams
.
NgramsType
->
TableNgrams
.
NgramsType
...
@@ -686,7 +680,7 @@ setNgramsTableScores nId listId ngramsType table = do
...
@@ -686,7 +680,7 @@ setNgramsTableScores nId listId ngramsType table = do
scoresRecomputeTableNgrams
::
forall
env
err
m
.
scoresRecomputeTableNgrams
::
forall
env
err
m
.
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
CmdCommon
env
)
=>
NodeId
->
TabType
->
ListId
->
m
Int
=>
NodeId
->
TabType
->
ListId
->
m
Int
scoresRecomputeTableNgrams
nId
tabType
listId
=
do
scoresRecomputeTableNgrams
nId
tabType
listId
=
do
tableMap
<-
getNgramsTableMap
listId
ngramsType
tableMap
<-
getNgramsTableMap
listId
ngramsType
...
@@ -769,7 +763,7 @@ type TableNgramsAsyncApi = Summary "Table Ngrams Async API"
...
@@ -769,7 +763,7 @@ type TableNgramsAsyncApi = Summary "Table Ngrams Async API"
:>
"update"
:>
"update"
:>
AsyncJobs
JobLog
'[
J
SON
]
UpdateTableNgramsCharts
JobLog
:>
AsyncJobs
JobLog
'[
J
SON
]
UpdateTableNgramsCharts
JobLog
getTableNgramsCorpus
::
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
getTableNgramsCorpus
::
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
CmdCommon
env
)
=>
NodeId
=>
NodeId
->
TabType
->
TabType
->
ListId
->
ListId
...
@@ -787,7 +781,7 @@ getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize o
...
@@ -787,7 +781,7 @@ getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize o
getTableNgramsVersion
::
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
HasConnectionPool
env
,
HasConfig
env
)
getTableNgramsVersion
::
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
CmdCommon
env
)
=>
NodeId
=>
NodeId
->
TabType
->
TabType
->
ListId
->
ListId
...
@@ -803,7 +797,7 @@ getTableNgramsVersion _nId _tabType listId = currentVersion listId
...
@@ -803,7 +797,7 @@ getTableNgramsVersion _nId _tabType listId = currentVersion listId
-- | Text search is deactivated for now for ngrams by doc only
-- | Text search is deactivated for now for ngrams by doc only
getTableNgramsDoc
::
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
getTableNgramsDoc
::
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
CmdCommon
env
)
=>
DocId
->
TabType
=>
DocId
->
TabType
->
ListId
->
Limit
->
Maybe
Offset
->
ListId
->
Limit
->
Maybe
Offset
->
Maybe
ListType
->
Maybe
ListType
...
...
src/Gargantext/API/Node/Corpus/Searx.hs
View file @
a050a009
...
@@ -23,9 +23,9 @@ import Gargantext.Prelude
...
@@ -23,9 +23,9 @@ import Gargantext.Prelude
import
Gargantext.Prelude.Config
import
Gargantext.Prelude.Config
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
(
..
))
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
(
..
))
--import Gargantext.API.Admin.Types (HasSettings)
import
Gargantext.API.Job
(
jobLogSuccess
)
import
Gargantext.API.Job
(
jobLogSuccess
)
import
Gargantext.Core
(
Lang
(
..
),
PosTagAlgo
(
..
))
import
Gargantext.Core
(
Lang
(
..
))
import
Gargantext.Core.NLP
(
nlpServerGet
)
import
qualified
Gargantext.Core.Text.Corpus.API
as
API
import
qualified
Gargantext.Core.Text.Corpus.API
as
API
import
Gargantext.Core.Text.List
(
buildNgramsLists
)
import
Gargantext.Core.Text.List
(
buildNgramsLists
)
import
Gargantext.Core.Text.List.Group.WithStem
(
{-StopSize(..),-}
GroupParams
(
..
))
import
Gargantext.Core.Text.List.Group.WithStem
(
{-StopSize(..),-}
GroupParams
(
..
))
...
@@ -120,11 +120,12 @@ insertSearxResponse :: (MonadBase IO m, FlowCmdM env err m)
...
@@ -120,11 +120,12 @@ insertSearxResponse :: (MonadBase IO m, FlowCmdM env err m)
->
m
()
->
m
()
insertSearxResponse
_
_
_
_
(
Left
_
)
=
pure
()
insertSearxResponse
_
_
_
_
(
Left
_
)
=
pure
()
insertSearxResponse
user
cId
listId
l
(
Right
(
SearxResponse
{
_srs_results
}))
=
do
insertSearxResponse
user
cId
listId
l
(
Right
(
SearxResponse
{
_srs_results
}))
=
do
server
<-
view
(
nlpServerGet
l
)
-- docs :: [Either Text HyperdataDocument]
-- docs :: [Either Text HyperdataDocument]
let
docs
=
hyperdataDocumentFromSearxResult
l
<$>
_srs_results
let
docs
=
hyperdataDocumentFromSearxResult
l
<$>
_srs_results
--printDebug "[triggerSearxSearch] docs" docs
--printDebug "[triggerSearxSearch] docs" docs
let
docs'
=
catMaybes
$
rightToMaybe
<$>
docs
let
docs'
=
catMaybes
$
rightToMaybe
<$>
docs
{-
{-
Prelude.mapM_ (\(HyperdataDocument { _hd_title, _hd_publication_year, _hd_publication_date }) -> do
Prelude.mapM_ (\(HyperdataDocument { _hd_title, _hd_publication_year, _hd_publication_date }) -> do
printDebug "[triggerSearxSearch] doc time" $
printDebug "[triggerSearxSearch] doc time" $
"[title] " <> (show _hd_title) <>
"[title] " <> (show _hd_title) <>
...
@@ -138,10 +139,10 @@ insertSearxResponse user cId listId l (Right (SearxResponse { _srs_results })) =
...
@@ -138,10 +139,10 @@ insertSearxResponse user cId listId l (Right (SearxResponse { _srs_results })) =
_
<-
Doc
.
add
cId
ids
_
<-
Doc
.
add
cId
ids
(
_masterUserId
,
_masterRootId
,
masterCorpusId
)
(
_masterUserId
,
_masterRootId
,
masterCorpusId
)
<-
getOrMk_RootWithCorpus
(
UserName
userMaster
)
(
Left
""
)
mCorpus
<-
getOrMk_RootWithCorpus
(
UserName
userMaster
)
(
Left
""
)
mCorpus
let
let
gp
=
GroupWithPosTag
l
server
HashMap
.
empty
gp
=
case
l
of
--
gp = case l of
FR
->
GroupWithPosTag
l
Spacy
HashMap
.
empty
--
FR -> GroupWithPosTag l Spacy HashMap.empty
_
->
GroupWithPosTag
l
CoreNLP
HashMap
.
empty
--
_ -> GroupWithPosTag l CoreNLP HashMap.empty
ngs
<-
buildNgramsLists
user
cId
masterCorpusId
Nothing
gp
ngs
<-
buildNgramsLists
user
cId
masterCorpusId
Nothing
gp
_userListId
<-
flowList_DbRepo
listId
ngs
_userListId
<-
flowList_DbRepo
listId
ngs
...
...
src/Gargantext/API/Node/Share.hs
View file @
a050a009
...
@@ -20,6 +20,7 @@ import Data.Swagger
...
@@ -20,6 +20,7 @@ import Data.Swagger
import
Data.Text
(
Text
)
import
Data.Text
(
Text
)
import
GHC.Generics
(
Generic
)
import
GHC.Generics
(
Generic
)
import
Gargantext.API.Prelude
import
Gargantext.API.Prelude
import
Gargantext.Core.NLP
(
HasNLPServer
)
import
Gargantext.Core.Types.Individu
(
User
(
..
),
arbitraryUsername
)
import
Gargantext.Core.Types.Individu
(
User
(
..
),
arbitraryUsername
)
import
Gargantext.Database.Action.Share
(
ShareNodeWith
(
..
))
import
Gargantext.Database.Action.Share
(
ShareNodeWith
(
..
))
import
Gargantext.Database.Action.Share
as
DB
(
shareNodeWith
,
unPublish
)
import
Gargantext.Database.Action.Share
as
DB
(
shareNodeWith
,
unPublish
)
...
@@ -56,11 +57,11 @@ instance Arbitrary ShareNodeParams where
...
@@ -56,11 +57,11 @@ instance Arbitrary ShareNodeParams where
-- TODO permission
-- TODO permission
-- TODO refactor userId which is used twice
-- TODO refactor userId which is used twice
-- TODO change return type for better warning/info/success/error handling on the front
-- TODO change return type for better warning/info/success/error handling on the front
api
::
HasNodeError
err
api
::
(
HasNodeError
err
,
HasNLPServer
env
,
CmdRandom
env
err
m
)
=>
User
=>
User
->
NodeId
->
NodeId
->
ShareNodeParams
->
ShareNodeParams
->
CmdR
err
Int
->
m
Int
api
userInviting
nId
(
ShareTeamParams
user'
)
=
do
api
userInviting
nId
(
ShareTeamParams
user'
)
=
do
let
user''
=
Text
.
toLower
user'
let
user''
=
Text
.
toLower
user'
user
<-
case
guessUserName
user''
of
user
<-
case
guessUserName
user''
of
...
@@ -88,7 +89,7 @@ api userInviting nId (ShareTeamParams user') = do
...
@@ -88,7 +89,7 @@ api userInviting nId (ShareTeamParams user') = do
True
->
do
True
->
do
-- printDebug "[G.A.N.Share.api]" ("Invitation is enabled if you share a corpus at least" :: Text)
-- printDebug "[G.A.N.Share.api]" ("Invitation is enabled if you share a corpus at least" :: Text)
pure
0
pure
0
False
->
do
False
->
do
-- printDebug "[G.A.N.Share.api]" ("Your invitation is sent to: " <> user'')
-- printDebug "[G.A.N.Share.api]" ("Your invitation is sent to: " <> user'')
newUsers
[
user''
]
newUsers
[
user''
]
pure
()
pure
()
...
...
src/Gargantext/API/Prelude.hs
View file @
a050a009
...
@@ -34,6 +34,7 @@ import Data.Typeable
...
@@ -34,6 +34,7 @@ import Data.Typeable
import
Data.Validity
import
Data.Validity
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Admin.Types
import
Gargantext.API.Admin.Types
import
Gargantext.Core.NLP
(
HasNLPServer
)
import
Gargantext.Core.NodeStory
import
Gargantext.Core.NodeStory
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.Types
import
Gargantext.Core.Types
...
@@ -61,6 +62,7 @@ type EnvC env =
...
@@ -61,6 +62,7 @@ type EnvC env =
,
HasConfig
env
,
HasConfig
env
,
HasNodeStoryEnv
env
,
HasNodeStoryEnv
env
,
HasMail
env
,
HasMail
env
,
HasNLPServer
env
)
)
type
ErrC
err
=
type
ErrC
err
=
...
...
src/Gargantext/Core.hs
View file @
a050a009
...
@@ -27,7 +27,7 @@ import Servant.API
...
@@ -27,7 +27,7 @@ import Servant.API
------------------------------------------------------------------------
------------------------------------------------------------------------
-- | Language of a Text
-- | Language of a Text
-- For simplicity, we suppose text has an homogenous language
-- For simplicity, we suppose text has an homogenous language
--
--
-- Next steps: | DE | IT | SP
-- Next steps: | DE | IT | SP
--
--
-- - EN == english
-- - EN == english
...
@@ -74,6 +74,11 @@ instance HasDBid Lang where
...
@@ -74,6 +74,11 @@ instance HasDBid Lang where
fromDBid
_
=
panic
"HasDBid lang, not implemented"
fromDBid
_
=
panic
"HasDBid lang, not implemented"
------------------------------------------------------------------------
------------------------------------------------------------------------
data
NLPServerConfig
=
NLPServerConfig
{
server
::
!
PosTagAlgo
,
url
::
!
URI
}
deriving
(
Show
,
Eq
)
------------------------------------------------------------------------
type
Form
=
Text
type
Form
=
Text
type
Lem
=
Text
type
Lem
=
Text
------------------------------------------------------------------------
------------------------------------------------------------------------
...
@@ -90,4 +95,3 @@ instance HasDBid PosTagAlgo where
...
@@ -90,4 +95,3 @@ instance HasDBid PosTagAlgo where
fromDBid
2
=
JohnSnowServer
fromDBid
2
=
JohnSnowServer
fromDBid
3
=
Spacy
fromDBid
3
=
Spacy
fromDBid
_
=
panic
"HasDBid posTagAlgo : Not implemented"
fromDBid
_
=
panic
"HasDBid posTagAlgo : Not implemented"
src/Gargantext/Core/Mail.hs
View file @
a050a009
...
@@ -139,4 +139,3 @@ email_signature =
...
@@ -139,4 +139,3 @@ email_signature =
,
"-- "
,
"-- "
,
"The Gargantext Team (CNRS)"
,
"The Gargantext Team (CNRS)"
]
]
src/Gargantext/Core/NLP.hs
0 → 100644
View file @
a050a009
module
Gargantext.Core.NLP
where
import
Control.Lens
(
Getter
,
at
,
non
)
import
qualified
Data.Map.Strict
as
Map
import
Data.Maybe
(
fromJust
)
import
Network.URI
(
URI
(
..
),
parseURI
)
import
Gargantext.Core
(
Lang
(
..
),
NLPServerConfig
(
..
),
PosTagAlgo
(
..
))
import
Gargantext.Prelude.NLP.Types
(
NLPConfig
(
..
))
import
Gargantext.Utils.Tuple
(
uncurryMaybeSecond
)
import
Protolude
hiding
(
All
)
type
NLPServerMap
=
Map
.
Map
Lang
NLPServerConfig
class
HasNLPServer
env
where
nlpServer
::
Getter
env
NLPServerMap
nlpServerGet
::
Lang
->
Getter
env
NLPServerConfig
-- default implementation
nlpServerGet
l
=
nlpServer
.
at
l
.
non
defaultNLPServer
defaultNLPServer
::
NLPServerConfig
defaultNLPServer
=
NLPServerConfig
{
server
=
CoreNLP
,
url
=
fromJust
$
parseURI
"http://localhost:9000"
}
nlpServerConfigFromURI
::
URI
->
Maybe
NLPServerConfig
nlpServerConfigFromURI
uri
@
(
URI
{
uriScheme
=
"corenlp:"
})
=
Just
$
NLPServerConfig
{
server
=
CoreNLP
,
url
=
uri
{
uriScheme
=
"http:"
}
}
nlpServerConfigFromURI
uri
@
(
URI
{
uriScheme
=
"johnsnow:"
})
=
Just
$
NLPServerConfig
{
server
=
JohnSnowServer
,
url
=
uri
{
uriScheme
=
"http:"
}
}
nlpServerConfigFromURI
uri
@
(
URI
{
uriScheme
=
"spacy:"
})
=
Just
$
NLPServerConfig
{
server
=
Spacy
,
url
=
uri
{
uriScheme
=
"http:"
}
}
nlpServerConfigFromURI
_
=
Nothing
nlpServerMap
::
NLPConfig
->
NLPServerMap
nlpServerMap
(
NLPConfig
{
..
})
=
Map
.
fromList
$
catMaybes
[
uncurryMaybeSecond
(
EN
,
nlpServerConfigFromURI
_nlp_en
)
,
uncurryMaybeSecond
(
FR
,
nlpServerConfigFromURI
_nlp_fr
)
,
uncurryMaybeSecond
(
All
,
nlpServerConfigFromURI
_nlp_all
)
]
src/Gargantext/Core/Text/List.hs
View file @
a050a009
...
@@ -139,8 +139,8 @@ getGroupParams :: ( HasNodeError err
...
@@ -139,8 +139,8 @@ getGroupParams :: ( HasNodeError err
,
HasTreeError
err
,
HasTreeError
err
)
)
=>
GroupParams
->
HashSet
Ngrams
->
m
GroupParams
=>
GroupParams
->
HashSet
Ngrams
->
m
GroupParams
getGroupParams
gp
@
(
GroupWithPosTag
l
a
_m
)
ng
=
do
getGroupParams
gp
@
(
GroupWithPosTag
l
nsc
_m
)
ng
=
do
!
hashMap
<-
HashMap
.
fromList
<$>
selectLems
l
a
(
HashSet
.
toList
ng
)
!
hashMap
<-
HashMap
.
fromList
<$>
selectLems
l
nsc
(
HashSet
.
toList
ng
)
-- printDebug "hashMap" hashMap
-- printDebug "hashMap" hashMap
pure
$
over
gwl_map
(
\
x
->
x
<>
hashMap
)
gp
pure
$
over
gwl_map
(
\
x
->
x
<>
hashMap
)
gp
getGroupParams
gp
_
=
pure
gp
getGroupParams
gp
_
=
pure
gp
...
...
src/Gargantext/Core/Text/List/Group/WithStem.hs
View file @
a050a009
...
@@ -23,7 +23,7 @@ import Data.HashSet (HashSet)
...
@@ -23,7 +23,7 @@ import Data.HashSet (HashSet)
import
Data.Map.Strict
(
Map
)
import
Data.Map.Strict
(
Map
)
import
Data.Maybe
(
catMaybes
)
import
Data.Maybe
(
catMaybes
)
import
Gargantext.API.Ngrams.Types
import
Gargantext.API.Ngrams.Types
import
Gargantext.Core
(
Lang
(
..
),
PosTagAlgo
(
..
),
Form
,
Lem
)
import
Gargantext.Core
(
Lang
(
..
),
Form
,
Lem
,
NLPServerConfig
)
import
Gargantext.Core.Text.List.Group.Prelude
import
Gargantext.Core.Text.List.Group.Prelude
import
Gargantext.Core.Text.List.Social.Patch
import
Gargantext.Core.Text.List.Social.Patch
import
Gargantext.Core.Text.List.Social.Prelude
import
Gargantext.Core.Text.List.Social.Prelude
...
@@ -61,9 +61,9 @@ data GroupParams = GroupParams { unGroupParams_lang :: !Lang
...
@@ -61,9 +61,9 @@ data GroupParams = GroupParams { unGroupParams_lang :: !Lang
,
unGroupParams_stopSize
::
!
StopSize
,
unGroupParams_stopSize
::
!
StopSize
}
}
|
GroupIdentity
|
GroupIdentity
|
GroupWithPosTag
{
_gwl_lang
::
!
Lang
|
GroupWithPosTag
{
_gwl_lang
::
!
Lang
,
_gwl_
algo
::
!
PosTagAlgo
,
_gwl_
nlp_config
::
!
NLPServerConfig
,
_gwl_map
::
!
(
HashMap
Form
Lem
)
,
_gwl_map
::
!
(
HashMap
Form
Lem
)
}
}
deriving
(
Eq
)
deriving
(
Eq
)
...
...
src/Gargantext/Core/Text/List/Management.sh
View file @
a050a009
...
@@ -79,12 +79,12 @@ restrictListSize corpusId listId ngramsType listType size = do
...
@@ -79,12 +79,12 @@ restrictListSize corpusId listId ngramsType listType size = do
where filterWith :: ListType -> Int -> HashMap NgramsTerm Int
where filterWith :: ListType -> Int -> HashMap NgramsTerm Int
-> HashMap NgramsTerm NgramsRepoElement
-> HashMap NgramsTerm NgramsRepoElement
-> m (Map NgramsTerm NgramsRepoElement)
-> m (Map NgramsTerm NgramsRepoElement)
filterWith listType'
size occs ngrams
=
filterWith listType'
size occs ngrams
=
HashMap.filter with ngrams
HashMap.filter with ngrams
where
where
with nre
=
case
(&&
)
<
$>
Just
(
nre^.nre_list
==
listType
)
with nre
=
case
(&&
)
<
$>
Just
(
nre^.nre_list
==
listType
)
<
*
>
(
HashMap.lookup
(
nre^.nre_root
)
occs
<
*
>
(
HashMap.lookup
(
nre^.nre_root
)
occs
&&
&&
...
@@ -92,5 +92,3 @@ restrictListSize corpusId listId ngramsType listType size = do
...
@@ -92,5 +92,3 @@ restrictListSize corpusId listId ngramsType listType size = do
-
}
-
}
src/Gargantext/Core/Text/Terms.hs
View file @
a050a009
...
@@ -83,13 +83,13 @@ makeLenses ''TermType
...
@@ -83,13 +83,13 @@ makeLenses ''TermType
------------------------------------------------------------------------
------------------------------------------------------------------------
-- | Sugar to extract terms from text (hidding 'mapM' from end user).
-- | Sugar to extract terms from text (hidding 'mapM' from end user).
--extractTerms :: Traversable t => TermType Lang -> t Text -> IO (t [Terms])
--extractTerms :: Traversable t => TermType Lang -> t Text -> IO (t [Terms])
extractTerms
::
TermType
Lang
->
[
Text
]
->
IO
[[
TermsWithCount
]]
extractTerms
::
NLPServerConfig
->
TermType
Lang
->
[
Text
]
->
IO
[[
TermsWithCount
]]
extractTerms
(
Unsupervised
{
..
})
xs
=
mapM
(
term
s
(
Unsupervised
{
_tt_model
=
Just
m'
,
..
}))
xs
extractTerms
ncs
(
Unsupervised
{
..
})
xs
=
mapM
(
terms
nc
s
(
Unsupervised
{
_tt_model
=
Just
m'
,
..
}))
xs
where
where
m'
=
case
_tt_model
of
m'
=
case
_tt_model
of
Just
m''
->
m''
Just
m''
->
m''
Nothing
->
newTries
_tt_windowSize
(
Text
.
intercalate
" "
xs
)
Nothing
->
newTries
_tt_windowSize
(
Text
.
intercalate
" "
xs
)
extractTerms
termTypeLang
xs
=
mapM
(
term
s
termTypeLang
)
xs
extractTerms
ncs
termTypeLang
xs
=
mapM
(
terms
nc
s
termTypeLang
)
xs
------------------------------------------------------------------------
------------------------------------------------------------------------
...
@@ -170,11 +170,11 @@ isSimpleNgrams _ = False
...
@@ -170,11 +170,11 @@ isSimpleNgrams _ = False
-- 'Multi' : multi terms
-- 'Multi' : multi terms
-- 'MonoMulti' : mono and multi
-- 'MonoMulti' : mono and multi
-- TODO : multi terms should exclude mono (intersection is not empty yet)
-- TODO : multi terms should exclude mono (intersection is not empty yet)
terms
::
TermType
Lang
->
Text
->
IO
[
TermsWithCount
]
terms
::
NLPServerConfig
->
TermType
Lang
->
Text
->
IO
[
TermsWithCount
]
terms
(
Mono
lang
)
txt
=
pure
$
monoTerms
lang
txt
terms
_
(
Mono
lang
)
txt
=
pure
$
monoTerms
lang
txt
terms
(
Multi
lang
)
txt
=
multiterm
s
lang
txt
terms
ncs
(
Multi
lang
)
txt
=
multiterms
nc
s
lang
txt
terms
(
MonoMulti
lang
)
txt
=
term
s
(
Multi
lang
)
txt
terms
ncs
(
MonoMulti
lang
)
txt
=
terms
nc
s
(
Multi
lang
)
txt
terms
(
Unsupervised
{
..
})
txt
=
pure
$
termsUnsupervised
(
Unsupervised
{
_tt_model
=
Just
m'
,
..
})
txt
terms
_
(
Unsupervised
{
..
})
txt
=
pure
$
termsUnsupervised
(
Unsupervised
{
_tt_model
=
Just
m'
,
..
})
txt
where
where
m'
=
maybe
(
newTries
_tt_ngramsSize
txt
)
identity
_tt_model
m'
=
maybe
(
newTries
_tt_ngramsSize
txt
)
identity
_tt_model
-- terms (WithList list) txt = pure . concat $ extractTermsWithList list txt
-- terms (WithList list) txt = pure . concat $ extractTermsWithList list txt
...
...
src/Gargantext/Core/Text/Terms/Multi.hs
View file @
a050a009
...
@@ -19,7 +19,7 @@ import Data.Text hiding (map, group, filter, concat)
...
@@ -19,7 +19,7 @@ import Data.Text hiding (map, group, filter, concat)
import
Data.List
(
concat
)
import
Data.List
(
concat
)
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Core
(
Lang
(
..
))
import
Gargantext.Core
(
Lang
(
..
)
,
NLPServerConfig
(
..
),
PosTagAlgo
(
..
)
)
import
Gargantext.Core.Types
import
Gargantext.Core.Types
import
Gargantext.Core.Utils
(
groupWithCounts
)
import
Gargantext.Core.Utils
(
groupWithCounts
)
...
@@ -38,8 +38,8 @@ import qualified Gargantext.Utils.SpacyNLP as SpacyNLP
...
@@ -38,8 +38,8 @@ import qualified Gargantext.Utils.SpacyNLP as SpacyNLP
type
NLP_API
=
Lang
->
Text
->
IO
PosSentences
type
NLP_API
=
Lang
->
Text
->
IO
PosSentences
-------------------------------------------------------------------
-------------------------------------------------------------------
multiterms
::
Lang
->
Text
->
IO
[
TermsWithCount
]
multiterms
::
NLPServerConfig
->
Lang
->
Text
->
IO
[
TermsWithCount
]
multiterms
l
txt
=
do
multiterms
nsc
l
txt
=
do
ret
<-
multiterms'
tokenTag2terms
l
txt
ret
<-
multiterms'
tokenTag2terms
l
txt
pure
$
groupWithCounts
ret
pure
$
groupWithCounts
ret
where
where
...
@@ -47,20 +47,21 @@ multiterms l txt = do
...
@@ -47,20 +47,21 @@ multiterms l txt = do
multiterms'
f
lang
txt'
=
concat
multiterms'
f
lang
txt'
=
concat
<$>
map
(
map
f
)
<$>
map
(
map
f
)
<$>
map
(
filter
(
\
t
->
_my_token_pos
t
==
Just
NP
))
<$>
map
(
filter
(
\
t
->
_my_token_pos
t
==
Just
NP
))
<$>
tokenTags
lang
txt'
<$>
tokenTags
nsc
lang
txt'
-------------------------------------------------------------------
-------------------------------------------------------------------
tokenTag2terms
::
TokenTag
->
Terms
tokenTag2terms
::
TokenTag
->
Terms
tokenTag2terms
(
TokenTag
ws
t
_
_
)
=
Terms
ws
t
tokenTag2terms
(
TokenTag
ws
t
_
_
)
=
Terms
ws
t
tokenTags
::
Lang
->
Text
->
IO
[[
TokenTag
]]
tokenTags
::
NLPServerConfig
->
Lang
->
Text
->
IO
[[
TokenTag
]]
tokenTags
EN
txt
=
tokenTagsWith
EN
txt
corenlp
tokenTags
(
NLPServerConfig
{
server
=
CoreNLP
,
url
})
l
txt
=
tokenTagsWith
l
txt
$
corenlp
url
tokenTags
FR
txt
=
do
tokenTags
(
NLPServerConfig
{
server
=
Spacy
,
url
})
l
txt
=
tokenTagsWith
l
txt
$
SpacyNLP
.
nlp
url
-- printDebug "[Spacy Debug]" txt
-- tokenTags FR txt = do
if
txt
==
""
-- -- printDebug "[Spacy Debug]" txt
then
pure
[
[]
]
-- if txt == ""
else
tokenTagsWith
FR
txt
SpacyNLP
.
nlp
-- then pure [[]]
tokenTags
l
_
=
panic
$
"[G.C.T.T.Multi] Lang NLP API not implemented yet "
<>
(
cs
$
show
l
)
-- else tokenTagsWith FR txt SpacyNLP.nlp
tokenTags
_
l
_
=
panic
$
"[G.C.T.T.Multi] Lang NLP API not implemented yet "
<>
(
cs
$
show
l
)
tokenTagsWith
::
Lang
->
Text
->
NLP_API
->
IO
[[
TokenTag
]]
tokenTagsWith
::
Lang
->
Text
->
NLP_API
->
IO
[[
TokenTag
]]
tokenTagsWith
lang
txt
nlp
=
map
(
groupTokens
lang
)
tokenTagsWith
lang
txt
nlp
=
map
(
groupTokens
lang
)
...
...
src/Gargantext/Core/Text/Terms/Multi/PosTagging.hs
View file @
a050a009
...
@@ -34,6 +34,7 @@ import Gargantext.Core.Text.Terms.Multi.PosTagging.Types
...
@@ -34,6 +34,7 @@ import Gargantext.Core.Text.Terms.Multi.PosTagging.Types
import
Gargantext.Core.Types
import
Gargantext.Core.Types
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Network.HTTP.Simple
import
Network.HTTP.Simple
import
Network.URI
(
URI
(
..
))
-- import qualified Gargantext.Utils.SpacyNLP as SpacyNLP
-- import qualified Gargantext.Utils.SpacyNLP as SpacyNLP
...
@@ -76,21 +77,21 @@ filter' xs = filter isNgrams xs
...
@@ -76,21 +77,21 @@ filter' xs = filter isNgrams xs
corenlp'
::
(
FromJSON
a
corenlp'
::
(
FromJSON
a
,
ConvertibleStrings
p
ByteString
,
ConvertibleStrings
p
ByteString
)
)
=>
Lang
->
p
->
IO
(
Response
a
)
=>
URI
->
Lang
->
p
->
IO
(
Response
a
)
corenlp'
lang
txt
=
do
corenlp'
uri
lang
txt
=
do
let
properties
=
case
lang
of
let
properties
=
case
lang
of
EN
->
"{
\"
annotators
\"
:
\"
tokenize,ssplit,pos,ner
\"
,
\"
outputFormat
\"
:
\"
json
\"
}"
EN
->
"{
\"
annotators
\"
:
\"
tokenize,ssplit,pos,ner
\"
,
\"
outputFormat
\"
:
\"
json
\"
}"
FR
->
"{
\"
annotators
\"
:
\"
tokenize,ssplit,pos,lemma,ner
\"
,
\"
parse.model
\"
:
\"
edu/stanford/nlp/models/lexparser/frenchFactored.ser.gz
\"
,
\"
pos.model
\"
:
\"
edu/stanford/nlp/models/pos-tagger/french/french.tagger
\"
,
\"
tokenize.language
\"
:
\"
fr
\"
,
\"
outputFormat
\"
:
\"
json
\"
}"
FR
->
"{
\"
annotators
\"
:
\"
tokenize,ssplit,pos,lemma,ner
\"
,
\"
parse.model
\"
:
\"
edu/stanford/nlp/models/lexparser/frenchFactored.ser.gz
\"
,
\"
pos.model
\"
:
\"
edu/stanford/nlp/models/pos-tagger/french/french.tagger
\"
,
\"
tokenize.language
\"
:
\"
fr
\"
,
\"
outputFormat
\"
:
\"
json
\"
}"
_
->
panic
$
pack
"not implemented yet"
_
->
panic
$
pack
"not implemented yet"
url
<-
parseRequest
$
"POST http://localhost:9000/?properties="
<>
properties
req
<-
parseRequest
$
"POST "
<>
show
(
uri
{
uriQuery
=
"?properties="
<>
properties
})
-- curl -XPOST 'http://localhost:9000/?properties=%7B%22annotators%22:%20%22tokenize,ssplit,pos,ner%22,%20%22outputFormat%22:%20%22json%22%7D' -d 'hello world, hello' | jq .
-- curl -XPOST 'http://localhost:9000/?properties=%7B%22annotators%22:%20%22tokenize,ssplit,pos,ner%22,%20%22outputFormat%22:%20%22json%22%7D' -d 'hello world, hello' | jq .
let
request
=
setRequestBodyLBS
(
cs
txt
)
url
let
request
=
setRequestBodyLBS
(
cs
txt
)
req
httpJSON
request
httpJSON
request
corenlp
::
Lang
->
Text
->
IO
PosSentences
corenlp
::
URI
->
Lang
->
Text
->
IO
PosSentences
corenlp
lang
txt
=
do
corenlp
uri
lang
txt
=
do
response
<-
corenlp'
lang
txt
response
<-
corenlp'
uri
lang
txt
pure
(
getResponseBody
response
)
pure
(
getResponseBody
response
)
-- | parseWith
-- | parseWith
...
@@ -101,11 +102,11 @@ corenlp lang txt = do
...
@@ -101,11 +102,11 @@ corenlp lang txt = do
-- Named Entity Recognition example
-- Named Entity Recognition example
-- parseWith _tokenNer "Hello world of Peter."
-- parseWith _tokenNer "Hello world of Peter."
-- [[("``","O"),("Hello","O"),("world","O"),("of","O"),("Peter","PERSON"),(".","O"),("''","O")]]
-- [[("``","O"),("Hello","O"),("world","O"),("of","O"),("Peter","PERSON"),(".","O"),("''","O")]]
tokenWith
::
(
Token
->
t
)
->
Lang
->
Text
->
IO
[[(
Text
,
t
)]]
tokenWith
::
URI
->
(
Token
->
t
)
->
Lang
->
Text
->
IO
[[(
Text
,
t
)]]
tokenWith
f
lang
s
=
map
(
map
(
\
t
->
(
_tokenWord
t
,
f
t
)))
tokenWith
uri
f
lang
s
=
map
(
map
(
\
t
->
(
_tokenWord
t
,
f
t
)))
<$>
map
_sentenceTokens
<$>
map
_sentenceTokens
<$>
_sentences
<$>
_sentences
<$>
corenlp
lang
s
<$>
corenlp
uri
lang
s
----------------------------------------------------------------------------------
----------------------------------------------------------------------------------
-- Here connect to the JohnSnow Server as it has been done above with the corenlp'
-- Here connect to the JohnSnow Server as it has been done above with the corenlp'
...
...
src/Gargantext/Database/Action/Delete.hs
View file @
a050a009
{-|
{-|
Module : Gargantext.Database.Action.Delete
Module : Gargantext.Database.Action.Delete
Description :
Description :
Copyright : (c) CNRS, 2017-Present
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Maintainer : team@gargantext.org
...
@@ -22,13 +22,12 @@ import Data.Text
...
@@ -22,13 +22,12 @@ import Data.Text
import
Servant
import
Servant
import
Gargantext.Core
import
Gargantext.Core
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Database.Action.Share
(
delFolderTeam
)
import
Gargantext.Database.Action.Share
(
delFolderTeam
)
import
Gargantext.Database.Action.User
(
getUserId
)
import
Gargantext.Database.Action.User
(
getUserId
)
import
Gargantext.Database.Admin.Types.Hyperdata.File
import
Gargantext.Database.Admin.Types.Hyperdata.File
import
Gargantext.Database.Admin.Types.Node
-- (NodeType(..))
import
Gargantext.Database.Admin.Types.Node
-- (NodeType(..))
import
Gargantext.Database.Prelude
(
Cmd
'
,
HasConfig
,
HasConnectionPool
)
import
Gargantext.Database.Prelude
(
Cmd
'
,
CmdCommon
)
import
Gargantext.Database.Query.Table.Node
(
getNodeWith
)
import
Gargantext.Database.Query.Table.Node
(
getNodeWith
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Schema.Node
import
Gargantext.Database.Schema.Node
...
@@ -40,7 +39,7 @@ import qualified Gargantext.Database.Query.Table.Node as N (getNode, deleteNode)
...
@@ -40,7 +39,7 @@ import qualified Gargantext.Database.Query.Table.Node as N (getNode, deleteNode)
-- TODO
-- TODO
-- Delete Corpus children accoring its types
-- Delete Corpus children accoring its types
-- Delete NodeList (NodeStory + cbor file)
-- Delete NodeList (NodeStory + cbor file)
deleteNode
::
(
HasMail
env
,
HasConfig
env
,
HasConnectionPool
env
,
HasNodeError
err
)
deleteNode
::
(
CmdCommon
env
,
HasNodeError
err
)
=>
User
=>
User
->
NodeId
->
NodeId
->
Cmd'
env
err
Int
->
Cmd'
env
err
Int
...
@@ -59,7 +58,7 @@ deleteNode u nodeId = do
...
@@ -59,7 +58,7 @@ deleteNode u nodeId = do
GargDB
.
rmFile
$
unpack
path
GargDB
.
rmFile
$
unpack
path
N
.
deleteNode
nodeId
N
.
deleteNode
nodeId
_
->
N
.
deleteNode
nodeId
_
->
N
.
deleteNode
nodeId
-- if hasNodeType node' NodeUser
-- if hasNodeType node' NodeUser
-- then panic "Not allowed to delete NodeUser (yet)"
-- then panic "Not allowed to delete NodeUser (yet)"
-- else if hasNodeType node' NodeTeam
-- else if hasNodeType node' NodeTeam
...
...
src/Gargantext/Database/Action/Flow.hs
View file @
a050a009
...
@@ -78,6 +78,7 @@ import Gargantext.Core (Lang(..), PosTagAlgo(..))
...
@@ -78,6 +78,7 @@ import Gargantext.Core (Lang(..), PosTagAlgo(..))
-- import Gargantext.Core.Ext.IMT (toSchoolName)
-- import Gargantext.Core.Ext.IMT (toSchoolName)
import
Gargantext.Core.Ext.IMTUser
(
readFile_Annuaire
)
import
Gargantext.Core.Ext.IMTUser
(
readFile_Annuaire
)
import
Gargantext.Core.Flow.Types
import
Gargantext.Core.Flow.Types
import
Gargantext.Core.NLP
(
nlpServerGet
)
import
Gargantext.Core.Text
import
Gargantext.Core.Text
import
Gargantext.Core.Text.Corpus.Parsers
(
parseFile
,
FileFormat
,
FileType
,
splitOn
)
import
Gargantext.Core.Text.Corpus.Parsers
(
parseFile
,
FileFormat
,
FileType
,
splitOn
)
import
Gargantext.Core.Text.List
(
buildNgramsLists
)
import
Gargantext.Core.Text.List
(
buildNgramsLists
)
...
@@ -346,6 +347,7 @@ flowCorpusUser :: ( FlowCmdM env err m
...
@@ -346,6 +347,7 @@ flowCorpusUser :: ( FlowCmdM env err m
->
Maybe
FlowSocialListWith
->
Maybe
FlowSocialListWith
->
m
CorpusId
->
m
CorpusId
flowCorpusUser
l
user
userCorpusId
listId
ctype
mfslw
=
do
flowCorpusUser
l
user
userCorpusId
listId
ctype
mfslw
=
do
server
<-
view
(
nlpServerGet
l
)
-- User List Flow
-- User List Flow
(
masterUserId
,
_masterRootId
,
masterCorpusId
)
(
masterUserId
,
_masterRootId
,
masterCorpusId
)
<-
getOrMk_RootWithCorpus
(
UserName
userMaster
)
(
Left
""
)
ctype
<-
getOrMk_RootWithCorpus
(
UserName
userMaster
)
(
Left
""
)
ctype
...
@@ -358,7 +360,7 @@ flowCorpusUser l user userCorpusId listId ctype mfslw = do
...
@@ -358,7 +360,7 @@ flowCorpusUser l user userCorpusId listId ctype mfslw = do
pure
()
pure
()
_
->
do
_
->
do
ngs
<-
buildNgramsLists
user
userCorpusId
masterCorpusId
mfslw
ngs
<-
buildNgramsLists
user
userCorpusId
masterCorpusId
mfslw
$
GroupWithPosTag
l
CoreNLP
HashMap
.
empty
$
GroupWithPosTag
l
server
HashMap
.
empty
-- printDebug "flowCorpusUser:ngs" ngs
-- printDebug "flowCorpusUser:ngs" ngs
...
@@ -558,10 +560,11 @@ instance ExtractNgramsT HyperdataDocument
...
@@ -558,10 +560,11 @@ instance ExtractNgramsT HyperdataDocument
$
maybe
[
"Nothing"
]
(
splitOn
Authors
(
doc
^.
hd_bdd
))
$
maybe
[
"Nothing"
]
(
splitOn
Authors
(
doc
^.
hd_bdd
))
$
_hd_authors
doc
$
_hd_authors
doc
ncs
<-
view
(
nlpServerGet
$
lang'
^.
tt_lang
)
termsWithCounts'
<-
map
(
\
(
t
,
cnt
)
->
(
enrichedTerms
(
lang'
^.
tt_lang
)
CoreNLP
NP
t
,
cnt
))
termsWithCounts'
<-
map
(
\
(
t
,
cnt
)
->
(
enrichedTerms
(
lang'
^.
tt_lang
)
CoreNLP
NP
t
,
cnt
))
<$>
concat
<$>
concat
<$>
liftBase
(
extractTerms
lang'
$
hasText
doc
)
<$>
liftBase
(
extractTerms
ncs
lang'
$
hasText
doc
)
pure
$
HashMap
.
fromList
pure
$
HashMap
.
fromList
$
[(
SimpleNgrams
source
,
(
Map
.
singleton
Sources
1
,
1
))
]
$
[(
SimpleNgrams
source
,
(
Map
.
singleton
Sources
1
,
1
))
]
...
...
src/Gargantext/Database/Action/Mail.hs
View file @
a050a009
{-|
{-|
Module : Gargantext.Database.Action.Mail
Module : Gargantext.Database.Action.Mail
Description :
Description :
Copyright : (c) CNRS, 2017-Present
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Maintainer : team@gargantext.org
...
@@ -33,4 +33,3 @@ sendMail u = do
...
@@ -33,4 +33,3 @@ sendMail u = do
,
mailInfo_address
=
userLight_email
userLight
,
mailInfo_address
=
userLight_email
userLight
}
}
)
)
src/Gargantext/Database/Prelude.hs
View file @
a050a009
...
@@ -15,10 +15,10 @@ Portability : POSIX
...
@@ -15,10 +15,10 @@ Portability : POSIX
module
Gargantext.Database.Prelude
where
module
Gargantext.Database.Prelude
where
--import Control.Monad.Logger (MonadLogger)
import
Control.Exception
import
Control.Exception
import
Control.Lens
(
Getter
,
view
)
import
Control.Lens
(
Getter
,
view
)
import
Control.Monad.Except
import
Control.Monad.Except
--import Control.Monad.Logger (MonadLogger)
import
Control.Monad.Random
import
Control.Monad.Random
import
Control.Monad.Reader
import
Control.Monad.Reader
import
Control.Monad.Trans.Control
(
MonadBaseControl
)
import
Control.Monad.Trans.Control
(
MonadBaseControl
)
...
@@ -34,17 +34,18 @@ import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(Conversion
...
@@ -34,17 +34,18 @@ import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(Conversion
import
Database.PostgreSQL.Simple.Internal
(
Field
)
import
Database.PostgreSQL.Simple.Internal
(
Field
)
import
Database.PostgreSQL.Simple.Types
(
Query
(
..
))
import
Database.PostgreSQL.Simple.Types
(
Query
(
..
))
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.NLP
(
HasNLPServer
)
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
(
GargConfig
(),
readIniFile'
,
val
)
import
Gargantext.Prelude.Config
(
GargConfig
(),
readIniFile'
,
val
)
import
Opaleye
(
Unpackspec
,
showSql
,
FromFields
,
Select
,
runSelect
,
SqlJsonb
,
DefaultFromField
,
toFields
,
matchMaybe
,
MaybeFields
)
import
Opaleye
(
Unpackspec
,
showSql
,
FromFields
,
Select
,
runSelect
,
SqlJsonb
,
DefaultFromField
,
toFields
,
matchMaybe
,
MaybeFields
)
import
Opaleye.Aggregate
(
countRows
)
import
Opaleye.Aggregate
(
countRows
)
import
qualified
Opaleye.Internal.Constant
import
qualified
Opaleye.Internal.Operators
import
System.IO
(
FilePath
,
stderr
)
import
System.IO
(
FilePath
,
stderr
)
import
Text.Read
(
readMaybe
)
import
Text.Read
(
readMaybe
)
import
qualified
Data.ByteString
as
DB
import
qualified
Data.ByteString
as
DB
import
qualified
Data.List
as
DL
import
qualified
Data.List
as
DL
import
qualified
Database.PostgreSQL.Simple
as
PGS
import
qualified
Database.PostgreSQL.Simple
as
PGS
import
qualified
Opaleye.Internal.Constant
import
qualified
Opaleye.Internal.Operators
-------------------------------------------------------
-------------------------------------------------------
class
HasConnectionPool
env
where
class
HasConnectionPool
env
where
...
@@ -79,11 +80,15 @@ type CmdM' env err m =
...
@@ -79,11 +80,15 @@ type CmdM' env err m =
-- , MonadRandom m
-- , MonadRandom m
)
)
type
CmdM
env
err
m
=
type
CmdCommon
env
=
(
CmdM'
env
err
m
(
HasConnectionPool
env
,
HasConnectionPool
env
,
HasConfig
env
,
HasConfig
env
,
HasMail
env
,
HasMail
env
,
HasNLPServer
env
)
type
CmdM
env
err
m
=
(
CmdM'
env
err
m
,
CmdCommon
env
)
)
type
CmdRandom
env
err
m
=
type
CmdRandom
env
err
m
=
...
...
src/Gargantext/Database/Query/Table/NgramsPostag.hs
View file @
a050a009
...
@@ -155,11 +155,11 @@ SELECT terms,id FROM ins_form_ret
...
@@ -155,11 +155,11 @@ SELECT terms,id FROM ins_form_ret
-- TODO add lang and postag algo
-- TODO add lang and postag algo
-- TODO remove when form == lem in insert
-- TODO remove when form == lem in insert
selectLems
::
Lang
->
PosTagAlgo
->
[
Ngrams
]
->
Cmd
err
[(
Form
,
Lem
)]
selectLems
::
Lang
->
NLPServerConfig
->
[
Ngrams
]
->
Cmd
err
[(
Form
,
Lem
)]
selectLems
l
a
ns
=
runPGSQuery
querySelectLems
(
PGS
.
Only
$
Values
fields
datas
)
selectLems
l
(
NLPServerConfig
{
server
})
ns
=
runPGSQuery
querySelectLems
(
PGS
.
Only
$
Values
fields
datas
)
where
where
fields
=
map
(
\
t
->
QualifiedIdentifier
Nothing
t
)
[
"int4"
,
"int4"
,
"text"
,
"int4"
]
fields
=
map
(
\
t
->
QualifiedIdentifier
Nothing
t
)
[
"int4"
,
"int4"
,
"text"
,
"int4"
]
datas
=
map
(
\
d
->
[
toField
$
toDBid
l
,
toField
$
toDBid
a
]
<>
toRow
d
)
ns
datas
=
map
(
\
d
->
[
toField
$
toDBid
l
,
toField
$
toDBid
server
]
<>
toRow
d
)
ns
----------------------
----------------------
querySelectLems
::
PGS
.
Query
querySelectLems
::
PGS
.
Query
...
@@ -203,5 +203,3 @@ createTable_NgramsPostag = map (\(PGS.Only a) -> a)
...
@@ -203,5 +203,3 @@ createTable_NgramsPostag = map (\(PGS.Only a) -> a)
CREATE UNIQUE INDEX ON public.ngrams_postag (lang_id,algo_id,postag,ngrams_id,lemm_id);
CREATE UNIQUE INDEX ON public.ngrams_postag (lang_id,algo_id,postag,ngrams_id,lemm_id);
|]
|]
src/Gargantext/Utils/SpacyNLP.hs
View file @
a050a009
...
@@ -27,6 +27,7 @@ import Gargantext.Core.Types (POS(..), NER(..))
...
@@ -27,6 +27,7 @@ import Gargantext.Core.Types (POS(..), NER(..))
import
Gargantext.Core.Utils.Prefix
(
unPrefix
)
import
Gargantext.Core.Utils.Prefix
(
unPrefix
)
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Network.HTTP.Simple
(
parseRequest
,
httpJSON
,
setRequestBodyLBS
,
getResponseBody
,
Response
)
import
Network.HTTP.Simple
(
parseRequest
,
httpJSON
,
setRequestBodyLBS
,
getResponseBody
,
Response
)
import
Network.URI
(
URI
(
..
))
data
SpacyData
=
SpacyData
{
_spacy_data
::
!
[
SpacyText
]}
data
SpacyData
=
SpacyData
{
_spacy_data
::
!
[
SpacyText
]}
...
@@ -79,10 +80,10 @@ data SpacyTags =
...
@@ -79,10 +80,10 @@ data SpacyTags =
data
SpacyRequest
=
SpacyRequest
{
_spacyRequest_text
::
!
Text
}
data
SpacyRequest
=
SpacyRequest
{
_spacyRequest_text
::
!
Text
}
deriving
(
Show
)
deriving
(
Show
)
spacyRequest
::
Text
->
IO
SpacyData
spacyRequest
::
URI
->
Text
->
IO
SpacyData
spacyRequest
txt
=
do
spacyRequest
uri
txt
=
do
url
<-
parseRequest
$
unpack
"POST http://localhost:8001/pos"
req
<-
parseRequest
$
"POST "
<>
show
(
uri
{
uriPath
=
"/pos"
})
let
request
=
setRequestBodyLBS
(
encode
$
SpacyRequest
txt
)
url
let
request
=
setRequestBodyLBS
(
encode
$
SpacyRequest
txt
)
req
result
<-
httpJSON
request
::
IO
(
Response
SpacyData
)
result
<-
httpJSON
request
::
IO
(
Response
SpacyData
)
pure
$
getResponseBody
result
pure
$
getResponseBody
result
...
@@ -119,8 +120,8 @@ spacyDataToPosSentences (SpacyData ds) = PosSentences
...
@@ -119,8 +120,8 @@ spacyDataToPosSentences (SpacyData ds) = PosSentences
-----------------------------------------------------------------
-----------------------------------------------------------------
nlp
::
Lang
->
Text
->
IO
PosSentences
nlp
::
URI
->
Lang
->
Text
->
IO
PosSentences
nlp
FR
txt
=
spacyDataToPosSentences
<$>
spacyRequest
txt
nlp
uri
FR
txt
=
spacyDataToPosSentences
<$>
spacyRequest
uri
txt
nlp
_
_
=
panic
"Make sure you have the right model for your lang for spacy Server"
nlp
_
_
_
=
panic
"Make sure you have the right model for your lang for spacy Server"
-- nlp FR txt = spacyDataToPosSentences <$> spacyRequest txt
-- nlp _ _ = panic "Make sure you have the right model for your lang for spacy Server"
src/Gargantext/Utils/Tuple.hs
View file @
a050a009
...
@@ -8,3 +8,7 @@ uncurryMaybe :: (Maybe a, Maybe b) -> Maybe (a, b)
...
@@ -8,3 +8,7 @@ uncurryMaybe :: (Maybe a, Maybe b) -> Maybe (a, b)
uncurryMaybe
(
Nothing
,
_
)
=
Nothing
uncurryMaybe
(
Nothing
,
_
)
=
Nothing
uncurryMaybe
(
_
,
Nothing
)
=
Nothing
uncurryMaybe
(
_
,
Nothing
)
=
Nothing
uncurryMaybe
(
Just
a
,
Just
b
)
=
Just
(
a
,
b
)
uncurryMaybe
(
Just
a
,
Just
b
)
=
Just
(
a
,
b
)
uncurryMaybeSecond
::
(
a
,
Maybe
b
)
->
Maybe
(
a
,
b
)
uncurryMaybeSecond
(
_
,
Nothing
)
=
Nothing
uncurryMaybeSecond
(
a
,
Just
b
)
=
Just
(
a
,
b
)
stack.yaml
View file @
a050a009
...
@@ -37,9 +37,10 @@ extra-deps:
...
@@ -37,9 +37,10 @@ extra-deps:
-
HSvm-0.1.1.3.22
-
HSvm-0.1.1.3.22
-
hsparql-0.3.8
-
hsparql-0.3.8
-
git
:
https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude.git
#- git: https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude.git
commit
:
791c2a7046a3760f8ae5fabdbd708f61caa63741
# commit: 791c2a7046a3760f8ae5fabdbd708f61caa63741
#- git: https://gitlab.iscpif.fr/cgenie/haskell-gargantext-prelude
-
git
:
https://gitlab.iscpif.fr/cgenie/haskell-gargantext-prelude
commit
:
175d4b295be2a0f56edc4eb6c7d8227d81bc2841
-
git
:
https://gitlab.iscpif.fr/gargantext/gargantext-graph.git
-
git
:
https://gitlab.iscpif.fr/gargantext/gargantext-graph.git
commit
:
588e104fe7593210956610cab0041fd16584a4ce
commit
:
588e104fe7593210956610cab0041fd16584a4ce
# Data Mining Libs
# Data Mining Libs
...
...
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