Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
P
purescript-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
153
Issues
153
List
Board
Labels
Milestones
Merge Requests
3
Merge Requests
3
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
purescript-gargantext
Commits
ec01d870
Commit
ec01d870
authored
Sep 23, 2024
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Plain Diff
Merge remote-tracking branch 'origin/304-dev-toml-config-rewrite-and-update-deps' into dev
parents
651caaee
177173ea
Changes
75
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
75 changed files
with
839 additions
and
710 deletions
+839
-710
Ini.hs
bin/gargantext-cli/CLI/Ini.hs
+14
-5
Init.hs
bin/gargantext-cli/CLI/Init.hs
+3
-4
Invitations.hs
bin/gargantext-cli/CLI/Invitations.hs
+1
-3
gargantext-settings.toml_toModify
gargantext-settings.toml_toModify
+6
-0
gargantext.cabal
gargantext.cabal
+2
-1
API.hs
src/Gargantext/API.hs
+12
-12
Auth.hs
src/Gargantext/API/Admin/Auth.hs
+7
-7
EnvTypes.hs
src/Gargantext/API/Admin/EnvTypes.hs
+28
-32
Settings.hs
src/Gargantext/API/Admin/Settings.hs
+9
-44
CORS.hs
src/Gargantext/API/Admin/Settings/CORS.hs
+0
-43
MicroServices.hs
src/Gargantext/API/Admin/Settings/MicroServices.hs
+0
-31
Types.hs
src/Gargantext/API/Admin/Types.hs
+0
-53
PolicyCheck.hs
src/Gargantext/API/Auth/PolicyCheck.hs
+23
-24
Count.hs
src/Gargantext/API/Count.hs
+1
-1
Dev.hs
src/Gargantext/API/Dev.hs
+2
-7
Types.hs
src/Gargantext/API/Errors/Types.hs
+2
-121
GraphQL.hs
src/Gargantext/API/GraphQL.hs
+4
-4
AsyncTask.hs
src/Gargantext/API/GraphQL/AsyncTask.hs
+2
-1
Context.hs
src/Gargantext/API/GraphQL/Context.hs
+1
-2
PolicyCheck.hs
src/Gargantext/API/GraphQL/PolicyCheck.hs
+2
-1
Team.hs
src/Gargantext/API/GraphQL/Team.hs
+2
-2
User.hs
src/Gargantext/API/GraphQL/User.hs
+3
-4
UserInfo.hs
src/Gargantext/API/GraphQL/UserInfo.hs
+2
-2
Utils.hs
src/Gargantext/API/GraphQL/Utils.hs
+3
-3
Metrics.hs
src/Gargantext/API/Metrics.hs
+1
-1
Ngrams.hs
src/Gargantext/API/Ngrams.hs
+4
-11
Types.hs
src/Gargantext/API/Ngrams/Types.hs
+8
-58
Node.hs
src/Gargantext/API/Node.hs
+2
-3
Contact.hs
src/Gargantext/API/Node/Contact.hs
+1
-2
New.hs
src/Gargantext/API/Node/Corpus/New.hs
+2
-6
Searx.hs
src/Gargantext/API/Node/Corpus/Searx.hs
+1
-5
DocumentUpload.hs
src/Gargantext/API/Node/DocumentUpload.hs
+2
-3
DocumentsFromWriteNodes.hs
src/Gargantext/API/Node/DocumentsFromWriteNodes.hs
+1
-3
File.hs
src/Gargantext/API/Node/File.hs
+3
-4
FrameCalcUpload.hs
src/Gargantext/API/Node/FrameCalcUpload.hs
+1
-3
New.hs
src/Gargantext/API/Node/New.hs
+2
-3
Share.hs
src/Gargantext/API/Node/Share.hs
+0
-2
ShareURL.hs
src/Gargantext/API/Node/ShareURL.hs
+6
-9
Update.hs
src/Gargantext/API/Node/Update.hs
+0
-2
Prelude.hs
src/Gargantext/API/Prelude.hs
+2
-4
Routes.hs
src/Gargantext/API/Routes.hs
+1
-2
Named.hs
src/Gargantext/API/Server/Named.hs
+1
-2
Ngrams.hs
src/Gargantext/API/Server/Named/Ngrams.hs
+0
-2
Types.hs
src/Gargantext/Core/AsyncUpdates/Dispatcher/Types.hs
+0
-1
WebSocket.hs
src/Gargantext/Core/AsyncUpdates/Dispatcher/WebSocket.hs
+8
-9
Config.hs
src/Gargantext/Core/Config.hs
+25
-5
Mail.hs
src/Gargantext/Core/Config/Ini/Mail.hs
+2
-12
Mail.hs
src/Gargantext/Core/Config/Mail.hs
+11
-1
NLP.hs
src/Gargantext/Core/Config/NLP.hs
+3
-1
Types.hs
src/Gargantext/Core/Config/Types.hs
+65
-11
Mail.hs
src/Gargantext/Core/Mail.hs
+1
-2
Utils.hs
src/Gargantext/Core/Methods/Matrix/Accelerate/Utils.hs
+1
-1
Distributional.hs
...xt/Core/Methods/Similarities/Accelerate/Distributional.hs
+2
-0
Types.hs
src/Gargantext/Core/NodeStory/Types.hs
+0
-14
Eleve.hs
src/Gargantext/Core/Text/Terms/Eleve.hs
+1
-1
Utils.hs
src/Gargantext/Core/Utils.hs
+1
-1
API.hs
src/Gargantext/Core/Viz/Graph/API.hs
+1
-2
Env.hs
src/Gargantext/Core/Worker/Env.hs
+225
-0
Jobs.hs
src/Gargantext/Core/Worker/Jobs.hs
+55
-0
Flow.hs
src/Gargantext/Database/Action/Flow.hs
+5
-15
Node.hs
src/Gargantext/Database/Action/Node.hs
+12
-14
New.hs
src/Gargantext/Database/Action/User/New.hs
+5
-6
GargDB.hs
src/Gargantext/Database/GargDB.hs
+1
-2
Prelude.hs
src/Gargantext/Database/Prelude.hs
+1
-7
Root.hs
src/Gargantext/Database/Query/Tree/Root.hs
+3
-4
ReverseProxy.hs
src/Gargantext/MicroServices/ReverseProxy.hs
+20
-25
test_config.toml
test-data/test_config.toml
+5
-0
Notifications.hs
test/Test/API/Notifications.hs
+0
-3
Setup.hs
test/Test/API/Setup.hs
+7
-16
Setup.hs
test/Test/Database/Setup.hs
+0
-2
Types.hs
test/Test/Database/Types.hs
+10
-13
Instances.hs
test/Test/Instances.hs
+197
-3
JSON.hs
test/Test/Offline/JSON.hs
+1
-1
Utils.hs
test/Test/Utils.hs
+1
-2
Jobs.hs
test/Test/Utils/Jobs.hs
+3
-4
No files found.
bin/gargantext-cli/CLI/Ini.hs
View file @
ec01d870
...
...
@@ -19,6 +19,7 @@ Import a corpus binary.
module
CLI.Ini
where
import
CLI.Types
import
Control.Monad.Logger
(
LogLevel
(
LevelDebug
))
import
Data.Text
qualified
as
T
import
Data.Text.IO
qualified
as
T
(
writeFile
)
import
Database.PostgreSQL.Simple
qualified
as
PGS
...
...
@@ -58,7 +59,8 @@ iniParser = fmap CCMD_ini $ IniArgs <$>
convertConfigs
::
Ini
.
GargConfig
->
IniMail
.
MailConfig
->
IniNLP
.
NLPConfig
->
PGS
.
ConnectInfo
->
Config
.
GargConfig
convertConfigs
ini
@
(
Ini
.
GargConfig
{
..
})
iniMail
nlpConfig
connInfo
=
Config
.
GargConfig
{
_gc_secrets
=
CTypes
.
SecretsConfig
{
_s_master_user
=
_gc_masteruser
,
_s_secret_key
=
_gc_secretkey
}
,
_s_secret_key
=
_gc_secretkey
,
_s_jwk_file
=
CTypes
.
JWKFile
"dev.jwk"
}
,
_gc_datafilepath
,
_gc_mail_config
=
iniMail
,
_gc_nlp_config
=
nlpConfig
...
...
@@ -75,18 +77,25 @@ convertConfigs ini@(Ini.GargConfig { .. }) iniMail nlpConfig connInfo =
,
_jc_js_job_timeout
=
_gc_js_job_timeout
,
_jc_js_id_timeout
=
_gc_js_id_timeout
}
,
_gc_apis
=
CTypes
.
APIsConfig
{
_ac_pubmed_api_key
=
_gc_pubmed_api_key
,
_ac_epo_api_url
=
_gc_epo_api_url
}
,
_ac_epo_api_url
=
_gc_epo_api_url
,
_ac_scrapyd_url
}
,
_gc_log_level
=
LevelDebug
}
where
_ac_scrapyd_url
=
case
parseBaseUrl
"http://localhost:6800"
of
Nothing
->
panicTrace
"Cannot parse base url for scrapyd"
Just
b
->
b
mkFrontendConfig
::
Ini
.
GargConfig
->
CTypes
.
FrontendConfig
mkFrontendConfig
(
Ini
.
GargConfig
{
..
})
=
CTypes
.
FrontendConfig
{
_fc_url
=
_gc_url
,
_fc_backend_name
=
_gc_backend_name
,
_fc_url_backend_api
=
_gc_url_backend_api
,
_fc_jwt_settings
=
"TODO"
,
_fc_cors
,
_fc_microservices
}
,
_fc_microservices
,
_fc_appPort
=
3000
,
_fc_cookie_settings
=
CTypes
.
defaultCookieSettings
}
where
_fc_cors
=
CTypes
.
CORSSettings
{
_corsAllowedOrigins
=
[
toCORSOrigin
"https://demo.gargantext.org"
...
...
bin/gargantext-cli/CLI/Init.hs
View file @
ec01d870
...
...
@@ -18,7 +18,6 @@ module CLI.Init where
import
CLI.Parsers
import
CLI.Types
import
Data.List.NonEmpty
qualified
as
NE
import
Gargantext.API.Admin.Types
import
Gargantext.API.Dev
(
withDevEnv
,
runCmdDev
)
import
Gargantext.API.Errors.Types
import
Gargantext.API.Node
()
-- instances only
...
...
@@ -50,18 +49,18 @@ initCLI (InitArgs settingsPath) = do
cfg
<-
readConfig
settingsPath
let
secret
=
_s_secret_key
$
_gc_secrets
cfg
let
createUsers
::
forall
env
.
HasSettings
env
=>
DBCmd'
env
BackendInternalError
Int64
let
createUsers
::
forall
env
.
DBCmd'
env
BackendInternalError
Int64
createUsers
=
insertNewUsers
(
NewUser
"gargantua"
(
cs
email
)
(
GargPassword
$
cs
password
)
NE
.:|
arbitraryNewUsers
)
let
mkRoots
::
forall
env
.
HasSettings
env
=>
DBCmd'
env
BackendInternalError
[(
UserId
,
RootId
)]
mkRoots
::
forall
env
.
DBCmd'
env
BackendInternalError
[(
UserId
,
RootId
)]
mkRoots
=
mapM
getOrMkRoot
$
map
UserName
(
"gargantua"
:
arbitraryUsername
)
-- TODO create all users roots
let
initMaster
::
forall
env
.
HasSettings
env
=>
DBCmd'
env
BackendInternalError
(
UserId
,
RootId
,
CorpusId
,
ListId
)
initMaster
::
forall
env
.
DBCmd'
env
BackendInternalError
(
UserId
,
RootId
,
CorpusId
,
ListId
)
initMaster
=
do
(
masterUserId
,
masterRootId
,
masterCorpusId
)
<-
getOrMkRootWithCorpus
MkCorpusUserMaster
...
...
bin/gargantext-cli/CLI/Invitations.hs
View file @
ec01d870
...
...
@@ -16,7 +16,6 @@ module CLI.Invitations where
import
CLI.Parsers
import
CLI.Types
import
Gargantext.API.Admin.Types
import
Gargantext.API.Dev
(
withDevEnv
,
runCmdDev
)
import
Gargantext.API.Errors.Types
import
Gargantext.API.Node
()
-- instances only
...
...
@@ -35,8 +34,7 @@ invitationsCLI :: InvitationsArgs -> IO ()
invitationsCLI
(
InvitationsArgs
settingsPath
user
node_id
email
)
=
do
-- _cfg <- readConfig settingsPath
let
invite
::
(
HasSettings
env
,
CmdRandom
env
BackendInternalError
m
let
invite
::
(
CmdRandom
env
BackendInternalError
m
,
HasNLPServer
env
,
CET
.
HasCentralExchangeNotification
env
)
=>
m
Int
invite
=
Share
.
api
(
UserName
$
cs
user
)
node_id
(
Share
.
ShareTeamParams
$
cs
email
)
...
...
gargantext-settings.toml_toModify
View file @
ec01d870
...
...
@@ -47,6 +47,9 @@ master_user = "gargantua"
# frame_id seeds are computed.
secret_key = "something_speciaL"
# JWK token
jwk_file = "dev.jwk"
[paths]
...
...
@@ -62,6 +65,9 @@ api_key = ENTER_PUBMED_API_KEY
[apis.epo]
api_url = EPO_API_URL
[apis.scrapyd]
url = "http://localhost:6800"
[external]
...
...
gargantext.cabal
View file @
ec01d870
...
...
@@ -108,7 +108,6 @@ library
Gargantext.API.Admin.EnvTypes
Gargantext.API.Admin.Orchestrator.Types
Gargantext.API.Admin.Settings
Gargantext.API.Admin.Types
Gargantext.API.Auth.PolicyCheck
Gargantext.API.Count.Types
Gargantext.API.Dev
...
...
@@ -659,6 +658,8 @@ executable gargantext-cli
, gargantext
, gargantext-prelude
, ini ^>= 0.4.1
, lens >= 5.2.2 && < 5.3
, monad-logger ^>= 0.3.36
, optparse-applicative
, optparse-generic ^>= 1.4.7
, parallel ^>= 3.2.2.0
...
...
src/Gargantext/API.hs
View file @
ec01d870
...
...
@@ -30,12 +30,12 @@ Pouillard (who mainly made it).
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module
Gargantext.API
where
import
Control.Concurrent
import
Control.Concurrent.Async
qualified
as
Async
import
Control.Lens
hiding
(
Level
)
import
Data.Cache
qualified
as
InMemory
import
Data.List
(
lookup
)
import
Data.Set
qualified
as
Set
...
...
@@ -44,18 +44,17 @@ import Data.Text.Encoding qualified as TE
import
Data.Text.IO
(
putStrLn
)
import
Data.Validity
import
Gargantext.API.Admin.Auth.Types
(
AuthContext
)
import
Gargantext.API.Admin.EnvTypes
(
Env
,
Mode
(
..
),
_env_config
)
import
Gargantext.API.Admin.EnvTypes
(
Env
,
FireWall
(
..
),
Mode
(
..
),
env_config
,
env_jwt_settings
)
import
Gargantext.API.Admin.Settings
(
newEnv
)
import
Gargantext.API.Admin.Types
(
FireWall
(
..
),
MicroServicesProxyStatus
(
..
),
PortNumber
,
cookieSettings
,
jwtSettings
,
settings
,
corsSettings
,
microServicesProxyStatus
)
import
Gargantext.API.Middleware
(
logStdoutDevSanitised
)
import
Gargantext.API.Routes.Named
(
API
)
import
Gargantext.API.Routes.Named.EKG
import
Gargantext.API.Server.Named
(
server
)
import
Gargantext.Core.Config
(
_gc_notifications
_config
)
import
Gargantext.Core.Config.Types
(
CORSOrigin
(
..
),
CORSSettings
,
NotificationsConfig
(
..
),
SettingsFile
(
..
),
corsAllowedOrigin
s
)
import
Gargantext.Core.Config
(
gc_notifications_config
,
gc_frontend
_config
)
import
Gargantext.Core.Config.Types
(
CORSOrigin
(
..
),
CORSSettings
,
MicroServicesProxyStatus
(
..
),
NotificationsConfig
(
..
),
PortNumber
,
SettingsFile
(
..
),
corsAllowedOrigins
,
fc_cors
,
fc_cookie_settings
,
microServicesProxyStatu
s
)
import
Gargantext.Database.Prelude
qualified
as
DB
import
Gargantext.MicroServices.ReverseProxy
(
microServicesProxyApp
)
import
Gargantext.Prelude
hiding
(
putStrLn
)
import
Gargantext.Prelude
hiding
(
putStrLn
,
to
)
import
Gargantext.System.Logging
import
Network.HTTP.Types
hiding
(
Query
)
import
Network.Wai
...
...
@@ -73,11 +72,12 @@ import System.Cron.Schedule qualified as Cron
startGargantext
::
Mode
->
PortNumber
->
SettingsFile
->
IO
()
startGargantext
mode
port
sf
@
(
SettingsFile
settingsFile
)
=
withLoggerHoisted
mode
$
\
logger
->
do
env
<-
newEnv
logger
port
sf
let
proxyStatus
=
microServicesProxyStatus
(
env
^.
settings
)
let
fc
=
env
^.
env_config
.
gc_frontend_config
let
proxyStatus
=
microServicesProxyStatus
fc
runDbCheck
env
portRouteInfo
(
_gc_notifications_config
$
_env_config
env
)
port
proxyStatus
portRouteInfo
(
env
^.
env_config
.
gc_notifications_config
)
port
proxyStatus
app
<-
makeApp
env
mid
<-
makeGargMiddleware
(
env
^.
settings
.
corsSetting
s
)
mode
mid
<-
makeGargMiddleware
(
fc
^.
fc_cor
s
)
mode
periodicActions
<-
schedulePeriodicActions
env
let
runServer
=
run
port
(
mid
app
)
`
finally
`
stopGargantext
periodicActions
...
...
@@ -131,7 +131,7 @@ stopGargantext scheduledPeriodicActions = do
-- | Schedules all sorts of useful periodic actions to be run while
-- the server is alive accepting requests.
schedulePeriodicActions
::
DB
.
CmdCommon
env
=>
env
->
IO
[
ThreadId
]
schedulePeriodicActions
::
env
->
IO
[
ThreadId
]
schedulePeriodicActions
_env
=
-- Add your scheduled actions here.
let
actions
=
[
...
...
@@ -203,8 +203,8 @@ makeApp env = do
-- })
where
cfg
::
Servant
.
Context
AuthContext
cfg
=
env
^.
settings
.
jwtS
ettings
:.
env
^.
settings
.
cookieS
ettings
cfg
=
env
^.
env_jwt_s
ettings
:.
env
^.
env_config
.
gc_frontend_config
.
fc_cookie_s
ettings
:.
EmptyContext
---------------------------------------------------------------------
...
...
src/Gargantext/API/Admin/Auth.hs
View file @
ec01d870
...
...
@@ -51,10 +51,10 @@ import Data.UUID.V4 (nextRandom)
import
Gargantext.API.Admin.Auth.Types
import
Gargantext.API.Admin.EnvTypes
(
GargJob
(
..
),
Env
)
import
Gargantext.API.Admin.Orchestrator.Types
(
AsyncJobs
(
..
))
import
Gargantext.API.Admin.Types
import
Gargantext.API.Auth.PolicyCheck
import
Gargantext.API.Errors
import
Gargantext.API.Prelude
(
authenticationError
,
HasServerError
,
GargServerC
,
_ServerError
,
GargM
,
IsGargServer
)
import
Gargantext.Core.Config
(
HasJWTSettings
(
..
))
import
Gargantext.Core.Mail
(
MailModel
(
..
),
mail
)
import
Gargantext.Core.Mail.Types
(
mailSettings
)
import
Gargantext.Core.Types.Individu
(
User
(
..
),
Username
,
GargPassword
(
..
))
...
...
@@ -81,18 +81,18 @@ import qualified Gargantext.API.Routes.Named as Named
-- | Main functions of authorization
makeTokenForUser
::
(
HasSettings
env
,
HasAuthenticationError
err
)
makeTokenForUser
::
(
Has
JWT
Settings
env
,
HasAuthenticationError
err
)
=>
NodeId
->
UserId
->
Cmd'
env
err
Token
makeTokenForUser
nodeId
userId
=
do
jwtS
<-
view
$
settings
.
jwtSettings
jwtS
<-
view
jwtSettings
e
<-
liftBase
$
makeJWT
(
AuthenticatedUser
nodeId
userId
)
jwtS
Nothing
-- TODO-SECURITY here we can implement token expiration ^^.
either
(
authenticationError
.
LoginFailed
nodeId
userId
)
(
pure
.
toStrict
.
LE
.
decodeUtf8
)
e
-- TODO not sure about the encoding...
checkAuthRequest
::
(
HasSettings
env
,
HasAuthenticationError
err
,
DbCmd'
env
err
m
)
checkAuthRequest
::
(
Has
JWT
Settings
env
,
HasAuthenticationError
err
,
DbCmd'
env
err
m
)
=>
Username
->
GargPassword
->
m
CheckAuth
...
...
@@ -117,7 +117,7 @@ checkAuthRequest couldBeEmail (GargPassword p) = do
token
<-
makeTokenForUser
nodeId
userLight_id
pure
$
Valid
token
nodeId
userLight_id
auth
::
(
HasSettings
env
,
HasAuthenticationError
err
,
DbCmd'
env
err
m
)
auth
::
(
Has
JWT
Settings
env
,
HasAuthenticationError
err
,
DbCmd'
env
err
m
)
=>
AuthRequest
->
m
AuthResponse
auth
(
AuthRequest
u
p
)
=
do
checkAuthRequest'
<-
checkAuthRequest
u
p
...
...
@@ -250,7 +250,7 @@ forgotPasswordPost (ForgotPasswordRequest email) = do
-- users' emails
pure
$
ForgotPasswordResponse
"ok"
forgotPasswordGet
::
(
HasSettings
env
,
CmdCommon
env
,
HasAuthenticationError
err
,
HasServerError
err
)
forgotPasswordGet
::
(
CmdCommon
env
,
HasServerError
err
)
=>
Maybe
Text
->
Cmd'
env
err
ForgotPasswordGet
forgotPasswordGet
Nothing
=
pure
$
ForgotPasswordGet
""
forgotPasswordGet
(
Just
uuid
)
=
do
...
...
@@ -267,7 +267,7 @@ forgotPasswordGet (Just uuid) = do
---------------------
forgotPasswordGetUser
::
(
HasSettings
env
,
CmdCommon
env
,
HasAuthenticationError
err
,
HasServerError
err
)
forgotPasswordGetUser
::
(
CmdCommon
env
)
=>
UserLight
->
Cmd'
env
err
ForgotPasswordGet
forgotPasswordGetUser
(
UserLight
{
..
})
=
do
-- pick some random password
...
...
src/Gargantext/API/Admin/EnvTypes.hs
View file @
ec01d870
...
...
@@ -10,15 +10,18 @@ module Gargantext.API.Admin.EnvTypes (
,
Mode
(
..
)
,
modeToLoggingLevels
,
mkJobHandle
,
env_config
,
env_logger
,
env_manager
,
env_settings
,
env_self_url
,
env_central_exchange
,
env_dispatcher
,
env_jwt_settings
,
menv_firewall
,
dev_env_logger
,
FireWall
(
..
)
,
MockEnv
(
..
)
,
DevEnv
(
..
)
,
DevJobHandle
(
..
)
...
...
@@ -34,7 +37,6 @@ import Data.Sequence (ViewL(..), viewl)
import
Data.Text
qualified
as
T
import
Database.PostgreSQL.Simple
(
Connection
)
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Admin.Types
import
Gargantext.API.Errors.Types
import
Gargantext.API.Job
import
Gargantext.API.Prelude
(
GargM
,
IsGargServer
)
...
...
@@ -42,18 +44,18 @@ import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
import
Gargantext.Core.AsyncUpdates.CentralExchange.Types
qualified
as
CET
import
Gargantext.Core.AsyncUpdates.Dispatcher
(
Dispatcher
)
import
Gargantext.Core.AsyncUpdates.Dispatcher.Types
(
HasDispatcher
(
..
))
import
Gargantext.Core.Config
(
GargConfig
(
..
),
gc_mail_config
,
gc_nlp_config
,
HasJWTSettings
(
..
),
HasConfig
(
..
))
import
Gargantext.Core.Mail.Types
(
HasMail
,
mailSettings
)
import
Gargantext.Core.NLP
(
NLPServerMap
,
HasNLPServer
(
..
)
)
import
Gargantext.Core.NLP
(
HasNLPServer
(
..
),
nlpServerMap
)
import
Gargantext.Core.NodeStory
import
Gargantext.Database.Prelude
(
HasConnectionPool
(
..
),
HasConfig
(
..
))
import
Gargantext.Prelude
import
Gargantext.Core.Config
(
GargConfig
(
..
))
import
Gargantext.Core.Config.Mail
(
MailConfig
)
import
Gargantext.Database.Prelude
(
HasConnectionPool
(
..
))
import
Gargantext.Prelude
hiding
(
to
)
import
Gargantext.System.Logging
import
Gargantext.Utils.Jobs.Internal
(
pollJob
)
import
Gargantext.Utils.Jobs.Map
(
LoggerM
,
J
(
..
),
jTask
,
rjGetLog
)
import
Gargantext.Utils.Jobs.Monad
qualified
as
Jobs
import
Network.HTTP.Client
(
Manager
)
import
Servant.Auth.Server
(
JWTSettings
)
import
Servant.Client
(
BaseUrl
)
import
Servant.Job.Async
(
HasJobEnv
(
..
),
Job
)
import
Servant.Job.Async
qualified
as
SJ
...
...
@@ -120,19 +122,17 @@ data GargJob
-- having to specify /everything/. This means that when we /construct/ an 'Env',
-- we need to remember to force the fields to WHNF at that point.
data
Env
=
Env
{
_env_settings
::
~
Settings
,
_env_logger
::
~
(
Logger
(
GargM
Env
BackendInternalError
))
,
_env_pool
::
~
(
Pool
Connection
)
,
_env_nodeStory
::
~
NodeStoryEnv
,
_env_manager
::
~
Manager
,
_env_self_url
::
~
BaseUrl
,
_env_scrapers
::
~
ScrapersEnv
,
_env_jobs
::
~
(
Jobs
.
JobEnv
GargJob
(
Seq
JobLog
)
JobLog
)
,
_env_config
::
~
GargConfig
,
_env_mail
::
~
MailConfig
,
_env_nlp
::
~
NLPServerMap
{
_env_logger
::
~
(
Logger
(
GargM
Env
BackendInternalError
))
,
_env_pool
::
~
(
Pool
Connection
)
,
_env_nodeStory
::
~
NodeStoryEnv
,
_env_manager
::
~
Manager
,
_env_self_url
::
~
BaseUrl
,
_env_scrapers
::
~
ScrapersEnv
,
_env_jobs
::
~
(
Jobs
.
JobEnv
GargJob
(
Seq
JobLog
)
JobLog
)
,
_env_config
::
~
GargConfig
,
_env_central_exchange
::
~
ThreadId
,
_env_dispatcher
::
~
Dispatcher
,
_env_dispatcher
::
~
Dispatcher
,
_env_jwt_settings
::
~
JWTSettings
}
deriving
(
Generic
)
...
...
@@ -153,14 +153,14 @@ instance HasNodeStoryImmediateSaver Env where
instance
HasNodeArchiveStoryImmediateSaver
Env
where
hasNodeArchiveStoryImmediateSaver
=
hasNodeStory
.
nse_archive_saver_immediate
instance
HasSettings
Env
where
settings
=
env
_settings
instance
Has
JWT
Settings
Env
where
jwtSettings
=
env_jwt
_settings
instance
HasMail
Env
where
mailSettings
=
env_
mail
mailSettings
=
env_
config
.
gc_mail_config
instance
HasNLPServer
Env
where
nlpServer
=
env_
nlp
nlpServer
=
env_
config
.
gc_nlp_config
.
(
to
nlpServerMap
)
instance
HasDispatcher
Env
Dispatcher
where
hasDispatcher
=
env_dispatcher
...
...
@@ -259,6 +259,8 @@ instance Jobs.MonadJobStatus (GargM Env err) where
addMoreSteps
steps
jh
=
updateJobProgress
jh
(
jobLogAddMore
steps
)
data
FireWall
=
FireWall
{
unFireWall
::
Bool
}
data
MockEnv
=
MockEnv
{
_menv_firewall
::
!
FireWall
}
...
...
@@ -288,13 +290,10 @@ instance HasLogger (GargM DevEnv BackendInternalError) where
logTxt
lgr
lvl
msg
=
logMsg
lgr
lvl
(
FL
.
toLogStr
$
T
.
unpack
msg
)
data
DevEnv
=
DevEnv
{
_dev_env_settings
::
!
Settings
,
_dev_env_config
::
!
GargConfig
{
_dev_env_config
::
!
GargConfig
,
_dev_env_logger
::
!
(
Logger
(
GargM
DevEnv
BackendInternalError
))
,
_dev_env_pool
::
!
(
Pool
Connection
)
,
_dev_env_nodeStory
::
!
NodeStoryEnv
,
_dev_env_mail
::
!
MailConfig
,
_dev_env_nlp
::
!
NLPServerMap
}
makeLenses
''
D
evEnv
...
...
@@ -339,9 +338,6 @@ instance HasConfig DevEnv where
instance
HasConnectionPool
DevEnv
where
connPool
=
dev_env_pool
instance
HasSettings
DevEnv
where
settings
=
dev_env_settings
instance
HasNodeStoryEnv
DevEnv
where
hasNodeStory
=
dev_env_nodeStory
...
...
@@ -353,10 +349,10 @@ instance HasNodeArchiveStoryImmediateSaver DevEnv where
hasNodeArchiveStoryImmediateSaver
=
hasNodeStory
.
nse_archive_saver_immediate
instance
HasMail
DevEnv
where
mailSettings
=
dev_env_
mail
mailSettings
=
dev_env_
config
.
gc_mail_config
instance
HasNLPServer
DevEnv
where
nlpServer
=
dev_env_
nlp
nlpServer
=
dev_env_
config
.
gc_nlp_config
.
(
to
nlpServerMap
)
instance
IsGargServer
Env
BackendInternalError
(
GargM
Env
BackendInternalError
)
src/Gargantext/API/Admin/Settings.hs
View file @
ec01d870
...
...
@@ -20,24 +20,20 @@ module Gargantext.API.Admin.Settings
import
Codec.Serialise
(
Serialise
(),
serialise
)
import
Control.Lens
import
Control.Monad.Logger
(
LogLevel
(
..
))
import
Control.Monad.Reader
import
Data.ByteString.Lazy
qualified
as
L
import
Data.Pool
(
Pool
)
import
Data.Pool
qualified
as
Pool
import
Database.PostgreSQL.Simple
(
Connection
,
connect
,
close
,
ConnectInfo
)
import
Gargantext.API.Admin.EnvTypes
import
Gargantext.API.Admin.Types
import
Gargantext.API.Errors.Types
import
Gargantext.API.Prelude
import
Gargantext.Core.AsyncUpdates.CentralExchange
qualified
as
CE
import
Gargantext.Core.AsyncUpdates.Dispatcher
qualified
as
D
import
Gargantext.Core.Config
(
GargConfig
(
..
),
gc_jobs
)
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
),
_fc_cors
,
_fc_microservices
,
jc_js_job_timeout
,
jc_js_id_timeout
)
import
Gargantext.Core.Config
(
GargConfig
(
..
),
gc_jobs
,
gc_frontend_config
,
hasConfig
)
import
Gargantext.Core.Config.Types
(
PortNumber
,
SettingsFile
(
..
),
fc_appPort
,
jc_js_job_timeout
,
jc_js_id_timeout
,
jwtSettings
)
import
Gargantext.Core.Config.Utils
(
readConfig
)
import
Gargantext.Core.NLP
(
nlpServerMap
)
import
Gargantext.Core.NodeStory
import
Gargantext.Database.Prelude
(
hasConfig
)
import
Gargantext.Prelude
import
Gargantext.System.Logging
import
Gargantext.Utils.Jobs
qualified
as
Jobs
...
...
@@ -45,43 +41,16 @@ import Gargantext.Utils.Jobs.Monad qualified as Jobs
import
Gargantext.Utils.Jobs.Queue
qualified
as
Jobs
import
Gargantext.Utils.Jobs.Settings
qualified
as
Jobs
import
Network.HTTP.Client.TLS
(
newTlsManager
)
import
Servant.Auth.Server
(
defaultJWTSettings
,
CookieSettings
(
..
),
XsrfCookieSettings
(
..
),
defaultCookieSettings
,
defaultXsrfCookieSettings
,
readKey
,
writeKey
)
import
Servant.Client
(
parseBaseUrl
)
import
Servant.Job.Async
(
newJobEnv
,
defaultSettings
)
import
System.Directory
import
System.Directory
(
renameFile
)
import
System.IO
(
hClose
)
import
System.IO.Temp
(
withTempFile
)
newtype
JwkFile
=
JwkFile
{
_JwkFile
::
FilePath
}
deriving
(
Show
,
Eq
,
IsString
)
newtype
IniFile
=
IniFile
{
_IniFile
::
FilePath
}
deriving
(
Show
,
Eq
,
IsString
)
devSettings
::
JwkFile
->
SettingsFile
->
IO
Settings
devSettings
(
JwkFile
jwkFile
)
settingsFile
=
do
jwkExists
<-
doesFileExist
jwkFile
when
(
not
jwkExists
)
$
writeKey
jwkFile
jwk
<-
readKey
jwkFile
-- GargTomlSettings{..} <- loadGargTomlSettings settingsFile
gc
@
(
GargConfig
{})
<-
readConfig
settingsFile
pure
$
Settings
{
-- _corsSettings = _gargCorsSettings
_corsSettings
=
_fc_cors
$
_gc_frontend_config
gc
-- , _microservicesSettings = _gargMicroServicesSettings
,
_microservicesSettings
=
_fc_microservices
$
_gc_frontend_config
gc
,
_appPort
=
3000
,
_logLevelLimit
=
LevelDebug
-- , _dbServer = "localhost"
,
_sendLoginEmails
=
LogEmailToConsole
,
_scrapydUrl
=
fromMaybe
(
panicTrace
"Invalid scrapy URL"
)
$
parseBaseUrl
"http://localhost:6800"
,
_cookieSettings
=
defaultCookieSettings
{
cookieXsrfSetting
=
Just
xsrfCookieSetting
}
-- TODO-SECURITY tune
,
_jwtSettings
=
defaultJWTSettings
jwk
-- TODO-SECURITY tune
}
where
xsrfCookieSetting
=
defaultXsrfCookieSettings
{
xsrfExcludeGet
=
True
}
{- NOT USED YET
import System.Environment (lookupEnv)
...
...
@@ -181,17 +150,13 @@ readRepoEnv repoDir = do
pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
--}
devJwkFile
::
JwkFile
devJwkFile
=
JwkFile
"dev.jwk"
newEnv
::
Logger
(
GargM
Env
BackendInternalError
)
->
PortNumber
->
SettingsFile
->
IO
Env
newEnv
logger
port
settingsFile
@
(
SettingsFile
sf
)
=
do
!
manager_env
<-
newTlsManager
!
settings'
<-
devSettings
devJwkFile
settingsFile
<&>
appPort
.~
port
-- TODO read from 'file'
when
(
port
/=
settings'
^.
appPort
)
$
!
config_env
<-
readConfig
settingsFile
<&>
(
gc_frontend_config
.
fc_appPort
)
.~
port
-- TODO read from 'file'
when
(
port
/=
config_env
^.
gc_frontend_config
.
fc_
appPort
)
$
panicTrace
"TODO: conflicting settings of port"
!
config_env
<-
readConfig
settingsFile
prios
<-
withLogger
()
$
\
ioLogger
->
Jobs
.
readPrios
ioLogger
(
sf
<>
".jobs"
)
let
prios'
=
Jobs
.
applyPrios
prios
Jobs
.
defaultPrios
putStrLn
(
"Overrides: "
<>
show
prios
::
Text
)
...
...
@@ -210,12 +175,13 @@ newEnv logger port settingsFile@(SettingsFile sf) = do
!
central_exchange
<-
forkIO
$
CE
.
gServer
(
_gc_notifications_config
config_env
)
!
dispatcher
<-
D
.
newDispatcher
(
_gc_notifications_config
config_env
)
!
_env_jwt_settings
<-
jwtSettings
(
_gc_secrets
config_env
)
{- An 'Env' by default doesn't have strict fields, but when constructing one in production
we want to force them to WHNF to avoid accumulating unnecessary thunks.
-}
pure
$
Env
{
_env_settings
=
settings'
,
_env_logger
=
logger
{
_env_logger
=
logger
,
_env_pool
=
pool
,
_env_nodeStory
=
nodeStory_env
,
_env_manager
=
manager_env
...
...
@@ -223,10 +189,9 @@ newEnv logger port settingsFile@(SettingsFile sf) = do
,
_env_jobs
=
jobs_env
,
_env_self_url
=
self_url_env
,
_env_config
=
config_env
,
_env_mail
=
_gc_mail_config
config_env
,
_env_nlp
=
nlpServerMap
$
_gc_nlp_config
config_env
,
_env_central_exchange
=
central_exchange
,
_env_dispatcher
=
dispatcher
,
_env_jwt_settings
}
newPool
::
ConnectInfo
->
IO
(
Pool
Connection
)
...
...
src/Gargantext/API/Admin/Settings/CORS.hs
deleted
100644 → 0
View file @
651caaee
{--| Support in Gargantext for CORS (Cross-origin resource sharing) --}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module
Gargantext.API.Admin.Settings.CORS
where
import
Prelude
import
Control.Arrow
import
Data.Text
qualified
as
T
import
Toml
import
Control.Lens
hiding
(
iso
,
(
.=
))
import
Servant.Client.Core
import
Data.Maybe
(
fromMaybe
)
newtype
CORSOrigin
=
CORSOrigin
{
_CORSOrigin
::
BaseUrl
}
deriving
(
Show
,
Eq
)
data
CORSSettings
=
CORSSettings
{
_corsAllowedOrigins
::
[
CORSOrigin
]
,
_corsAllowedHosts
::
[
CORSOrigin
]
-- | If 'True', we will reuse the origin whitelist
-- as the allowed hosts as well. This allows, for example,
-- to connect from \"demo.gargantext.org\" to \"dev.sub.gargantext.org\"
-- and vice-versa.
,
_corsUseOriginsForHosts
::
!
Bool
}
deriving
(
Show
,
Eq
)
corsOriginCodec
::
TomlBiMap
CORSOrigin
AnyValue
corsOriginCodec
=
_Orig
>>>
_Text
where
_Orig
::
BiMap
e
CORSOrigin
T
.
Text
_Orig
=
iso
(
T
.
pack
.
showBaseUrl
.
_CORSOrigin
)
(
\
(
T
.
unpack
->
u
)
->
CORSOrigin
.
fromMaybe
(
error
$
"invalid origin: "
<>
u
)
.
parseBaseUrl
$
u
)
corsSettingsCodec
::
TomlCodec
CORSSettings
corsSettingsCodec
=
CORSSettings
<$>
Toml
.
arrayOf
corsOriginCodec
"allowed-origins"
.=
_corsAllowedOrigins
<*>
pure
mempty
-- FIXME(adn) Currently we don't need to support this field.
<*>
Toml
.
bool
"use-origins-for-hosts"
.=
_corsUseOriginsForHosts
makeLenses
''
C
ORSSettings
src/Gargantext/API/Admin/Settings/MicroServices.hs
deleted
100644 → 0
View file @
651caaee
{-# LANGUAGE TemplateHaskell #-}
module
Gargantext.API.Admin.Settings.MicroServices
where
import
Prelude
import
Control.Lens.TH
import
Data.Text
qualified
as
T
import
Gargantext.Core.Config
import
Servant.Client.Core.BaseUrl
import
Toml
data
MicroServicesSettings
=
MicroServicesSettings
{
-- | The port where the microservices proxy will be listening on.
_msProxyPort
::
!
Int
,
_msProxyEnabled
::
!
Bool
}
deriving
(
Show
,
Eq
)
microServicesSettingsCodec
::
TomlCodec
MicroServicesSettings
microServicesSettingsCodec
=
MicroServicesSettings
<$>
Toml
.
int
"port"
.=
_msProxyPort
<*>
Toml
.
bool
"enabled"
.=
_msProxyEnabled
mkProxyUrl
::
GargConfig
->
MicroServicesSettings
->
BaseUrl
mkProxyUrl
GargConfig
{
..
}
MicroServicesSettings
{
..
}
=
case
parseBaseUrl
(
T
.
unpack
_gc_url
)
of
Nothing
->
BaseUrl
Http
"localhost"
80
""
Just
bh
->
bh
{
baseUrlPort
=
_msProxyPort
}
makeLenses
''
M
icroServicesSettings
src/Gargantext/API/Admin/Types.hs
deleted
100644 → 0
View file @
651caaee
{-# LANGUAGE TemplateHaskell #-}
module
Gargantext.API.Admin.Types
where
import
Control.Lens
import
Control.Monad.Logger
(
LogLevel
)
import
GHC.Enum
import
Gargantext.Core.Config.Types
import
Gargantext.Prelude
import
Servant.Auth.Server
(
JWTSettings
,
CookieSettings
(
..
))
import
Servant.Client
(
BaseUrl
)
type
PortNumber
=
Int
data
SendEmailType
=
SendEmailViaAws
|
LogEmailToConsole
|
WriteEmailToFile
deriving
(
Show
,
Read
,
Enum
,
Bounded
,
Generic
)
data
Settings
=
Settings
{
_corsSettings
::
!
CORSSettings
-- CORS settings
,
_microservicesSettings
::
!
MicroServicesSettings
,
_appPort
::
!
PortNumber
,
_logLevelLimit
::
!
LogLevel
-- log level from the monad-logger package
-- , _dbServer :: Text
-- ^ this is not used yet
,
_jwtSettings
::
!
JWTSettings
,
_cookieSettings
::
!
CookieSettings
,
_sendLoginEmails
::
!
SendEmailType
,
_scrapydUrl
::
!
BaseUrl
}
makeLenses
''
S
ettings
data
MicroServicesProxyStatus
=
PXY_enabled
PortNumber
|
PXY_disabled
deriving
(
Show
,
Eq
)
microServicesProxyStatus
::
Settings
->
MicroServicesProxyStatus
microServicesProxyStatus
stgs
=
if
stgs
^.
microservicesSettings
.
msProxyEnabled
then
PXY_enabled
(
stgs
^.
microservicesSettings
.
msProxyPort
)
else
PXY_disabled
class
HasSettings
env
where
settings
::
Getter
env
Settings
instance
HasSettings
Settings
where
settings
=
identity
data
FireWall
=
FireWall
{
unFireWall
::
Bool
}
src/Gargantext/API/Auth/PolicyCheck.hs
View file @
ec01d870
...
...
@@ -21,27 +21,26 @@ module Gargantext.API.Auth.PolicyCheck (
,
alwaysDeny
)
where
import
Control.Lens
import
Control.Monad
import
Data.BoolExpr
import
Gargantext.API.Admin.Auth.Types
import
Gargantext.API.Errors.Types
import
Gargantext.Core.Types
import
Gargantext.Core.Types.Individu
import
Gargantext.Database.Prelude
(
DBCmd
,
HasConfig
(
..
))
import
Gargantext.Database.Query.Table.Node.Error
import
Gargantext.Database.Query.Tree
import
Gargantext.Database.Query.Tree.Root
import
Gargantext.Core.Config
(
GargConfig
(
..
))
import
Control.Lens
(
view
)
import
Data.BoolExpr
(
BoolExpr
(
..
),
Signed
(
..
))
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
(
..
))
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.Core.Config
(
GargConfig
(
..
),
HasConfig
(
hasConfig
))
import
Gargantext.Core.Config.Types
(
SecretsConfig
(
..
))
import
Prelude
import
Servant
import
Servant.API.Routes
import
Servant.Auth.Server.Internal.AddSetCookie
import
Servant.Client.Core
import
Servant.Ekg
import
Servant.Server.Internal.Delayed
import
Servant.Server.Internal.DelayedIO
import
Gargantext.Core.Types
(
NodeId
,
UserId
)
import
Gargantext.Core.Types.Individu
(
User
(
UserName
))
import
Gargantext.Database.Prelude
(
DBCmd
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Tree
(
isDescendantOf
,
isOwnedBy
,
isSharedWith
)
import
Gargantext.Database.Query.Tree.Root
(
getRootId
)
import
Gargantext.Prelude
import
Servant
(
HasServer
(
..
),
ServerError
,
ServerT
,
err403
,
err500
)
import
Servant.API.Routes
(
HasRoutes
(
getRoutes
))
import
Servant.Auth.Server.Internal.AddSetCookie
(
AddSetCookieApi
,
AddSetCookies
(
..
),
Nat
(
S
))
import
Servant.Client.Core
(
HasClient
(
..
),
Client
)
import
Servant.Ekg
(
HasEndpoint
(
..
))
import
Servant.Server.Internal.Delayed
(
addParameterCheck
)
import
Servant.Server.Internal.DelayedIO
(
DelayedIO
(
..
))
import
Servant.Swagger
qualified
as
Swagger
-------------------------------------------------------------------------------
...
...
@@ -122,13 +121,13 @@ accessPolicyManager = AccessPolicyManager (\ur ac -> interpretPolicy ur ac)
BFalse
->
pure
$
Deny
err403
BConst
(
Positive
b
)
->
check
ur
b
->
check
'
ur
b
BConst
(
Negative
b
)
->
check
ur
b
->
check
'
ur
b
check
::
HasNodeError
err
=>
AuthenticatedUser
->
AccessCheck
->
DBCmd
err
AccessResult
check
(
AuthenticatedUser
loggedUserNodeId
loggedUserUserId
)
=
\
case
check
'
::
HasNodeError
err
=>
AuthenticatedUser
->
AccessCheck
->
DBCmd
err
AccessResult
check
'
(
AuthenticatedUser
loggedUserNodeId
loggedUserUserId
)
=
\
case
AC_always_deny
->
pure
$
Deny
err500
AC_always_allow
...
...
src/Gargantext/API/Count.hs
View file @
ec01d870
...
...
@@ -29,5 +29,5 @@ import Servant.Server.Generic (AsServerT)
-- TODO-ACCESS: CanCount
-- TODO-EVENTS: No events as this is a read only query.
-----------------------------------------------------------------------
countAPI
::
Monad
m
=>
Query
->
Named
.
CountAPI
(
AsServerT
m
)
countAPI
::
Query
->
Named
.
CountAPI
(
AsServerT
m
)
countAPI
_
=
Named
.
CountAPI
undefined
src/Gargantext/API/Dev.hs
View file @
ec01d870
...
...
@@ -17,12 +17,11 @@ import Control.Monad (fail)
import
Data.Pool
(
withResource
)
import
Database.PostgreSQL.Simple
qualified
as
PGS
import
Gargantext.API.Admin.EnvTypes
(
DevEnv
(
..
),
Mode
(
Dev
)
)
import
Gargantext.API.Admin.Settings
(
devJwkFile
,
devSettings
,
newPool
)
import
Gargantext.API.Admin.Settings
(
newPool
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.Core.Config
(
_gc_database_config
,
_gc_mail_config
,
_gc_nlp_config
)
import
Gargantext.Core.Config
(
_gc_database_config
)
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
))
import
Gargantext.Core.NLP
(
nlpServerMap
)
import
Gargantext.Core.NodeStory
(
fromDBNodeStoryEnv
)
import
Gargantext.Database.Prelude
(
Cmd
'
,
Cmd
''
,
connPool
,
runCmd
)
import
Gargantext.Prelude
...
...
@@ -42,15 +41,11 @@ withDevEnv settingsFile k = withLoggerHoisted Dev $ \logger -> do
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
pool
<-
newPool
(
_gc_database_config
cfg
)
nodeStory_env
<-
fromDBNodeStoryEnv
pool
setts
<-
devSettings
devJwkFile
settingsFile
pure
$
DevEnv
{
_dev_env_pool
=
pool
,
_dev_env_logger
=
logger
,
_dev_env_nodeStory
=
nodeStory_env
,
_dev_env_settings
=
setts
,
_dev_env_config
=
cfg
,
_dev_env_mail
=
_gc_mail_config
cfg
,
_dev_env_nlp
=
nlpServerMap
(
_gc_nlp_config
cfg
)
}
defaultSettingsFile
::
SettingsFile
...
...
src/Gargantext/API/Errors/Types.hs
View file @
ec01d870
...
...
@@ -8,6 +8,7 @@ Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -Wredundant-constraints #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE LambdaCase #-}
...
...
@@ -39,9 +40,6 @@ module Gargantext.API.Errors.Types (
-- * Evidence carrying
,
Dict
(
..
)
,
IsFrontendErrorData
(
..
)
-- * Generating test cases
,
genFrontendErr
)
where
import
Control.Lens
(
makePrisms
)
...
...
@@ -51,7 +49,7 @@ import Data.Aeson.Types (typeMismatch, emptyArray)
import
Data.List.NonEmpty
qualified
as
NE
import
Data.Singletons.TH
(
SingI
(
sing
),
SingKind
(
fromSing
)
)
import
Data.Text
qualified
as
T
import
Data.Validity
(
Validation
(
..
)
,
ValidationChain
(
..
),
prettyValidation
)
import
Data.Validity
(
Validation
(
..
))
import
Gargantext.API.Admin.Auth.Types
(
AuthenticationError
)
import
Gargantext.API.Errors.Class
(
HasAuthenticationError
(
..
))
import
Gargantext.API.Errors.TH
(
deriveIsFrontendErrorData
)
...
...
@@ -67,8 +65,6 @@ import Gargantext.Utils.Jobs.Monad qualified as Jobs
import
Servant
(
ServerError
)
import
Servant.Job.Core
(
HasServerError
(
..
)
)
import
Servant.Job.Types
qualified
as
SJ
import
Test.QuickCheck
import
Test.QuickCheck.Instances.Text
()
-- | A 'WithStacktrace' carries an error alongside its
-- 'CallStack', to be able to print the correct source location
...
...
@@ -574,121 +570,6 @@ instance FromJSON (ToFrontendErrorData 'EC_500__job_generic_exception) where
jege_error
<-
o
.:
"error"
pure
FE_job_generic_exception
{
..
}
----------------------------------------------------------------------------
-- Arbitrary instances and test data generation
----------------------------------------------------------------------------
instance
Arbitrary
BackendErrorCode
where
arbitrary
=
arbitraryBoundedEnum
genFrontendErr
::
BackendErrorCode
->
Gen
FrontendError
genFrontendErr
be
=
do
txt
<-
arbitrary
case
be
of
-- node errors
EC_404__node_list_not_found
->
arbitrary
>>=
\
lid
->
pure
$
mkFrontendErr'
txt
$
FE_node_list_not_found
lid
EC_404__node_root_not_found
->
pure
$
mkFrontendErr'
txt
FE_node_root_not_found
EC_404__node_corpus_not_found
->
pure
$
mkFrontendErr'
txt
FE_node_corpus_not_found
EC_500__node_not_implemented_yet
->
pure
$
mkFrontendErr'
txt
FE_node_not_implemented_yet
EC_404__node_lookup_failed_not_found
->
do
nodeId
<-
arbitrary
pure
$
mkFrontendErr'
txt
(
FE_node_lookup_failed_not_found
nodeId
)
EC_404__node_lookup_failed_parent_not_found
->
do
nodeId
<-
arbitrary
pure
$
mkFrontendErr'
txt
(
FE_node_lookup_failed_parent_not_found
nodeId
)
EC_404__node_lookup_failed_user_not_found
->
do
userId
<-
arbitrary
pure
$
mkFrontendErr'
txt
(
FE_node_lookup_failed_user_not_found
userId
)
EC_404__node_lookup_failed_username_not_found
->
do
username
<-
arbitrary
pure
$
mkFrontendErr'
txt
(
FE_node_lookup_failed_username_not_found
username
)
EC_400__node_lookup_failed_user_too_many_roots
->
do
userId
<-
arbitrary
roots
<-
arbitrary
pure
$
mkFrontendErr'
txt
(
FE_node_lookup_failed_user_too_many_roots
userId
roots
)
EC_404__node_context_not_found
->
do
contextId
<-
arbitrary
pure
$
mkFrontendErr'
txt
(
FE_node_context_not_found
contextId
)
EC_400__node_creation_failed_no_parent
->
do
userId
<-
arbitrary
pure
$
mkFrontendErr'
txt
(
FE_node_creation_failed_no_parent
userId
)
EC_400__node_creation_failed_parent_exists
->
do
userId
<-
arbitrary
parentId
<-
arbitrary
pure
$
mkFrontendErr'
txt
(
FE_node_creation_failed_parent_exists
userId
parentId
)
EC_400__node_creation_failed_insert_node
->
do
userId
<-
arbitrary
parentId
<-
arbitrary
pure
$
mkFrontendErr'
txt
$
FE_node_creation_failed_insert_node
parentId
userId
EC_400__node_creation_failed_user_negative_id
->
pure
$
mkFrontendErr'
txt
(
FE_node_creation_failed_user_negative_id
(
UnsafeMkUserId
(
-
42
)))
EC_500__node_generic_exception
->
do
err
<-
arbitrary
pure
$
mkFrontendErr'
txt
$
FE_node_generic_exception
err
EC_400__node_needs_configuration
->
pure
$
mkFrontendErr'
txt
$
FE_node_needs_configuration
-- validation error
EC_400__validation_error
->
do
let
genValChain
=
oneof
[
Violated
<$>
arbitrary
,
Location
<$>
arbitrary
<*>
genValChain
]
chain
<-
listOf1
genValChain
pure
$
mkFrontendErr'
txt
$
FE_validation_error
(
T
.
pack
$
fromMaybe
"unknown_validation_error"
$
prettyValidation
$
Validation
chain
)
-- authentication error
EC_403__login_failed_error
->
do
nid
<-
arbitrary
uid
<-
arbitrary
pure
$
mkFrontendErr'
txt
$
FE_login_failed_error
nid
uid
EC_403__login_failed_invalid_username_or_password
->
do
pure
$
mkFrontendErr'
txt
$
FE_login_failed_invalid_username_or_password
EC_403__user_not_authorized
->
do
uid
<-
arbitrary
msg
<-
arbitrary
pure
$
mkFrontendErr'
txt
$
FE_user_not_authorized
uid
msg
-- internal error
EC_500__internal_server_error
->
do
err
<-
arbitrary
pure
$
mkFrontendErr'
txt
$
FE_internal_server_error
err
EC_405__not_allowed
->
do
err
<-
arbitrary
pure
$
mkFrontendErr'
txt
$
FE_not_allowed
err
-- tree errors
EC_404__tree_root_not_found
->
pure
$
mkFrontendErr'
txt
$
FE_tree_root_not_found
EC_404__tree_empty_root
->
pure
$
mkFrontendErr'
txt
$
FE_tree_empty_root
EC_500__tree_too_many_roots
->
do
nodes
<-
getNonEmpty
<$>
arbitrary
pure
$
mkFrontendErr'
txt
$
FE_tree_too_many_roots
(
NE
.
fromList
nodes
)
-- job errors
EC_500__job_invalid_id_type
->
do
idTy
<-
arbitrary
pure
$
mkFrontendErr'
txt
$
FE_job_invalid_id_type
idTy
EC_500__job_expired
->
do
jobId
<-
getPositive
<$>
arbitrary
pure
$
mkFrontendErr'
txt
$
FE_job_expired
jobId
EC_500__job_invalid_mac
->
do
macId
<-
arbitrary
pure
$
mkFrontendErr'
txt
$
FE_job_expired
macId
EC_500__job_unknown_job
->
do
jobId
<-
getPositive
<$>
arbitrary
pure
$
mkFrontendErr'
txt
$
FE_job_unknown_job
jobId
EC_500__job_generic_exception
->
do
err
<-
arbitrary
pure
$
mkFrontendErr'
txt
$
FE_job_generic_exception
err
instance
ToJSON
BackendErrorCode
where
toJSON
=
String
.
T
.
pack
.
show
...
...
src/Gargantext/API/GraphQL.hs
View file @
ec01d870
...
...
@@ -28,7 +28,6 @@ import Data.Morpheus.Types ( GQLRequest, GQLResponse, GQLType, RootResolver(..),
-- import Data.Proxy
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
)
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Auth.PolicyCheck
import
Gargantext.API.Errors.Types
import
Gargantext.API.GraphQL.Annuaire
qualified
as
GQLA
...
...
@@ -44,6 +43,7 @@ import Gargantext.API.GraphQL.UserInfo qualified as GQLUserInfo
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.API.Prelude
(
HasJobEnv
'
)
import
Gargantext.API.Types
import
Gargantext.Core.Config
(
HasJWTSettings
)
import
Gargantext.Core.NLP
(
HasNLPServer
)
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
Gargantext.Prelude
hiding
(
ByteString
)
...
...
@@ -102,7 +102,7 @@ data Contet m
-- | The main GraphQL resolver: how queries, mutations and
-- subscriptions are handled.
rootResolver
::
(
CmdCommon
env
,
HasNLPServer
env
,
HasJobEnv'
env
,
HasSettings
env
)
::
(
CmdCommon
env
,
HasNLPServer
env
,
HasJobEnv'
env
,
Has
JWT
Settings
env
)
=>
AuthenticatedUser
->
AccessPolicyManager
->
RootResolver
(
GargM
env
BackendInternalError
)
e
Query
Mutation
Undefined
...
...
@@ -134,7 +134,7 @@ rootResolver authenticatedUser policyManager =
-- | Main GraphQL "app".
app
::
(
Typeable
env
,
CmdCommon
env
,
HasJobEnv'
env
,
HasNLPServer
env
,
HasSettings
env
)
::
(
Typeable
env
,
CmdCommon
env
,
HasJobEnv'
env
,
HasNLPServer
env
,
Has
JWT
Settings
env
)
=>
AuthenticatedUser
->
AccessPolicyManager
->
App
(
EVENT
(
GargM
env
BackendInternalError
))
(
GargM
env
BackendInternalError
)
...
...
@@ -172,7 +172,7 @@ data GraphQLAPIEndpoints mode = GraphQLAPIEndpoints
-- | Implementation of our API.
api
::
(
Typeable
env
,
CmdCommon
env
,
HasJobEnv'
env
,
HasSettings
env
)
::
(
Typeable
env
,
CmdCommon
env
,
HasJobEnv'
env
,
Has
JWT
Settings
env
)
=>
GraphQLAPI
(
AsServerT
(
GargM
env
BackendInternalError
))
api
=
GraphQLAPI
$
\
case
(
SAS
.
Authenticated
auser
)
...
...
src/Gargantext/API/GraphQL/AsyncTask.hs
View file @
ec01d870
...
...
@@ -20,7 +20,8 @@ import Data.Morpheus.Types ( GQLType, Resolver, QUERY )
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
(
..
))
import
Gargantext.API.Errors.Types
import
Gargantext.API.Prelude
(
GargM
,
HasJobEnv
'
)
import
Gargantext.Database.Prelude
(
HasConnectionPool
,
HasConfig
)
import
Gargantext.Core.Config
(
HasConfig
)
import
Gargantext.Database.Prelude
(
HasConnectionPool
)
import
Gargantext.Prelude
import
Servant.Job.Async
(
HasJobEnv
(
job_env
),
jenv_jobs
,
job_async
)
import
Servant.Job.Core
(
env_item
,
env_map
,
env_state_mvar
)
...
...
src/Gargantext/API/GraphQL/Context.hs
View file @
ec01d870
...
...
@@ -25,7 +25,6 @@ import Data.Morpheus.Types
import
Data.Text
(
pack
,
unpack
)
import
qualified
Data.Text
as
Text
import
Data.Time.Format.ISO8601
(
iso8601Show
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.Core.Types.Search
(
HyperdataRow
(
..
),
toHyperdataRow
)
...
...
@@ -219,7 +218,7 @@ toHyperdataRowDocumentGQL hyperdata =
}
HyperdataRowContact
{
}
->
Nothing
updateNodeContextCategory
::
(
CmdCommon
env
,
HasSettings
env
)
updateNodeContextCategory
::
(
CmdCommon
env
)
=>
NodeContextCategoryMArgs
->
GqlM'
e
env
[
Int
]
updateNodeContextCategory
NodeContextCategoryMArgs
{
context_id
,
node_id
,
category
}
=
do
_
<-
lift
$
DNC
.
updateNodeContextCategory
(
UnsafeMkContextId
context_id
)
(
UnsafeMkNodeId
node_id
)
category
...
...
src/Gargantext/API/GraphQL/PolicyCheck.hs
View file @
ec01d870
...
...
@@ -8,7 +8,8 @@ import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser )
import
Gargantext.API.Auth.PolicyCheck
(
BoolExpr
,
AccessCheck
,
AccessPolicyManager
(
..
),
AccessResult
(
..
))
import
Gargantext.API.Errors.Types
(
BackendInternalError
(
..
)
)
import
Gargantext.API.GraphQL.Types
(
GqlM
)
import
Gargantext.Database.Prelude
(
HasConnectionPool
,
HasConfig
)
import
Gargantext.Core.Config
(
HasConfig
)
import
Gargantext.Database.Prelude
(
HasConnectionPool
)
withPolicy
::
(
HasConnectionPool
env
,
HasConfig
env
)
=>
AuthenticatedUser
...
...
src/Gargantext/API/GraphQL/Team.hs
View file @
ec01d870
...
...
@@ -17,11 +17,11 @@ module Gargantext.API.GraphQL.Team where
import
Data.Morpheus.Types
(
GQLType
,
ResolverM
)
import
Data.Text
qualified
as
T
import
Gargantext.API.Admin.Auth.Types
(
AuthenticationError
(
..
))
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Errors.Types
import
Gargantext.API.GraphQL.Types
(
GqlM
)
import
Gargantext.API.GraphQL.Utils
(
authUser
,
AuthStatus
(
Invalid
,
Valid
))
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.Core.Config
(
HasJWTSettings
)
import
Gargantext.Core.Types
(
NodeId
(
..
),
unNodeId
)
import
Gargantext.Core.Types.Individu
qualified
as
Individu
import
Gargantext.Database.Action.Share
(
membersOf
,
deleteMemberShip
)
...
...
@@ -78,7 +78,7 @@ dbTeam nodeId = do
getUsername
((
UserLight
{
userLight_username
},
_
)
:
_
)
=
userLight_username
-- TODO: list as argument
deleteTeamMembership
::
(
CmdCommon
env
,
HasSettings
env
)
=>
deleteTeamMembership
::
(
CmdCommon
env
,
Has
JWT
Settings
env
)
=>
TeamDeleteMArgs
->
GqlM'
e
env
[
Int
]
deleteTeamMembership
TeamDeleteMArgs
{
token
,
shared_folder_id
,
team_node_id
}
=
do
teamNode
<-
lift
$
getNode
$
UnsafeMkNodeId
team_node_id
...
...
src/Gargantext/API/GraphQL/User.hs
View file @
ec01d870
...
...
@@ -16,7 +16,6 @@ module Gargantext.API.GraphQL.User where
import
Data.Morpheus.Types
(
GQLType
)
import
Gargantext.API.Admin.Auth.Types
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Auth.PolicyCheck
import
Gargantext.API.GraphQL.PolicyCheck
import
Gargantext.API.GraphQL.Types
...
...
@@ -88,21 +87,21 @@ resolveHyperdata
=>
UserId
->
GqlM
e
env
(
Maybe
HyperdataUser
)
resolveHyperdata
userid
=
lift
(
listToMaybe
<$>
DBUser
.
getUserHyperdata
(
Individu
.
UserDBId
userid
))
updateUserPubmedAPIKey
::
(
CmdCommon
env
,
HasSettings
env
)
=>
updateUserPubmedAPIKey
::
(
CmdCommon
env
)
=>
UserPubmedAPIKeyMArgs
->
GqlM'
e
env
Int
updateUserPubmedAPIKey
UserPubmedAPIKeyMArgs
{
user_id
,
api_key
}
=
do
_
<-
lift
$
DBUser
.
updateUserPubmedAPIKey
(
Individu
.
RootId
$
UnsafeMkNodeId
user_id
)
api_key
pure
1
updateUserEPOAPIUser
::
(
CmdCommon
env
,
HasSettings
env
)
=>
updateUserEPOAPIUser
::
(
CmdCommon
env
)
=>
UserEPOAPIUserMArgs
->
GqlM'
e
env
Int
updateUserEPOAPIUser
UserEPOAPIUserMArgs
{
user_id
,
api_user
}
=
do
_
<-
lift
$
DBUser
.
updateUserEPOAPIUser
(
Individu
.
RootId
$
UnsafeMkNodeId
user_id
)
api_user
pure
1
updateUserEPOAPIToken
::
(
CmdCommon
env
,
HasSettings
env
)
=>
updateUserEPOAPIToken
::
(
CmdCommon
env
)
=>
UserEPOAPITokenMArgs
->
GqlM'
e
env
Int
updateUserEPOAPIToken
UserEPOAPITokenMArgs
{
user_id
,
api_token
}
=
do
_
<-
lift
$
DBUser
.
updateUserEPOAPIToken
(
Individu
.
RootId
$
UnsafeMkNodeId
user_id
)
api_token
...
...
src/Gargantext/API/GraphQL/UserInfo.hs
View file @
ec01d870
...
...
@@ -41,11 +41,11 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact
,
hc_who
,
hc_where
)
import
Gargantext.API.Admin.Auth.Types
hiding
(
Valid
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Auth.PolicyCheck
import
Gargantext.API.GraphQL.PolicyCheck
import
Gargantext.API.GraphQL.Types
import
Gargantext.API.GraphQL.Utils
(
AuthStatus
(
Invalid
,
Valid
),
authUser
)
import
Gargantext.Core.Config
(
HasJWTSettings
)
import
Gargantext.Core.Types.Individu
qualified
as
Individu
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
...
...
@@ -117,7 +117,7 @@ resolveUserInfos autUser mgr UserInfoArgs { user_id } =
-- | Mutation for user info
updateUserInfo
::
(
CmdCommon
env
,
HasSettings
env
)
::
(
CmdCommon
env
,
Has
JWT
Settings
env
)
-- => UserInfoMArgs -> ResolverM e (GargM env err) Int
=>
UserInfoMArgs
->
GqlM'
e
env
Int
updateUserInfo
(
UserInfoMArgs
{
ui_id
,
..
})
=
do
...
...
src/Gargantext/API/GraphQL/Utils.hs
View file @
ec01d870
...
...
@@ -14,7 +14,7 @@ module Gargantext.API.GraphQL.Utils where
import
Control.Lens
(
view
)
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
(
..
),
auth_node_id
)
import
Gargantext.
API.Admin.Types
(
jwtSettings
,
HasSettings
(
settings
))
import
Gargantext.
Core.Config
(
HasJWTSettings
(
..
))
import
Gargantext.Database.Admin.Types.Node
(
NodeId
)
import
Gargantext.Database.Prelude
(
Cmd
'
)
import
Gargantext.Prelude
...
...
@@ -22,10 +22,10 @@ import Servant.Auth.Server (verifyJWT, JWTSettings)
data
AuthStatus
=
Valid
|
Invalid
authUser
::
(
HasSettings
env
)
=>
NodeId
->
Text
->
Cmd'
env
err
AuthStatus
authUser
::
(
Has
JWT
Settings
env
)
=>
NodeId
->
Text
->
Cmd'
env
err
AuthStatus
authUser
ui_id
token
=
do
let
token'
=
encodeUtf8
token
jwtS
<-
view
$
settings
.
jwtSettings
jwtS
<-
view
jwtSettings
u
<-
liftBase
$
getUserFromToken
jwtS
token'
case
u
of
Nothing
->
pure
Invalid
...
...
src/Gargantext/API/Metrics.hs
View file @
ec01d870
...
...
@@ -260,7 +260,7 @@ updatePie cId maybeListId tabType maybeLimit = do
_
<-
updatePie'
cId
listId
tabType
maybeLimit
pure
()
updatePie'
::
(
HasNodeStory
env
err
m
,
HasNodeError
err
)
updatePie'
::
(
HasNodeStory
env
err
m
)
=>
CorpusId
->
ListId
->
TabType
...
...
src/Gargantext/API/Ngrams.hs
View file @
ec01d870
...
...
@@ -99,7 +99,6 @@ import Gargantext.Core.Types (ListType(..), NodeId, ListId, TODO, assertValid, H
import
Gargantext.Core.Types.Query
(
Limit
(
..
),
Offset
(
..
),
MinSize
(
..
),
MaxSize
(
..
))
import
Gargantext.Database.Action.Metrics.NgramsByContext
(
getOccByNgramsOnlyFast
)
import
Gargantext.Database.Query.Table.Ngrams
(
text2ngrams
,
insertNgrams
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Prelude
hiding
(
log
,
to
,
toLower
,
(
%
),
isInfixOf
)
import
Gargantext.Prelude.Clock
(
hasTime
,
getTime
)
import
Text.Collate
qualified
as
Unicode
...
...
@@ -256,7 +255,6 @@ newNgramsFromNgramsStatePatch p =
commitStatePatch
::
(
HasNodeStory
env
err
m
,
HasNodeStoryImmediateSaver
env
,
HasNodeArchiveStoryImmediateSaver
env
)
=>
ListId
->
Versioned
NgramsStatePatch'
...
...
@@ -364,7 +362,6 @@ tableNgramsPull listId ngramsType p_version = do
-- client.
-- TODO-ACCESS check
tableNgramsPut
::
(
HasNodeStory
env
err
m
,
HasNodeStoryImmediateSaver
env
,
HasNodeArchiveStoryImmediateSaver
env
,
HasValidationError
err
)
...
...
@@ -520,8 +517,7 @@ unicodeDUCETSorter :: Text -> Text -> Ordering
unicodeDUCETSorter
=
Unicode
.
collate
Unicode
.
rootCollator
getTableNgrams
::
forall
env
err
m
.
(
HasNodeStory
env
err
m
,
HasNodeError
err
)
(
HasNodeStory
env
err
m
)
=>
NodeId
->
ListId
->
TabType
...
...
@@ -535,8 +531,7 @@ getTableNgrams nodeId listId tabType searchQuery = do
-- | Helper function to get the ngrams table with scores.
getNgramsTable'
::
forall
env
err
m
.
(
HasNodeStory
env
err
m
,
HasNodeError
err
)
(
HasNodeStory
env
err
m
)
=>
NodeId
->
ListId
->
NgramsType
...
...
@@ -549,8 +544,7 @@ getNgramsTable' nId listId ngramsType = do
-- | Helper function to set scores on an `NgramsTable`.
setNgramsTableScores
::
forall
env
err
m
t
.
(
Each
t
t
NgramsElement
NgramsElement
,
HasNodeStory
env
err
m
,
HasNodeError
err
)
,
HasNodeStory
env
err
m
)
=>
NodeId
->
ListId
->
NgramsType
...
...
@@ -586,8 +580,7 @@ needsScores (Just ScoreAsc) = True
needsScores
(
Just
ScoreDesc
)
=
True
needsScores
_
=
False
getTableNgramsCorpus
::
(
HasNodeStory
env
err
m
,
HasNodeError
err
)
getTableNgramsCorpus
::
(
HasNodeStory
env
err
m
)
=>
NodeId
->
TabType
->
ListId
...
...
src/Gargantext/API/Ngrams/Types.hs
View file @
ec01d870
...
...
@@ -15,7 +15,7 @@ Portability : POSIX
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS -fno-warn-orphans #-}
{-# OPTIONS -fno-warn-orphans #-}
-- some instances are orphaned here
module
Gargantext.API.Ngrams.Types
where
...
...
@@ -38,21 +38,20 @@ import Data.TreeDiff
import
Data.Validity
(
Validity
(
..
)
)
import
Database.PostgreSQL.Simple.FromField
(
FromField
,
fromField
,
fromJSONField
)
import
Database.PostgreSQL.Simple.ToField
(
ToField
,
toJSONField
,
toField
)
import
Gargantext.Core.Config
(
HasConfig
)
import
Gargantext.Core.Text
(
size
)
import
Gargantext.Core.Text.Ngrams
qualified
as
Ngrams
import
Gargantext.Core.Types
(
ListType
(
..
),
ListId
,
NodeId
,
TODO
)
import
Gargantext.Core.Types.Query
(
Limit
,
Offset
,
MaxSize
,
MinSize
)
import
Gargantext.Core.Utils.Prefix
(
unPrefix
,
unPrefixUntagged
,
unPrefixSwagger
,
wellNamedSchema
)
import
Gargantext.Database.Admin.Types.Node
(
ContextId
)
import
Gargantext.Database.Prelude
(
fromField'
,
HasConnectionPool
,
HasConfig
,
CmdM
'
)
import
Gargantext.Database.Prelude
(
fromField'
,
HasConnectionPool
,
CmdM
'
)
import
Gargantext.Prelude
hiding
(
IsString
,
hash
,
from
,
replace
,
to
)
import
Gargantext.Prelude.Crypto.Hash
(
IsHashable
(
..
))
import
Gargantext.Utils.Servant
(
TSV
,
ZIP
)
import
Gargantext.Utils.Zip
(
zipContentsPure
)
import
Servant
(
FromHttpApiData
(
parseUrlPiece
),
ToHttpApiData
(
toUrlPiece
),
Required
,
Strict
,
QueryParam
'
,
MimeRender
(
..
),
MimeUnrender
(
..
))
import
Servant.Job.Utils
(
jsonOptions
)
import
Test.QuickCheck
(
elements
,
frequency
)
import
Test.QuickCheck.Arbitrary
(
Arbitrary
,
arbitrary
)
------------------------------------------------------------------------
...
...
@@ -95,7 +94,7 @@ instance ToJSONKey TabType where
newtype
MSet
a
=
MSet
(
Map
a
()
)
deriving
stock
(
Eq
,
Ord
,
Show
,
Read
,
Generic
)
deriving
newtype
(
Arbitrary
,
Semigroup
,
Monoid
)
deriving
newtype
(
Semigroup
,
Monoid
)
deriving
anyclass
(
ToExpr
)
instance
ToJSON
a
=>
ToJSON
(
MSet
a
)
where
...
...
@@ -122,14 +121,14 @@ instance Foldable MSet where
instance
(
Ord
a
,
FromJSON
a
)
=>
FromJSON
(
MSet
a
)
where
parseJSON
=
fmap
mSetFromList
.
parseJSON
instance
(
ToJSONKey
a
,
ToSchema
a
)
=>
ToSchema
(
MSet
a
)
where
instance
ToSchema
(
MSet
a
)
where
-- TODO
declareNamedSchema
_
=
wellNamedSchema
""
(
Proxy
::
Proxy
TODO
)
------------------------------------------------------------------------
newtype
NgramsTerm
=
NgramsTerm
{
unNgramsTerm
::
Text
}
deriving
(
Ord
,
Eq
,
Show
,
Read
,
Generic
)
deriving
newtype
(
ToJSONKey
,
ToJSON
,
FromJSON
,
Semigroup
,
Arbitrary
,
Serialise
,
ToSchema
,
Hashable
,
NFData
,
FromField
,
ToField
)
deriving
newtype
(
ToJSONKey
,
ToJSON
,
FromJSON
,
Semigroup
,
Serialise
,
ToSchema
,
Hashable
,
NFData
,
FromField
,
ToField
)
deriving
anyclass
(
ToExpr
)
instance
IsHashable
NgramsTerm
where
hash
(
NgramsTerm
t
)
=
hash
t
...
...
@@ -242,24 +241,6 @@ toNgramsElement ns = map toNgramsElement' ns
$ map (\(NgramsTableData _ p t _ _ _) -> (p, Set.singleton t)) ns
-}
mockTable
::
NgramsTable
mockTable
=
NgramsTable
[
mkNgramsElement
"animal"
MapTerm
Nothing
(
mSetFromList
[
"dog"
,
"cat"
])
,
mkNgramsElement
"cat"
MapTerm
(
rp
"animal"
)
mempty
,
mkNgramsElement
"cats"
StopTerm
Nothing
mempty
,
mkNgramsElement
"dog"
MapTerm
(
rp
"animal"
)
(
mSetFromList
[
"dogs"
])
,
mkNgramsElement
"dogs"
StopTerm
(
rp
"dog"
)
mempty
,
mkNgramsElement
"fox"
MapTerm
Nothing
mempty
,
mkNgramsElement
"object"
CandidateTerm
Nothing
mempty
,
mkNgramsElement
"nothing"
StopTerm
Nothing
mempty
,
mkNgramsElement
"organic"
MapTerm
Nothing
(
mSetFromList
[
"flower"
])
,
mkNgramsElement
"flower"
MapTerm
(
rp
"organic"
)
mempty
,
mkNgramsElement
"moon"
CandidateTerm
Nothing
mempty
,
mkNgramsElement
"sky"
StopTerm
Nothing
mempty
]
where
rp
n
=
Just
$
RootParent
n
n
instance
ToSchema
NgramsTable
------------------------------------------------------------------------
...
...
@@ -411,7 +392,7 @@ makePrisms ''PatchMSet
_PatchMSetIso
::
Ord
a
=>
Iso'
(
PatchMSet
a
)
(
PatchSet
a
)
_PatchMSetIso
=
_PatchMSet
.
_PatchMap
.
iso
f
g
.
from
_PatchSet
where
f
::
Ord
a
=>
Map
a
(
Replace
(
Maybe
()
))
->
(
Set
a
,
Set
a
)
f
::
Map
a
(
Replace
(
Maybe
()
))
->
(
Set
a
,
Set
a
)
f
=
Map
.
partition
isRem
>>>
both
%~
Map
.
keysSet
g
::
Ord
a
=>
(
Set
a
,
Set
a
)
->
Map
a
(
Replace
(
Maybe
()
))
...
...
@@ -431,7 +412,7 @@ instance (Ord a, ToJSON a) => ToJSON (PatchMSet a) where
instance
(
Ord
a
,
FromJSON
a
)
=>
FromJSON
(
PatchMSet
a
)
where
parseJSON
=
fmap
(
_PatchMSetIso
#
)
.
parseJSON
instance
ToSchema
a
=>
ToSchema
(
PatchMSet
a
)
where
instance
ToSchema
(
PatchMSet
a
)
where
-- TODO
declareNamedSchema
_
=
wellNamedSchema
""
(
Proxy
::
Proxy
TODO
)
...
...
@@ -832,37 +813,6 @@ instance (Serialise a, Ord a) => Serialise (PatchMap a AddRem)
instance
(
Serialise
a
,
Ord
a
)
=>
Serialise
(
PatchMSet
a
)
instance
(
Serialise
s
,
Serialise
p
)
=>
Serialise
(
Repo
s
p
)
--
-- Arbitrary instances
--
instance
Arbitrary
TabType
where
arbitrary
=
elements
[
minBound
..
maxBound
]
instance
Arbitrary
NgramsElement
where
arbitrary
=
elements
[
newNgramsElement
Nothing
"sport"
]
instance
Arbitrary
NgramsTable
where
arbitrary
=
pure
mockTable
instance
Arbitrary
OrderBy
where
arbitrary
=
elements
[
minBound
..
maxBound
]
instance
(
Ord
a
,
Arbitrary
a
)
=>
Arbitrary
(
PatchMSet
a
)
where
arbitrary
=
(
PatchMSet
.
PM
.
fromMap
)
<$>
arbitrary
instance
(
Eq
a
,
Arbitrary
a
)
=>
Arbitrary
(
Replace
a
)
where
arbitrary
=
uncurry
replace
<$>
arbitrary
-- If they happen to be equal then the patch is Keep.
instance
Arbitrary
NgramsPatch
where
arbitrary
=
frequency
[
(
9
,
NgramsPatch
<$>
arbitrary
<*>
(
replace
<$>
arbitrary
<*>
arbitrary
))
,
(
1
,
NgramsReplace
<$>
arbitrary
<*>
arbitrary
)
]
instance
Arbitrary
NgramsTablePatch
where
arbitrary
=
NgramsTablePatch
<$>
PM
.
fromMap
<$>
arbitrary
instance
Arbitrary
a
=>
Arbitrary
(
Versioned
a
)
where
arbitrary
=
Versioned
1
<$>
arbitrary
-- TODO 1 is constant so far
instance
Arbitrary
a
=>
Arbitrary
(
VersionedWithCount
a
)
where
arbitrary
=
VersionedWithCount
1
1
<$>
arbitrary
-- TODO 1 is constant so far
instance
Arbitrary
NgramsRepoElement
where
arbitrary
=
elements
$
map
ngramsElementToRepo
ns
where
NgramsTable
ns
=
mockTable
toNgramsPatch
::
[
NgramsTerm
]
->
NgramsPatch
...
...
src/Gargantext/API/Node.hs
View file @
ec01d870
...
...
@@ -61,7 +61,6 @@ import Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Prelude
(
Cmd
,
JSONB
)
import
Gargantext.Database.Query.Table.Node
import
Gargantext.Database.Query.Table.Node.Children
(
getChildren
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
(
..
))
import
Gargantext.Database.Query.Table.Node.Update
(
Update
(
..
),
update
)
import
Gargantext.Database.Query.Table.Node.Update
qualified
as
U
(
update
,
Update
(
..
))
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
...
...
@@ -187,7 +186,7 @@ treeFlatAPI authenticatedUser rootId =
rename
::
NodeId
->
RenameNode
->
Cmd
err
[
Int
]
rename
nId
(
RenameNode
name'
)
=
U
.
update
(
U
.
Rename
nId
name'
)
putNode
::
forall
err
a
.
(
H
asNodeError
err
,
H
yperdataC
a
)
putNode
::
forall
err
a
.
(
HyperdataC
a
)
=>
NodeId
->
a
->
Cmd
err
Int
...
...
@@ -223,7 +222,7 @@ nodeAPI authenticatedUser = Named.NodeAPIEndpoint $ \targetNode ->
concreteAPI
=
genericNodeAPI'
(
Proxy
::
Proxy
HyperdataAny
)
authenticatedUser
-- | The /actual/ (generic) node API, instantiated depending on the concrete type of node.
genericNodeAPI'
::
forall
a
proxy
.
(
HyperdataC
a
,
Show
a
,
MimeUnrender
JSON
a
,
Named
.
IsGenericNodeRoute
a
)
genericNodeAPI'
::
forall
a
proxy
.
(
HyperdataC
a
)
=>
proxy
a
->
AuthenticatedUser
->
NodeId
...
...
src/Gargantext/API/Node/Contact.hs
View file @
ec01d870
...
...
@@ -22,7 +22,6 @@ import Conduit ( yield )
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
(
AuthenticatedUser
)
)
import
Gargantext.API.Admin.EnvTypes
(
Env
,
GargJob
(
..
))
import
Gargantext.API.Admin.Orchestrator.Types
(
AsyncJobs
(
..
))
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Node
(
nodeNodeAPI
)
import
Gargantext.API.Node.Contact.Types
...
...
@@ -54,7 +53,7 @@ api_async u nId = Named.ContactAsyncAPI $ AsyncJobs $
serveJobsAPI
AddContactJob
$
\
jHandle
p
->
addContact
u
nId
p
jHandle
addContact
::
(
HasSettings
env
,
FlowCmdM
env
err
m
,
MonadJobStatus
m
)
addContact
::
(
FlowCmdM
env
err
m
,
MonadJobStatus
m
)
=>
User
->
NodeId
->
AddContactParams
...
...
src/Gargantext/API/Node/Corpus/New.hs
View file @
ec01d870
...
...
@@ -29,7 +29,6 @@ import Data.Text qualified as T
import
Data.Text.Encoding
qualified
as
TE
import
EPO.API.Client.Types
qualified
as
EPO
import
Gargantext.API.Admin.Orchestrator.Types
qualified
as
API
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Ngrams
(
commitStatePatch
,
Versioned
(
..
))
import
Gargantext.API.Node.Corpus.New.Types
(
FileFormat
(
..
),
FileType
(
..
)
)
import
Gargantext.API.Node.Corpus.Searx
(
triggerSearxSearch
)
...
...
@@ -37,7 +36,7 @@ import Gargantext.API.Node.Corpus.Types ( Datafield(Web), database2origin )
import
Gargantext.API.Node.Corpus.Update
(
addLanguageToCorpus
)
import
Gargantext.API.Node.Types
import
Gargantext.Core
(
withDefaultLanguage
,
defaultLanguage
)
import
Gargantext.Core.Config
(
gc_jobs
)
import
Gargantext.Core.Config
(
gc_jobs
,
hasConfig
)
import
Gargantext.Core.Config.Types
(
jc_max_docs_parsers
)
import
Gargantext.Core.NodeStory
(
HasNodeStoryImmediateSaver
,
HasNodeArchiveStoryImmediateSaver
,
currentVersion
,
NgramsStatePatch
'
)
import
Gargantext.Core.Text.Corpus.Parsers
qualified
as
Parser
(
FileType
(
..
),
parseFormatC
,
_ParseFormatError
)
...
...
@@ -53,7 +52,6 @@ import Gargantext.Database.Admin.Types.Hyperdata.Document ( ToHyperdataDocument(
import
Gargantext.Database.Admin.Types.Hyperdata.File
(
HyperdataFile
(
..
)
)
import
Gargantext.Database.Admin.Types.Node
(
CorpusId
,
NodeType
(
..
),
ParentId
)
import
Gargantext.Database.GargDB
qualified
as
GargDB
import
Gargantext.Database.Prelude
(
hasConfig
)
import
Gargantext.Database.Query.Table.Node
(
getNodeWith
,
getOrMkList
)
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
import
Gargantext.Database.Query.Tree.Root
(
MkCorpusUser
(
MkCorpusUserNormalCorpusIds
))
...
...
@@ -149,7 +147,6 @@ addToCorpusWithQuery :: ( FlowCmdM env err m
,
MonadJobStatus
m
,
HasNodeStoryImmediateSaver
env
,
HasNodeArchiveStoryImmediateSaver
env
,
HasSettings
env
)
=>
User
->
CorpusId
...
...
@@ -223,7 +220,6 @@ addToCorpusWithForm :: ( FlowCmdM env err m
,
MonadJobStatus
m
,
HasNodeStoryImmediateSaver
env
,
HasNodeArchiveStoryImmediateSaver
env
,
HasSettings
env
)
=>
User
->
CorpusId
...
...
@@ -327,7 +323,7 @@ addToCorpusWithFile cid input filetype logStatus = do
}
-}
addToCorpusWithFile
::
(
HasSettings
env
,
FlowCmdM
env
err
m
,
MonadJobStatus
m
)
addToCorpusWithFile
::
(
FlowCmdM
env
err
m
,
MonadJobStatus
m
)
=>
User
->
CorpusId
->
NewWithFile
...
...
src/Gargantext/API/Node/Corpus/Searx.hs
View file @
ec01d870
...
...
@@ -21,9 +21,8 @@ import Data.Text qualified as Text
import
Data.Time.Calendar
(
Day
,
toGregorian
)
import
Data.Time.Format
(
defaultTimeLocale
,
formatTime
,
parseTimeM
)
import
Data.Tuple.Select
(
sel1
,
sel2
,
sel3
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.Core
(
Lang
(
..
))
import
Gargantext.Core.Config
(
GargConfig
(
..
))
import
Gargantext.Core.Config
(
GargConfig
(
..
)
,
hasConfig
)
import
Gargantext.Core.Config.Types
(
FramesConfig
(
..
))
import
Gargantext.Core.NLP
(
HasNLPServer
,
nlpServerGet
)
import
Gargantext.Core.NodeStory.Types
(
HasNodeStory
)
...
...
@@ -40,7 +39,6 @@ import Gargantext.Database.Action.User (getUserId)
import
Gargantext.Database.Admin.Types.Hyperdata.Corpus
(
HyperdataCorpus
)
import
Gargantext.Database.Admin.Types.Hyperdata.Document
(
HyperdataDocument
(
..
))
import
Gargantext.Database.Admin.Types.Node
(
CorpusId
,
ListId
,
NodeType
(
NodeTexts
))
import
Gargantext.Database.Prelude
(
hasConfig
)
import
Gargantext.Database.Query.Table.Node
(
getOrMkList
,
insertDefaultNodeIfNotExists
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Tree.Error
(
HasTreeError
)
...
...
@@ -124,7 +122,6 @@ insertSearxResponse :: ( MonadBase IO m
,
HasNodeError
err
,
HasTreeError
err
,
HasValidationError
err
,
HasSettings
env
)
=>
User
->
CorpusId
...
...
@@ -169,7 +166,6 @@ triggerSearxSearch :: ( MonadBase IO m
,
HasTreeError
err
,
HasValidationError
err
,
MonadJobStatus
m
,
HasSettings
env
)
=>
User
->
CorpusId
...
...
src/Gargantext/API/Node/DocumentUpload.hs
View file @
ec01d870
...
...
@@ -20,7 +20,6 @@ import Control.Lens (view)
import
Data.Text
qualified
as
T
import
Gargantext.API.Admin.EnvTypes
(
GargJob
(
..
),
Env
)
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Node.DocumentUpload.Types
import
Gargantext.API.Prelude
(
GargM
)
...
...
@@ -45,7 +44,7 @@ api nId = Named.DocumentUploadAPI $ AsyncJobs $
serveJobsAPI
UploadDocumentJob
$
\
jHandle
q
->
do
documentUploadAsync
nId
q
jHandle
documentUploadAsync
::
(
FlowCmdM
env
err
m
,
MonadJobStatus
m
,
HasSettings
env
)
documentUploadAsync
::
(
FlowCmdM
env
err
m
,
MonadJobStatus
m
)
=>
NodeId
->
DocumentUpload
->
JobHandle
m
...
...
@@ -56,7 +55,7 @@ documentUploadAsync nId doc jobHandle = do
-- printDebug "documentUploadAsync" docIds
markComplete
jobHandle
documentUpload
::
(
FlowCmdM
env
err
m
,
HasSettings
env
)
documentUpload
::
(
FlowCmdM
env
err
m
)
=>
NodeId
->
DocumentUpload
->
m
[
DocId
]
...
...
src/Gargantext/API/Node/DocumentsFromWriteNodes.hs
View file @
ec01d870
...
...
@@ -22,7 +22,6 @@ import Data.Text qualified as T
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
,
auth_node_id
,
auth_user_id
)
import
Gargantext.API.Admin.EnvTypes
(
Env
,
GargJob
(
..
))
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Ngrams
(
commitStatePatch
,
Versioned
(
..
))
import
Gargantext.API.Node.DocumentsFromWriteNodes.Types
...
...
@@ -55,8 +54,7 @@ api authenticatedUser nId = Named.DocumentsFromWriteNodesAPI $ AsyncJobs $
serveJobsAPI
DocumentFromWriteNodeJob
$
\
jHandle
p
->
documentsFromWriteNodes
authenticatedUser
nId
p
jHandle
documentsFromWriteNodes
::
(
HasSettings
env
,
FlowCmdM
env
err
m
documentsFromWriteNodes
::
(
FlowCmdM
env
err
m
,
MonadJobStatus
m
,
HasNodeStoryImmediateSaver
env
,
HasNodeArchiveStoryImmediateSaver
env
)
...
...
src/Gargantext/API/Node/File.hs
View file @
ec01d870
...
...
@@ -22,7 +22,6 @@ import Data.Text qualified as T
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
,
auth_user_id
)
import
Gargantext.API.Admin.EnvTypes
(
GargJob
(
..
),
Env
)
import
Gargantext.API.Admin.Orchestrator.Types
(
AsyncJobs
(
..
))
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Node.File.Types
import
Gargantext.API.Node.Types
(
NewWithFile
(
NewWithFile
)
)
...
...
@@ -41,12 +40,12 @@ import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
import
Servant
import
Servant.Server.Generic
(
AsServerT
)
fileApi
::
(
HasSettings
env
,
FlowCmdM
env
err
m
)
fileApi
::
(
FlowCmdM
env
err
m
)
=>
NodeId
->
m
(
Headers
'[
S
ervant
.
Header
"Content-Type"
Text
]
BSResponse
)
fileApi
nId
=
fileDownload
nId
fileDownload
::
(
HasSettings
env
,
FlowCmdM
env
err
m
)
fileDownload
::
(
FlowCmdM
env
err
m
)
=>
NodeId
->
m
(
Headers
'[
S
ervant
.
Header
"Content-Type"
Text
]
BSResponse
)
fileDownload
nId
=
do
...
...
@@ -83,7 +82,7 @@ fileAsyncApi authenticatedUser nId = Named.FileAsyncAPI $ AsyncJobs $
addWithFile
authenticatedUser
nId
i
jHandle
addWithFile
::
(
HasSettings
env
,
FlowCmdM
env
err
m
,
MonadJobStatus
m
)
addWithFile
::
(
FlowCmdM
env
err
m
,
MonadJobStatus
m
)
=>
AuthenticatedUser
-- ^ The logged-in user
->
NodeId
...
...
src/Gargantext/API/Node/FrameCalcUpload.hs
View file @
ec01d870
...
...
@@ -28,12 +28,12 @@ import Gargantext.API.Node.FrameCalcUpload.Types
import
Gargantext.API.Node.Types
(
NewWithForm
(
..
))
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.API.Routes.Named.FrameCalc
qualified
as
Named
import
Gargantext.Core.Config
(
HasConfig
)
import
Gargantext.Core.NodeStory.Types
(
HasNodeArchiveStoryImmediateSaver
)
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
import
Gargantext.Database.Admin.Types.Hyperdata.Frame
(
HyperdataFrame
(
..
)
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
,
NodeType
(
NodeCorpus
)
)
import
Gargantext.Database.Prelude
(
HasConfig
)
import
Gargantext.Database.Query.Table.Node
(
getClosestParentIdByType
,
getNodeWith
)
import
Gargantext.Database.Schema.Node
(
node_hyperdata
)
import
Gargantext.Prelude
...
...
@@ -41,7 +41,6 @@ import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..), markFailureNoErr
import
Network.HTTP.Client
(
newManager
,
httpLbs
,
parseRequest
,
responseBody
)
import
Network.HTTP.Client.TLS
(
tlsManagerSettings
)
import
Servant.Server.Generic
(
AsServerT
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
api
::
AuthenticatedUser
->
NodeId
->
Named
.
FrameCalcAPI
(
AsServerT
(
GargM
Env
BackendInternalError
))
...
...
@@ -55,7 +54,6 @@ frameCalcUploadAsync :: ( HasConfig env
,
FlowCmdM
env
err
m
,
MonadJobStatus
m
,
HasNodeArchiveStoryImmediateSaver
env
,
HasSettings
env
)
=>
AuthenticatedUser
-- ^ The logged-in user
...
...
src/Gargantext/API/Node/New.hs
View file @
ec01d870
...
...
@@ -36,10 +36,9 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import
Gargantext.Prelude
import
Gargantext.Utils.Jobs
(
serveJobsAPI
,
MonadJobStatus
(
..
))
import
Servant.Server.Generic
(
AsServerT
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
------------------------------------------------------------------------
postNode
::
(
HasNodeError
err
,
HasSettings
env
,
CE
.
HasCentralExchangeNotification
env
)
postNode
::
(
HasNodeError
err
,
CE
.
HasCentralExchangeNotification
env
)
=>
AuthenticatedUser
-- ^ The logged-in user
->
NodeId
...
...
@@ -64,7 +63,7 @@ postNodeAsyncAPI authenticatedUser nId = Named.PostNodeAsyncAPI $ AsyncJobs $
serveJobsAPI
NewNodeJob
$
\
jHandle
p
->
postNodeAsync
authenticatedUser
nId
p
jHandle
------------------------------------------------------------------------
postNodeAsync
::
(
FlowCmdM
env
err
m
,
MonadJobStatus
m
,
HasSettings
env
,
CE
.
HasCentralExchangeNotification
env
)
postNodeAsync
::
(
FlowCmdM
env
err
m
,
MonadJobStatus
m
,
CE
.
HasCentralExchangeNotification
env
)
=>
AuthenticatedUser
-- ^ The logged in user
->
NodeId
...
...
src/Gargantext/API/Node/Share.hs
View file @
ec01d870
...
...
@@ -33,7 +33,6 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import
Gargantext.Database.Query.Tree
(
findNodesWithType
)
import
Gargantext.Prelude
import
Servant.Server.Generic
(
AsServerT
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
------------------------------------------------------------------------
-- TODO permission
...
...
@@ -42,7 +41,6 @@ import Gargantext.API.Admin.Types (HasSettings)
api
::
(
HasNodeError
err
,
HasNLPServer
env
,
CmdRandom
env
err
m
,
HasSettings
env
,
HasCentralExchangeNotification
env
)
=>
User
->
NodeId
...
...
src/Gargantext/API/Node/ShareURL.hs
View file @
ec01d870
...
...
@@ -7,13 +7,12 @@ module Gargantext.API.Node.ShareURL where
import
Control.Lens
import
Data.Text
qualified
as
T
import
Data.Validity
qualified
as
V
import
Gargantext.API.Admin.Types
(
appPort
,
settings
,
Settings
)
import
Gargantext.API.Prelude
import
Gargantext.API.Routes.Named.Share
qualified
as
Named
import
Gargantext.Core.Config
(
GargConfig
,
gc_frontend_config
)
import
Gargantext.Core.Config.Types
(
fc_url
)
import
Gargantext.Core.Config
(
GargConfig
,
gc_frontend_config
,
HasConfig
(
hasConfig
)
)
import
Gargantext.Core.Config.Types
(
fc_
appPort
,
fc_
url
)
import
Gargantext.Core.Types
(
NodeType
,
NodeId
,
unNodeId
,
_ValidationError
)
import
Gargantext.Database.Prelude
(
HasConfig
(
hasConfig
),
CmdCommon
)
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
Gargantext.Prelude
import
Network.URI
(
parseURI
)
import
Prelude
(
String
)
...
...
@@ -29,19 +28,17 @@ getUrl :: (IsGargServer env err m, CmdCommon env)
getUrl
nt
id
=
do
-- TODO add check that the node is able to be shared (in a shared folder)
gc
<-
view
hasConfig
urlPort
<-
view
settings
case
get_url
nt
id
gc
urlPort
of
case
get_url
nt
id
gc
of
Left
err
->
throwError
$
_ValidationError
#
(
V
.
check
False
err
)
Right
shareLink
->
pure
shareLink
get_url
::
Maybe
NodeType
->
Maybe
NodeId
->
GargConfig
->
Settings
->
Either
String
Named
.
ShareLink
get_url
nt
id
gc
stgs
=
do
get_url
nt
id
gc
=
do
let
urlHost
=
T
.
unpack
$
gc
^.
gc_frontend_config
.
fc_url
let
urlPort
=
stgs
^.
appPort
let
urlPort
=
gc
^.
gc_frontend_config
.
fc_
appPort
t
<-
maybe
(
Left
"Invalid node Type"
)
Right
nt
i
<-
maybe
(
Left
"Invalid node ID"
)
Right
id
...
...
src/Gargantext/API/Node/Update.hs
View file @
ec01d870
...
...
@@ -18,7 +18,6 @@ import Control.Lens (view)
import
Data.Set
qualified
as
Set
import
Gargantext.API.Admin.EnvTypes
(
GargJob
(
..
),
Env
)
import
Gargantext.API.Admin.Orchestrator.Types
(
AsyncJobs
(
..
))
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Metrics
qualified
as
Metrics
import
Gargantext.API.Ngrams.Types
qualified
as
NgramsTypes
...
...
@@ -52,7 +51,6 @@ api nId = Named.UpdateAPI $ AsyncJobs $
updateNode
nId
p
jHandle
updateNode
::
(
HasNodeStory
env
err
m
,
HasSettings
env
,
MonadJobStatus
m
,
MonadLogger
m
)
...
...
src/Gargantext/API/Prelude.hs
View file @
ec01d870
...
...
@@ -24,14 +24,14 @@ import Control.Lens ((#))
import
Data.Aeson.Types
import
Gargantext.API.Admin.Auth.Types
(
AuthenticationError
)
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Admin.Types
import
Gargantext.API.Errors.Class
import
Gargantext.Core.AsyncUpdates.CentralExchange.Types
(
HasCentralExchangeNotification
)
import
Gargantext.Core.Config
(
HasConfig
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.NLP
(
HasNLPServer
)
import
Gargantext.Core.NodeStory
import
Gargantext.Core.Types
import
Gargantext.Database.Prelude
(
CmdM
,
CmdRandom
,
HasConnectionPool
,
HasConfig
)
import
Gargantext.Database.Prelude
(
CmdM
,
CmdRandom
,
HasConnectionPool
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
(
..
))
import
Gargantext.Database.Query.Tree
import
Gargantext.Prelude
...
...
@@ -48,7 +48,6 @@ type HasJobEnv' env = HasJobEnv env JobLog JobLog
type
EnvC
env
=
(
HasConnectionPool
env
,
HasSettings
env
-- TODO rename HasDbSettings
,
HasJobEnv
env
JobLog
JobLog
,
HasConfig
env
,
HasNodeStoryEnv
env
...
...
@@ -96,7 +95,6 @@ type GargNoServer t =
type
GargNoServer'
env
err
m
=
(
CmdM
env
err
m
,
HasNodeStory
env
err
m
,
HasSettings
env
,
HasNodeError
err
)
...
...
src/Gargantext/API/Routes.hs
View file @
ec01d870
...
...
@@ -30,10 +30,9 @@ import Gargantext.API.Node.Corpus.New qualified as New
import
Gargantext.API.Prelude
import
Gargantext.API.Routes.Named.Annuaire
qualified
as
Named
import
Gargantext.API.Routes.Named.Corpus
qualified
as
Named
import
Gargantext.Core.Config
(
gc_jobs
)
import
Gargantext.Core.Config
(
gc_jobs
,
HasConfig
(
..
)
)
import
Gargantext.Core.Config.Types
(
jc_max_docs_scrapers
)
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Database.Prelude
(
HasConfig
(
..
))
import
Gargantext.Prelude
import
Gargantext.Utils.Jobs
(
serveJobsAPI
,
MonadJobStatus
(
..
))
import
Servant
...
...
src/Gargantext/API/Server/Named.hs
View file @
ec01d870
...
...
@@ -23,9 +23,8 @@ import Gargantext.API.Server.Named.Public (serverPublicGargAPI)
import
Gargantext.API.Swagger
(
swaggerDoc
)
import
Gargantext.API.ThrowAll
(
serverPrivateGargAPI
)
import
Gargantext.Core.AsyncUpdates.Dispatcher.WebSocket
qualified
as
Dispatcher
import
Gargantext.Core.Config
(
gc_frontend_config
)
import
Gargantext.Core.Config
(
gc_frontend_config
,
hasConfig
)
import
Gargantext.Core.Config.Types
(
fc_url_backend_api
)
import
Gargantext.Database.Prelude
(
hasConfig
)
import
Gargantext.Prelude
hiding
(
Handler
,
catch
)
import
Gargantext.System.Logging
(
logLocM
,
LogLevel
(
..
))
import
Paths_gargantext
qualified
as
PG
-- cabal magic build module
...
...
src/Gargantext/API/Server/Named/Ngrams.hs
View file @
ec01d870
...
...
@@ -12,7 +12,6 @@ import Gargantext.API.Admin.Auth (withNamedAccess)
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
,
PathId
(
..
))
import
Gargantext.API.Admin.EnvTypes
import
Gargantext.API.Admin.Orchestrator.Types
(
AsyncJobs
(
..
))
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Metrics
qualified
as
Metrics
import
Gargantext.API.Ngrams
...
...
@@ -72,7 +71,6 @@ apiNgramsAsync _dId = Named.TableNgramsAsyncAPI $ AsyncJobs $
tableNgramsPostChartsAsync
::
(
HasNodeStory
env
err
m
,
HasSettings
env
,
MonadJobStatus
m
)
=>
UpdateTableNgramsCharts
->
JobHandle
m
...
...
src/Gargantext/Core/AsyncUpdates/Dispatcher/Types.hs
View file @
ec01d870
...
...
@@ -31,7 +31,6 @@ import DeferredFolds.UnfoldlM qualified as UnfoldlM
import
Data.UUID.V4
as
UUID
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
(
_auth_user_id
))
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
)
import
Gargantext.API.Admin.Types
(
jwtSettings
,
Settings
,
jwtSettings
)
import
Gargantext.API.Prelude
(
IsGargServer
)
import
Gargantext.Core.AsyncUpdates.CentralExchange.Types
qualified
as
CETypes
import
Gargantext.Core.Types
(
NodeId
,
UserId
)
...
...
src/Gargantext/Core/AsyncUpdates/Dispatcher/WebSocket.hs
View file @
ec01d870
...
...
@@ -23,17 +23,17 @@ import Control.Lens (view)
import
Data.Aeson
qualified
as
Aeson
import
Data.UUID.V4
as
UUID
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
(
_auth_user_id
))
import
Gargantext.API.Admin.Types
(
HasSettings
(
settings
),
Settings
,
jwtSettings
)
import
Gargantext.API.Prelude
(
IsGargServer
)
import
Gargantext.Core.AsyncUpdates.Dispatcher.Subscriptions
import
Gargantext.Core.AsyncUpdates.Dispatcher.Types
import
Gargantext.Core.AsyncUpdates.Dispatcher
(
Dispatcher
,
dispatcherSubscriptions
)
import
Gargantext.Core.Config
(
HasJWTSettings
(
jwtSettings
))
import
Gargantext.Prelude
import
Gargantext.System.Logging
(
LogLevel
(
DEBUG
),
logMsg
,
withLogger
)
import
Network.WebSockets
qualified
as
WS
import
Servant
import
Servant.API.WebSocket
qualified
as
WS
(
WebSocketPending
)
import
Servant.Auth.Server
(
verifyJWT
)
import
Servant.Auth.Server
(
JWTSettings
,
verifyJWT
)
import
Servant.Server.Generic
(
AsServerT
)
import
StmContainers.Set
as
SSet
...
...
@@ -43,19 +43,19 @@ newtype WSAPI mode = WSAPI {
}
deriving
Generic
wsServer
::
(
IsGargServer
env
err
m
,
HasDispatcher
env
Dispatcher
,
HasSettings
env
)
=>
WSAPI
(
AsServerT
m
)
wsServer
::
(
IsGargServer
env
err
m
,
HasDispatcher
env
Dispatcher
,
Has
JWT
Settings
env
)
=>
WSAPI
(
AsServerT
m
)
wsServer
=
WSAPI
{
wsAPIServer
=
streamData
}
where
streamData
::
(
IsGargServer
env
err
m
,
HasDispatcher
env
Dispatcher
,
HasSettings
env
)
streamData
::
(
IsGargServer
env
err
m
,
HasDispatcher
env
Dispatcher
,
Has
JWT
Settings
env
)
=>
WS
.
PendingConnection
->
m
()
streamData
pc
=
do
authSettings
<-
view
s
ettings
jwtS
<-
view
jwtS
ettings
d
<-
view
hasDispatcher
let
subscriptions
=
dispatcherSubscriptions
d
key
<-
getWSKey
pc
c
<-
liftBase
$
WS
.
acceptRequest
pc
let
ws
=
WSKeyConnection
(
key
,
c
)
_
<-
liftBase
$
Async
.
concurrently
(
wsLoop
authSettings
subscriptions
ws
)
(
pingLoop
ws
)
_
<-
liftBase
$
Async
.
concurrently
(
wsLoop
jwtS
subscriptions
ws
)
(
pingLoop
ws
)
-- _ <- liftIO $ Async.withAsync (pure ()) (\_ -> wsLoop ws)
pure
()
...
...
@@ -73,8 +73,8 @@ pingLoop ws = do
threadDelay
$
10
*
1000000
wsLoop
::
Settings
->
SSet
.
Set
Subscription
->
WSKeyConnection
->
IO
a
wsLoop
authSettings
subscriptions
ws
=
flip
finally
disconnect
$
do
wsLoop
::
JWT
Settings
->
SSet
.
Set
Subscription
->
WSKeyConnection
->
IO
a
wsLoop
jwtS
subscriptions
ws
=
flip
finally
disconnect
$
do
withLogger
()
$
\
ioLogger
->
do
logMsg
ioLogger
DEBUG
"[wsLoop] connecting"
wsLoop'
CUPublic
ioLogger
...
...
@@ -105,7 +105,6 @@ wsLoop authSettings subscriptions ws = flip finally disconnect $ do
-- putText $ "[wsLoop] subscriptions: " <> show (showSub <$> ss)
return
user
Just
(
WSAuthorize
token
)
->
do
let
jwtS
=
authSettings
^.
jwtSettings
mUser
<-
liftBase
$
verifyJWT
jwtS
(
encodeUtf8
token
)
logMsg
ioLogger
DEBUG
$
"[wsLoop] authorized user: "
<>
show
mUser
...
...
src/Gargantext/Core/Config.hs
View file @
ec01d870
...
...
@@ -28,16 +28,23 @@ module Gargantext.Core.Config (
,
gc_jobs
,
gc_secrets
,
gc_apis
,
gc_log_level
,
mkProxyUrl
,
HasJWTSettings
(
..
)
,
HasConfig
(
..
)
)
where
import
Control.Lens
(
Getter
)
import
Control.Monad.Logger
(
LogLevel
(
LevelDebug
))
import
Data.Text
as
T
import
Database.PostgreSQL.Simple
qualified
as
PSQL
import
Gargantext.Core.Config.Mail
(
MailConfig
)
import
Gargantext.Core.Config.NLP
(
NLPConfig
)
import
Gargantext.Core.Config.Types
import
Gargantext.Prelude
import
Servant.Auth.Server
(
JWTSettings
)
import
Servant.Client
(
BaseUrl
(
..
),
Scheme
(
Http
),
parseBaseUrl
)
import
Toml.Schema
...
...
@@ -49,7 +56,6 @@ import Toml.Schema
-- Non-strict data so that we can use it in tests
data
GargConfig
=
GargConfig
{
_gc_datafilepath
::
~
FilePath
-- , _gc_repofilepath :: ~FilePath
,
_gc_frontend_config
::
~
FrontendConfig
,
_gc_mail_config
::
~
MailConfig
,
_gc_database_config
::
~
PSQL
.
ConnectInfo
...
...
@@ -59,6 +65,7 @@ data GargConfig = GargConfig { _gc_datafilepath :: ~FilePath
,
_gc_jobs
::
~
JobsConfig
,
_gc_secrets
::
~
SecretsConfig
,
_gc_apis
::
~
APIsConfig
,
_gc_log_level
::
~
LogLevel
}
deriving
(
Generic
,
Show
)
...
...
@@ -76,6 +83,7 @@ instance FromValue GargConfig where
_gc_jobs
<-
reqKey
"jobs"
_gc_apis
<-
reqKey
"apis"
_gc_notifications_config
<-
reqKey
"notifications"
let
_gc_log_level
=
LevelDebug
return
$
GargConfig
{
_gc_datafilepath
,
_gc_jobs
,
_gc_apis
...
...
@@ -85,7 +93,8 @@ instance FromValue GargConfig where
,
_gc_nlp_config
,
_gc_notifications_config
,
_gc_frames
,
_gc_secrets
}
,
_gc_secrets
,
_gc_log_level
}
instance
ToValue
GargConfig
where
toValue
=
defaultTableToValue
instance
ToTable
GargConfig
where
...
...
@@ -103,8 +112,19 @@ instance ToTable GargConfig where
]
mkProxyUrl
::
GargConfig
->
MicroServicesSettings
->
BaseUrl
mkProxyUrl
GargConfig
{
..
}
MicroServicesSettings
{
..
}
=
mkProxyUrl
::
GargConfig
->
BaseUrl
mkProxyUrl
GargConfig
{
..
}
=
case
parseBaseUrl
(
T
.
unpack
$
_fc_url
_gc_frontend_config
)
of
Nothing
->
BaseUrl
Http
"localhost"
80
""
Just
bh
->
bh
{
baseUrlPort
=
_msProxyPort
}
Just
bh
->
bh
{
baseUrlPort
=
_msProxyPort
$
_fc_microservices
_gc_frontend_config
}
class
HasConfig
env
where
hasConfig
::
Getter
env
GargConfig
instance
HasConfig
GargConfig
where
hasConfig
=
identity
class
HasJWTSettings
env
where
jwtSettings
::
Getter
env
JWTSettings
src/Gargantext/Core/Config/Ini/Mail.hs
View file @
ec01d870
...
...
@@ -9,8 +9,6 @@ Portability : POSIX
-}
{-# LANGUAGE TemplateHaskell #-}
module
Gargantext.Core.Config.Ini.Mail
(
-- * Types
GargMail
(
..
)
...
...
@@ -20,21 +18,13 @@ module Gargantext.Core.Config.Ini.Mail (
-- * Utility functions
,
gargMail
,
readConfig
-- * Lenses
,
mc_mail_from
,
mc_mail_host
,
mc_mail_login_type
,
mc_mail_password
,
mc_mail_port
,
mc_mail_user
)
where
import
Data.Maybe
import
Data.Text
(
unpack
)
import
Gargantext.Core.Config.Ini.Ini
(
readIniFile'
,
val
)
import
Gargantext.Core.Config.Mail
(
LoginType
(
..
),
MailConfig
(
..
))
import
Gargantext.Core.Config.Mail
(
LoginType
(
..
),
MailConfig
(
..
)
,
SendEmailType
(
LogEmailToConsole
)
)
import
Gargantext.Prelude
import
Network.Mail.Mime
(
plainPart
)
import
Network.Mail.SMTP
hiding
(
htmlPart
,
STARTTLS
)
...
...
@@ -55,6 +45,7 @@ readConfig fp = do
,
_mc_mail_from
=
cs
$
val'
"MAIL_FROM"
,
_mc_mail_password
=
cs
$
val'
"MAIL_PASSWORD"
,
_mc_mail_login_type
=
read
$
cs
$
val'
"MAIL_LOGIN_TYPE"
,
_mc_send_login_emails
=
LogEmailToConsole
}
...
...
@@ -84,4 +75,3 @@ gargMail (MailConfig {..}) (GargMail { .. }) = do
cc
=
[]
bcc
=
[]
makeLenses
''
M
ailConfig
src/Gargantext/Core/Config/Mail.hs
View file @
ec01d870
...
...
@@ -15,6 +15,7 @@ module Gargantext.Core.Config.Mail (
-- * Types
GargMail
(
..
)
,
LoginType
(
..
)
,
SendEmailType
(
..
)
,
MailConfig
(
..
)
-- * Utility functions
...
...
@@ -27,6 +28,7 @@ module Gargantext.Core.Config.Mail (
,
mc_mail_password
,
mc_mail_port
,
mc_mail_user
,
mc_send_login_emails
)
where
...
...
@@ -47,7 +49,6 @@ type Name = Text
data
LoginType
=
NoAuth
|
Normal
|
SSL
|
TLS
|
STARTTLS
deriving
(
Generic
,
Eq
,
Show
,
Read
)
instance
FromValue
LoginType
where
fromValue
(
Toml
.
Text'
_
t
)
=
case
t
of
...
...
@@ -61,12 +62,20 @@ instance FromValue LoginType where
instance
ToValue
LoginType
where
toValue
v
=
toValue
(
show
v
::
Text
)
data
SendEmailType
=
SendEmailViaAws
|
LogEmailToConsole
|
WriteEmailToFile
deriving
(
Show
,
Read
,
Enum
,
Bounded
,
Generic
)
data
MailConfig
=
MailConfig
{
_mc_mail_host
::
!
T
.
Text
,
_mc_mail_port
::
!
PortNumber
,
_mc_mail_user
::
!
T
.
Text
,
_mc_mail_password
::
!
T
.
Text
,
_mc_mail_login_type
::
!
LoginType
,
_mc_mail_from
::
!
T
.
Text
,
_mc_send_login_emails
::
!
SendEmailType
}
deriving
(
Generic
,
Show
)
instance
FromValue
MailConfig
where
...
...
@@ -77,6 +86,7 @@ instance FromValue MailConfig where
_mc_mail_password
<-
reqKey
"password"
_mc_mail_login_type
<-
reqKey
"login_type"
_mc_mail_from
<-
reqKey
"from"
let
_mc_send_login_emails
=
LogEmailToConsole
return
$
MailConfig
{
_mc_mail_port
=
fromIntegral
port
,
..
}
instance
ToValue
MailConfig
where
toValue
=
defaultTableToValue
...
...
src/Gargantext/Core/Config/NLP.hs
View file @
ec01d870
...
...
@@ -56,7 +56,9 @@ instance ToValue NLPConfig where
toValue
=
defaultTableToValue
instance
ToTable
NLPConfig
where
toTable
(
NLPConfig
{
..
})
=
table
[
k
.=
v
|
(
k
,
v
)
<-
Map
.
toList
_nlp_languages
]
table
([
k
.=
v
|
(
k
,
v
)
<-
Map
.
toList
_nlp_languages
]
-- output the default "EN" language as well
<>
[
(
"EN"
::
Text
)
.=
_nlp_default
])
-- readConfig :: SettingsFile -> IO NLPConfig
...
...
src/Gargantext/Core/Config/Types.hs
View file @
ec01d870
...
...
@@ -17,6 +17,7 @@ module Gargantext.Core.Config.Types
(
APIsConfig
(
..
)
,
ac_pubmed_api_key
,
ac_epo_api_url
,
ac_scrapyd_url
,
CORSOrigin
(
..
)
,
CORSSettings
(
..
)
,
FramesConfig
(
..
)
...
...
@@ -25,13 +26,18 @@ module Gargantext.Core.Config.Types
,
f_visio_url
,
f_searx_url
,
f_istex_url
,
PortNumber
,
FrontendConfig
(
..
)
,
fc_url
,
fc_backend_name
,
fc_url_backend_api
,
fc_jwt_settings
,
fc_cors
,
fc_microservices
,
fc_appPort
,
fc_cookie_settings
,
defaultCookieSettings
,
MicroServicesProxyStatus
(
..
)
,
microServicesProxyStatus
,
JobsConfig
(
..
)
,
jc_max_docs_parsers
,
jc_max_docs_scrapers
...
...
@@ -39,7 +45,9 @@ module Gargantext.Core.Config.Types
,
jc_js_id_timeout
,
MicroServicesSettings
(
..
)
,
NotificationsConfig
(
..
)
,
JWKFile
(
..
)
,
SecretsConfig
(
..
)
,
jwtSettings
,
SettingsFile
(
..
)
,
TOMLConnectInfo
(
..
)
...
...
@@ -54,7 +62,10 @@ import Control.Monad.Fail (fail)
import
Data.Text
qualified
as
T
import
Database.PostgreSQL.Simple
qualified
as
PGS
import
Gargantext.Prelude
import
Servant.Auth.Server
(
CookieSettings
(
..
),
JWTSettings
,
XsrfCookieSettings
(
..
),
defaultJWTSettings
,
readKey
,
writeKey
)
import
Servant.Auth.Server
qualified
as
SAuth
import
Servant.Client.Core
(
BaseUrl
,
parseBaseUrl
,
showBaseUrl
)
import
System.Directory
(
doesFileExist
)
import
Toml
import
Toml.Schema
...
...
@@ -179,13 +190,23 @@ instance ToTable FramesConfig where
makeLenses
''
F
ramesConfig
type
PortNumber
=
Int
defaultCookieSettings
::
CookieSettings
defaultCookieSettings
=
SAuth
.
defaultCookieSettings
{
cookieXsrfSetting
=
Just
xsrfCookieSetting
}
-- TODO-SECURITY tune
where
xsrfCookieSetting
=
SAuth
.
defaultXsrfCookieSettings
{
xsrfExcludeGet
=
True
}
-- TODO jwtSettings = defaultJWTSettings
data
FrontendConfig
=
FrontendConfig
{
_fc_url
::
!
Text
,
_fc_backend_name
::
!
Text
FrontendConfig
{
_fc_url
::
!
Text
,
_fc_backend_name
::
!
Text
,
_fc_url_backend_api
::
!
Text
,
_fc_jwt_settings
::
!
Text
,
_fc_cors
::
!
CORSSettings
,
_fc_microservices
::
!
MicroServicesSettings
,
_fc_cors
::
!
CORSSettings
,
_fc_microservices
::
!
MicroServicesSettings
,
_fc_appPort
::
!
PortNumber
,
_fc_cookie_settings
::
!
CookieSettings
}
deriving
(
Generic
,
Show
)
instance
FromValue
FrontendConfig
where
...
...
@@ -193,38 +214,64 @@ instance FromValue FrontendConfig where
_fc_url
<-
reqKey
"url"
_fc_backend_name
<-
reqKey
"backend_name"
_fc_url_backend_api
<-
reqKey
"url_backend_api"
_fc_jwt_settings
<-
reqKey
"jwt_settings"
_fc_cors
<-
reqKey
"cors"
_fc_microservices
<-
reqKey
"microservices"
return
$
FrontendConfig
{
..
}
let
_fc_appPort
=
3000
return
$
FrontendConfig
{
_fc_cookie_settings
=
defaultCookieSettings
,
..
}
instance
ToValue
FrontendConfig
where
toValue
=
defaultTableToValue
instance
ToTable
FrontendConfig
where
toTable
(
FrontendConfig
{
..
})
=
table
[
"url"
.=
_fc_url
,
"backend_name"
.=
_fc_backend_name
,
"url_backend_api"
.=
_fc_url_backend_api
,
"jwt_settings"
.=
_fc_jwt_settings
,
"cors"
.=
_fc_cors
,
"microservices"
.=
_fc_microservices
]
makeLenses
''
F
rontendConfig
data
MicroServicesProxyStatus
=
PXY_enabled
PortNumber
|
PXY_disabled
deriving
(
Show
,
Eq
)
microServicesProxyStatus
::
FrontendConfig
->
MicroServicesProxyStatus
microServicesProxyStatus
fc
=
if
fc
^.
fc_microservices
.
msProxyEnabled
then
PXY_enabled
(
fc
^.
fc_microservices
.
msProxyPort
)
else
PXY_disabled
newtype
JWKFile
=
JWKFile
{
unJWKFile
::
FilePath
}
deriving
(
Show
,
Eq
,
Generic
)
data
SecretsConfig
=
SecretsConfig
{
_s_master_user
::
!
Text
,
_s_secret_key
::
!
Text
,
_s_jwk_file
::
!
JWKFile
}
deriving
(
Generic
,
Show
)
instance
FromValue
SecretsConfig
where
fromValue
=
parseTableFromValue
$
do
_s_master_user
<-
reqKey
"master_user"
_s_secret_key
<-
reqKey
"secret_key"
jwkFile
<-
reqKey
"jwk_file"
let
_s_jwk_file
=
JWKFile
jwkFile
return
$
SecretsConfig
{
..
}
instance
ToValue
SecretsConfig
where
toValue
=
defaultTableToValue
instance
ToTable
SecretsConfig
where
toTable
(
SecretsConfig
{
..
})
=
table
[
"master_user"
.=
_s_master_user
,
"secret_key"
.=
_s_secret_key
]
,
"secret_key"
.=
_s_secret_key
,
"jwk_file"
.=
unJWKFile
_s_jwk_file
]
jwtSettings
::
SecretsConfig
->
IO
JWTSettings
jwtSettings
(
SecretsConfig
{
_s_jwk_file
=
JWKFile
jwkFile
})
=
do
jwkExists
<-
doesFileExist
jwkFile
when
(
not
jwkExists
)
$
writeKey
jwkFile
jwk
<-
readKey
jwkFile
pure
$
defaultJWTSettings
jwk
data
JobsConfig
=
...
...
@@ -253,18 +300,25 @@ makeLenses ''JobsConfig
data
APIsConfig
=
APIsConfig
{
_ac_pubmed_api_key
::
!
Text
,
_ac_epo_api_url
::
!
Text
}
,
_ac_epo_api_url
::
!
Text
,
_ac_scrapyd_url
::
!
BaseUrl
}
deriving
(
Generic
,
Show
)
instance
FromValue
APIsConfig
where
fromValue
=
parseTableFromValue
$
do
_ac_pubmed_api_key
<-
reqKeyOf
"pubmed"
$
parseTableFromValue
$
reqKey
"api_key"
_ac_epo_api_url
<-
reqKeyOf
"epo"
$
parseTableFromValue
$
reqKey
"api_url"
scrapyd_url
<-
reqKeyOf
"scrapyd"
$
parseTableFromValue
$
reqKey
"url"
_ac_scrapyd_url
<-
case
parseBaseUrl
(
T
.
unpack
scrapyd_url
)
of
Nothing
->
fail
$
"Cannot parse scrapyd base url for: "
<>
T
.
unpack
scrapyd_url
Just
b
->
return
b
return
$
APIsConfig
{
..
}
instance
ToValue
APIsConfig
where
toValue
=
defaultTableToValue
instance
ToTable
APIsConfig
where
toTable
(
APIsConfig
{
..
})
=
table
[
"pubmed"
.=
table
[
"api_key"
.=
_ac_pubmed_api_key
]
,
"epo"
.=
table
[
"api_url"
.=
_ac_epo_api_url
]
,
"scrapyd"
.=
table
[
"url"
.=
showBaseUrl
_ac_scrapyd_url
]
]
makeLenses
''
A
PIsConfig
...
...
src/Gargantext/Core/Mail.hs
View file @
ec01d870
...
...
@@ -15,11 +15,10 @@ import Control.Lens (view)
import
Control.Monad.Trans.Control
(
MonadBaseControl
)
import
Data.List
qualified
as
List
import
Data.Text
(
splitOn
)
import
Gargantext.Core.Config
(
gc_frontend_config
)
import
Gargantext.Core.Config
(
gc_frontend_config
,
HasConfig
(
..
)
)
import
Gargantext.Core.Config.Types
(
fc_url
,
fc_backend_name
)
import
Gargantext.Core.Config.Mail
(
gargMail
,
GargMail
(
..
),
MailConfig
)
import
Gargantext.Core.Types.Individu
import
Gargantext.Database.Prelude
(
HasConfig
(
..
))
import
Gargantext.Database.Schema.User
(
UserLight
(
..
))
import
Gargantext.Prelude
import
Network.URI.Encode
(
encodeText
)
...
...
src/Gargantext/Core/Methods/Matrix/Accelerate/Utils.hs
View file @
ec01d870
...
...
@@ -22,7 +22,7 @@ Implementation use Accelerate library which enables GPU and CPU computation:
-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
{-# OPTIONS_GHC -fno-warn-deprecations
-fno-warn-redundant-constraints
#-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
...
...
src/Gargantext/Core/Methods/Similarities/Accelerate/Distributional.hs
View file @
ec01d870
...
...
@@ -81,6 +81,8 @@ where $n_{ij}$ is the cooccurrence between term $i$ and term $j$
)
-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
...
...
src/Gargantext/Core/NodeStory/Types.hs
View file @
ec01d870
...
...
@@ -26,7 +26,6 @@ module Gargantext.Core.NodeStory.Types
,
NgramsStatePatch
'
,
NodeListStory
,
ArchiveList
,
initNodeListStoryMock
,
NodeStoryEnv
(
..
)
,
initNodeStory
,
nse_getter
...
...
@@ -160,19 +159,6 @@ initArchive = Archive { _a_version = 0
,
_a_state
=
mempty
,
_a_history
=
[]
}
initNodeListStoryMock
::
NodeListStory
initNodeListStoryMock
=
NodeStory
$
Map
.
singleton
nodeListId
archive
where
nodeListId
=
0
archive
=
Archive
{
_a_version
=
0
,
_a_state
=
ngramsTableMap
,
_a_history
=
[]
}
ngramsTableMap
=
Map
.
singleton
Ngrams
.
NgramsTerms
$
Map
.
fromList
[
(
n
^.
ne_ngrams
,
ngramsElementToRepo
n
)
|
n
<-
mockTable
^.
_NgramsTable
]
----------------------------------------------------------------------
data
NodeStoryPoly
nid
v
ngtid
ngid
nre
=
NodeStoryDB
{
node_id
::
!
nid
...
...
src/Gargantext/Core/Text/Terms/Eleve.hs
View file @
ec01d870
...
...
@@ -95,7 +95,7 @@ makeLenses ''I
type
ModEntropy
i
o
e
=
(
e
->
e
)
->
i
->
o
set_autonomy
::
Entropy
e
=>
ModEntropy
(
I
e
)
(
I
e
)
e
set_autonomy
::
ModEntropy
(
I
e
)
(
I
e
)
e
set_autonomy
fe
i
=
i
&
info_autonomy
.~
fe
(
i
^.
info_entropy_var
)
set_entropy_var
::
Entropy
e
=>
Setter
e
(
I
e
)
e
e
...
...
src/Gargantext/Core/Utils.hs
View file @
ec01d870
...
...
@@ -61,7 +61,7 @@ randomString num = do
-- | Given a list of items of type 'a', return list with unique items
-- (like List.nub) but tuple-d with their counts in the original list
groupWithCounts
::
(
Ord
a
,
Eq
a
)
=>
[
a
]
->
[(
a
,
Int
)]
groupWithCounts
::
(
Eq
a
,
Ord
a
)
=>
[
a
]
->
[(
a
,
Int
)]
groupWithCounts
=
map
f
.
List
.
group
.
List
.
sort
...
...
src/Gargantext/Core/Viz/Graph/API.hs
View file @
ec01d870
...
...
@@ -21,7 +21,6 @@ module Gargantext.Core.Viz.Graph.API
import
Control.Lens
(
set
,
_Just
,
(
^?
),
at
)
import
Data.HashMap.Strict
qualified
as
HashMap
import
Gargantext.API.Admin.EnvTypes
(
GargJob
(
..
),
Env
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Ngrams.Tools
import
Gargantext.API.Prelude
(
GargM
)
...
...
@@ -267,7 +266,7 @@ recomputeVersions :: HasNodeStory env err m
recomputeVersions
nId
=
recomputeGraph
nId
Spinglass
BridgenessMethod_Basic
Nothing
Nothing
NgramsTerms
NgramsTerms
False
------------------------------------------------------------
graphClone
::
(
HasNodeError
err
,
HasSettings
env
)
graphClone
::
(
HasNodeError
err
)
=>
UserId
->
NodeId
->
HyperdataGraphAPI
...
...
src/Gargantext/Core/Worker/Env.hs
0 → 100644
View file @
ec01d870
{-|
Module : Gargantext.Core.Worker.Env
Description : Asynchronous worker logic (environment)
Copyright : (c) CNRS, 2024
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- orphan HasNodeError IOException
module
Gargantext.Core.Worker.Env
where
import
Control.Lens
(
prism'
,
to
,
view
)
import
Control.Monad.Trans.Control
(
MonadBaseControl
)
import
Data.Pool
(
Pool
)
import
Data.Text
qualified
as
T
import
Database.PostgreSQL.Simple
(
Connection
)
import
Gargantext.API.Admin.EnvTypes
(
ConcreteJobHandle
,
GargJob
,
Mode
(
Dev
),
modeToLoggingLevels
)
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
,
noJobLog
)
import
Gargantext.API.Admin.Settings
(
devSettings
,
newPool
)
import
Gargantext.API.Admin.Types
(
HasSettings
(
..
),
Settings
(
..
))
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.Core.AsyncUpdates.CentralExchange
qualified
as
CE
import
Gargantext.Core.AsyncUpdates.CentralExchange.Types
qualified
as
CET
import
Gargantext.Core.Config
(
GargConfig
(
..
),
HasConfig
(
..
))
import
Gargantext.Core.Config.Mail
qualified
as
Mail
import
Gargantext.Core.Config.Utils
(
readConfig
)
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
))
import
Gargantext.Core.Mail.Types
(
HasMail
(
..
))
import
Gargantext.Core.NLP
(
HasNLPServer
(
..
),
NLPServerMap
,
nlpServerMap
)
import
Gargantext.Core.NodeStory
(
HasNodeStoryEnv
(
..
),
HasNodeStoryImmediateSaver
(
..
),
HasNodeArchiveStoryImmediateSaver
(
..
),
NodeStoryEnv
,
fromDBNodeStoryEnv
,
nse_saver_immediate
,
nse_archive_saver_immediate
)
import
Gargantext.Core.Types
(
HasValidationError
(
..
))
import
Gargantext.Database.Prelude
(
HasConnectionPool
(
..
))
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
(
..
))
import
Gargantext.Database.Query.Tree.Error
(
HasTreeError
(
..
))
import
Gargantext.Prelude
hiding
(
to
)
import
Gargantext.System.Logging
(
HasLogger
(
..
),
Logger
,
MonadLogger
(
..
),
withLoggerHoisted
)
import
Gargantext.Utils.Jobs.Monad
(
MonadJobStatus
(
..
),
JobHandle
)
import
GHC.IO.Exception
(
IOException
(
..
),
IOErrorType
(
OtherError
))
import
Prelude
qualified
import
System.Log.FastLogger
qualified
as
FL
data
WorkerEnv
=
WorkerEnv
{
_w_env_settings
::
!
Settings
,
_w_env_config
::
!
GargConfig
,
_w_env_logger
::
!
(
Logger
(
GargM
WorkerEnv
IOException
))
,
_w_env_pool
::
!
(
Pool
Connection
)
,
_w_env_nodeStory
::
!
NodeStoryEnv
,
_w_env_mail
::
!
Mail
.
MailConfig
,
_w_env_nlp
::
!
NLPServerMap
}
withWorkerEnv
::
SettingsFile
->
(
WorkerEnv
->
IO
a
)
->
IO
a
withWorkerEnv
settingsFile
k
=
withLoggerHoisted
Dev
$
\
logger
->
do
env
<-
newWorkerEnv
logger
k
env
-- `finally` cleanEnv env
where
newWorkerEnv
logger
=
do
cfg
<-
readConfig
settingsFile
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
pool
<-
newPool
$
_gc_database_config
cfg
nodeStory_env
<-
fromDBNodeStoryEnv
pool
let
setts
=
devSettings
pure
$
WorkerEnv
{
_w_env_pool
=
pool
,
_w_env_logger
=
logger
,
_w_env_nodeStory
=
nodeStory_env
,
_w_env_settings
=
setts
,
_w_env_config
=
cfg
,
_w_env_mail
=
_gc_mail_config
cfg
,
_w_env_nlp
=
nlpServerMap
$
_gc_nlp_config
cfg
}
instance
HasConfig
WorkerEnv
where
hasConfig
=
to
_w_env_config
instance
HasSettings
WorkerEnv
where
settings
=
to
_w_env_settings
instance
HasLogger
(
GargM
WorkerEnv
IOException
)
where
data
instance
Logger
(
GargM
WorkerEnv
IOException
)
=
GargWorkerLogger
{
w_logger_mode
::
Mode
,
w_logger_set
::
FL
.
LoggerSet
}
type
instance
LogInitParams
(
GargM
WorkerEnv
IOException
)
=
Mode
type
instance
LogPayload
(
GargM
WorkerEnv
IOException
)
=
FL
.
LogStr
initLogger
=
\
mode
->
do
w_logger_set
<-
liftIO
$
FL
.
newStderrLoggerSet
FL
.
defaultBufSize
pure
$
GargWorkerLogger
mode
w_logger_set
destroyLogger
=
\
GargWorkerLogger
{
..
}
->
liftIO
$
FL
.
rmLoggerSet
w_logger_set
logMsg
=
\
(
GargWorkerLogger
mode
logger_set
)
lvl
msg
->
do
let
pfx
=
"["
<>
show
lvl
<>
"] "
::
Text
when
(
lvl
`
elem
`
(
modeToLoggingLevels
mode
))
$
liftIO
$
FL
.
pushLogStrLn
logger_set
$
FL
.
toLogStr
pfx
<>
msg
logTxt
lgr
lvl
msg
=
logMsg
lgr
lvl
(
FL
.
toLogStr
$
T
.
unpack
msg
)
instance
HasConnectionPool
WorkerEnv
where
connPool
=
to
_w_env_pool
instance
HasMail
WorkerEnv
where
mailSettings
=
to
_w_env_mail
instance
HasNLPServer
WorkerEnv
where
nlpServer
=
to
_w_env_nlp
instance
HasNodeStoryEnv
WorkerEnv
where
hasNodeStory
=
to
_w_env_nodeStory
instance
HasNodeStoryImmediateSaver
WorkerEnv
where
hasNodeStoryImmediateSaver
=
hasNodeStory
.
nse_saver_immediate
instance
HasNodeArchiveStoryImmediateSaver
WorkerEnv
where
hasNodeArchiveStoryImmediateSaver
=
hasNodeStory
.
nse_archive_saver_immediate
instance
MonadLogger
(
GargM
WorkerEnv
IOException
)
where
getLogger
=
asks
_w_env_logger
instance
CET
.
HasCentralExchangeNotification
WorkerEnv
where
ce_notify
m
=
do
c
<-
asks
(
view
$
to
_w_env_config
)
liftBase
$
CE
.
notify
(
_gc_notifications_config
c
)
m
---------
instance
HasValidationError
IOException
where
_ValidationError
=
prism'
mkIOException
(
const
Nothing
)
where
mkIOException
v
=
IOError
{
ioe_handle
=
Nothing
,
ioe_type
=
OtherError
,
ioe_location
=
"Worker job (validation)"
,
ioe_description
=
show
v
,
ioe_errno
=
Nothing
,
ioe_filename
=
Nothing
}
instance
HasTreeError
IOException
where
_TreeError
=
prism'
mkIOException
(
const
Nothing
)
where
mkIOException
v
=
IOError
{
ioe_handle
=
Nothing
,
ioe_type
=
OtherError
,
ioe_location
=
"Worker job (tree)"
,
ioe_description
=
show
v
,
ioe_errno
=
Nothing
,
ioe_filename
=
Nothing
}
instance
HasNodeError
IOException
where
_NodeError
=
prism'
(
Prelude
.
userError
.
show
)
(
const
Nothing
)
---------------
newtype
WorkerMonad
a
=
WorkerMonad
{
_WorkerMonad
::
GargM
WorkerEnv
IOException
a
}
deriving
(
Functor
,
Applicative
,
Monad
,
MonadIO
,
MonadReader
WorkerEnv
,
MonadBase
IO
,
MonadBaseControl
IO
,
MonadError
IOException
,
MonadFail
)
instance
HasLogger
WorkerMonad
where
data
instance
Logger
WorkerMonad
=
WorkerMonadLogger
{
wm_logger_mode
::
Mode
,
wm_logger_set
::
FL
.
LoggerSet
}
type
instance
LogInitParams
WorkerMonad
=
Mode
type
instance
LogPayload
WorkerMonad
=
FL
.
LogStr
initLogger
=
\
mode
->
do
wm_logger_set
<-
liftIO
$
FL
.
newStderrLoggerSet
FL
.
defaultBufSize
pure
$
WorkerMonadLogger
mode
wm_logger_set
destroyLogger
=
\
WorkerMonadLogger
{
..
}
->
liftIO
$
FL
.
rmLoggerSet
wm_logger_set
logMsg
=
\
(
WorkerMonadLogger
mode
logger_set
)
lvl
msg
->
do
let
pfx
=
"["
<>
show
lvl
<>
"] "
::
Text
when
(
lvl
`
elem
`
(
modeToLoggingLevels
mode
))
$
liftIO
$
FL
.
pushLogStrLn
logger_set
$
FL
.
toLogStr
pfx
<>
msg
logTxt
lgr
lvl
msg
=
logMsg
lgr
lvl
(
FL
.
toLogStr
$
T
.
unpack
msg
)
instance
MonadLogger
WorkerMonad
where
getLogger
=
do
env
<-
ask
let
(
GargWorkerLogger
{
..
})
=
_w_env_logger
env
pure
$
WorkerMonadLogger
{
wm_logger_mode
=
w_logger_mode
,
wm_logger_set
=
w_logger_set
}
runWorkerMonad
::
WorkerEnv
->
WorkerMonad
a
->
IO
a
runWorkerMonad
env
m
=
do
res
<-
runExceptT
.
flip
runReaderT
env
$
_WorkerMonad
m
case
res
of
Left
e
->
throwIO
e
Right
x
->
pure
x
data
WorkerJobHandle
=
WorkerNoJobHandle
instance
MonadJobStatus
WorkerMonad
where
-- type JobHandle WorkerMonad = WorkerJobHandle
type
JobHandle
WorkerMonad
=
ConcreteJobHandle
IOException
type
JobType
WorkerMonad
=
GargJob
type
JobOutputType
WorkerMonad
=
JobLog
type
JobEventType
WorkerMonad
=
JobLog
-- noJobHandle _ = WorkerNoJobHandle
-- noJobHandle _ = noJobHandle (Proxy :: Proxy (GargM WorkerEnv IOException)) -- ConcreteNullHandle
noJobHandle
_
=
noJobHandle
(
Proxy
::
Proxy
WorkerMonad
)
getLatestJobStatus
_
=
WorkerMonad
(
pure
noJobLog
)
withTracer
_
jh
n
=
n
jh
markStarted
_
_
=
WorkerMonad
$
pure
()
markProgress
_
_
=
WorkerMonad
$
pure
()
markFailure
_
_
_
=
WorkerMonad
$
pure
()
markComplete
_
=
WorkerMonad
$
pure
()
markFailed
_
_
=
WorkerMonad
$
pure
()
addMoreSteps
_
_
=
WorkerMonad
$
pure
()
src/Gargantext/Core/Worker/Jobs.hs
0 → 100644
View file @
ec01d870
{-|
Module : Gargantext.Core.Worker.Jobs
Description : Worker job definitions
Copyright : (c) CNRS, 2024
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
module
Gargantext.Core.Worker.Jobs
where
import
Async.Worker.Broker.Redis
(
RedisBroker
,
BrokerInitParams
(
RedisBrokerInitParams
))
import
Async.Worker.Broker.Types
(
Broker
,
initBroker
)
import
Async.Worker
qualified
as
Worker
import
Async.Worker.Types
qualified
as
Worker
import
Async.Worker.Types
(
HasWorkerBroker
)
import
Control.Lens
(
view
)
import
Database.Redis
qualified
as
Redis
import
Gargantext.Core.Config
(
gc_worker
,
HasConfig
(
..
))
import
Gargantext.Core.Config.Worker
(
WorkerSettings
(
..
),
WorkerDefinition
(
..
),
wdToRedisConnectInfo
)
import
Gargantext.Core.Worker.Jobs.Types
(
Job
(
..
))
import
Gargantext.Database.Prelude
(
Cmd
'
)
import
Gargantext.Prelude
initializeRedisBroker
::
(
HasWorkerBroker
RedisBroker
Job
)
=>
Redis
.
ConnectInfo
->
IO
(
Broker
RedisBroker
(
Worker
.
Job
Job
))
initializeRedisBroker
connInfo
=
do
let
initParams
=
RedisBrokerInitParams
connInfo
initBroker
initParams
sendJob
::
(
HasWorkerBroker
RedisBroker
Job
,
HasConfig
env
)
=>
Job
->
Cmd'
env
err
()
sendJob
job
=
do
ws
<-
view
$
hasConfig
.
gc_worker
-- TODO Try to guess which worker should get this job
-- let mWd = findDefinitionByName ws workerName
let
mWd
=
head
$
_wsDefinitions
ws
case
mWd
of
Nothing
->
panicTrace
$
"worker definition not found"
Just
wd
->
liftBase
$
do
case
wdToRedisConnectInfo
wd
of
Nothing
->
panicTrace
$
"worker definition: could not create redis conn info"
Just
connInfo
->
do
b
<-
initializeRedisBroker
connInfo
let
queueName
=
_wdQueue
wd
void
$
Worker
.
sendJob'
$
Worker
.
mkDefaultSendJob'
b
queueName
job
src/Gargantext/Database/Action/Flow.hs
View file @
ec01d870
...
...
@@ -66,7 +66,7 @@ import EPO.API.Client.Types qualified as EPO
import
Gargantext.API.Ngrams.Tools
(
getTermsWith
)
import
Gargantext.Core
(
Lang
(
..
),
NLPServerConfig
,
withDefaultLanguage
)
import
Gargantext.Core.AsyncUpdates.CentralExchange.Types
(
HasCentralExchangeNotification
(
ce_notify
),
CEMessage
(
..
))
import
Gargantext.Core.Config
(
GargConfig
(
..
))
import
Gargantext.Core.Config
(
GargConfig
(
..
)
,
hasConfig
)
import
Gargantext.Core.Config.Types
(
APIsConfig
(
..
))
import
Gargantext.Core.Ext.IMTUser
(
readFile_Annuaire
)
import
Gargantext.Core.NLP
(
HasNLPServer
,
nlpServerGet
)
...
...
@@ -93,7 +93,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact ( HyperdataContact )
import
Gargantext.Database.Admin.Types.Hyperdata.Corpus
(
HyperdataAnnuaire
,
HyperdataCorpus
(
_hc_lang
)
)
import
Gargantext.Database.Admin.Types.Hyperdata.Document
(
ToHyperdataDocument
(
toHyperdataDocument
)
)
import
Gargantext.Database.Admin.Types.Node
hiding
(
DEBUG
)
-- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
import
Gargantext.Database.Prelude
(
DbCmd
'
,
hasConfig
,
DBCmd
'
)
import
Gargantext.Database.Prelude
(
DbCmd
'
,
DBCmd
'
)
import
Gargantext.Database.Query.Table.ContextNodeNgrams2
(
ContextNodeNgrams2Poly
(
..
),
insertContextNodeNgrams2
)
import
Gargantext.Database.Query.Table.Node
(
MkCorpus
,
insertDefaultNodeIfNotExists
,
getOrMkList
,
getNodeWith
)
import
Gargantext.Database.Query.Table.Node.Document.Add
qualified
as
Doc
(
add
)
...
...
@@ -112,7 +112,6 @@ import PUBMED.Types qualified as PUBMED
------------------------------------------------------------------------
-- Imports for upgrade function
import
Gargantext.Database.Query.Tree.Error
(
HasTreeError
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
------------------------------------------------------------------------
...
...
@@ -129,7 +128,7 @@ printDataText (DataNew (maybeInt, conduitData)) = do
putText
$
show
(
maybeInt
,
res
)
-- TODO use the split parameter in config file
getDataText
::
(
HasNodeError
err
,
HasSettings
env
)
getDataText
::
(
HasNodeError
err
)
=>
DataOrigin
->
TermType
Lang
->
API
.
RawQuery
...
...
@@ -146,7 +145,7 @@ getDataText (InternalOrigin _) la q _ _ _li = do
ids
<-
map
fst
<$>
searchDocInDatabase
cId
(
stem
(
_tt_lang
la
)
GargPorterAlgorithm
$
API
.
getRawQuery
q
)
pure
$
Right
$
DataOld
ids
getDataText_Debug
::
(
HasNodeError
err
,
HasSettings
env
)
getDataText_Debug
::
(
HasNodeError
err
)
=>
DataOrigin
->
TermType
Lang
->
API
.
RawQuery
...
...
@@ -168,7 +167,6 @@ flowDataText :: forall env err m.
,
HasTreeError
err
,
HasValidationError
err
,
MonadJobStatus
m
,
HasSettings
env
,
HasCentralExchangeNotification
env
)
=>
User
...
...
@@ -199,7 +197,6 @@ flowAnnuaire :: ( DbCmd' env err m
,
HasTreeError
err
,
HasValidationError
err
,
MonadJobStatus
m
,
HasSettings
env
,
HasCentralExchangeNotification
env
)
=>
MkCorpusUser
->
TermType
Lang
...
...
@@ -219,7 +216,6 @@ flowCorpusFile :: ( DbCmd' env err m
,
HasTreeError
err
,
HasValidationError
err
,
MonadJobStatus
m
,
HasSettings
env
,
HasCentralExchangeNotification
env
)
=>
MkCorpusUser
->
Limit
-- Limit the number of docs (for dev purpose)
...
...
@@ -250,7 +246,6 @@ flowCorpus :: ( DbCmd' env err m
,
HasValidationError
err
,
FlowCorpus
a
,
MonadJobStatus
m
,
HasSettings
env
,
HasCentralExchangeNotification
env
)
=>
MkCorpusUser
->
TermType
Lang
...
...
@@ -271,7 +266,6 @@ flow :: forall env err m a c.
,
FlowCorpus
a
,
MkCorpus
c
,
MonadJobStatus
m
,
HasSettings
env
,
HasCentralExchangeNotification
env
)
=>
Maybe
c
...
...
@@ -309,7 +303,6 @@ addDocumentsToHyperCorpus :: ( DbCmd' env err m
,
HasNodeError
err
,
FlowCorpus
document
,
MkCorpus
corpus
,
HasSettings
env
)
=>
NLPServerConfig
->
Maybe
corpus
...
...
@@ -323,7 +316,7 @@ addDocumentsToHyperCorpus ncs mb_hyper la corpusId docs = do
pure
ids
------------------------------------------------------------------------
createNodes
::
(
DbCmd'
env
err
m
,
HasNodeError
err
,
HasSettings
env
createNodes
::
(
DbCmd'
env
err
m
,
HasNodeError
err
,
MkCorpus
c
,
HasCentralExchangeNotification
env
)
...
...
@@ -356,7 +349,6 @@ flowCorpusUser :: ( HasNodeError err
,
HasTreeError
err
,
HasNodeStory
env
err
m
,
MkCorpus
c
,
HasSettings
env
)
=>
Lang
->
User
...
...
@@ -386,7 +378,6 @@ buildSocialList :: ( HasNodeError err
,
HasTreeError
err
,
HasNodeStory
env
err
m
,
MkCorpus
c
,
HasSettings
env
)
=>
Lang
->
User
...
...
@@ -422,7 +413,6 @@ insertMasterDocs :: ( DbCmd' env err m
,
HasNodeError
err
,
FlowCorpus
a
,
MkCorpus
c
,
HasSettings
env
)
=>
NLPServerConfig
->
Maybe
c
...
...
src/Gargantext/Database/Action/Node.hs
View file @
ec01d870
...
...
@@ -19,15 +19,14 @@ module Gargantext.Database.Action.Node
import
Control.Lens
(
view
)
import
Data.Text
qualified
as
T
import
Gargantext.API.Admin.Types
(
settings
,
_microservicesSettings
,
HasSettings
)
import
Gargantext.Core
import
Gargantext.Core.Config
(
GargConfig
(
..
),
mkProxyUrl
)
import
Gargantext.Core.Config.Types
(
FramesConfig
(
..
),
MicroServicesSettings
(
..
),
SecretsConfig
(
..
))
import
Gargantext.Core.Config
(
GargConfig
(
..
),
gc_frames
,
gc_frontend_config
,
mkProxyUrl
,
HasConfig
(
..
)
)
import
Gargantext.Core.Config.Types
(
FramesConfig
(
..
),
f_write_url
,
fc_microservices
,
MicroServicesSettings
(
..
),
SecretsConfig
(
..
))
import
Gargantext.Core.Types
(
Name
)
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Hyperdata.Default
import
Gargantext.Database.Admin.Types.Node
import
Gargantext.Database.Prelude
(
HasConfig
(
..
),
DBCmd
'
)
import
Gargantext.Database.Prelude
(
DBCmd
'
)
import
Gargantext.Database.Query.Table.Node
import
Gargantext.Database.Query.Table.Node.Error
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
...
...
@@ -37,7 +36,7 @@ import Servant.Client.Core.BaseUrl
------------------------------------------------------------------------
-- | TODO mk all others nodes
mkNodeWithParent
::
(
HasNodeError
err
,
HasDBid
NodeType
,
HasSettings
env
)
mkNodeWithParent
::
(
HasNodeError
err
,
HasDBid
NodeType
)
=>
NodeType
->
Maybe
ParentId
->
UserId
...
...
@@ -71,7 +70,7 @@ mkNodeWithParent nt (Just pId) uId name = (:[]) <$> insertNode nt (Just name) N
-- | Sugar to create a node, get its NodeId and update its Hyperdata after
mkNodeWithParent_ConfigureHyperdata
::
(
HasNodeError
err
,
HasDBid
NodeType
,
HasSettings
env
)
mkNodeWithParent_ConfigureHyperdata
::
(
HasNodeError
err
,
HasDBid
NodeType
)
=>
NodeType
->
Maybe
ParentId
->
UserId
...
...
@@ -95,15 +94,15 @@ mkNodeWithParent_ConfigureHyperdata _ _ _ _ = nodeError NotImplYet
-- | Creates the base URL for the notes microservices proxy, or defaults
-- to the notes microservice if the proxy has been disabled from the settings.
internalNotesProxy
::
GargConfig
->
MicroServicesSettings
->
T
.
Text
internalNotesProxy
cfg
msSettings
|
_msProxyEnabled
msSettings
=
T
.
pack
$
showBaseUrl
proxyUrl
<>
"/notes"
|
otherwise
=
_f_write_url
$
_gc_frames
cfg
internalNotesProxy
::
GargConfig
->
T
.
Text
internalNotesProxy
cfg
|
_msProxyEnabled
(
cfg
^.
gc_frontend_config
.
fc_microservices
)
=
T
.
pack
$
showBaseUrl
proxyUrl
<>
"/notes"
|
otherwise
=
cfg
^.
gc_frames
.
f_write_url
where
proxyUrl
=
mkProxyUrl
cfg
msSettings
proxyUrl
=
mkProxyUrl
cfg
-- | Function not exposed
mkNodeWithParent_ConfigureHyperdata'
::
(
HasNodeError
err
,
HasDBid
NodeType
,
HasSettings
env
)
mkNodeWithParent_ConfigureHyperdata'
::
(
HasNodeError
err
,
HasDBid
NodeType
)
=>
NodeType
->
Maybe
ParentId
->
UserId
...
...
@@ -117,9 +116,8 @@ mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
_
->
nodeError
NeedsConfiguration
cfg
<-
view
hasConfig
stt
<-
view
settings
u
<-
case
nt
of
Notes
->
pure
$
internalNotesProxy
cfg
(
_microservicesSettings
stt
)
Notes
->
pure
$
internalNotesProxy
cfg
Calc
->
pure
$
_f_calc_url
$
_gc_frames
cfg
NodeFrameVisio
->
pure
$
_f_visio_url
$
_gc_frames
cfg
_
->
nodeError
NeedsConfiguration
...
...
src/Gargantext/Database/Action/User/New.hs
View file @
ec01d870
...
...
@@ -29,7 +29,6 @@ import Control.Lens (view)
import
Control.Monad.Random
import
Data.Text
(
splitOn
)
import
Data.Text
qualified
as
Text
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.Core.Mail
import
Gargantext.Core.Mail.Types
(
HasMail
,
mailSettings
)
import
Gargantext.Core.Types.Individu
...
...
@@ -46,7 +45,7 @@ import qualified Data.List.NonEmpty as NE
------------------------------------------------------------------------
-- | Creates a new 'User' from the input 'EmailAddress', which needs to
-- be valid (i.e. a valid username needs to be inferred via 'guessUsername').
newUser
::
(
CmdM
env
err
m
,
MonadRandom
m
,
HasNodeError
err
,
HasMail
env
,
HasSettings
env
)
newUser
::
(
CmdM
env
err
m
,
MonadRandom
m
,
HasNodeError
err
,
HasMail
env
)
=>
EmailAddress
->
m
UserId
newUser
emailAddress
=
do
...
...
@@ -61,7 +60,7 @@ newUser emailAddress = do
-- This is an internal function and as such it /doesn't/ send out any email
-- notification, and thus lives in the 'DbCmd' effect stack. You may want to
-- use 'newUser' instead for standard Gargantext code.
new_user
::
(
HasNodeError
err
,
HasSettings
env
)
new_user
::
(
HasNodeError
err
)
=>
NewUser
GargPassword
->
DBCmd'
env
err
UserId
new_user
rq
=
do
...
...
@@ -73,7 +72,7 @@ new_user rq = do
-- This is an internal function and as such it /doesn't/ send out any email
-- notification, and thus lives in the 'DbCmd' effect stack. You may want to
-- use 'newUsers' instead for standard Gargantext code.
new_users
::
(
HasNodeError
err
,
HasSettings
env
)
new_users
::
(
HasNodeError
err
)
=>
NonEmpty
(
NewUser
GargPassword
)
-- ^ A list of users to create.
->
DBCmd'
env
err
(
NonEmpty
UserId
)
...
...
@@ -83,7 +82,7 @@ new_users us = do
mapM
(
fmap
fst
.
getOrMkRoot
)
$
NE
.
map
(
\
u
->
UserName
(
_nu_username
u
))
us
------------------------------------------------------------------------
newUsers
::
(
CmdM
env
err
m
,
MonadRandom
m
,
HasNodeError
err
,
HasMail
env
,
HasSettings
env
)
newUsers
::
(
CmdM
env
err
m
,
MonadRandom
m
,
HasNodeError
err
,
HasMail
env
)
=>
NonEmpty
EmailAddress
->
m
(
NonEmpty
UserId
)
newUsers
us
=
do
...
...
@@ -109,7 +108,7 @@ guessUserName n = case splitOn "@" n of
_
->
Nothing
------------------------------------------------------------------------
newUsers'
::
(
HasNodeError
err
,
HasSettings
env
)
newUsers'
::
(
HasNodeError
err
)
=>
MailConfig
->
NonEmpty
(
NewUser
GargPassword
)
->
DBCmd'
env
err
(
NonEmpty
UserId
)
newUsers'
cfg
us
=
do
us'
<-
liftBase
$
mapM
toUserHash
us
...
...
src/Gargantext/Database/GargDB.hs
View file @
ec01d870
...
...
@@ -18,9 +18,8 @@ module Gargantext.Database.GargDB
import
Control.Lens
(
view
)
import
Data.Text
qualified
as
Text
import
Data.Tuple.Extra
(
both
)
import
Gargantext.
Database.Prelude
(
HasConfig
(
..
)
)
import
Gargantext.
Core.Config
(
gc_datafilepath
,
HasConfig
(
..
)
)
import
Gargantext.Prelude
hiding
(
hash
)
import
Gargantext.Core.Config
(
gc_datafilepath
)
import
Gargantext.Prelude.Crypto.Hash
(
IsHashable
(
hash
)
)
import
Prelude
qualified
import
System.Directory
(
createDirectoryIfMissing
)
...
...
src/Gargantext/Database/Prelude.hs
View file @
ec01d870
...
...
@@ -29,7 +29,7 @@ import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(Conversion
import
Database.PostgreSQL.Simple.Internal
(
Field
)
import
Database.PostgreSQL.Simple.Types
(
Query
(
..
))
import
Gargantext.Core.AsyncUpdates.CentralExchange.Types
qualified
as
CET
import
Gargantext.Core.Config
(
GargConfig
)
import
Gargantext.Core.Config
(
HasConfig
(
..
)
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.NLP
(
HasNLPServer
)
import
Gargantext.Prelude
...
...
@@ -45,12 +45,6 @@ class HasConnectionPool env where
instance
HasConnectionPool
(
Pool
Connection
)
where
connPool
=
identity
class
HasConfig
env
where
hasConfig
::
Getter
env
GargConfig
instance
HasConfig
GargConfig
where
hasConfig
=
identity
-------------------------------------------------------
type
JSONB
=
DefaultFromField
SqlJsonb
-------------------------------------------------------
...
...
src/Gargantext/Database/Query/Tree/Root.hs
View file @
ec01d870
...
...
@@ -30,7 +30,6 @@ import Gargantext.Database.Schema.Node (NodePoly(..), NodeRead, queryNodeTable)
import
Gargantext.Prelude
import
Opaleye
(
restrict
,
(
.==
),
Select
)
import
Opaleye.SqlTypes
(
sqlStrictText
,
sqlInt4
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
getRootId
::
(
HasNodeError
err
)
=>
User
->
DBCmd
err
NodeId
...
...
@@ -43,7 +42,7 @@ getRootId u = do
getRoot
::
User
->
DBCmd
err
[
Node
HyperdataUser
]
getRoot
=
runOpaQuery
.
selectRoot
getOrMkRoot
::
(
HasNodeError
err
,
HasSettings
env
)
getOrMkRoot
::
(
HasNodeError
err
)
=>
User
->
DBCmd'
env
err
(
UserId
,
RootId
)
getOrMkRoot
user
=
do
...
...
@@ -78,7 +77,7 @@ userFromMkCorpusUser (MkCorpusUserNormalCorpusIds u _cids) = u
userFromMkCorpusUser
(
MkCorpusUserNormalCorpusName
u
_cname
)
=
u
getOrMkRootWithCorpus
::
(
HasNodeError
err
,
MkCorpus
a
,
HasSettings
env
)
getOrMkRootWithCorpus
::
(
HasNodeError
err
,
MkCorpus
a
)
=>
MkCorpusUser
->
Maybe
a
->
DBCmd'
env
err
(
UserId
,
RootId
,
CorpusId
)
...
...
@@ -120,7 +119,7 @@ mkCorpus cName c rootId userId = do
pure
(
userId
,
rootId
,
corpusId
)
mkRoot
::
(
HasNodeError
err
,
HasSettings
env
)
mkRoot
::
(
HasNodeError
err
)
=>
User
->
DBCmd'
env
err
[
RootId
]
mkRoot
user
=
do
...
...
src/Gargantext/MicroServices/ReverseProxy.hs
View file @
ec01d870
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
...
...
@@ -17,8 +16,6 @@ module Gargantext.MicroServices.ReverseProxy (
,
FrameId
(
..
)
)
where
import
Prelude
import
Conduit
import
Data.ByteString
qualified
as
B
import
Data.ByteString.Builder
...
...
@@ -33,15 +30,13 @@ import Data.Text.Encoding qualified as TE
import
GHC.Generics
import
Gargantext.API.Admin.Auth.Types
(
AuthContext
)
import
Gargantext.API.Admin.EnvTypes
import
Gargantext.API.Admin.Types
import
Gargantext.API.Node.ShareURL
qualified
as
Share
import
Gargantext.API.Routes.Named.Private
import
Gargantext.API.Routes.Named.Share
(
ShareLink
(
..
))
import
Gargantext.API.ThrowAll
(
throwAllRoutes
)
import
Gargantext.Core.Config
(
gc_frames
,
mkProxyUrl
)
import
Gargantext.Core.Config.Types
(
f_write_url
)
import
Gargantext.Core.Config
(
gc_frames
,
gc_frontend_config
,
mkProxyUrl
,
hasConfig
)
import
Gargantext.Core.Config.Types
(
f_write_url
,
fc_cookie_settings
)
import
Gargantext.Database.Admin.Types.Node
(
NodeType
(
..
),
NodeId
(
..
))
import
Gargantext.Database.Prelude
(
hasConfig
)
import
Gargantext.Prelude
hiding
(
Handler
)
import
Network.HTTP.ReverseProxy
import
Network.HTTP.Types
(
hCacheControl
,
RequestHeaders
,
hReferer
,
ResponseHeaders
,
Header
)
...
...
@@ -158,11 +153,11 @@ type ProxyCache = InMemory.Cache FrameId NodeId
microServicesProxyApp
::
ProxyCache
->
Env
->
Application
microServicesProxyApp
cache
env
=
genericServeTWithContext
id
(
server
cache
env
)
cfg
microServicesProxyApp
cache
env
=
genericServeTWithContext
id
entity
(
server
cache
env
)
cfg
where
cfg
::
Context
AuthContext
cfg
=
env
^.
settings
.
jwtS
ettings
:.
env
^.
settings
.
cookieS
ettings
cfg
=
env
^.
env_jwt_s
ettings
:.
env
^.
env_config
.
gc_frontend_config
.
fc_cookie_s
ettings
:.
EmptyContext
server
::
ProxyCache
->
Env
->
ReverseProxyAPI
(
AsServerT
Handler
)
...
...
@@ -212,10 +207,10 @@ notesProxyImplementation :: ProxyCache -> Env -> NotesProxy AsServer
notesProxyImplementation
cache
env
=
NotesProxy
{
slideEp
=
\
frameId
->
slideProxyServer
env
frameId
,
publishEp
=
\
frameId
->
publishProxyServer
cache
env
frameId
,
configFile
=
defaultForwardServerWithSettings
sty
id
env
(
configFileSettings
env
sty
)
,
configFile
=
defaultForwardServerWithSettings
sty
id
entity
env
(
configFileSettings
env
sty
)
,
notesSocket
=
socketIOProxyImplementation
sty
env
,
meEndpoint
=
proxyPassServer
sty
env
,
notesEp
=
\
frameId
mbNodeId
->
notesForwardServer
cache
frameId
mbNodeId
sty
id
env
,
notesEp
=
\
frameId
mbNodeId
->
notesForwardServer
cache
frameId
mbNodeId
sty
id
entity
env
,
notesStaticAssets
=
proxyPassServer
sty
env
}
where
...
...
@@ -224,7 +219,7 @@ notesProxyImplementation cache env = NotesProxy {
socketIOProxyImplementation
::
ServiceType
->
Env
->
SocketIOProxy
AsServer
socketIOProxyImplementation
sty
env
=
SocketIOProxy
{
socketIoEp
=
\
_noteId
->
defaultForwardServer
sty
id
id
env
socketIoEp
=
\
_noteId
->
defaultForwardServer
sty
id
entity
identity
env
}
removeServiceFromPath
::
ServiceType
->
Request
->
Request
...
...
@@ -236,7 +231,7 @@ removeServiceFromPath sty = removeProxyPath (T.pack $ serviceTypeToProxyPath sty
slideProxyServer
::
Env
->
FrameId
->
ServerT
Raw
m
slideProxyServer
env
(
FrameId
frameId
)
=
defaultForwardServer
ST_notes
(
\
rq
->
rq
{
rawPathInfo
=
changePath
(
rawPathInfo
rq
)
})
id
env
defaultForwardServer
ST_notes
(
\
rq
->
rq
{
rawPathInfo
=
changePath
(
rawPathInfo
rq
)
})
id
entity
env
where
changePath
::
ByteString
->
ByteString
changePath
_
=
TE
.
encodeUtf8
$
"/p/"
<>
frameId
<>
"#/"
...
...
@@ -253,7 +248,7 @@ publishProxyServer cache env frameId = Tagged $ \req res -> do
Just
nodeId
->
do
-- Using a mock for now.
case
Share
.
get_url
(
Just
Notes
)
(
Just
nodeId
)
(
_env_config
env
)
(
_env_settings
env
)
of
case
Share
.
get_url
(
Just
Notes
)
(
Just
nodeId
)
(
_env_config
env
)
of
Left
_e
->
-- Invalid link, treat this as a normal proxy
forwardRaw
req
res
...
...
@@ -264,14 +259,14 @@ publishProxyServer cache env frameId = Tagged $ \req res -> do
where
forwardRaw
=
unTagged
(
defaultForwardServer
ST_notes
(
\
rq
->
rq
{
rawPathInfo
=
changePath
(
rawPathInfo
rq
)
})
id
env
)
unTagged
(
defaultForwardServer
ST_notes
(
\
rq
->
rq
{
rawPathInfo
=
changePath
(
rawPathInfo
rq
)
})
id
entity
env
)
changePath
::
ByteString
->
ByteString
changePath
_
=
TE
.
encodeUtf8
$
"/s/"
<>
(
_FrameId
frameId
)
-- Generic server forwarder
proxyPassServer
::
ServiceType
->
Env
->
ServerT
Raw
m
proxyPassServer
sty
env
=
defaultForwardServer
sty
id
id
env
proxyPassServer
sty
env
=
defaultForwardServer
sty
id
entity
identity
env
mkProxyDestination
::
Env
->
ProxyDestination
mkProxyDestination
env
=
fromMaybe
(
panicTrace
"Invalid URI found in the proxied Request."
)
$
do
...
...
@@ -284,8 +279,8 @@ mkProxyDestination env = fromMaybe (panicTrace "Invalid URI found in the proxied
removeFromReferer
::
T
.
Text
->
Request
->
Request
removeFromReferer
pth
originalRequest
=
originalRequest
{
requestHeaders
=
(
Prelude
.
map
tweakReferer
(
requestHeaders
originalRequest
)
)
}
originalRequest
{
requestHeaders
=
map
tweakReferer
(
requestHeaders
originalRequest
)
}
where
tweakReferer
::
Header
->
Header
tweakReferer
(
k
,
v
)
...
...
@@ -295,7 +290,7 @@ removeFromReferer pth originalRequest =
=
(
k
,
v
)
proxyUrl
::
Env
->
BaseUrl
proxyUrl
env
=
mkProxyUrl
(
env
^.
hasConfig
)
(
env
^.
env_settings
.
microservicesSettings
)
proxyUrl
env
=
mkProxyUrl
(
env
^.
hasConfig
)
notesForwardServer
::
ProxyCache
->
FrameId
...
...
@@ -307,7 +302,7 @@ notesForwardServer :: ProxyCache
notesForwardServer
cache
frameId
mbNodeId
sty
presendModifyRequest
env
=
case
mbNodeId
of
Nothing
->
defaultForwardServer
sty
presendModifyRequest
id
env
->
defaultForwardServer
sty
presendModifyRequest
id
entity
env
Just
nid
->
do
-- Persist the node id in the cache
...
...
@@ -317,7 +312,7 @@ notesForwardServer cache frameId mbNodeId sty presendModifyRequest env =
where
setFrameIdCookie
::
FrameId
->
NodeId
->
(
ResponseHeaders
->
ResponseHeaders
)
setFrameIdCookie
(
FrameId
(
T
.
unpack
->
fid
))
(
UnsafeMkNodeId
nid
)
origHeaders
=
let
sk
=
(
hSetCookie
,
fromString
$
fid
<>
"="
<>
Prelude
.
show
nid
)
=
let
sk
=
(
hSetCookie
,
fromString
$
fid
<>
"="
<>
show
nid
)
in
sk
:
origHeaders
defaultForwardServerWithSettings
::
ServiceType
...
...
@@ -326,7 +321,7 @@ defaultForwardServerWithSettings :: ServiceType
->
WaiProxySettings
->
ServerT
Raw
m
defaultForwardServerWithSettings
sty
presendModifyRequest
env
proxySettings
=
Tagged
$
waiProxyToSettings
forwardRequest
(
proxySettings
)
(
env
^.
env_manager
)
Tagged
$
waiProxyToSettings
forwardRequest
proxySettings
(
env
^.
env_manager
)
where
proxyDestination
::
ProxyDestination
...
...
@@ -360,7 +355,7 @@ defaultForwardServer sty presendModifyRequest mapRespHeaders env =
defaultForwardServerWithSettings
sty
presendModifyRequest
env
$
defaultWaiProxySettings
{
wpsProcessBody
=
\
_req
_res
->
Just
$
replaceRelativeLinks
proxyDestination
proxyPath
,
wpsModifyResponseHeaders
=
\
_req
_res
->
(
mapRespHeaders
.
tweakResponseHeaders
)
,
wpsModifyResponseHeaders
=
\
_req
_res
->
mapRespHeaders
.
tweakResponseHeaders
,
wpsRedirectCounts
=
5
}
where
...
...
@@ -382,7 +377,7 @@ noCache hdrs = (hCacheControl, fromString "no-cache") : filter ((/=) hCacheContr
-- | Tweak the response headers so that they will have a bit more permissive
-- 'Content-Security-Policy'.
tweakResponseHeaders
::
ResponseHeaders
->
ResponseHeaders
tweakResponseHeaders
=
Prelude
.
map
tweakHeader
tweakResponseHeaders
=
map
tweakHeader
where
tweakHeader
(
k
,
v
)
|
k
==
"Content-Security-Policy"
...
...
test-data/test_config.toml
View file @
ec01d870
...
...
@@ -15,6 +15,7 @@ enabled = false
[secrets]
master_user
=
"gargantua"
secret_key
=
"test_key"
jwk_file
=
"test.jwk"
[paths]
data_filepath
=
"~/.garg"
...
...
@@ -27,6 +28,10 @@ api_key = "no_key"
[apis.epo]
api_url
=
""
[apis.scrapyd]
url
=
"http://localhost:6800"
[external]
[external.frames]
write_url
=
"URL_TO_CHANGE"
...
...
test/Test/API/Notifications.hs
View file @
ec01d870
...
...
@@ -11,7 +11,6 @@ Portability : POSIX
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE QuasiQuotes #-}
module
Test.API.Notifications
(
tests
...
...
@@ -28,11 +27,9 @@ import Gargantext.Core.Config.Types (NotificationsConfig(..))
import
Network.WebSockets.Client
qualified
as
WS
import
Network.WebSockets.Connection
qualified
as
WS
import
Prelude
import
System.Timeout
qualified
as
Timeout
import
Test.API.Setup
(
withTestDBAndPort
)
-- , setupEnvironment, createAliceAndBob)
import
Test.Hspec
import
Test.Instances
()
import
Text.RawString.QQ
(
r
)
tests
::
NotificationsConfig
->
Spec
...
...
test/Test/API/Setup.hs
View file @
ec01d870
...
...
@@ -13,18 +13,11 @@ import Data.Streaming.Network (bindPortTCP)
import
Gargantext.API
(
makeApp
)
import
Gargantext.API.Admin.EnvTypes
(
Mode
(
Mock
),
Env
(
..
))
import
Gargantext.API.Admin.Settings
import
Gargantext.API.Admin.Types
import
Gargantext.API.Errors.Types
import
Gargantext.API.Prelude
import
Gargantext.Core.AsyncUpdates.CentralExchange
qualified
as
CE
import
Gargantext.Core.AsyncUpdates.Dispatcher
qualified
as
D
import
Gargantext.Core.AsyncUpdates.Dispatcher.Types
qualified
as
DT
import
Gargantext.Core.Config
import
Gargantext.Core.Config.Mail
qualified
as
Mail
import
Gargantext.Core.Config.NLP
qualified
as
NLP
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
),
jc_js_job_timeout
,
jc_js_id_timeout
)
import
Gargantext.Core.Config
(
_gc_secrets
,
gc_frontend_config
,
gc_jobs
,
hasConfig
)
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
),
jc_js_job_timeout
,
jc_js_id_timeout
,
fc_appPort
,
jwtSettings
)
import
Gargantext.Core.Config.Utils
(
readConfig
)
import
Gargantext.Core.NLP
import
Gargantext.Core.NodeStory
import
Gargantext.Core.Types.Individu
import
Gargantext.Database.Action.Flow
...
...
@@ -32,7 +25,7 @@ import Gargantext.Database.Action.User.New
import
Gargantext.Database.Admin.Config
(
userMaster
)
import
Gargantext.Database.Admin.Trigger.Init
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
()
import
Gargantext.Database.Query.Table.Node
(
getOrMkList
)
import
Gargantext.Database.Query.Tree.Root
(
MkCorpusUser
(
..
))
import
Gargantext.MicroServices.ReverseProxy
(
microServicesProxyApp
)
...
...
@@ -61,9 +54,8 @@ newTestEnv :: TestEnv -> Logger (GargM Env BackendInternalError) -> Warp.Port ->
newTestEnv
testEnv
logger
port
=
do
tomlFile
@
(
SettingsFile
sf
)
<-
fakeTomlPath
!
manager_env
<-
newTlsManager
!
settings'
<-
devSettings
devJwkFile
tomlFile
<&>
appPort
.~
port
!
config_env
<-
readConfig
tomlFile
!
config_env
<-
readConfig
tomlFile
<&>
(
gc_frontend_config
.
fc_appPort
)
.~
port
prios
<-
withLogger
()
$
\
ioLogger
->
Jobs
.
readPrios
ioLogger
(
sf
<>
".jobs"
)
let
prios'
=
Jobs
.
applyPrios
prios
Jobs
.
defaultPrios
!
self_url_env
<-
parseBaseUrl
$
"http://0.0.0.0:"
<>
show
port
...
...
@@ -78,13 +70,13 @@ newTestEnv testEnv logger port = do
&
Jobs
.
l_jsJobTimeout
.~
(
fromIntegral
$
config_env
^.
hasConfig
^.
gc_jobs
.
jc_js_job_timeout
)
&
Jobs
.
l_jsIDTimeout
.~
(
fromIntegral
$
config_env
^.
hasConfig
^.
gc_jobs
.
jc_js_id_timeout
)
!
jobs_env
<-
Jobs
.
newJobEnv
jobs_settings
prios'
manager_env
!
_env_jwt_settings
<-
jwtSettings
(
_gc_secrets
config_env
)
-- !central_exchange <- forkIO CE.gServer
-- !dispatcher <- D.dispatcher
pure
$
Env
{
_env_settings
=
settings'
,
_env_logger
=
logger
{
_env_logger
=
logger
,
_env_pool
=
pool
,
_env_nodeStory
=
nodeStory_env
,
_env_manager
=
manager_env
...
...
@@ -92,12 +84,11 @@ newTestEnv testEnv logger port = do
,
_env_jobs
=
jobs_env
,
_env_self_url
=
self_url_env
,
_env_config
=
config_env
,
_env_mail
=
_gc_mail_config
config_env
,
_env_nlp
=
nlpServerMap
$
_gc_nlp_config
config_env
,
_env_central_exchange
=
Prelude
.
error
"central exchange not needed, but forced somewhere (check StrictData)"
,
_env_dispatcher
=
Prelude
.
error
"dispatcher not needed, but forced somewhere (check StrictData)"
-- , _env_central_exchange = central_exchange
-- , _env_dispatcher = dispatcher
,
_env_jwt_settings
}
-- | Run the gargantext server on a random port, picked by Warp, which allows
...
...
test/Test/Database/Setup.hs
View file @
ec01d870
...
...
@@ -76,14 +76,12 @@ setup = do
bootstrapDB
db
pool
gargConfig
ugen
<-
emptyCounter
test_nodeStory
<-
fromDBNodeStoryEnv
pool
stgs
<-
devSettings
devJwkFile
=<<
fakeTomlPath
withLoggerHoisted
Mock
$
\
logger
->
do
pure
$
TestEnv
{
test_db
=
DBHandle
pool
db
,
test_config
=
gargConfig
,
test_nodeStory
,
test_usernameGen
=
ugen
,
test_logger
=
logger
,
test_settings
=
stgs
}
withTestDB
::
(
TestEnv
->
IO
()
)
->
IO
()
...
...
test/Test/Database/Types.hs
View file @
ec01d870
...
...
@@ -28,16 +28,16 @@ import Database.Postgres.Temp qualified as Tmp
import
Gargantext
hiding
(
to
)
import
Gargantext.API.Admin.EnvTypes
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Admin.Types
import
Gargantext.API.Errors.Types
import
Gargantext.API.Prelude
import
Gargantext.Core.Config
(
HasConfig
(
..
))
import
Gargantext.Core.Mail.Types
(
HasMail
(
..
))
import
Gargantext.Core.NLP
(
HasNLPServer
(
..
))
import
Gargantext.Core.NodeStory
import
Gargantext.Database.Prelude
(
HasCon
fig
(
..
),
HasCon
nectionPool
(
..
))
import
Gargantext.Database.Prelude
(
HasConnectionPool
(
..
))
import
Gargantext.Database.Query.Table.Node.Error
import
Gargantext.Core.Config
import
Gargantext.Core.Config.Mail
(
MailConfig
(
..
),
LoginType
(
NoAuth
))
import
Gargantext.Core.Config.Mail
(
MailConfig
(
..
),
LoginType
(
NoAuth
)
,
SendEmailType
(
LogEmailToConsole
)
)
import
Gargantext.System.Logging
(
HasLogger
(
..
),
Logger
,
MonadLogger
(
..
))
import
Gargantext.Utils.Jobs
import
Network.URI
(
parseURI
)
...
...
@@ -62,7 +62,6 @@ data TestEnv = TestEnv {
,
test_nodeStory
::
!
NodeStoryEnv
,
test_usernameGen
::
!
Counter
,
test_logger
::
!
(
Logger
(
GargM
TestEnv
BackendInternalError
))
,
test_settings
::
!
Settings
}
newtype
TestMonad
a
=
TestMonad
{
runTestMonad
::
ReaderT
TestEnv
IO
a
}
...
...
@@ -106,16 +105,14 @@ instance HasConnectionPool TestEnv where
instance
HasConfig
TestEnv
where
hasConfig
=
to
test_config
instance
HasSettings
TestEnv
where
settings
=
to
test_settings
instance
HasMail
TestEnv
where
mailSettings
=
to
$
const
(
MailConfig
{
_mc_mail_host
=
"localhost"
,
_mc_mail_port
=
25
,
_mc_mail_user
=
"test"
,
_mc_mail_from
=
"test@localhost"
,
_mc_mail_password
=
"test"
,
_mc_mail_login_type
=
NoAuth
})
mailSettings
=
to
$
const
(
MailConfig
{
_mc_mail_host
=
"localhost"
,
_mc_mail_port
=
25
,
_mc_mail_user
=
"test"
,
_mc_mail_from
=
"test@localhost"
,
_mc_mail_password
=
"test"
,
_mc_mail_login_type
=
NoAuth
,
_mc_send_login_emails
=
LogEmailToConsole
})
instance
HasNodeStoryEnv
TestEnv
where
hasNodeStory
=
to
test_nodeStory
...
...
test/Test/Instances.hs
View file @
ec01d870
This diff is collapsed.
Click to expand it.
test/Test/Offline/JSON.hs
View file @
ec01d870
...
...
@@ -17,7 +17,7 @@ import Gargantext.Core.Types.Phylo
import
Gargantext.Database.Admin.Types.Node
import
Paths_gargantext
import
Prelude
import
Test.Instances
()
import
Test.Instances
(
genFrontendErr
)
import
Test.Tasty
import
Test.Tasty.HUnit
import
Test.Tasty.QuickCheck
...
...
test/Test/Utils.hs
View file @
ec01d870
...
...
@@ -28,8 +28,7 @@ import Network.HTTP.Types.Header (hAccept, hAuthorization, hContentType)
import
Network.Wai.Handler.Warp
(
Port
)
import
Network.Wai.Test
(
SResponse
(
..
))
import
Prelude
qualified
import
Servant.Client
(
ClientEnv
,
baseUrlPort
,
defaultMakeClientRequest
,
makeClientRequest
,
mkClientEnv
,
parseBaseUrl
,
runClientM
)
import
Servant.Client.Core.Request
(
addHeader
)
import
Servant.Client
(
ClientEnv
,
baseUrlPort
,
mkClientEnv
,
parseBaseUrl
,
runClientM
)
import
System.Timeout
qualified
as
Timeout
import
Test.API.Routes
(
auth_api
,
mkUrl
)
import
Test.Hspec.Expectations
...
...
test/Test/Utils/Jobs.hs
View file @
ec01d870
...
...
@@ -288,10 +288,10 @@ newTestEnv = do
,
_gc_jobs
=
Prelude
.
error
"gc_jobs not needed, but forced somewhere (check StrictData)"
,
_gc_secrets
=
Prelude
.
error
"gc_secrets not needed, but forced somewhere (check StrictData)"
,
_gc_apis
=
Prelude
.
error
"gc_apis not needed, but forced somewhere (check StrictData)"
,
_gc_log_level
=
Prelude
.
error
"gc_log_level not needed, but forced somewhere (check StrictData)"
}
pure
$
Env
{
_env_settings
=
Prelude
.
error
"env_settings not needed, but forced somewhere (check StrictData)"
,
_env_logger
=
Prelude
.
error
"env_logger not needed, but forced somewhere (check StrictData)"
{
_env_logger
=
Prelude
.
error
"env_logger not needed, but forced somewhere (check StrictData)"
,
_env_pool
=
Prelude
.
error
"env_pool not needed, but forced somewhere (check StrictData)"
,
_env_nodeStory
=
Prelude
.
error
"env_nodeStory not needed, but forced somewhere (check StrictData)"
,
_env_manager
=
testTlsManager
...
...
@@ -299,10 +299,9 @@ newTestEnv = do
,
_env_scrapers
=
Prelude
.
error
"scrapers not needed, but forced somewhere (check StrictData)"
,
_env_jobs
=
myEnv
,
_env_config
,
_env_mail
=
Prelude
.
error
"mail not needed, but forced somewhere (check StrictData)"
,
_env_nlp
=
Prelude
.
error
"nlp not needed, but forced somewhere (check StrictData)"
,
_env_central_exchange
=
Prelude
.
error
"central exchange not needed, but forced somewhere (check StrictData)"
,
_env_dispatcher
=
Prelude
.
error
"dispatcher not needed, but forced somewhere (check StrictData)"
,
_env_jwt_settings
=
Prelude
.
error
"jwt_settings not needed, but forced somewherer (check StrictData)"
}
testFetchJobStatus
::
IO
()
...
...
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