Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
haskell-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
195
Issues
195
List
Board
Labels
Milestones
Merge Requests
12
Merge Requests
12
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
gargantext
haskell-gargantext
Commits
890a8076
Verified
Commit
890a8076
authored
Sep 19, 2024
by
Przemyslaw Kaminski
Browse files
Options
Browse Files
Download
Plain Diff
Merge branch '304-dev-toml-config-rewrite-and-update-deps' into 238-dev-async-job-worker
parents
db2b4cff
261fb04e
Pipeline
#6666
failed with stages
in 29 minutes and 56 seconds
Changes
45
Pipelines
1
Show whitespace changes
Inline
Side-by-side
Showing
45 changed files
with
261 additions
and
265 deletions
+261
-265
Ini.hs
bin/gargantext-cli/CLI/Ini.hs
+7
-4
gargantext-settings.toml_toModify
gargantext-settings.toml_toModify
+3
-0
gargantext.cabal
gargantext.cabal
+1
-0
API.hs
src/Gargantext/API.hs
+11
-10
Auth.hs
src/Gargantext/API/Admin/Auth.hs
+5
-4
EnvTypes.hs
src/Gargantext/API/Admin/EnvTypes.hs
+26
-23
Settings.hs
src/Gargantext/API/Admin/Settings.hs
+14
-32
Types.hs
src/Gargantext/API/Admin/Types.hs
+3
-23
PolicyCheck.hs
src/Gargantext/API/Auth/PolicyCheck.hs
+23
-24
Dev.hs
src/Gargantext/API/Dev.hs
+3
-6
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
Types.hs
src/Gargantext/API/Ngrams/Types.hs
+2
-1
New.hs
src/Gargantext/API/Node/Corpus/New.hs
+1
-2
Searx.hs
src/Gargantext/API/Node/Corpus/Searx.hs
+1
-2
FrameCalcUpload.hs
src/Gargantext/API/Node/FrameCalcUpload.hs
+2
-2
ShareURL.hs
src/Gargantext/API/Node/ShareURL.hs
+6
-9
Prelude.hs
src/Gargantext/API/Prelude.hs
+2
-1
Routes.hs
src/Gargantext/API/Routes.hs
+1
-2
Named.hs
src/Gargantext/API/Server/Named.hs
+1
-2
Types.hs
src/Gargantext/Core/AsyncUpdates/Dispatcher/Types.hs
+1
-1
WebSocket.hs
src/Gargantext/Core/AsyncUpdates/Dispatcher/WebSocket.hs
+8
-9
Config.hs
src/Gargantext/Core/Config.hs
+25
-5
Types.hs
src/Gargantext/Core/Config/Types.hs
+42
-5
Mail.hs
src/Gargantext/Core/Mail.hs
+1
-2
Env.hs
src/Gargantext/Core/Worker/Env.hs
+4
-4
Jobs.hs
src/Gargantext/Core/Worker/Jobs.hs
+3
-3
Flow.hs
src/Gargantext/Database/Action/Flow.hs
+2
-2
Node.hs
src/Gargantext/Database/Action/Node.hs
+12
-14
GargDB.hs
src/Gargantext/Database/GargDB.hs
+1
-2
Prelude.hs
src/Gargantext/Database/Prelude.hs
+1
-7
ReverseProxy.hs
src/Gargantext/MicroServices/ReverseProxy.hs
+18
-22
test_config.toml
test-data/test_config.toml
+1
-0
Notifications.hs
test/Test/API/Notifications.hs
+0
-3
Setup.hs
test/Test/API/Setup.hs
+7
-14
Setup.hs
test/Test/Database/Setup.hs
+1
-1
Types.hs
test/Test/Database/Types.hs
+2
-1
Utils.hs
test/Test/Utils.hs
+1
-2
Jobs.hs
test/Test/Utils/Jobs.hs
+0
-2
No files found.
bin/gargantext-cli/CLI/Ini.hs
View file @
890a8076
...
...
@@ -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
Database.PostgreSQL.Simple
qualified
as
PGS
import
Gargantext.Core.Config
qualified
as
Config
...
...
@@ -56,7 +57,8 @@ ini_p = 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
...
...
@@ -74,7 +76,8 @@ convertConfigs ini@(Ini.GargConfig { .. }) iniMail nlpConfig connInfo =
,
_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
}
,
_gc_worker
=
WorkerSettings
{
_wsDefinitions
=
[]
}
-- not supported for ini file
,
_gc_worker
=
WorkerSettings
{
_wsDefinitions
=
[]
}
,
_gc_log_level
=
LevelDebug
}
mkFrontendConfig
::
Ini
.
GargConfig
->
CTypes
.
FrontendConfig
...
...
@@ -82,9 +85,9 @@ 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
}
where
_fc_cors
=
CTypes
.
CORSSettings
{
_corsAllowedOrigins
=
[
toCORSOrigin
"https://demo.gargantext.org"
...
...
gargantext-settings.toml_toModify
View file @
890a8076
...
...
@@ -47,6 +47,9 @@ master_user = "gargantua"
# frame_id seeds are computed.
secret_key = "something_speciaL"
# JWK token
jwk_file = "dev.jwk"
[paths]
...
...
gargantext.cabal
View file @
890a8076
...
...
@@ -669,6 +669,7 @@ executable gargantext-cli
, haskell-bee
, 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 @
890a8076
...
...
@@ -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,18 @@ 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
,
Mode
(
..
),
env_config
,
env_jwt_settings
)
import
Gargantext.API.Admin.Settings
(
newEnv
)
import
Gargantext.API.Admin.Types
(
FireWall
(
..
),
MicroServicesProxyStatus
(
..
),
PortNumber
,
cookieSettings
,
jwtSettings
,
settings
,
corsSettings
,
microServicesProxyStatu
s
)
import
Gargantext.API.Admin.Types
(
FireWall
(
..
),
cookieSettings
,
setting
s
)
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
,
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 +73,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
...
...
@@ -203,7 +204,7 @@ makeApp env = do
-- })
where
cfg
::
Servant
.
Context
AuthContext
cfg
=
env
^.
settings
.
jwtS
ettings
cfg
=
env
^.
env_jwt_s
ettings
:.
env
^.
settings
.
cookieSettings
:.
EmptyContext
...
...
src/Gargantext/API/Admin/Auth.hs
View file @
890a8076
...
...
@@ -56,6 +56,7 @@ 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
(
..
))
...
...
@@ -83,18 +84,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
...
...
@@ -119,7 +120,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
...
...
src/Gargantext/API/Admin/EnvTypes.hs
View file @
890a8076
...
...
@@ -11,12 +11,15 @@ 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
...
...
@@ -46,18 +49,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
...
...
@@ -178,10 +181,9 @@ data Env = Env
,
_env_scrapers
::
~
ScrapersEnv
,
_env_jobs
::
~
(
Jobs
.
JobEnv
GargJob
(
Seq
JobLog
)
JobLog
)
,
_env_config
::
~
GargConfig
,
_env_mail
::
~
MailConfig
,
_env_nlp
::
~
NLPServerMap
,
_env_central_exchange
::
~
ThreadId
,
_env_dispatcher
::
~
Dispatcher
,
_env_jwt_settings
::
~
JWTSettings
}
deriving
(
Generic
)
...
...
@@ -205,11 +207,14 @@ instance HasNodeArchiveStoryImmediateSaver Env where
instance
HasSettings
Env
where
settings
=
env_settings
instance
HasJWTSettings
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
...
...
@@ -342,8 +347,6 @@ data DevEnv = DevEnv
,
_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
...
...
@@ -402,10 +405,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 @
890a8076
...
...
@@ -20,7 +20,6 @@ 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
)
...
...
@@ -32,12 +31,10 @@ 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,40 +42,27 @@ 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.Auth.Server
(
CookieSettings
(
..
),
XsrfCookieSettings
(
..
),
defaultCookieSettings
,
defaultXsrfCookieSettings
)
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
devSettings
::
Settings
devSettings
=
-- GargTomlSettings{..} <- loadGargTomlSettings settingsFile
gc
@
(
GargConfig
{})
<-
readConfig
settingsFile
pure
$
Settings
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
_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
,
_workerSettings
=
_gc_worker
gc
}
where
xsrfCookieSetting
=
defaultXsrfCookieSettings
{
xsrfExcludeGet
=
True
}
...
...
@@ -182,17 +166,14 @@ 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
)
$
let
!
settings'
=
devSettings
!
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
)
...
...
@@ -211,6 +192,8 @@ 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.
-}
...
...
@@ -224,10 +207,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/Types.hs
View file @
890a8076
...
...
@@ -3,16 +3,12 @@
module
Gargantext.API.Admin.Types
where
import
Control.Lens
import
Control.Monad.Logger
(
LogLevel
)
import
GHC.Enum
import
Gargantext.Core.Config.Worker
(
WorkerSettings
)
import
Gargantext.Core.Config.Types
import
Gargantext.Prelude
import
Servant.Auth.Server
(
JWTSettings
,
CookieSettings
(
..
))
import
Servant.Auth.Server
(
CookieSettings
(
..
))
import
Servant.Client
(
BaseUrl
)
type
PortNumber
=
Int
data
SendEmailType
=
SendEmailViaAws
|
LogEmailToConsole
...
...
@@ -20,32 +16,16 @@ data SendEmailType = SendEmailViaAws
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
_cookieSettings
::
!
CookieSettings
,
_sendLoginEmails
::
!
SendEmailType
,
_scrapydUrl
::
!
BaseUrl
,
_workerSettings
::
!
WorkerSettings
}
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
...
...
src/Gargantext/API/Auth/PolicyCheck.hs
View file @
890a8076
...
...
@@ -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/Dev.hs
View file @
890a8076
...
...
@@ -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
(
dev
JwkFile
,
dev
Settings
,
newPool
)
import
Gargantext.API.Admin.Settings
(
devSettings
,
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,13 @@ 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
let
setts
=
devSettings
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/GraphQL.hs
View file @
890a8076
...
...
@@ -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 @
890a8076
...
...
@@ -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 @
890a8076
...
...
@@ -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 @
890a8076
...
...
@@ -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 @
890a8076
...
...
@@ -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 @
890a8076
...
...
@@ -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 @
890a8076
...
...
@@ -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 @
890a8076
...
...
@@ -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/Ngrams/Types.hs
View file @
890a8076
...
...
@@ -38,13 +38,14 @@ 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
)
...
...
src/Gargantext/API/Node/Corpus/New.hs
View file @
890a8076
...
...
@@ -37,7 +37,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 +53,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
))
...
...
src/Gargantext/API/Node/Corpus/Searx.hs
View file @
890a8076
...
...
@@ -23,7 +23,7 @@ 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 +40,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
)
...
...
src/Gargantext/API/Node/FrameCalcUpload.hs
View file @
890a8076
...
...
@@ -21,6 +21,7 @@ import Data.Text qualified as T
import
Gargantext.API.Admin.Auth.Types
(
auth_node_id
,
AuthenticatedUser
)
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.Corpus.New
(
addToCorpusWithForm
)
import
Gargantext.API.Node.Corpus.New.Types
(
FileFormat
(
..
),
FileType
(
..
))
...
...
@@ -28,12 +29,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 +42,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
))
...
...
src/Gargantext/API/Node/ShareURL.hs
View file @
890a8076
...
...
@@ -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/Prelude.hs
View file @
890a8076
...
...
@@ -27,11 +27,12 @@ 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
...
...
src/Gargantext/API/Routes.hs
View file @
890a8076
...
...
@@ -30,12 +30,11 @@ 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.Core.Worker.Jobs
qualified
as
Jobs
import
Gargantext.Core.Worker.Jobs.Types
qualified
as
Jobs
import
Gargantext.Database.Prelude
(
HasConfig
(
..
))
import
Gargantext.Prelude
import
Gargantext.Utils.Jobs
(
serveJobsAPI
)
import
Servant
...
...
src/Gargantext/API/Server/Named.hs
View file @
890a8076
...
...
@@ -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/Core/AsyncUpdates/Dispatcher/Types.hs
View file @
890a8076
...
...
@@ -31,7 +31,7 @@ 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
,
jwt
Settings
)
import
Gargantext.API.Admin.Types
(
Settings
)
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 @
890a8076
...
...
@@ -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 @
890a8076
...
...
@@ -29,10 +29,16 @@ module Gargantext.Core.Config (
,
gc_secrets
,
gc_apis
,
gc_worker
,
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
)
...
...
@@ -40,6 +46,7 @@ import Gargantext.Core.Config.NLP (NLPConfig)
import
Gargantext.Core.Config.Worker
(
WorkerSettings
)
import
Gargantext.Core.Config.Types
import
Gargantext.Prelude
import
Servant.Auth.Server
(
JWTSettings
)
import
Servant.Client
(
BaseUrl
(
..
),
Scheme
(
Http
),
parseBaseUrl
)
import
Toml.Schema
...
...
@@ -51,7 +58,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
...
...
@@ -62,6 +68,7 @@ data GargConfig = GargConfig { _gc_datafilepath :: ~FilePath
,
_gc_secrets
::
~
SecretsConfig
,
_gc_apis
::
~
APIsConfig
,
_gc_worker
::
~
WorkerSettings
,
_gc_log_level
::
~
LogLevel
}
deriving
(
Generic
,
Show
)
...
...
@@ -80,6 +87,7 @@ instance FromValue GargConfig where
_gc_apis
<-
reqKey
"apis"
_gc_notifications_config
<-
reqKey
"notifications"
_gc_worker
<-
reqKey
"worker"
let
_gc_log_level
=
LevelDebug
return
$
GargConfig
{
_gc_datafilepath
,
_gc_jobs
,
_gc_apis
...
...
@@ -90,7 +98,8 @@ instance FromValue GargConfig where
,
_gc_notifications_config
,
_gc_frames
,
_gc_secrets
,
_gc_worker
}
,
_gc_worker
,
_gc_log_level
}
instance
ToValue
GargConfig
where
toValue
=
defaultTableToValue
instance
ToTable
GargConfig
where
...
...
@@ -110,8 +119,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/Types.hs
View file @
890a8076
...
...
@@ -25,13 +25,16 @@ 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
,
MicroServicesProxyStatus
(
..
)
,
microServicesProxyStatus
,
JobsConfig
(
..
)
,
jc_max_docs_parsers
,
jc_max_docs_scrapers
...
...
@@ -39,7 +42,9 @@ module Gargantext.Core.Config.Types
,
jc_js_id_timeout
,
MicroServicesSettings
(
..
)
,
NotificationsConfig
(
..
)
,
JWKFile
(
..
)
,
SecretsConfig
(
..
)
,
jwtSettings
,
SettingsFile
(
..
)
,
TOMLConnectInfo
(
..
)
...
...
@@ -54,7 +59,9 @@ 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
(
JWTSettings
,
defaultJWTSettings
,
readKey
,
writeKey
)
import
Servant.Client.Core
(
BaseUrl
,
parseBaseUrl
,
showBaseUrl
)
import
System.Directory
(
doesFileExist
)
import
Toml
import
Toml.Schema
...
...
@@ -179,13 +186,17 @@ instance ToTable FramesConfig where
makeLenses
''
F
ramesConfig
type
PortNumber
=
Int
-- TODO jwtSettings = defaultJWTSettings
data
FrontendConfig
=
FrontendConfig
{
_fc_url
::
!
Text
,
_fc_backend_name
::
!
Text
,
_fc_url_backend_api
::
!
Text
,
_fc_jwt_settings
::
!
Text
,
_fc_cors
::
!
CORSSettings
,
_fc_microservices
::
!
MicroServicesSettings
,
_fc_appPort
::
!
PortNumber
}
deriving
(
Generic
,
Show
)
instance
FromValue
FrontendConfig
where
...
...
@@ -193,9 +204,9 @@ 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"
let
_fc_appPort
=
3000
return
$
FrontendConfig
{
..
}
instance
ToValue
FrontendConfig
where
toValue
=
defaultTableToValue
...
...
@@ -203,28 +214,54 @@ 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
=
...
...
src/Gargantext/Core/Mail.hs
View file @
890a8076
...
...
@@ -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/Worker/Env.hs
View file @
890a8076
...
...
@@ -24,12 +24,12 @@ 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
(
dev
JwkFile
,
dev
Settings
,
newPool
)
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
(
..
))
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
(
..
))
...
...
@@ -37,7 +37,7 @@ 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
(
HasCon
fig
(
..
),
HasCon
nectionPool
(
..
))
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
)
...
...
@@ -70,7 +70,7 @@ withWorkerEnv 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
let
setts
=
devSettings
pure
$
WorkerEnv
{
_w_env_pool
=
pool
,
_w_env_logger
=
logger
...
...
src/Gargantext/Core/Worker/Jobs.hs
View file @
890a8076
...
...
@@ -20,7 +20,7 @@ import Async.Worker.Types qualified as Worker
import
Async.Worker.Types
(
HasWorkerBroker
)
import
Control.Lens
(
view
)
import
Database.Redis
qualified
as
Redis
import
Gargantext.
API.Admin.Types
(
HasSettings
,
settings
,
workerSettings
)
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
'
)
...
...
@@ -36,11 +36,11 @@ initializeRedisBroker connInfo = do
initBroker
initParams
sendJob
::
(
HasWorkerBroker
RedisBroker
Job
,
Has
Settings
env
)
sendJob
::
(
HasWorkerBroker
RedisBroker
Job
,
Has
Config
env
)
=>
Job
->
Cmd'
env
err
()
sendJob
job
=
do
ws
<-
view
$
settings
.
workerSettings
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
...
...
src/Gargantext/Database/Action/Flow.hs
View file @
890a8076
...
...
@@ -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
)
...
...
src/Gargantext/Database/Action/Node.hs
View file @
890a8076
...
...
@@ -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/GargDB.hs
View file @
890a8076
...
...
@@ -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 @
890a8076
...
...
@@ -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/MicroServices/ReverseProxy.hs
View file @
890a8076
{-# 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
...
...
@@ -38,10 +35,9 @@ 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
(
gc_frames
,
mkProxyUrl
,
hasConfig
)
import
Gargantext.Core.Config.Types
(
f_write_url
)
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,10 +154,10 @@ 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
cfg
=
env
^.
env_jwt_s
ettings
:.
env
^.
settings
.
cookieSettings
:.
EmptyContext
...
...
@@ -212,10 +208,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 +220,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 +232,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 +249,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 +260,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,7 +280,7 @@ 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
...
...
@@ -295,7 +291,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 +303,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 +313,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 +322,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 +356,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 +378,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 @
890a8076
...
...
@@ -15,6 +15,7 @@ enabled = false
[secrets]
master_user
=
"gargantua"
secret_key
=
"test_key"
jwk_file
=
"test.jwk"
[paths]
data_filepath
=
"~/.garg"
...
...
test/Test/API/Notifications.hs
View file @
890a8076
...
...
@@ -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 @
890a8076
...
...
@@ -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,9 @@ 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
let
!
settings'
=
devSettings
!
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,6 +71,7 @@ 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
...
...
@@ -92,12 +86,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 @
890a8076
...
...
@@ -76,7 +76,7 @@ setup = do
bootstrapDB
db
pool
gargConfig
ugen
<-
emptyCounter
test_nodeStory
<-
fromDBNodeStoryEnv
pool
stgs
<-
devSettings
devJwkFile
=<<
fakeTomlPath
let
stgs
=
devSettings
withLoggerHoisted
Mock
$
\
logger
->
do
pure
$
TestEnv
{
test_db
=
DBHandle
pool
db
,
test_config
=
gargConfig
...
...
test/Test/Database/Types.hs
View file @
890a8076
...
...
@@ -31,10 +31,11 @@ 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
))
...
...
test/Test/Utils.hs
View file @
890a8076
...
...
@@ -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 @
890a8076
...
...
@@ -303,8 +303,6 @@ 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)"
}
...
...
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