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
150
Issues
150
List
Board
Labels
Milestones
Merge Requests
4
Merge Requests
4
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
Hide 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.
...
@@ -19,6 +19,7 @@ Import a corpus binary.
module
CLI.Ini
where
module
CLI.Ini
where
import
CLI.Types
import
CLI.Types
import
Control.Monad.Logger
(
LogLevel
(
LevelDebug
))
import
Data.Text
qualified
as
T
import
Data.Text
qualified
as
T
import
Database.PostgreSQL.Simple
qualified
as
PGS
import
Database.PostgreSQL.Simple
qualified
as
PGS
import
Gargantext.Core.Config
qualified
as
Config
import
Gargantext.Core.Config
qualified
as
Config
...
@@ -56,7 +57,8 @@ ini_p = fmap CCMD_ini $ IniArgs
...
@@ -56,7 +57,8 @@ ini_p = fmap CCMD_ini $ IniArgs
convertConfigs
::
Ini
.
GargConfig
->
IniMail
.
MailConfig
->
IniNLP
.
NLPConfig
->
PGS
.
ConnectInfo
->
Config
.
GargConfig
convertConfigs
::
Ini
.
GargConfig
->
IniMail
.
MailConfig
->
IniNLP
.
NLPConfig
->
PGS
.
ConnectInfo
->
Config
.
GargConfig
convertConfigs
ini
@
(
Ini
.
GargConfig
{
..
})
iniMail
nlpConfig
connInfo
=
convertConfigs
ini
@
(
Ini
.
GargConfig
{
..
})
iniMail
nlpConfig
connInfo
=
Config
.
GargConfig
{
_gc_secrets
=
CTypes
.
SecretsConfig
{
_s_master_user
=
_gc_masteruser
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_datafilepath
,
_gc_mail_config
=
iniMail
,
_gc_mail_config
=
iniMail
,
_gc_nlp_config
=
nlpConfig
,
_gc_nlp_config
=
nlpConfig
...
@@ -74,7 +76,8 @@ convertConfigs ini@(Ini.GargConfig { .. }) iniMail nlpConfig connInfo =
...
@@ -74,7 +76,8 @@ convertConfigs ini@(Ini.GargConfig { .. }) iniMail nlpConfig connInfo =
,
_jc_js_id_timeout
=
_gc_js_id_timeout
}
,
_jc_js_id_timeout
=
_gc_js_id_timeout
}
,
_gc_apis
=
CTypes
.
APIsConfig
{
_ac_pubmed_api_key
=
_gc_pubmed_api_key
,
_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
}
,
_gc_worker
=
WorkerSettings
{
_wsDefinitions
=
[]
}
-- not supported for ini file
,
_gc_worker
=
WorkerSettings
{
_wsDefinitions
=
[]
}
,
_gc_log_level
=
LevelDebug
}
}
mkFrontendConfig
::
Ini
.
GargConfig
->
CTypes
.
FrontendConfig
mkFrontendConfig
::
Ini
.
GargConfig
->
CTypes
.
FrontendConfig
...
@@ -82,9 +85,9 @@ mkFrontendConfig (Ini.GargConfig { .. }) =
...
@@ -82,9 +85,9 @@ mkFrontendConfig (Ini.GargConfig { .. }) =
CTypes
.
FrontendConfig
{
_fc_url
=
_gc_url
CTypes
.
FrontendConfig
{
_fc_url
=
_gc_url
,
_fc_backend_name
=
_gc_backend_name
,
_fc_backend_name
=
_gc_backend_name
,
_fc_url_backend_api
=
_gc_url_backend_api
,
_fc_url_backend_api
=
_gc_url_backend_api
,
_fc_jwt_settings
=
"TODO"
,
_fc_cors
,
_fc_cors
,
_fc_microservices
}
,
_fc_microservices
,
_fc_appPort
=
3000
}
where
where
_fc_cors
=
CTypes
.
CORSSettings
{
_corsAllowedOrigins
=
[
_fc_cors
=
CTypes
.
CORSSettings
{
_corsAllowedOrigins
=
[
toCORSOrigin
"https://demo.gargantext.org"
toCORSOrigin
"https://demo.gargantext.org"
...
...
gargantext-settings.toml_toModify
View file @
890a8076
...
@@ -47,6 +47,9 @@ master_user = "gargantua"
...
@@ -47,6 +47,9 @@ master_user = "gargantua"
# frame_id seeds are computed.
# frame_id seeds are computed.
secret_key = "something_speciaL"
secret_key = "something_speciaL"
# JWK token
jwk_file = "dev.jwk"
[paths]
[paths]
...
...
gargantext.cabal
View file @
890a8076
...
@@ -669,6 +669,7 @@ executable gargantext-cli
...
@@ -669,6 +669,7 @@ executable gargantext-cli
, haskell-bee
, haskell-bee
, ini ^>= 0.4.1
, ini ^>= 0.4.1
, lens >= 5.2.2 && < 5.3
, lens >= 5.2.2 && < 5.3
, monad-logger ^>= 0.3.36
, optparse-applicative
, optparse-applicative
, optparse-generic ^>= 1.4.7
, optparse-generic ^>= 1.4.7
, parallel ^>= 3.2.2.0
, parallel ^>= 3.2.2.0
...
...
src/Gargantext/API.hs
View file @
890a8076
...
@@ -30,12 +30,12 @@ Pouillard (who mainly made it).
...
@@ -30,12 +30,12 @@ Pouillard (who mainly made it).
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeOperators #-}
module
Gargantext.API
module
Gargantext.API
where
where
import
Control.Concurrent
import
Control.Concurrent
import
Control.Concurrent.Async
qualified
as
Async
import
Control.Concurrent.Async
qualified
as
Async
import
Control.Lens
hiding
(
Level
)
import
Data.Cache
qualified
as
InMemory
import
Data.Cache
qualified
as
InMemory
import
Data.List
(
lookup
)
import
Data.List
(
lookup
)
import
Data.Set
qualified
as
Set
import
Data.Set
qualified
as
Set
...
@@ -44,18 +44,18 @@ import Data.Text.Encoding qualified as TE
...
@@ -44,18 +44,18 @@ import Data.Text.Encoding qualified as TE
import
Data.Text.IO
(
putStrLn
)
import
Data.Text.IO
(
putStrLn
)
import
Data.Validity
import
Data.Validity
import
Gargantext.API.Admin.Auth.Types
(
AuthContext
)
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.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.Middleware
(
logStdoutDevSanitised
)
import
Gargantext.API.Routes.Named
(
API
)
import
Gargantext.API.Routes.Named
(
API
)
import
Gargantext.API.Routes.Named.EKG
import
Gargantext.API.Routes.Named.EKG
import
Gargantext.API.Server.Named
(
server
)
import
Gargantext.API.Server.Named
(
server
)
import
Gargantext.Core.Config
(
_gc_notifications
_config
)
import
Gargantext.Core.Config
(
gc_notifications_config
,
gc_frontend
_config
)
import
Gargantext.Core.Config.Types
(
CORSOrigin
(
..
),
CORSSettings
,
NotificationsConfig
(
..
),
SettingsFile
(
..
),
corsAllowedOrigin
s
)
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.Database.Prelude
qualified
as
DB
import
Gargantext.MicroServices.ReverseProxy
(
microServicesProxyApp
)
import
Gargantext.MicroServices.ReverseProxy
(
microServicesProxyApp
)
import
Gargantext.Prelude
hiding
(
putStrLn
)
import
Gargantext.Prelude
hiding
(
putStrLn
,
to
)
import
Gargantext.System.Logging
import
Gargantext.System.Logging
import
Network.HTTP.Types
hiding
(
Query
)
import
Network.HTTP.Types
hiding
(
Query
)
import
Network.Wai
import
Network.Wai
...
@@ -73,11 +73,12 @@ import System.Cron.Schedule qualified as Cron
...
@@ -73,11 +73,12 @@ import System.Cron.Schedule qualified as Cron
startGargantext
::
Mode
->
PortNumber
->
SettingsFile
->
IO
()
startGargantext
::
Mode
->
PortNumber
->
SettingsFile
->
IO
()
startGargantext
mode
port
sf
@
(
SettingsFile
settingsFile
)
=
withLoggerHoisted
mode
$
\
logger
->
do
startGargantext
mode
port
sf
@
(
SettingsFile
settingsFile
)
=
withLoggerHoisted
mode
$
\
logger
->
do
env
<-
newEnv
logger
port
sf
env
<-
newEnv
logger
port
sf
let
proxyStatus
=
microServicesProxyStatus
(
env
^.
settings
)
let
fc
=
env
^.
env_config
.
gc_frontend_config
let
proxyStatus
=
microServicesProxyStatus
fc
runDbCheck
env
runDbCheck
env
portRouteInfo
(
_gc_notifications_config
$
_env_config
env
)
port
proxyStatus
portRouteInfo
(
env
^.
env_config
.
gc_notifications_config
)
port
proxyStatus
app
<-
makeApp
env
app
<-
makeApp
env
mid
<-
makeGargMiddleware
(
env
^.
settings
.
corsSetting
s
)
mode
mid
<-
makeGargMiddleware
(
fc
^.
fc_cor
s
)
mode
periodicActions
<-
schedulePeriodicActions
env
periodicActions
<-
schedulePeriodicActions
env
let
runServer
=
run
port
(
mid
app
)
`
finally
`
stopGargantext
periodicActions
let
runServer
=
run
port
(
mid
app
)
`
finally
`
stopGargantext
periodicActions
...
@@ -203,7 +204,7 @@ makeApp env = do
...
@@ -203,7 +204,7 @@ makeApp env = do
-- })
-- })
where
where
cfg
::
Servant
.
Context
AuthContext
cfg
::
Servant
.
Context
AuthContext
cfg
=
env
^.
settings
.
jwtS
ettings
cfg
=
env
^.
env_jwt_s
ettings
:.
env
^.
settings
.
cookieSettings
:.
env
^.
settings
.
cookieSettings
:.
EmptyContext
:.
EmptyContext
...
...
src/Gargantext/API/Admin/Auth.hs
View file @
890a8076
...
@@ -56,6 +56,7 @@ import Gargantext.API.Admin.Types
...
@@ -56,6 +56,7 @@ import Gargantext.API.Admin.Types
import
Gargantext.API.Auth.PolicyCheck
import
Gargantext.API.Auth.PolicyCheck
import
Gargantext.API.Errors
import
Gargantext.API.Errors
import
Gargantext.API.Prelude
(
authenticationError
,
HasServerError
,
GargServerC
,
_ServerError
,
GargM
,
IsGargServer
)
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
(
MailModel
(
..
),
mail
)
import
Gargantext.Core.Mail.Types
(
mailSettings
)
import
Gargantext.Core.Mail.Types
(
mailSettings
)
import
Gargantext.Core.Types.Individu
(
User
(
..
),
Username
,
GargPassword
(
..
))
import
Gargantext.Core.Types.Individu
(
User
(
..
),
Username
,
GargPassword
(
..
))
...
@@ -83,18 +84,18 @@ import qualified Gargantext.API.Routes.Named as Named
...
@@ -83,18 +84,18 @@ import qualified Gargantext.API.Routes.Named as Named
-- | Main functions of authorization
-- | Main functions of authorization
makeTokenForUser
::
(
HasSettings
env
,
HasAuthenticationError
err
)
makeTokenForUser
::
(
Has
JWT
Settings
env
,
HasAuthenticationError
err
)
=>
NodeId
=>
NodeId
->
UserId
->
UserId
->
Cmd'
env
err
Token
->
Cmd'
env
err
Token
makeTokenForUser
nodeId
userId
=
do
makeTokenForUser
nodeId
userId
=
do
jwtS
<-
view
$
settings
.
jwtSettings
jwtS
<-
view
jwtSettings
e
<-
liftBase
$
makeJWT
(
AuthenticatedUser
nodeId
userId
)
jwtS
Nothing
e
<-
liftBase
$
makeJWT
(
AuthenticatedUser
nodeId
userId
)
jwtS
Nothing
-- TODO-SECURITY here we can implement token expiration ^^.
-- TODO-SECURITY here we can implement token expiration ^^.
either
(
authenticationError
.
LoginFailed
nodeId
userId
)
(
pure
.
toStrict
.
LE
.
decodeUtf8
)
e
either
(
authenticationError
.
LoginFailed
nodeId
userId
)
(
pure
.
toStrict
.
LE
.
decodeUtf8
)
e
-- TODO not sure about the encoding...
-- 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
=>
Username
->
GargPassword
->
GargPassword
->
m
CheckAuth
->
m
CheckAuth
...
@@ -119,7 +120,7 @@ checkAuthRequest couldBeEmail (GargPassword p) = do
...
@@ -119,7 +120,7 @@ checkAuthRequest couldBeEmail (GargPassword p) = do
token
<-
makeTokenForUser
nodeId
userLight_id
token
<-
makeTokenForUser
nodeId
userLight_id
pure
$
Valid
token
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
=>
AuthRequest
->
m
AuthResponse
auth
(
AuthRequest
u
p
)
=
do
auth
(
AuthRequest
u
p
)
=
do
checkAuthRequest'
<-
checkAuthRequest
u
p
checkAuthRequest'
<-
checkAuthRequest
u
p
...
...
src/Gargantext/API/Admin/EnvTypes.hs
View file @
890a8076
...
@@ -11,12 +11,15 @@ module Gargantext.API.Admin.EnvTypes (
...
@@ -11,12 +11,15 @@ module Gargantext.API.Admin.EnvTypes (
,
Mode
(
..
)
,
Mode
(
..
)
,
modeToLoggingLevels
,
modeToLoggingLevels
,
mkJobHandle
,
mkJobHandle
,
env_config
,
env_logger
,
env_logger
,
env_manager
,
env_manager
,
env_settings
,
env_settings
,
env_self_url
,
env_self_url
,
env_central_exchange
,
env_central_exchange
,
env_dispatcher
,
env_dispatcher
,
env_jwt_settings
,
menv_firewall
,
menv_firewall
,
dev_env_logger
,
dev_env_logger
...
@@ -46,18 +49,18 @@ import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
...
@@ -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.CentralExchange.Types
qualified
as
CET
import
Gargantext.Core.AsyncUpdates.Dispatcher
(
Dispatcher
)
import
Gargantext.Core.AsyncUpdates.Dispatcher
(
Dispatcher
)
import
Gargantext.Core.AsyncUpdates.Dispatcher.Types
(
HasDispatcher
(
..
))
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.Mail.Types
(
HasMail
,
mailSettings
)
import
Gargantext.Core.NLP
(
NLPServerMap
,
HasNLPServer
(
..
)
)
import
Gargantext.Core.NLP
(
HasNLPServer
(
..
),
nlpServerMap
)
import
Gargantext.Core.NodeStory
import
Gargantext.Core.NodeStory
import
Gargantext.Database.Prelude
(
HasConnectionPool
(
..
),
HasConfig
(
..
))
import
Gargantext.Database.Prelude
(
HasConnectionPool
(
..
))
import
Gargantext.Prelude
import
Gargantext.Prelude
hiding
(
to
)
import
Gargantext.Core.Config
(
GargConfig
(
..
))
import
Gargantext.Core.Config.Mail
(
MailConfig
)
import
Gargantext.System.Logging
import
Gargantext.System.Logging
import
Gargantext.Utils.Jobs.Internal
(
pollJob
)
import
Gargantext.Utils.Jobs.Internal
(
pollJob
)
import
Gargantext.Utils.Jobs.Map
(
LoggerM
,
J
(
..
),
jTask
,
rjGetLog
)
import
Gargantext.Utils.Jobs.Map
(
LoggerM
,
J
(
..
),
jTask
,
rjGetLog
)
import
Gargantext.Utils.Jobs.Monad
qualified
as
Jobs
import
Gargantext.Utils.Jobs.Monad
qualified
as
Jobs
import
Network.HTTP.Client
(
Manager
)
import
Network.HTTP.Client
(
Manager
)
import
Servant.Auth.Server
(
JWTSettings
)
import
Servant.Client
(
BaseUrl
)
import
Servant.Client
(
BaseUrl
)
import
Servant.Job.Async
(
HasJobEnv
(
..
),
Job
)
import
Servant.Job.Async
(
HasJobEnv
(
..
),
Job
)
import
Servant.Job.Async
qualified
as
SJ
import
Servant.Job.Async
qualified
as
SJ
...
@@ -169,19 +172,18 @@ instance ToJSON GargJob where
...
@@ -169,19 +172,18 @@ instance ToJSON GargJob where
-- having to specify /everything/. This means that when we /construct/ an 'Env',
-- 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.
-- we need to remember to force the fields to WHNF at that point.
data
Env
=
Env
data
Env
=
Env
{
_env_settings
::
~
Settings
{
_env_settings
::
~
Settings
,
_env_logger
::
~
(
Logger
(
GargM
Env
BackendInternalError
))
,
_env_logger
::
~
(
Logger
(
GargM
Env
BackendInternalError
))
,
_env_pool
::
~
(
Pool
Connection
)
,
_env_pool
::
~
(
Pool
Connection
)
,
_env_nodeStory
::
~
NodeStoryEnv
,
_env_nodeStory
::
~
NodeStoryEnv
,
_env_manager
::
~
Manager
,
_env_manager
::
~
Manager
,
_env_self_url
::
~
BaseUrl
,
_env_self_url
::
~
BaseUrl
,
_env_scrapers
::
~
ScrapersEnv
,
_env_scrapers
::
~
ScrapersEnv
,
_env_jobs
::
~
(
Jobs
.
JobEnv
GargJob
(
Seq
JobLog
)
JobLog
)
,
_env_jobs
::
~
(
Jobs
.
JobEnv
GargJob
(
Seq
JobLog
)
JobLog
)
,
_env_config
::
~
GargConfig
,
_env_config
::
~
GargConfig
,
_env_mail
::
~
MailConfig
,
_env_nlp
::
~
NLPServerMap
,
_env_central_exchange
::
~
ThreadId
,
_env_central_exchange
::
~
ThreadId
,
_env_dispatcher
::
~
Dispatcher
,
_env_dispatcher
::
~
Dispatcher
,
_env_jwt_settings
::
~
JWTSettings
}
}
deriving
(
Generic
)
deriving
(
Generic
)
...
@@ -205,11 +207,14 @@ instance HasNodeArchiveStoryImmediateSaver Env where
...
@@ -205,11 +207,14 @@ instance HasNodeArchiveStoryImmediateSaver Env where
instance
HasSettings
Env
where
instance
HasSettings
Env
where
settings
=
env_settings
settings
=
env_settings
instance
HasJWTSettings
Env
where
jwtSettings
=
env_jwt_settings
instance
HasMail
Env
where
instance
HasMail
Env
where
mailSettings
=
env_
mail
mailSettings
=
env_
config
.
gc_mail_config
instance
HasNLPServer
Env
where
instance
HasNLPServer
Env
where
nlpServer
=
env_
nlp
nlpServer
=
env_
config
.
gc_nlp_config
.
(
to
nlpServerMap
)
instance
HasDispatcher
Env
Dispatcher
where
instance
HasDispatcher
Env
Dispatcher
where
hasDispatcher
=
env_dispatcher
hasDispatcher
=
env_dispatcher
...
@@ -342,8 +347,6 @@ data DevEnv = DevEnv
...
@@ -342,8 +347,6 @@ data DevEnv = DevEnv
,
_dev_env_logger
::
!
(
Logger
(
GargM
DevEnv
BackendInternalError
))
,
_dev_env_logger
::
!
(
Logger
(
GargM
DevEnv
BackendInternalError
))
,
_dev_env_pool
::
!
(
Pool
Connection
)
,
_dev_env_pool
::
!
(
Pool
Connection
)
,
_dev_env_nodeStory
::
!
NodeStoryEnv
,
_dev_env_nodeStory
::
!
NodeStoryEnv
,
_dev_env_mail
::
!
MailConfig
,
_dev_env_nlp
::
!
NLPServerMap
}
}
makeLenses
''
D
evEnv
makeLenses
''
D
evEnv
...
@@ -402,10 +405,10 @@ instance HasNodeArchiveStoryImmediateSaver DevEnv where
...
@@ -402,10 +405,10 @@ instance HasNodeArchiveStoryImmediateSaver DevEnv where
hasNodeArchiveStoryImmediateSaver
=
hasNodeStory
.
nse_archive_saver_immediate
hasNodeArchiveStoryImmediateSaver
=
hasNodeStory
.
nse_archive_saver_immediate
instance
HasMail
DevEnv
where
instance
HasMail
DevEnv
where
mailSettings
=
dev_env_
mail
mailSettings
=
dev_env_
config
.
gc_mail_config
instance
HasNLPServer
DevEnv
where
instance
HasNLPServer
DevEnv
where
nlpServer
=
dev_env_
nlp
nlpServer
=
dev_env_
config
.
gc_nlp_config
.
(
to
nlpServerMap
)
instance
IsGargServer
Env
BackendInternalError
(
GargM
Env
BackendInternalError
)
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
...
@@ -20,7 +20,6 @@ module Gargantext.API.Admin.Settings
import
Codec.Serialise
(
Serialise
(),
serialise
)
import
Codec.Serialise
(
Serialise
(),
serialise
)
import
Control.Lens
import
Control.Lens
import
Control.Monad.Logger
(
LogLevel
(
..
))
import
Control.Monad.Reader
import
Control.Monad.Reader
import
Data.ByteString.Lazy
qualified
as
L
import
Data.ByteString.Lazy
qualified
as
L
import
Data.Pool
(
Pool
)
import
Data.Pool
(
Pool
)
...
@@ -32,12 +31,10 @@ import Gargantext.API.Errors.Types
...
@@ -32,12 +31,10 @@ import Gargantext.API.Errors.Types
import
Gargantext.API.Prelude
import
Gargantext.API.Prelude
import
Gargantext.Core.AsyncUpdates.CentralExchange
qualified
as
CE
import
Gargantext.Core.AsyncUpdates.CentralExchange
qualified
as
CE
import
Gargantext.Core.AsyncUpdates.Dispatcher
qualified
as
D
import
Gargantext.Core.AsyncUpdates.Dispatcher
qualified
as
D
import
Gargantext.Core.Config
(
GargConfig
(
..
),
gc_jobs
)
import
Gargantext.Core.Config
(
GargConfig
(
..
),
gc_jobs
,
gc_frontend_config
,
hasConfig
)
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
),
_fc_cors
,
_fc_microservices
,
jc_js_job_timeout
,
jc_js_id_timeout
)
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.Config.Utils
(
readConfig
)
import
Gargantext.Core.NLP
(
nlpServerMap
)
import
Gargantext.Core.NodeStory
import
Gargantext.Core.NodeStory
import
Gargantext.Database.Prelude
(
hasConfig
)
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.System.Logging
import
Gargantext.System.Logging
import
Gargantext.Utils.Jobs
qualified
as
Jobs
import
Gargantext.Utils.Jobs
qualified
as
Jobs
...
@@ -45,40 +42,27 @@ import Gargantext.Utils.Jobs.Monad 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.Queue
qualified
as
Jobs
import
Gargantext.Utils.Jobs.Settings
qualified
as
Jobs
import
Gargantext.Utils.Jobs.Settings
qualified
as
Jobs
import
Network.HTTP.Client.TLS
(
newTlsManager
)
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.Client
(
parseBaseUrl
)
import
Servant.Job.Async
(
newJobEnv
,
defaultSettings
)
import
Servant.Job.Async
(
newJobEnv
,
defaultSettings
)
import
System.Directory
import
System.Directory
(
renameFile
)
import
System.IO
(
hClose
)
import
System.IO
(
hClose
)
import
System.IO.Temp
(
withTempFile
)
import
System.IO.Temp
(
withTempFile
)
newtype
JwkFile
=
JwkFile
{
_JwkFile
::
FilePath
}
deriving
(
Show
,
Eq
,
IsString
)
newtype
IniFile
=
IniFile
{
_IniFile
::
FilePath
}
newtype
IniFile
=
IniFile
{
_IniFile
::
FilePath
}
deriving
(
Show
,
Eq
,
IsString
)
deriving
(
Show
,
Eq
,
IsString
)
devSettings
::
JwkFile
->
SettingsFile
->
IO
Settings
devSettings
::
Settings
devSettings
(
JwkFile
jwkFile
)
settingsFile
=
do
devSettings
=
jwkExists
<-
doesFileExist
jwkFile
when
(
not
jwkExists
)
$
writeKey
jwkFile
jwk
<-
readKey
jwkFile
-- GargTomlSettings{..} <- loadGargTomlSettings settingsFile
-- GargTomlSettings{..} <- loadGargTomlSettings settingsFile
gc
@
(
GargConfig
{})
<-
readConfig
settingsFile
Settings
pure
$
Settings
{
-- _corsSettings = _gargCorsSettings
{
-- _corsSettings = _gargCorsSettings
_corsSettings
=
_fc_cors
$
_gc_frontend_config
gc
-- , _microservicesSettings = _gargMicroServicesSettings
-- , _microservicesSettings = _gargMicroServicesSettings
,
_microservicesSettings
=
_fc_microservices
$
_gc_frontend_config
gc
,
_appPort
=
3000
,
_logLevelLimit
=
LevelDebug
-- , _dbServer = "localhost"
-- , _dbServer = "localhost"
,
_sendLoginEmails
=
LogEmailToConsole
_sendLoginEmails
=
LogEmailToConsole
,
_scrapydUrl
=
fromMaybe
(
panicTrace
"Invalid scrapy URL"
)
$
parseBaseUrl
"http://localhost:6800"
,
_scrapydUrl
=
fromMaybe
(
panicTrace
"Invalid scrapy URL"
)
$
parseBaseUrl
"http://localhost:6800"
,
_cookieSettings
=
defaultCookieSettings
{
cookieXsrfSetting
=
Just
xsrfCookieSetting
}
-- TODO-SECURITY tune
,
_cookieSettings
=
defaultCookieSettings
{
cookieXsrfSetting
=
Just
xsrfCookieSetting
}
-- TODO-SECURITY tune
,
_jwtSettings
=
defaultJWTSettings
jwk
-- TODO-SECURITY tune
,
_workerSettings
=
_gc_worker
gc
}
}
where
where
xsrfCookieSetting
=
defaultXsrfCookieSettings
{
xsrfExcludeGet
=
True
}
xsrfCookieSetting
=
defaultXsrfCookieSettings
{
xsrfExcludeGet
=
True
}
...
@@ -182,17 +166,14 @@ readRepoEnv repoDir = do
...
@@ -182,17 +166,14 @@ readRepoEnv repoDir = do
pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
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
(
GargM
Env
BackendInternalError
)
->
PortNumber
->
SettingsFile
->
IO
Env
newEnv
logger
port
settingsFile
@
(
SettingsFile
sf
)
=
do
newEnv
logger
port
settingsFile
@
(
SettingsFile
sf
)
=
do
!
manager_env
<-
newTlsManager
!
manager_env
<-
newTlsManager
!
settings'
<-
devSettings
devJwkFile
settingsFile
<&>
appPort
.~
port
-- TODO read from 'file'
let
!
settings'
=
devSettings
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"
panicTrace
"TODO: conflicting settings of port"
!
config_env
<-
readConfig
settingsFile
prios
<-
withLogger
()
$
\
ioLogger
->
Jobs
.
readPrios
ioLogger
(
sf
<>
".jobs"
)
prios
<-
withLogger
()
$
\
ioLogger
->
Jobs
.
readPrios
ioLogger
(
sf
<>
".jobs"
)
let
prios'
=
Jobs
.
applyPrios
prios
Jobs
.
defaultPrios
let
prios'
=
Jobs
.
applyPrios
prios
Jobs
.
defaultPrios
putStrLn
(
"Overrides: "
<>
show
prios
::
Text
)
putStrLn
(
"Overrides: "
<>
show
prios
::
Text
)
...
@@ -211,6 +192,8 @@ newEnv logger port settingsFile@(SettingsFile sf) = do
...
@@ -211,6 +192,8 @@ newEnv logger port settingsFile@(SettingsFile sf) = do
!
central_exchange
<-
forkIO
$
CE
.
gServer
(
_gc_notifications_config
config_env
)
!
central_exchange
<-
forkIO
$
CE
.
gServer
(
_gc_notifications_config
config_env
)
!
dispatcher
<-
D
.
newDispatcher
(
_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
{- 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.
we want to force them to WHNF to avoid accumulating unnecessary thunks.
-}
-}
...
@@ -224,10 +207,9 @@ newEnv logger port settingsFile@(SettingsFile sf) = do
...
@@ -224,10 +207,9 @@ newEnv logger port settingsFile@(SettingsFile sf) = do
,
_env_jobs
=
jobs_env
,
_env_jobs
=
jobs_env
,
_env_self_url
=
self_url_env
,
_env_self_url
=
self_url_env
,
_env_config
=
config_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_central_exchange
=
central_exchange
,
_env_dispatcher
=
dispatcher
,
_env_dispatcher
=
dispatcher
,
_env_jwt_settings
}
}
newPool
::
ConnectInfo
->
IO
(
Pool
Connection
)
newPool
::
ConnectInfo
->
IO
(
Pool
Connection
)
...
...
src/Gargantext/API/Admin/Types.hs
View file @
890a8076
...
@@ -3,16 +3,12 @@
...
@@ -3,16 +3,12 @@
module
Gargantext.API.Admin.Types
where
module
Gargantext.API.Admin.Types
where
import
Control.Lens
import
Control.Lens
import
Control.Monad.Logger
(
LogLevel
)
import
GHC.Enum
import
GHC.Enum
import
Gargantext.Core.Config.Worker
(
WorkerSettings
)
import
Gargantext.Core.Config.Types
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Servant.Auth.Server
(
JWTSettings
,
CookieSettings
(
..
))
import
Servant.Auth.Server
(
CookieSettings
(
..
))
import
Servant.Client
(
BaseUrl
)
import
Servant.Client
(
BaseUrl
)
type
PortNumber
=
Int
data
SendEmailType
=
SendEmailViaAws
data
SendEmailType
=
SendEmailViaAws
|
LogEmailToConsole
|
LogEmailToConsole
...
@@ -20,32 +16,16 @@ data SendEmailType = SendEmailViaAws
...
@@ -20,32 +16,16 @@ data SendEmailType = SendEmailViaAws
deriving
(
Show
,
Read
,
Enum
,
Bounded
,
Generic
)
deriving
(
Show
,
Read
,
Enum
,
Bounded
,
Generic
)
data
Settings
=
Settings
data
Settings
=
Settings
{
_corsSettings
::
!
CORSSettings
-- CORS settings
{
,
_microservicesSettings
::
!
MicroServicesSettings
,
_appPort
::
!
PortNumber
,
_logLevelLimit
::
!
LogLevel
-- log level from the monad-logger package
-- , _dbServer :: Text
-- , _dbServer :: Text
-- ^ this is not used yet
-- ^ this is not used yet
,
_jwtSettings
::
!
JWTSettings
_cookieSettings
::
!
CookieSettings
,
_cookieSettings
::
!
CookieSettings
,
_sendLoginEmails
::
!
SendEmailType
,
_sendLoginEmails
::
!
SendEmailType
,
_scrapydUrl
::
!
BaseUrl
,
_scrapydUrl
::
!
BaseUrl
,
_workerSettings
::
!
WorkerSettings
}
}
makeLenses
''
S
ettings
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
class
HasSettings
env
where
settings
::
Getter
env
Settings
settings
::
Getter
env
Settings
...
...
src/Gargantext/API/Auth/PolicyCheck.hs
View file @
890a8076
...
@@ -21,27 +21,26 @@ module Gargantext.API.Auth.PolicyCheck (
...
@@ -21,27 +21,26 @@ module Gargantext.API.Auth.PolicyCheck (
,
alwaysDeny
,
alwaysDeny
)
where
)
where
import
Control.Lens
import
Control.Lens
(
view
)
import
Control.Monad
import
Data.BoolExpr
(
BoolExpr
(
..
),
Signed
(
..
))
import
Data.BoolExpr
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
(
..
))
import
Gargantext.API.Admin.Auth.Types
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Errors.Types
import
Gargantext.Core.Config
(
GargConfig
(
..
),
HasConfig
(
hasConfig
))
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
Gargantext.Core.Config.Types
(
SecretsConfig
(
..
))
import
Gargantext.Core.Config.Types
(
SecretsConfig
(
..
))
import
Prelude
import
Gargantext.Core.Types
(
NodeId
,
UserId
)
import
Servant
import
Gargantext.Core.Types.Individu
(
User
(
UserName
))
import
Servant.API.Routes
import
Gargantext.Database.Prelude
(
DBCmd
)
import
Servant.Auth.Server.Internal.AddSetCookie
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Servant.Client.Core
import
Gargantext.Database.Query.Tree
(
isDescendantOf
,
isOwnedBy
,
isSharedWith
)
import
Servant.Ekg
import
Gargantext.Database.Query.Tree.Root
(
getRootId
)
import
Servant.Server.Internal.Delayed
import
Gargantext.Prelude
import
Servant.Server.Internal.DelayedIO
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
import
Servant.Swagger
qualified
as
Swagger
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
...
@@ -122,13 +121,13 @@ accessPolicyManager = AccessPolicyManager (\ur ac -> interpretPolicy ur ac)
...
@@ -122,13 +121,13 @@ accessPolicyManager = AccessPolicyManager (\ur ac -> interpretPolicy ur ac)
BFalse
BFalse
->
pure
$
Deny
err403
->
pure
$
Deny
err403
BConst
(
Positive
b
)
BConst
(
Positive
b
)
->
check
ur
b
->
check
'
ur
b
BConst
(
Negative
b
)
BConst
(
Negative
b
)
->
check
ur
b
->
check
'
ur
b
check
::
HasNodeError
err
=>
AuthenticatedUser
->
AccessCheck
->
DBCmd
err
AccessResult
check
'
::
HasNodeError
err
=>
AuthenticatedUser
->
AccessCheck
->
DBCmd
err
AccessResult
check
(
AuthenticatedUser
loggedUserNodeId
loggedUserUserId
)
=
\
case
check
'
(
AuthenticatedUser
loggedUserNodeId
loggedUserUserId
)
=
\
case
AC_always_deny
AC_always_deny
->
pure
$
Deny
err500
->
pure
$
Deny
err500
AC_always_allow
AC_always_allow
...
...
src/Gargantext/API/Dev.hs
View file @
890a8076
...
@@ -17,12 +17,11 @@ import Control.Monad (fail)
...
@@ -17,12 +17,11 @@ import Control.Monad (fail)
import
Data.Pool
(
withResource
)
import
Data.Pool
(
withResource
)
import
Database.PostgreSQL.Simple
qualified
as
PGS
import
Database.PostgreSQL.Simple
qualified
as
PGS
import
Gargantext.API.Admin.EnvTypes
(
DevEnv
(
..
),
Mode
(
Dev
)
)
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.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Prelude
(
GargM
)
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.Config.Types
(
SettingsFile
(
..
))
import
Gargantext.Core.NLP
(
nlpServerMap
)
import
Gargantext.Core.NodeStory
(
fromDBNodeStoryEnv
)
import
Gargantext.Core.NodeStory
(
fromDBNodeStoryEnv
)
import
Gargantext.Database.Prelude
(
Cmd
'
,
Cmd
''
,
connPool
,
runCmd
)
import
Gargantext.Database.Prelude
(
Cmd
'
,
Cmd
''
,
connPool
,
runCmd
)
import
Gargantext.Prelude
import
Gargantext.Prelude
...
@@ -42,15 +41,13 @@ withDevEnv settingsFile k = withLoggerHoisted Dev $ \logger -> do
...
@@ -42,15 +41,13 @@ withDevEnv settingsFile k = withLoggerHoisted Dev $ \logger -> do
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
pool
<-
newPool
(
_gc_database_config
cfg
)
pool
<-
newPool
(
_gc_database_config
cfg
)
nodeStory_env
<-
fromDBNodeStoryEnv
pool
nodeStory_env
<-
fromDBNodeStoryEnv
pool
setts
<-
devSettings
devJwkFile
settingsFile
let
setts
=
devSettings
pure
$
DevEnv
pure
$
DevEnv
{
_dev_env_pool
=
pool
{
_dev_env_pool
=
pool
,
_dev_env_logger
=
logger
,
_dev_env_logger
=
logger
,
_dev_env_nodeStory
=
nodeStory_env
,
_dev_env_nodeStory
=
nodeStory_env
,
_dev_env_settings
=
setts
,
_dev_env_settings
=
setts
,
_dev_env_config
=
cfg
,
_dev_env_config
=
cfg
,
_dev_env_mail
=
_gc_mail_config
cfg
,
_dev_env_nlp
=
nlpServerMap
(
_gc_nlp_config
cfg
)
}
}
defaultSettingsFile
::
SettingsFile
defaultSettingsFile
::
SettingsFile
...
...
src/Gargantext/API/GraphQL.hs
View file @
890a8076
...
@@ -28,7 +28,6 @@ import Data.Morpheus.Types ( GQLRequest, GQLResponse, GQLType, RootResolver(..),
...
@@ -28,7 +28,6 @@ import Data.Morpheus.Types ( GQLRequest, GQLResponse, GQLType, RootResolver(..),
-- import Data.Proxy
-- import Data.Proxy
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
)
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
)
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
)
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Auth.PolicyCheck
import
Gargantext.API.Auth.PolicyCheck
import
Gargantext.API.Errors.Types
import
Gargantext.API.Errors.Types
import
Gargantext.API.GraphQL.Annuaire
qualified
as
GQLA
import
Gargantext.API.GraphQL.Annuaire
qualified
as
GQLA
...
@@ -44,6 +43,7 @@ import Gargantext.API.GraphQL.UserInfo qualified as GQLUserInfo
...
@@ -44,6 +43,7 @@ import Gargantext.API.GraphQL.UserInfo qualified as GQLUserInfo
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.API.Prelude
(
HasJobEnv
'
)
import
Gargantext.API.Prelude
(
HasJobEnv
'
)
import
Gargantext.API.Types
import
Gargantext.API.Types
import
Gargantext.Core.Config
(
HasJWTSettings
)
import
Gargantext.Core.NLP
(
HasNLPServer
)
import
Gargantext.Core.NLP
(
HasNLPServer
)
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
Gargantext.Prelude
hiding
(
ByteString
)
import
Gargantext.Prelude
hiding
(
ByteString
)
...
@@ -102,7 +102,7 @@ data Contet m
...
@@ -102,7 +102,7 @@ data Contet m
-- | The main GraphQL resolver: how queries, mutations and
-- | The main GraphQL resolver: how queries, mutations and
-- subscriptions are handled.
-- subscriptions are handled.
rootResolver
rootResolver
::
(
CmdCommon
env
,
HasNLPServer
env
,
HasJobEnv'
env
,
HasSettings
env
)
::
(
CmdCommon
env
,
HasNLPServer
env
,
HasJobEnv'
env
,
Has
JWT
Settings
env
)
=>
AuthenticatedUser
=>
AuthenticatedUser
->
AccessPolicyManager
->
AccessPolicyManager
->
RootResolver
(
GargM
env
BackendInternalError
)
e
Query
Mutation
Undefined
->
RootResolver
(
GargM
env
BackendInternalError
)
e
Query
Mutation
Undefined
...
@@ -134,7 +134,7 @@ rootResolver authenticatedUser policyManager =
...
@@ -134,7 +134,7 @@ rootResolver authenticatedUser policyManager =
-- | Main GraphQL "app".
-- | Main GraphQL "app".
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
=>
AuthenticatedUser
->
AccessPolicyManager
->
AccessPolicyManager
->
App
(
EVENT
(
GargM
env
BackendInternalError
))
(
GargM
env
BackendInternalError
)
->
App
(
EVENT
(
GargM
env
BackendInternalError
))
(
GargM
env
BackendInternalError
)
...
@@ -172,7 +172,7 @@ data GraphQLAPIEndpoints mode = GraphQLAPIEndpoints
...
@@ -172,7 +172,7 @@ data GraphQLAPIEndpoints mode = GraphQLAPIEndpoints
-- | Implementation of our API.
-- | Implementation of our API.
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
))
=>
GraphQLAPI
(
AsServerT
(
GargM
env
BackendInternalError
))
api
=
GraphQLAPI
$
\
case
api
=
GraphQLAPI
$
\
case
(
SAS
.
Authenticated
auser
)
(
SAS
.
Authenticated
auser
)
...
...
src/Gargantext/API/GraphQL/AsyncTask.hs
View file @
890a8076
...
@@ -20,7 +20,8 @@ import Data.Morpheus.Types ( GQLType, Resolver, QUERY )
...
@@ -20,7 +20,8 @@ import Data.Morpheus.Types ( GQLType, Resolver, QUERY )
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
(
..
))
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
(
..
))
import
Gargantext.API.Errors.Types
import
Gargantext.API.Errors.Types
import
Gargantext.API.Prelude
(
GargM
,
HasJobEnv
'
)
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
Gargantext.Prelude
import
Servant.Job.Async
(
HasJobEnv
(
job_env
),
jenv_jobs
,
job_async
)
import
Servant.Job.Async
(
HasJobEnv
(
job_env
),
jenv_jobs
,
job_async
)
import
Servant.Job.Core
(
env_item
,
env_map
,
env_state_mvar
)
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
...
@@ -25,7 +25,6 @@ import Data.Morpheus.Types
import
Data.Text
(
pack
,
unpack
)
import
Data.Text
(
pack
,
unpack
)
import
qualified
Data.Text
as
Text
import
qualified
Data.Text
as
Text
import
Data.Time.Format.ISO8601
(
iso8601Show
)
import
Data.Time.Format.ISO8601
(
iso8601Show
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.Core.Types.Search
(
HyperdataRow
(
..
),
toHyperdataRow
)
import
Gargantext.Core.Types.Search
(
HyperdataRow
(
..
),
toHyperdataRow
)
...
@@ -219,7 +218,7 @@ toHyperdataRowDocumentGQL hyperdata =
...
@@ -219,7 +218,7 @@ toHyperdataRowDocumentGQL hyperdata =
}
}
HyperdataRowContact
{
}
->
Nothing
HyperdataRowContact
{
}
->
Nothing
updateNodeContextCategory
::
(
CmdCommon
env
,
HasSettings
env
)
updateNodeContextCategory
::
(
CmdCommon
env
)
=>
NodeContextCategoryMArgs
->
GqlM'
e
env
[
Int
]
=>
NodeContextCategoryMArgs
->
GqlM'
e
env
[
Int
]
updateNodeContextCategory
NodeContextCategoryMArgs
{
context_id
,
node_id
,
category
}
=
do
updateNodeContextCategory
NodeContextCategoryMArgs
{
context_id
,
node_id
,
category
}
=
do
_
<-
lift
$
DNC
.
updateNodeContextCategory
(
UnsafeMkContextId
context_id
)
(
UnsafeMkNodeId
node_id
)
category
_
<-
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 )
...
@@ -8,7 +8,8 @@ import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser )
import
Gargantext.API.Auth.PolicyCheck
(
BoolExpr
,
AccessCheck
,
AccessPolicyManager
(
..
),
AccessResult
(
..
))
import
Gargantext.API.Auth.PolicyCheck
(
BoolExpr
,
AccessCheck
,
AccessPolicyManager
(
..
),
AccessResult
(
..
))
import
Gargantext.API.Errors.Types
(
BackendInternalError
(
..
)
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
(
..
)
)
import
Gargantext.API.GraphQL.Types
(
GqlM
)
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
)
withPolicy
::
(
HasConnectionPool
env
,
HasConfig
env
)
=>
AuthenticatedUser
=>
AuthenticatedUser
...
...
src/Gargantext/API/GraphQL/Team.hs
View file @
890a8076
...
@@ -17,11 +17,11 @@ module Gargantext.API.GraphQL.Team where
...
@@ -17,11 +17,11 @@ module Gargantext.API.GraphQL.Team where
import
Data.Morpheus.Types
(
GQLType
,
ResolverM
)
import
Data.Morpheus.Types
(
GQLType
,
ResolverM
)
import
Data.Text
qualified
as
T
import
Data.Text
qualified
as
T
import
Gargantext.API.Admin.Auth.Types
(
AuthenticationError
(
..
))
import
Gargantext.API.Admin.Auth.Types
(
AuthenticationError
(
..
))
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Errors.Types
import
Gargantext.API.Errors.Types
import
Gargantext.API.GraphQL.Types
(
GqlM
)
import
Gargantext.API.GraphQL.Types
(
GqlM
)
import
Gargantext.API.GraphQL.Utils
(
authUser
,
AuthStatus
(
Invalid
,
Valid
))
import
Gargantext.API.GraphQL.Utils
(
authUser
,
AuthStatus
(
Invalid
,
Valid
))
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.Core.Config
(
HasJWTSettings
)
import
Gargantext.Core.Types
(
NodeId
(
..
),
unNodeId
)
import
Gargantext.Core.Types
(
NodeId
(
..
),
unNodeId
)
import
Gargantext.Core.Types.Individu
qualified
as
Individu
import
Gargantext.Core.Types.Individu
qualified
as
Individu
import
Gargantext.Database.Action.Share
(
membersOf
,
deleteMemberShip
)
import
Gargantext.Database.Action.Share
(
membersOf
,
deleteMemberShip
)
...
@@ -78,7 +78,7 @@ dbTeam nodeId = do
...
@@ -78,7 +78,7 @@ dbTeam nodeId = do
getUsername
((
UserLight
{
userLight_username
},
_
)
:
_
)
=
userLight_username
getUsername
((
UserLight
{
userLight_username
},
_
)
:
_
)
=
userLight_username
-- TODO: list as argument
-- TODO: list as argument
deleteTeamMembership
::
(
CmdCommon
env
,
HasSettings
env
)
=>
deleteTeamMembership
::
(
CmdCommon
env
,
Has
JWT
Settings
env
)
=>
TeamDeleteMArgs
->
GqlM'
e
env
[
Int
]
TeamDeleteMArgs
->
GqlM'
e
env
[
Int
]
deleteTeamMembership
TeamDeleteMArgs
{
token
,
shared_folder_id
,
team_node_id
}
=
do
deleteTeamMembership
TeamDeleteMArgs
{
token
,
shared_folder_id
,
team_node_id
}
=
do
teamNode
<-
lift
$
getNode
$
UnsafeMkNodeId
team_node_id
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
...
@@ -16,7 +16,6 @@ module Gargantext.API.GraphQL.User where
import
Data.Morpheus.Types
(
GQLType
)
import
Data.Morpheus.Types
(
GQLType
)
import
Gargantext.API.Admin.Auth.Types
import
Gargantext.API.Admin.Auth.Types
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Auth.PolicyCheck
import
Gargantext.API.Auth.PolicyCheck
import
Gargantext.API.GraphQL.PolicyCheck
import
Gargantext.API.GraphQL.PolicyCheck
import
Gargantext.API.GraphQL.Types
import
Gargantext.API.GraphQL.Types
...
@@ -88,21 +87,21 @@ resolveHyperdata
...
@@ -88,21 +87,21 @@ resolveHyperdata
=>
UserId
->
GqlM
e
env
(
Maybe
HyperdataUser
)
=>
UserId
->
GqlM
e
env
(
Maybe
HyperdataUser
)
resolveHyperdata
userid
=
lift
(
listToMaybe
<$>
DBUser
.
getUserHyperdata
(
Individu
.
UserDBId
userid
))
resolveHyperdata
userid
=
lift
(
listToMaybe
<$>
DBUser
.
getUserHyperdata
(
Individu
.
UserDBId
userid
))
updateUserPubmedAPIKey
::
(
CmdCommon
env
,
HasSettings
env
)
=>
updateUserPubmedAPIKey
::
(
CmdCommon
env
)
=>
UserPubmedAPIKeyMArgs
->
GqlM'
e
env
Int
UserPubmedAPIKeyMArgs
->
GqlM'
e
env
Int
updateUserPubmedAPIKey
UserPubmedAPIKeyMArgs
{
user_id
,
api_key
}
=
do
updateUserPubmedAPIKey
UserPubmedAPIKeyMArgs
{
user_id
,
api_key
}
=
do
_
<-
lift
$
DBUser
.
updateUserPubmedAPIKey
(
Individu
.
RootId
$
UnsafeMkNodeId
user_id
)
api_key
_
<-
lift
$
DBUser
.
updateUserPubmedAPIKey
(
Individu
.
RootId
$
UnsafeMkNodeId
user_id
)
api_key
pure
1
pure
1
updateUserEPOAPIUser
::
(
CmdCommon
env
,
HasSettings
env
)
=>
updateUserEPOAPIUser
::
(
CmdCommon
env
)
=>
UserEPOAPIUserMArgs
->
GqlM'
e
env
Int
UserEPOAPIUserMArgs
->
GqlM'
e
env
Int
updateUserEPOAPIUser
UserEPOAPIUserMArgs
{
user_id
,
api_user
}
=
do
updateUserEPOAPIUser
UserEPOAPIUserMArgs
{
user_id
,
api_user
}
=
do
_
<-
lift
$
DBUser
.
updateUserEPOAPIUser
(
Individu
.
RootId
$
UnsafeMkNodeId
user_id
)
api_user
_
<-
lift
$
DBUser
.
updateUserEPOAPIUser
(
Individu
.
RootId
$
UnsafeMkNodeId
user_id
)
api_user
pure
1
pure
1
updateUserEPOAPIToken
::
(
CmdCommon
env
,
HasSettings
env
)
=>
updateUserEPOAPIToken
::
(
CmdCommon
env
)
=>
UserEPOAPITokenMArgs
->
GqlM'
e
env
Int
UserEPOAPITokenMArgs
->
GqlM'
e
env
Int
updateUserEPOAPIToken
UserEPOAPITokenMArgs
{
user_id
,
api_token
}
=
do
updateUserEPOAPIToken
UserEPOAPITokenMArgs
{
user_id
,
api_token
}
=
do
_
<-
lift
$
DBUser
.
updateUserEPOAPIToken
(
Individu
.
RootId
$
UnsafeMkNodeId
user_id
)
api_token
_
<-
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
...
@@ -41,11 +41,11 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact
,
hc_who
,
hc_who
,
hc_where
)
,
hc_where
)
import
Gargantext.API.Admin.Auth.Types
hiding
(
Valid
)
import
Gargantext.API.Admin.Auth.Types
hiding
(
Valid
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Auth.PolicyCheck
import
Gargantext.API.Auth.PolicyCheck
import
Gargantext.API.GraphQL.PolicyCheck
import
Gargantext.API.GraphQL.PolicyCheck
import
Gargantext.API.GraphQL.Types
import
Gargantext.API.GraphQL.Types
import
Gargantext.API.GraphQL.Utils
(
AuthStatus
(
Invalid
,
Valid
),
authUser
)
import
Gargantext.API.GraphQL.Utils
(
AuthStatus
(
Invalid
,
Valid
),
authUser
)
import
Gargantext.Core.Config
(
HasJWTSettings
)
import
Gargantext.Core.Types.Individu
qualified
as
Individu
import
Gargantext.Core.Types.Individu
qualified
as
Individu
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
...
@@ -117,7 +117,7 @@ resolveUserInfos autUser mgr UserInfoArgs { user_id } =
...
@@ -117,7 +117,7 @@ resolveUserInfos autUser mgr UserInfoArgs { user_id } =
-- | Mutation for user info
-- | Mutation for user info
updateUserInfo
updateUserInfo
::
(
CmdCommon
env
,
HasSettings
env
)
::
(
CmdCommon
env
,
Has
JWT
Settings
env
)
-- => UserInfoMArgs -> ResolverM e (GargM env err) Int
-- => UserInfoMArgs -> ResolverM e (GargM env err) Int
=>
UserInfoMArgs
->
GqlM'
e
env
Int
=>
UserInfoMArgs
->
GqlM'
e
env
Int
updateUserInfo
(
UserInfoMArgs
{
ui_id
,
..
})
=
do
updateUserInfo
(
UserInfoMArgs
{
ui_id
,
..
})
=
do
...
...
src/Gargantext/API/GraphQL/Utils.hs
View file @
890a8076
...
@@ -14,7 +14,7 @@ module Gargantext.API.GraphQL.Utils where
...
@@ -14,7 +14,7 @@ module Gargantext.API.GraphQL.Utils where
import
Control.Lens
(
view
)
import
Control.Lens
(
view
)
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
(
..
),
auth_node_id
)
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.Admin.Types.Node
(
NodeId
)
import
Gargantext.Database.Prelude
(
Cmd
'
)
import
Gargantext.Database.Prelude
(
Cmd
'
)
import
Gargantext.Prelude
import
Gargantext.Prelude
...
@@ -22,10 +22,10 @@ import Servant.Auth.Server (verifyJWT, JWTSettings)
...
@@ -22,10 +22,10 @@ import Servant.Auth.Server (verifyJWT, JWTSettings)
data
AuthStatus
=
Valid
|
Invalid
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
authUser
ui_id
token
=
do
let
token'
=
encodeUtf8
token
let
token'
=
encodeUtf8
token
jwtS
<-
view
$
settings
.
jwtSettings
jwtS
<-
view
jwtSettings
u
<-
liftBase
$
getUserFromToken
jwtS
token'
u
<-
liftBase
$
getUserFromToken
jwtS
token'
case
u
of
case
u
of
Nothing
->
pure
Invalid
Nothing
->
pure
Invalid
...
...
src/Gargantext/API/Ngrams/Types.hs
View file @
890a8076
...
@@ -38,13 +38,14 @@ import Data.TreeDiff
...
@@ -38,13 +38,14 @@ import Data.TreeDiff
import
Data.Validity
(
Validity
(
..
)
)
import
Data.Validity
(
Validity
(
..
)
)
import
Database.PostgreSQL.Simple.FromField
(
FromField
,
fromField
,
fromJSONField
)
import
Database.PostgreSQL.Simple.FromField
(
FromField
,
fromField
,
fromJSONField
)
import
Database.PostgreSQL.Simple.ToField
(
ToField
,
toJSONField
,
toField
)
import
Database.PostgreSQL.Simple.ToField
(
ToField
,
toJSONField
,
toField
)
import
Gargantext.Core.Config
(
HasConfig
)
import
Gargantext.Core.Text
(
size
)
import
Gargantext.Core.Text
(
size
)
import
Gargantext.Core.Text.Ngrams
qualified
as
Ngrams
import
Gargantext.Core.Text.Ngrams
qualified
as
Ngrams
import
Gargantext.Core.Types
(
ListType
(
..
),
ListId
,
NodeId
,
TODO
)
import
Gargantext.Core.Types
(
ListType
(
..
),
ListId
,
NodeId
,
TODO
)
import
Gargantext.Core.Types.Query
(
Limit
,
Offset
,
MaxSize
,
MinSize
)
import
Gargantext.Core.Types.Query
(
Limit
,
Offset
,
MaxSize
,
MinSize
)
import
Gargantext.Core.Utils.Prefix
(
unPrefix
,
unPrefixUntagged
,
unPrefixSwagger
,
wellNamedSchema
)
import
Gargantext.Core.Utils.Prefix
(
unPrefix
,
unPrefixUntagged
,
unPrefixSwagger
,
wellNamedSchema
)
import
Gargantext.Database.Admin.Types.Node
(
ContextId
)
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
hiding
(
IsString
,
hash
,
from
,
replace
,
to
)
import
Gargantext.Prelude.Crypto.Hash
(
IsHashable
(
..
))
import
Gargantext.Prelude.Crypto.Hash
(
IsHashable
(
..
))
import
Gargantext.Utils.Servant
(
TSV
,
ZIP
)
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 )
...
@@ -37,7 +37,7 @@ import Gargantext.API.Node.Corpus.Types ( Datafield(Web), database2origin )
import
Gargantext.API.Node.Corpus.Update
(
addLanguageToCorpus
)
import
Gargantext.API.Node.Corpus.Update
(
addLanguageToCorpus
)
import
Gargantext.API.Node.Types
import
Gargantext.API.Node.Types
import
Gargantext.Core
(
withDefaultLanguage
,
defaultLanguage
)
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.Config.Types
(
jc_max_docs_parsers
)
import
Gargantext.Core.NodeStory
(
HasNodeStoryImmediateSaver
,
HasNodeArchiveStoryImmediateSaver
,
currentVersion
,
NgramsStatePatch
'
)
import
Gargantext.Core.NodeStory
(
HasNodeStoryImmediateSaver
,
HasNodeArchiveStoryImmediateSaver
,
currentVersion
,
NgramsStatePatch
'
)
import
Gargantext.Core.Text.Corpus.Parsers
qualified
as
Parser
(
FileType
(
..
),
parseFormatC
,
_ParseFormatError
)
import
Gargantext.Core.Text.Corpus.Parsers
qualified
as
Parser
(
FileType
(
..
),
parseFormatC
,
_ParseFormatError
)
...
@@ -53,7 +53,6 @@ import Gargantext.Database.Admin.Types.Hyperdata.Document ( ToHyperdataDocument(
...
@@ -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.Hyperdata.File
(
HyperdataFile
(
..
)
)
import
Gargantext.Database.Admin.Types.Node
(
CorpusId
,
NodeType
(
..
),
ParentId
)
import
Gargantext.Database.Admin.Types.Node
(
CorpusId
,
NodeType
(
..
),
ParentId
)
import
Gargantext.Database.GargDB
qualified
as
GargDB
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
(
getNodeWith
,
getOrMkList
)
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
import
Gargantext.Database.Query.Tree.Root
(
MkCorpusUser
(
MkCorpusUserNormalCorpusIds
))
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)
...
@@ -23,7 +23,7 @@ import Data.Time.Format (defaultTimeLocale, formatTime, parseTimeM)
import
Data.Tuple.Select
(
sel1
,
sel2
,
sel3
)
import
Data.Tuple.Select
(
sel1
,
sel2
,
sel3
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.Core
(
Lang
(
..
))
import
Gargantext.Core
(
Lang
(
..
))
import
Gargantext.Core.Config
(
GargConfig
(
..
))
import
Gargantext.Core.Config
(
GargConfig
(
..
)
,
hasConfig
)
import
Gargantext.Core.Config.Types
(
FramesConfig
(
..
))
import
Gargantext.Core.Config.Types
(
FramesConfig
(
..
))
import
Gargantext.Core.NLP
(
HasNLPServer
,
nlpServerGet
)
import
Gargantext.Core.NLP
(
HasNLPServer
,
nlpServerGet
)
import
Gargantext.Core.NodeStory.Types
(
HasNodeStory
)
import
Gargantext.Core.NodeStory.Types
(
HasNodeStory
)
...
@@ -40,7 +40,6 @@ import Gargantext.Database.Action.User (getUserId)
...
@@ -40,7 +40,6 @@ import Gargantext.Database.Action.User (getUserId)
import
Gargantext.Database.Admin.Types.Hyperdata.Corpus
(
HyperdataCorpus
)
import
Gargantext.Database.Admin.Types.Hyperdata.Corpus
(
HyperdataCorpus
)
import
Gargantext.Database.Admin.Types.Hyperdata.Document
(
HyperdataDocument
(
..
))
import
Gargantext.Database.Admin.Types.Hyperdata.Document
(
HyperdataDocument
(
..
))
import
Gargantext.Database.Admin.Types.Node
(
CorpusId
,
ListId
,
NodeType
(
NodeTexts
))
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
(
getOrMkList
,
insertDefaultNodeIfNotExists
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Tree.Error
(
HasTreeError
)
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
...
@@ -21,6 +21,7 @@ import Data.Text qualified as T
import
Gargantext.API.Admin.Auth.Types
(
auth_node_id
,
AuthenticatedUser
)
import
Gargantext.API.Admin.Auth.Types
(
auth_node_id
,
AuthenticatedUser
)
import
Gargantext.API.Admin.EnvTypes
(
GargJob
(
..
),
Env
)
import
Gargantext.API.Admin.EnvTypes
(
GargJob
(
..
),
Env
)
import
Gargantext.API.Admin.Orchestrator.Types
(
AsyncJobs
(
..
))
import
Gargantext.API.Admin.Orchestrator.Types
(
AsyncJobs
(
..
))
import
Gargantext.API.Admin.Types
(
HasSettings
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Node.Corpus.New
(
addToCorpusWithForm
)
import
Gargantext.API.Node.Corpus.New
(
addToCorpusWithForm
)
import
Gargantext.API.Node.Corpus.New.Types
(
FileFormat
(
..
),
FileType
(
..
))
import
Gargantext.API.Node.Corpus.New.Types
(
FileFormat
(
..
),
FileType
(
..
))
...
@@ -28,12 +29,12 @@ import Gargantext.API.Node.FrameCalcUpload.Types
...
@@ -28,12 +29,12 @@ import Gargantext.API.Node.FrameCalcUpload.Types
import
Gargantext.API.Node.Types
(
NewWithForm
(
..
))
import
Gargantext.API.Node.Types
(
NewWithForm
(
..
))
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.API.Routes.Named.FrameCalc
qualified
as
Named
import
Gargantext.API.Routes.Named.FrameCalc
qualified
as
Named
import
Gargantext.Core.Config
(
HasConfig
)
import
Gargantext.Core.NodeStory.Types
(
HasNodeArchiveStoryImmediateSaver
)
import
Gargantext.Core.NodeStory.Types
(
HasNodeArchiveStoryImmediateSaver
)
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
import
Gargantext.Database.Admin.Types.Hyperdata.Frame
(
HyperdataFrame
(
..
)
)
import
Gargantext.Database.Admin.Types.Hyperdata.Frame
(
HyperdataFrame
(
..
)
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
,
NodeType
(
NodeCorpus
)
)
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.Query.Table.Node
(
getClosestParentIdByType
,
getNodeWith
)
import
Gargantext.Database.Schema.Node
(
node_hyperdata
)
import
Gargantext.Database.Schema.Node
(
node_hyperdata
)
import
Gargantext.Prelude
import
Gargantext.Prelude
...
@@ -41,7 +42,6 @@ import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..), markFailureNoErr
...
@@ -41,7 +42,6 @@ import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..), markFailureNoErr
import
Network.HTTP.Client
(
newManager
,
httpLbs
,
parseRequest
,
responseBody
)
import
Network.HTTP.Client
(
newManager
,
httpLbs
,
parseRequest
,
responseBody
)
import
Network.HTTP.Client.TLS
(
tlsManagerSettings
)
import
Network.HTTP.Client.TLS
(
tlsManagerSettings
)
import
Servant.Server.Generic
(
AsServerT
)
import
Servant.Server.Generic
(
AsServerT
)
import
Gargantext.API.Admin.Types
(
HasSettings
)
api
::
AuthenticatedUser
->
NodeId
->
Named
.
FrameCalcAPI
(
AsServerT
(
GargM
Env
BackendInternalError
))
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
...
@@ -7,13 +7,12 @@ module Gargantext.API.Node.ShareURL where
import
Control.Lens
import
Control.Lens
import
Data.Text
qualified
as
T
import
Data.Text
qualified
as
T
import
Data.Validity
qualified
as
V
import
Data.Validity
qualified
as
V
import
Gargantext.API.Admin.Types
(
appPort
,
settings
,
Settings
)
import
Gargantext.API.Prelude
import
Gargantext.API.Prelude
import
Gargantext.API.Routes.Named.Share
qualified
as
Named
import
Gargantext.API.Routes.Named.Share
qualified
as
Named
import
Gargantext.Core.Config
(
GargConfig
,
gc_frontend_config
)
import
Gargantext.Core.Config
(
GargConfig
,
gc_frontend_config
,
HasConfig
(
hasConfig
)
)
import
Gargantext.Core.Config.Types
(
fc_url
)
import
Gargantext.Core.Config.Types
(
fc_
appPort
,
fc_
url
)
import
Gargantext.Core.Types
(
NodeType
,
NodeId
,
unNodeId
,
_ValidationError
)
import
Gargantext.Core.Types
(
NodeType
,
NodeId
,
unNodeId
,
_ValidationError
)
import
Gargantext.Database.Prelude
(
HasConfig
(
hasConfig
),
CmdCommon
)
import
Gargantext.Database.Prelude
(
CmdCommon
)
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Network.URI
(
parseURI
)
import
Network.URI
(
parseURI
)
import
Prelude
(
String
)
import
Prelude
(
String
)
...
@@ -29,19 +28,17 @@ getUrl :: (IsGargServer env err m, CmdCommon env)
...
@@ -29,19 +28,17 @@ getUrl :: (IsGargServer env err m, CmdCommon env)
getUrl
nt
id
=
do
getUrl
nt
id
=
do
-- TODO add check that the node is able to be shared (in a shared folder)
-- TODO add check that the node is able to be shared (in a shared folder)
gc
<-
view
hasConfig
gc
<-
view
hasConfig
urlPort
<-
view
settings
case
get_url
nt
id
gc
of
case
get_url
nt
id
gc
urlPort
of
Left
err
->
throwError
$
_ValidationError
#
(
V
.
check
False
err
)
Left
err
->
throwError
$
_ValidationError
#
(
V
.
check
False
err
)
Right
shareLink
->
pure
shareLink
Right
shareLink
->
pure
shareLink
get_url
::
Maybe
NodeType
get_url
::
Maybe
NodeType
->
Maybe
NodeId
->
Maybe
NodeId
->
GargConfig
->
GargConfig
->
Settings
->
Either
String
Named
.
ShareLink
->
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
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
t
<-
maybe
(
Left
"Invalid node Type"
)
Right
nt
i
<-
maybe
(
Left
"Invalid node ID"
)
Right
id
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
...
@@ -27,11 +27,12 @@ import Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Admin.Types
import
Gargantext.API.Admin.Types
import
Gargantext.API.Errors.Class
import
Gargantext.API.Errors.Class
import
Gargantext.Core.AsyncUpdates.CentralExchange.Types
(
HasCentralExchangeNotification
)
import
Gargantext.Core.AsyncUpdates.CentralExchange.Types
(
HasCentralExchangeNotification
)
import
Gargantext.Core.Config
(
HasConfig
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.NLP
(
HasNLPServer
)
import
Gargantext.Core.NLP
(
HasNLPServer
)
import
Gargantext.Core.NodeStory
import
Gargantext.Core.NodeStory
import
Gargantext.Core.Types
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.Table.Node.Error
(
HasNodeError
(
..
))
import
Gargantext.Database.Query.Tree
import
Gargantext.Database.Query.Tree
import
Gargantext.Prelude
import
Gargantext.Prelude
...
...
src/Gargantext/API/Routes.hs
View file @
890a8076
...
@@ -30,12 +30,11 @@ import Gargantext.API.Node.Corpus.New qualified as New
...
@@ -30,12 +30,11 @@ import Gargantext.API.Node.Corpus.New qualified as New
import
Gargantext.API.Prelude
import
Gargantext.API.Prelude
import
Gargantext.API.Routes.Named.Annuaire
qualified
as
Named
import
Gargantext.API.Routes.Named.Annuaire
qualified
as
Named
import
Gargantext.API.Routes.Named.Corpus
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.Config.Types
(
jc_max_docs_scrapers
)
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Core.Worker.Jobs
qualified
as
Jobs
import
Gargantext.Core.Worker.Jobs
qualified
as
Jobs
import
Gargantext.Core.Worker.Jobs.Types
qualified
as
Jobs
import
Gargantext.Core.Worker.Jobs.Types
qualified
as
Jobs
import
Gargantext.Database.Prelude
(
HasConfig
(
..
))
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Utils.Jobs
(
serveJobsAPI
)
import
Gargantext.Utils.Jobs
(
serveJobsAPI
)
import
Servant
import
Servant
...
...
src/Gargantext/API/Server/Named.hs
View file @
890a8076
...
@@ -23,9 +23,8 @@ import Gargantext.API.Server.Named.Public (serverPublicGargAPI)
...
@@ -23,9 +23,8 @@ import Gargantext.API.Server.Named.Public (serverPublicGargAPI)
import
Gargantext.API.Swagger
(
swaggerDoc
)
import
Gargantext.API.Swagger
(
swaggerDoc
)
import
Gargantext.API.ThrowAll
(
serverPrivateGargAPI
)
import
Gargantext.API.ThrowAll
(
serverPrivateGargAPI
)
import
Gargantext.Core.AsyncUpdates.Dispatcher.WebSocket
qualified
as
Dispatcher
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.Core.Config.Types
(
fc_url_backend_api
)
import
Gargantext.Database.Prelude
(
hasConfig
)
import
Gargantext.Prelude
hiding
(
Handler
,
catch
)
import
Gargantext.Prelude
hiding
(
Handler
,
catch
)
import
Gargantext.System.Logging
(
logLocM
,
LogLevel
(
..
))
import
Gargantext.System.Logging
(
logLocM
,
LogLevel
(
..
))
import
Paths_gargantext
qualified
as
PG
-- cabal magic build module
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
...
@@ -31,7 +31,7 @@ import DeferredFolds.UnfoldlM qualified as UnfoldlM
import
Data.UUID.V4
as
UUID
import
Data.UUID.V4
as
UUID
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
(
_auth_user_id
))
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
(
_auth_user_id
))
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
)
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.API.Prelude
(
IsGargServer
)
import
Gargantext.Core.AsyncUpdates.CentralExchange.Types
qualified
as
CETypes
import
Gargantext.Core.AsyncUpdates.CentralExchange.Types
qualified
as
CETypes
import
Gargantext.Core.Types
(
NodeId
,
UserId
)
import
Gargantext.Core.Types
(
NodeId
,
UserId
)
...
...
src/Gargantext/Core/AsyncUpdates/Dispatcher/WebSocket.hs
View file @
890a8076
...
@@ -23,17 +23,17 @@ import Control.Lens (view)
...
@@ -23,17 +23,17 @@ import Control.Lens (view)
import
Data.Aeson
qualified
as
Aeson
import
Data.Aeson
qualified
as
Aeson
import
Data.UUID.V4
as
UUID
import
Data.UUID.V4
as
UUID
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
(
_auth_user_id
))
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.API.Prelude
(
IsGargServer
)
import
Gargantext.Core.AsyncUpdates.Dispatcher.Subscriptions
import
Gargantext.Core.AsyncUpdates.Dispatcher.Subscriptions
import
Gargantext.Core.AsyncUpdates.Dispatcher.Types
import
Gargantext.Core.AsyncUpdates.Dispatcher.Types
import
Gargantext.Core.AsyncUpdates.Dispatcher
(
Dispatcher
,
dispatcherSubscriptions
)
import
Gargantext.Core.AsyncUpdates.Dispatcher
(
Dispatcher
,
dispatcherSubscriptions
)
import
Gargantext.Core.Config
(
HasJWTSettings
(
jwtSettings
))
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.System.Logging
(
LogLevel
(
DEBUG
),
logMsg
,
withLogger
)
import
Gargantext.System.Logging
(
LogLevel
(
DEBUG
),
logMsg
,
withLogger
)
import
Network.WebSockets
qualified
as
WS
import
Network.WebSockets
qualified
as
WS
import
Servant
import
Servant
import
Servant.API.WebSocket
qualified
as
WS
(
WebSocketPending
)
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
Servant.Server.Generic
(
AsServerT
)
import
StmContainers.Set
as
SSet
import
StmContainers.Set
as
SSet
...
@@ -43,19 +43,19 @@ newtype WSAPI mode = WSAPI {
...
@@ -43,19 +43,19 @@ newtype WSAPI mode = WSAPI {
}
deriving
Generic
}
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
}
wsServer
=
WSAPI
{
wsAPIServer
=
streamData
}
where
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
()
=>
WS
.
PendingConnection
->
m
()
streamData
pc
=
do
streamData
pc
=
do
authSettings
<-
view
s
ettings
jwtS
<-
view
jwtS
ettings
d
<-
view
hasDispatcher
d
<-
view
hasDispatcher
let
subscriptions
=
dispatcherSubscriptions
d
let
subscriptions
=
dispatcherSubscriptions
d
key
<-
getWSKey
pc
key
<-
getWSKey
pc
c
<-
liftBase
$
WS
.
acceptRequest
pc
c
<-
liftBase
$
WS
.
acceptRequest
pc
let
ws
=
WSKeyConnection
(
key
,
c
)
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)
-- _ <- liftIO $ Async.withAsync (pure ()) (\_ -> wsLoop ws)
pure
()
pure
()
...
@@ -73,8 +73,8 @@ pingLoop ws = do
...
@@ -73,8 +73,8 @@ pingLoop ws = do
threadDelay
$
10
*
1000000
threadDelay
$
10
*
1000000
wsLoop
::
Settings
->
SSet
.
Set
Subscription
->
WSKeyConnection
->
IO
a
wsLoop
::
JWT
Settings
->
SSet
.
Set
Subscription
->
WSKeyConnection
->
IO
a
wsLoop
authSettings
subscriptions
ws
=
flip
finally
disconnect
$
do
wsLoop
jwtS
subscriptions
ws
=
flip
finally
disconnect
$
do
withLogger
()
$
\
ioLogger
->
do
withLogger
()
$
\
ioLogger
->
do
logMsg
ioLogger
DEBUG
"[wsLoop] connecting"
logMsg
ioLogger
DEBUG
"[wsLoop] connecting"
wsLoop'
CUPublic
ioLogger
wsLoop'
CUPublic
ioLogger
...
@@ -105,7 +105,6 @@ wsLoop authSettings subscriptions ws = flip finally disconnect $ do
...
@@ -105,7 +105,6 @@ wsLoop authSettings subscriptions ws = flip finally disconnect $ do
-- putText $ "[wsLoop] subscriptions: " <> show (showSub <$> ss)
-- putText $ "[wsLoop] subscriptions: " <> show (showSub <$> ss)
return
user
return
user
Just
(
WSAuthorize
token
)
->
do
Just
(
WSAuthorize
token
)
->
do
let
jwtS
=
authSettings
^.
jwtSettings
mUser
<-
liftBase
$
verifyJWT
jwtS
(
encodeUtf8
token
)
mUser
<-
liftBase
$
verifyJWT
jwtS
(
encodeUtf8
token
)
logMsg
ioLogger
DEBUG
$
"[wsLoop] authorized user: "
<>
show
mUser
logMsg
ioLogger
DEBUG
$
"[wsLoop] authorized user: "
<>
show
mUser
...
...
src/Gargantext/Core/Config.hs
View file @
890a8076
...
@@ -29,10 +29,16 @@ module Gargantext.Core.Config (
...
@@ -29,10 +29,16 @@ module Gargantext.Core.Config (
,
gc_secrets
,
gc_secrets
,
gc_apis
,
gc_apis
,
gc_worker
,
gc_worker
,
gc_log_level
,
mkProxyUrl
,
mkProxyUrl
,
HasJWTSettings
(
..
)
,
HasConfig
(
..
)
)
where
)
where
import
Control.Lens
(
Getter
)
import
Control.Monad.Logger
(
LogLevel
(
LevelDebug
))
import
Data.Text
as
T
import
Data.Text
as
T
import
Database.PostgreSQL.Simple
qualified
as
PSQL
import
Database.PostgreSQL.Simple
qualified
as
PSQL
import
Gargantext.Core.Config.Mail
(
MailConfig
)
import
Gargantext.Core.Config.Mail
(
MailConfig
)
...
@@ -40,6 +46,7 @@ import Gargantext.Core.Config.NLP (NLPConfig)
...
@@ -40,6 +46,7 @@ import Gargantext.Core.Config.NLP (NLPConfig)
import
Gargantext.Core.Config.Worker
(
WorkerSettings
)
import
Gargantext.Core.Config.Worker
(
WorkerSettings
)
import
Gargantext.Core.Config.Types
import
Gargantext.Core.Config.Types
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Servant.Auth.Server
(
JWTSettings
)
import
Servant.Client
(
BaseUrl
(
..
),
Scheme
(
Http
),
parseBaseUrl
)
import
Servant.Client
(
BaseUrl
(
..
),
Scheme
(
Http
),
parseBaseUrl
)
import
Toml.Schema
import
Toml.Schema
...
@@ -51,7 +58,6 @@ import Toml.Schema
...
@@ -51,7 +58,6 @@ import Toml.Schema
-- Non-strict data so that we can use it in tests
-- Non-strict data so that we can use it in tests
data
GargConfig
=
GargConfig
{
_gc_datafilepath
::
~
FilePath
data
GargConfig
=
GargConfig
{
_gc_datafilepath
::
~
FilePath
-- , _gc_repofilepath :: ~FilePath
-- , _gc_repofilepath :: ~FilePath
,
_gc_frontend_config
::
~
FrontendConfig
,
_gc_frontend_config
::
~
FrontendConfig
,
_gc_mail_config
::
~
MailConfig
,
_gc_mail_config
::
~
MailConfig
,
_gc_database_config
::
~
PSQL
.
ConnectInfo
,
_gc_database_config
::
~
PSQL
.
ConnectInfo
...
@@ -62,6 +68,7 @@ data GargConfig = GargConfig { _gc_datafilepath :: ~FilePath
...
@@ -62,6 +68,7 @@ data GargConfig = GargConfig { _gc_datafilepath :: ~FilePath
,
_gc_secrets
::
~
SecretsConfig
,
_gc_secrets
::
~
SecretsConfig
,
_gc_apis
::
~
APIsConfig
,
_gc_apis
::
~
APIsConfig
,
_gc_worker
::
~
WorkerSettings
,
_gc_worker
::
~
WorkerSettings
,
_gc_log_level
::
~
LogLevel
}
}
deriving
(
Generic
,
Show
)
deriving
(
Generic
,
Show
)
...
@@ -80,6 +87,7 @@ instance FromValue GargConfig where
...
@@ -80,6 +87,7 @@ instance FromValue GargConfig where
_gc_apis
<-
reqKey
"apis"
_gc_apis
<-
reqKey
"apis"
_gc_notifications_config
<-
reqKey
"notifications"
_gc_notifications_config
<-
reqKey
"notifications"
_gc_worker
<-
reqKey
"worker"
_gc_worker
<-
reqKey
"worker"
let
_gc_log_level
=
LevelDebug
return
$
GargConfig
{
_gc_datafilepath
return
$
GargConfig
{
_gc_datafilepath
,
_gc_jobs
,
_gc_jobs
,
_gc_apis
,
_gc_apis
...
@@ -90,7 +98,8 @@ instance FromValue GargConfig where
...
@@ -90,7 +98,8 @@ instance FromValue GargConfig where
,
_gc_notifications_config
,
_gc_notifications_config
,
_gc_frames
,
_gc_frames
,
_gc_secrets
,
_gc_secrets
,
_gc_worker
}
,
_gc_worker
,
_gc_log_level
}
instance
ToValue
GargConfig
where
instance
ToValue
GargConfig
where
toValue
=
defaultTableToValue
toValue
=
defaultTableToValue
instance
ToTable
GargConfig
where
instance
ToTable
GargConfig
where
...
@@ -110,8 +119,19 @@ instance ToTable GargConfig where
...
@@ -110,8 +119,19 @@ instance ToTable GargConfig where
]
]
mkProxyUrl
::
GargConfig
->
MicroServicesSettings
->
BaseUrl
mkProxyUrl
::
GargConfig
->
BaseUrl
mkProxyUrl
GargConfig
{
..
}
MicroServicesSettings
{
..
}
=
mkProxyUrl
GargConfig
{
..
}
=
case
parseBaseUrl
(
T
.
unpack
$
_fc_url
_gc_frontend_config
)
of
case
parseBaseUrl
(
T
.
unpack
$
_fc_url
_gc_frontend_config
)
of
Nothing
->
BaseUrl
Http
"localhost"
80
""
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
...
@@ -25,13 +25,16 @@ module Gargantext.Core.Config.Types
,
f_visio_url
,
f_visio_url
,
f_searx_url
,
f_searx_url
,
f_istex_url
,
f_istex_url
,
PortNumber
,
FrontendConfig
(
..
)
,
FrontendConfig
(
..
)
,
fc_url
,
fc_url
,
fc_backend_name
,
fc_backend_name
,
fc_url_backend_api
,
fc_url_backend_api
,
fc_jwt_settings
,
fc_cors
,
fc_cors
,
fc_microservices
,
fc_microservices
,
fc_appPort
,
MicroServicesProxyStatus
(
..
)
,
microServicesProxyStatus
,
JobsConfig
(
..
)
,
JobsConfig
(
..
)
,
jc_max_docs_parsers
,
jc_max_docs_parsers
,
jc_max_docs_scrapers
,
jc_max_docs_scrapers
...
@@ -39,7 +42,9 @@ module Gargantext.Core.Config.Types
...
@@ -39,7 +42,9 @@ module Gargantext.Core.Config.Types
,
jc_js_id_timeout
,
jc_js_id_timeout
,
MicroServicesSettings
(
..
)
,
MicroServicesSettings
(
..
)
,
NotificationsConfig
(
..
)
,
NotificationsConfig
(
..
)
,
JWKFile
(
..
)
,
SecretsConfig
(
..
)
,
SecretsConfig
(
..
)
,
jwtSettings
,
SettingsFile
(
..
)
,
SettingsFile
(
..
)
,
TOMLConnectInfo
(
..
)
,
TOMLConnectInfo
(
..
)
...
@@ -54,7 +59,9 @@ import Control.Monad.Fail (fail)
...
@@ -54,7 +59,9 @@ import Control.Monad.Fail (fail)
import
Data.Text
qualified
as
T
import
Data.Text
qualified
as
T
import
Database.PostgreSQL.Simple
qualified
as
PGS
import
Database.PostgreSQL.Simple
qualified
as
PGS
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Servant.Auth.Server
(
JWTSettings
,
defaultJWTSettings
,
readKey
,
writeKey
)
import
Servant.Client.Core
(
BaseUrl
,
parseBaseUrl
,
showBaseUrl
)
import
Servant.Client.Core
(
BaseUrl
,
parseBaseUrl
,
showBaseUrl
)
import
System.Directory
(
doesFileExist
)
import
Toml
import
Toml
import
Toml.Schema
import
Toml.Schema
...
@@ -179,13 +186,17 @@ instance ToTable FramesConfig where
...
@@ -179,13 +186,17 @@ instance ToTable FramesConfig where
makeLenses
''
F
ramesConfig
makeLenses
''
F
ramesConfig
type
PortNumber
=
Int
-- TODO jwtSettings = defaultJWTSettings
data
FrontendConfig
=
data
FrontendConfig
=
FrontendConfig
{
_fc_url
::
!
Text
FrontendConfig
{
_fc_url
::
!
Text
,
_fc_backend_name
::
!
Text
,
_fc_backend_name
::
!
Text
,
_fc_url_backend_api
::
!
Text
,
_fc_url_backend_api
::
!
Text
,
_fc_jwt_settings
::
!
Text
,
_fc_cors
::
!
CORSSettings
,
_fc_cors
::
!
CORSSettings
,
_fc_microservices
::
!
MicroServicesSettings
,
_fc_microservices
::
!
MicroServicesSettings
,
_fc_appPort
::
!
PortNumber
}
}
deriving
(
Generic
,
Show
)
deriving
(
Generic
,
Show
)
instance
FromValue
FrontendConfig
where
instance
FromValue
FrontendConfig
where
...
@@ -193,9 +204,9 @@ instance FromValue FrontendConfig where
...
@@ -193,9 +204,9 @@ instance FromValue FrontendConfig where
_fc_url
<-
reqKey
"url"
_fc_url
<-
reqKey
"url"
_fc_backend_name
<-
reqKey
"backend_name"
_fc_backend_name
<-
reqKey
"backend_name"
_fc_url_backend_api
<-
reqKey
"url_backend_api"
_fc_url_backend_api
<-
reqKey
"url_backend_api"
_fc_jwt_settings
<-
reqKey
"jwt_settings"
_fc_cors
<-
reqKey
"cors"
_fc_cors
<-
reqKey
"cors"
_fc_microservices
<-
reqKey
"microservices"
_fc_microservices
<-
reqKey
"microservices"
let
_fc_appPort
=
3000
return
$
FrontendConfig
{
..
}
return
$
FrontendConfig
{
..
}
instance
ToValue
FrontendConfig
where
instance
ToValue
FrontendConfig
where
toValue
=
defaultTableToValue
toValue
=
defaultTableToValue
...
@@ -203,28 +214,54 @@ instance ToTable FrontendConfig where
...
@@ -203,28 +214,54 @@ instance ToTable FrontendConfig where
toTable
(
FrontendConfig
{
..
})
=
table
[
"url"
.=
_fc_url
toTable
(
FrontendConfig
{
..
})
=
table
[
"url"
.=
_fc_url
,
"backend_name"
.=
_fc_backend_name
,
"backend_name"
.=
_fc_backend_name
,
"url_backend_api"
.=
_fc_url_backend_api
,
"url_backend_api"
.=
_fc_url_backend_api
,
"jwt_settings"
.=
_fc_jwt_settings
,
"cors"
.=
_fc_cors
,
"cors"
.=
_fc_cors
,
"microservices"
.=
_fc_microservices
]
,
"microservices"
.=
_fc_microservices
]
makeLenses
''
F
rontendConfig
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
=
data
SecretsConfig
=
SecretsConfig
{
_s_master_user
::
!
Text
SecretsConfig
{
_s_master_user
::
!
Text
,
_s_secret_key
::
!
Text
,
_s_secret_key
::
!
Text
,
_s_jwk_file
::
!
JWKFile
}
}
deriving
(
Generic
,
Show
)
deriving
(
Generic
,
Show
)
instance
FromValue
SecretsConfig
where
instance
FromValue
SecretsConfig
where
fromValue
=
parseTableFromValue
$
do
fromValue
=
parseTableFromValue
$
do
_s_master_user
<-
reqKey
"master_user"
_s_master_user
<-
reqKey
"master_user"
_s_secret_key
<-
reqKey
"secret_key"
_s_secret_key
<-
reqKey
"secret_key"
jwkFile
<-
reqKey
"jwk_file"
let
_s_jwk_file
=
JWKFile
jwkFile
return
$
SecretsConfig
{
..
}
return
$
SecretsConfig
{
..
}
instance
ToValue
SecretsConfig
where
instance
ToValue
SecretsConfig
where
toValue
=
defaultTableToValue
toValue
=
defaultTableToValue
instance
ToTable
SecretsConfig
where
instance
ToTable
SecretsConfig
where
toTable
(
SecretsConfig
{
..
})
=
table
[
"master_user"
.=
_s_master_user
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
=
data
JobsConfig
=
...
...
src/Gargantext/Core/Mail.hs
View file @
890a8076
...
@@ -15,11 +15,10 @@ import Control.Lens (view)
...
@@ -15,11 +15,10 @@ import Control.Lens (view)
import
Control.Monad.Trans.Control
(
MonadBaseControl
)
import
Control.Monad.Trans.Control
(
MonadBaseControl
)
import
Data.List
qualified
as
List
import
Data.List
qualified
as
List
import
Data.Text
(
splitOn
)
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.Types
(
fc_url
,
fc_backend_name
)
import
Gargantext.Core.Config.Mail
(
gargMail
,
GargMail
(
..
),
MailConfig
)
import
Gargantext.Core.Config.Mail
(
gargMail
,
GargMail
(
..
),
MailConfig
)
import
Gargantext.Core.Types.Individu
import
Gargantext.Core.Types.Individu
import
Gargantext.Database.Prelude
(
HasConfig
(
..
))
import
Gargantext.Database.Schema.User
(
UserLight
(
..
))
import
Gargantext.Database.Schema.User
(
UserLight
(
..
))
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Network.URI.Encode
(
encodeText
)
import
Network.URI.Encode
(
encodeText
)
...
...
src/Gargantext/Core/Worker/Env.hs
View file @
890a8076
...
@@ -24,12 +24,12 @@ import Data.Text qualified as T
...
@@ -24,12 +24,12 @@ import Data.Text qualified as T
import
Database.PostgreSQL.Simple
(
Connection
)
import
Database.PostgreSQL.Simple
(
Connection
)
import
Gargantext.API.Admin.EnvTypes
(
ConcreteJobHandle
,
GargJob
,
Mode
(
Dev
),
modeToLoggingLevels
)
import
Gargantext.API.Admin.EnvTypes
(
ConcreteJobHandle
,
GargJob
,
Mode
(
Dev
),
modeToLoggingLevels
)
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
,
noJobLog
)
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.Admin.Types
(
HasSettings
(
..
),
Settings
(
..
))
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.Core.AsyncUpdates.CentralExchange
qualified
as
CE
import
Gargantext.Core.AsyncUpdates.CentralExchange
qualified
as
CE
import
Gargantext.Core.AsyncUpdates.CentralExchange.Types
qualified
as
CET
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.Mail
qualified
as
Mail
import
Gargantext.Core.Config.Utils
(
readConfig
)
import
Gargantext.Core.Config.Utils
(
readConfig
)
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
))
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
))
...
@@ -37,7 +37,7 @@ import Gargantext.Core.Mail.Types (HasMail(..))
...
@@ -37,7 +37,7 @@ import Gargantext.Core.Mail.Types (HasMail(..))
import
Gargantext.Core.NLP
(
HasNLPServer
(
..
),
NLPServerMap
,
nlpServerMap
)
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.NodeStory
(
HasNodeStoryEnv
(
..
),
HasNodeStoryImmediateSaver
(
..
),
HasNodeArchiveStoryImmediateSaver
(
..
),
NodeStoryEnv
,
fromDBNodeStoryEnv
,
nse_saver_immediate
,
nse_archive_saver_immediate
)
import
Gargantext.Core.Types
(
HasValidationError
(
..
))
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.Table.Node.Error
(
HasNodeError
(
..
))
import
Gargantext.Database.Query.Tree.Error
(
HasTreeError
(
..
))
import
Gargantext.Database.Query.Tree.Error
(
HasTreeError
(
..
))
import
Gargantext.Prelude
hiding
(
to
)
import
Gargantext.Prelude
hiding
(
to
)
...
@@ -70,7 +70,7 @@ withWorkerEnv settingsFile k = withLoggerHoisted Dev $ \logger -> do
...
@@ -70,7 +70,7 @@ withWorkerEnv settingsFile k = withLoggerHoisted Dev $ \logger -> do
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
pool
<-
newPool
$
_gc_database_config
cfg
pool
<-
newPool
$
_gc_database_config
cfg
nodeStory_env
<-
fromDBNodeStoryEnv
pool
nodeStory_env
<-
fromDBNodeStoryEnv
pool
setts
<-
devSettings
devJwkFile
settingsFile
let
setts
=
devSettings
pure
$
WorkerEnv
pure
$
WorkerEnv
{
_w_env_pool
=
pool
{
_w_env_pool
=
pool
,
_w_env_logger
=
logger
,
_w_env_logger
=
logger
...
...
src/Gargantext/Core/Worker/Jobs.hs
View file @
890a8076
...
@@ -20,7 +20,7 @@ import Async.Worker.Types qualified as Worker
...
@@ -20,7 +20,7 @@ import Async.Worker.Types qualified as Worker
import
Async.Worker.Types
(
HasWorkerBroker
)
import
Async.Worker.Types
(
HasWorkerBroker
)
import
Control.Lens
(
view
)
import
Control.Lens
(
view
)
import
Database.Redis
qualified
as
Redis
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.Config.Worker
(
WorkerSettings
(
..
),
WorkerDefinition
(
..
),
wdToRedisConnectInfo
)
import
Gargantext.Core.Worker.Jobs.Types
(
Job
(
..
))
import
Gargantext.Core.Worker.Jobs.Types
(
Job
(
..
))
import
Gargantext.Database.Prelude
(
Cmd
'
)
import
Gargantext.Database.Prelude
(
Cmd
'
)
...
@@ -36,11 +36,11 @@ initializeRedisBroker connInfo = do
...
@@ -36,11 +36,11 @@ initializeRedisBroker connInfo = do
initBroker
initParams
initBroker
initParams
sendJob
::
(
HasWorkerBroker
RedisBroker
Job
,
Has
Settings
env
)
sendJob
::
(
HasWorkerBroker
RedisBroker
Job
,
Has
Config
env
)
=>
Job
=>
Job
->
Cmd'
env
err
()
->
Cmd'
env
err
()
sendJob
job
=
do
sendJob
job
=
do
ws
<-
view
$
settings
.
workerSettings
ws
<-
view
$
hasConfig
.
gc_worker
-- TODO Try to guess which worker should get this job
-- TODO Try to guess which worker should get this job
-- let mWd = findDefinitionByName ws workerName
-- let mWd = findDefinitionByName ws workerName
let
mWd
=
head
$
_wsDefinitions
ws
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
...
@@ -66,7 +66,7 @@ import EPO.API.Client.Types qualified as EPO
import
Gargantext.API.Ngrams.Tools
(
getTermsWith
)
import
Gargantext.API.Ngrams.Tools
(
getTermsWith
)
import
Gargantext.Core
(
Lang
(
..
),
NLPServerConfig
,
withDefaultLanguage
)
import
Gargantext.Core
(
Lang
(
..
),
NLPServerConfig
,
withDefaultLanguage
)
import
Gargantext.Core.AsyncUpdates.CentralExchange.Types
(
HasCentralExchangeNotification
(
ce_notify
),
CEMessage
(
..
))
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.Config.Types
(
APIsConfig
(
..
))
import
Gargantext.Core.Ext.IMTUser
(
readFile_Annuaire
)
import
Gargantext.Core.Ext.IMTUser
(
readFile_Annuaire
)
import
Gargantext.Core.NLP
(
HasNLPServer
,
nlpServerGet
)
import
Gargantext.Core.NLP
(
HasNLPServer
,
nlpServerGet
)
...
@@ -93,7 +93,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact ( HyperdataContact )
...
@@ -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.Corpus
(
HyperdataAnnuaire
,
HyperdataCorpus
(
_hc_lang
)
)
import
Gargantext.Database.Admin.Types.Hyperdata.Document
(
ToHyperdataDocument
(
toHyperdataDocument
)
)
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.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.ContextNodeNgrams2
(
ContextNodeNgrams2Poly
(
..
),
insertContextNodeNgrams2
)
import
Gargantext.Database.Query.Table.Node
(
MkCorpus
,
insertDefaultNodeIfNotExists
,
getOrMkList
,
getNodeWith
)
import
Gargantext.Database.Query.Table.Node
(
MkCorpus
,
insertDefaultNodeIfNotExists
,
getOrMkList
,
getNodeWith
)
import
Gargantext.Database.Query.Table.Node.Document.Add
qualified
as
Doc
(
add
)
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
...
@@ -19,15 +19,14 @@ module Gargantext.Database.Action.Node
import
Control.Lens
(
view
)
import
Control.Lens
(
view
)
import
Data.Text
qualified
as
T
import
Data.Text
qualified
as
T
import
Gargantext.API.Admin.Types
(
settings
,
_microservicesSettings
,
HasSettings
)
import
Gargantext.Core
import
Gargantext.Core
import
Gargantext.Core.Config
(
GargConfig
(
..
),
mkProxyUrl
)
import
Gargantext.Core.Config
(
GargConfig
(
..
),
gc_frames
,
gc_frontend_config
,
mkProxyUrl
,
HasConfig
(
..
)
)
import
Gargantext.Core.Config.Types
(
FramesConfig
(
..
),
MicroServicesSettings
(
..
),
SecretsConfig
(
..
))
import
Gargantext.Core.Config.Types
(
FramesConfig
(
..
),
f_write_url
,
fc_microservices
,
MicroServicesSettings
(
..
),
SecretsConfig
(
..
))
import
Gargantext.Core.Types
(
Name
)
import
Gargantext.Core.Types
(
Name
)
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Hyperdata.Default
import
Gargantext.Database.Admin.Types.Hyperdata.Default
import
Gargantext.Database.Admin.Types.Node
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
import
Gargantext.Database.Query.Table.Node.Error
import
Gargantext.Database.Query.Table.Node.Error
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
import
Gargantext.Database.Query.Table.Node.UpdateOpaleye
(
updateHyperdata
)
...
@@ -37,7 +36,7 @@ import Servant.Client.Core.BaseUrl
...
@@ -37,7 +36,7 @@ import Servant.Client.Core.BaseUrl
------------------------------------------------------------------------
------------------------------------------------------------------------
-- | TODO mk all others nodes
-- | TODO mk all others nodes
mkNodeWithParent
::
(
HasNodeError
err
,
HasDBid
NodeType
,
HasSettings
env
)
mkNodeWithParent
::
(
HasNodeError
err
,
HasDBid
NodeType
)
=>
NodeType
=>
NodeType
->
Maybe
ParentId
->
Maybe
ParentId
->
UserId
->
UserId
...
@@ -71,7 +70,7 @@ mkNodeWithParent nt (Just pId) uId name = (:[]) <$> insertNode nt (Just name) N
...
@@ -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
-- | 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
=>
NodeType
->
Maybe
ParentId
->
Maybe
ParentId
->
UserId
->
UserId
...
@@ -95,15 +94,15 @@ mkNodeWithParent_ConfigureHyperdata _ _ _ _ = nodeError NotImplYet
...
@@ -95,15 +94,15 @@ mkNodeWithParent_ConfigureHyperdata _ _ _ _ = nodeError NotImplYet
-- | Creates the base URL for the notes microservices proxy, or defaults
-- | Creates the base URL for the notes microservices proxy, or defaults
-- to the notes microservice if the proxy has been disabled from the settings.
-- to the notes microservice if the proxy has been disabled from the settings.
internalNotesProxy
::
GargConfig
->
MicroServicesSettings
->
T
.
Text
internalNotesProxy
::
GargConfig
->
T
.
Text
internalNotesProxy
cfg
msSettings
internalNotesProxy
cfg
|
_msProxyEnabled
msSettings
=
T
.
pack
$
showBaseUrl
proxyUrl
<>
"/notes"
|
_msProxyEnabled
(
cfg
^.
gc_frontend_config
.
fc_microservices
)
=
T
.
pack
$
showBaseUrl
proxyUrl
<>
"/notes"
|
otherwise
=
_f_write_url
$
_gc_frames
cfg
|
otherwise
=
cfg
^.
gc_frames
.
f_write_url
where
where
proxyUrl
=
mkProxyUrl
cfg
msSettings
proxyUrl
=
mkProxyUrl
cfg
-- | Function not exposed
-- | Function not exposed
mkNodeWithParent_ConfigureHyperdata'
::
(
HasNodeError
err
,
HasDBid
NodeType
,
HasSettings
env
)
mkNodeWithParent_ConfigureHyperdata'
::
(
HasNodeError
err
,
HasDBid
NodeType
)
=>
NodeType
=>
NodeType
->
Maybe
ParentId
->
Maybe
ParentId
->
UserId
->
UserId
...
@@ -117,9 +116,8 @@ mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
...
@@ -117,9 +116,8 @@ mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
_
->
nodeError
NeedsConfiguration
_
->
nodeError
NeedsConfiguration
cfg
<-
view
hasConfig
cfg
<-
view
hasConfig
stt
<-
view
settings
u
<-
case
nt
of
u
<-
case
nt
of
Notes
->
pure
$
internalNotesProxy
cfg
(
_microservicesSettings
stt
)
Notes
->
pure
$
internalNotesProxy
cfg
Calc
->
pure
$
_f_calc_url
$
_gc_frames
cfg
Calc
->
pure
$
_f_calc_url
$
_gc_frames
cfg
NodeFrameVisio
->
pure
$
_f_visio_url
$
_gc_frames
cfg
NodeFrameVisio
->
pure
$
_f_visio_url
$
_gc_frames
cfg
_
->
nodeError
NeedsConfiguration
_
->
nodeError
NeedsConfiguration
...
...
src/Gargantext/Database/GargDB.hs
View file @
890a8076
...
@@ -18,9 +18,8 @@ module Gargantext.Database.GargDB
...
@@ -18,9 +18,8 @@ module Gargantext.Database.GargDB
import
Control.Lens
(
view
)
import
Control.Lens
(
view
)
import
Data.Text
qualified
as
Text
import
Data.Text
qualified
as
Text
import
Data.Tuple.Extra
(
both
)
import
Data.Tuple.Extra
(
both
)
import
Gargantext.
Database.Prelude
(
HasConfig
(
..
)
)
import
Gargantext.
Core.Config
(
gc_datafilepath
,
HasConfig
(
..
)
)
import
Gargantext.Prelude
hiding
(
hash
)
import
Gargantext.Prelude
hiding
(
hash
)
import
Gargantext.Core.Config
(
gc_datafilepath
)
import
Gargantext.Prelude.Crypto.Hash
(
IsHashable
(
hash
)
)
import
Gargantext.Prelude.Crypto.Hash
(
IsHashable
(
hash
)
)
import
Prelude
qualified
import
Prelude
qualified
import
System.Directory
(
createDirectoryIfMissing
)
import
System.Directory
(
createDirectoryIfMissing
)
...
...
src/Gargantext/Database/Prelude.hs
View file @
890a8076
...
@@ -29,7 +29,7 @@ import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(Conversion
...
@@ -29,7 +29,7 @@ import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(Conversion
import
Database.PostgreSQL.Simple.Internal
(
Field
)
import
Database.PostgreSQL.Simple.Internal
(
Field
)
import
Database.PostgreSQL.Simple.Types
(
Query
(
..
))
import
Database.PostgreSQL.Simple.Types
(
Query
(
..
))
import
Gargantext.Core.AsyncUpdates.CentralExchange.Types
qualified
as
CET
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.Mail.Types
(
HasMail
)
import
Gargantext.Core.NLP
(
HasNLPServer
)
import
Gargantext.Core.NLP
(
HasNLPServer
)
import
Gargantext.Prelude
import
Gargantext.Prelude
...
@@ -45,12 +45,6 @@ class HasConnectionPool env where
...
@@ -45,12 +45,6 @@ class HasConnectionPool env where
instance
HasConnectionPool
(
Pool
Connection
)
where
instance
HasConnectionPool
(
Pool
Connection
)
where
connPool
=
identity
connPool
=
identity
class
HasConfig
env
where
hasConfig
::
Getter
env
GargConfig
instance
HasConfig
GargConfig
where
hasConfig
=
identity
-------------------------------------------------------
-------------------------------------------------------
type
JSONB
=
DefaultFromField
SqlJsonb
type
JSONB
=
DefaultFromField
SqlJsonb
-------------------------------------------------------
-------------------------------------------------------
...
...
src/Gargantext/MicroServices/ReverseProxy.hs
View file @
890a8076
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ViewPatterns #-}
...
@@ -17,8 +16,6 @@ module Gargantext.MicroServices.ReverseProxy (
...
@@ -17,8 +16,6 @@ module Gargantext.MicroServices.ReverseProxy (
,
FrameId
(
..
)
,
FrameId
(
..
)
)
where
)
where
import
Prelude
import
Conduit
import
Conduit
import
Data.ByteString
qualified
as
B
import
Data.ByteString
qualified
as
B
import
Data.ByteString.Builder
import
Data.ByteString.Builder
...
@@ -38,10 +35,9 @@ import Gargantext.API.Node.ShareURL qualified as Share
...
@@ -38,10 +35,9 @@ import Gargantext.API.Node.ShareURL qualified as Share
import
Gargantext.API.Routes.Named.Private
import
Gargantext.API.Routes.Named.Private
import
Gargantext.API.Routes.Named.Share
(
ShareLink
(
..
))
import
Gargantext.API.Routes.Named.Share
(
ShareLink
(
..
))
import
Gargantext.API.ThrowAll
(
throwAllRoutes
)
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.Core.Config.Types
(
f_write_url
)
import
Gargantext.Database.Admin.Types.Node
(
NodeType
(
..
),
NodeId
(
..
))
import
Gargantext.Database.Admin.Types.Node
(
NodeType
(
..
),
NodeId
(
..
))
import
Gargantext.Database.Prelude
(
hasConfig
)
import
Gargantext.Prelude
hiding
(
Handler
)
import
Gargantext.Prelude
hiding
(
Handler
)
import
Network.HTTP.ReverseProxy
import
Network.HTTP.ReverseProxy
import
Network.HTTP.Types
(
hCacheControl
,
RequestHeaders
,
hReferer
,
ResponseHeaders
,
Header
)
import
Network.HTTP.Types
(
hCacheControl
,
RequestHeaders
,
hReferer
,
ResponseHeaders
,
Header
)
...
@@ -158,10 +154,10 @@ type ProxyCache = InMemory.Cache FrameId NodeId
...
@@ -158,10 +154,10 @@ type ProxyCache = InMemory.Cache FrameId NodeId
microServicesProxyApp
::
ProxyCache
->
Env
->
Application
microServicesProxyApp
::
ProxyCache
->
Env
->
Application
microServicesProxyApp
cache
env
=
genericServeTWithContext
id
(
server
cache
env
)
cfg
microServicesProxyApp
cache
env
=
genericServeTWithContext
id
entity
(
server
cache
env
)
cfg
where
where
cfg
::
Context
AuthContext
cfg
::
Context
AuthContext
cfg
=
env
^.
settings
.
jwtS
ettings
cfg
=
env
^.
env_jwt_s
ettings
:.
env
^.
settings
.
cookieSettings
:.
env
^.
settings
.
cookieSettings
:.
EmptyContext
:.
EmptyContext
...
@@ -212,10 +208,10 @@ notesProxyImplementation :: ProxyCache -> Env -> NotesProxy AsServer
...
@@ -212,10 +208,10 @@ notesProxyImplementation :: ProxyCache -> Env -> NotesProxy AsServer
notesProxyImplementation
cache
env
=
NotesProxy
{
notesProxyImplementation
cache
env
=
NotesProxy
{
slideEp
=
\
frameId
->
slideProxyServer
env
frameId
slideEp
=
\
frameId
->
slideProxyServer
env
frameId
,
publishEp
=
\
frameId
->
publishProxyServer
cache
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
,
notesSocket
=
socketIOProxyImplementation
sty
env
,
meEndpoint
=
proxyPassServer
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
,
notesStaticAssets
=
proxyPassServer
sty
env
}
}
where
where
...
@@ -224,7 +220,7 @@ notesProxyImplementation cache env = NotesProxy {
...
@@ -224,7 +220,7 @@ notesProxyImplementation cache env = NotesProxy {
socketIOProxyImplementation
::
ServiceType
->
Env
->
SocketIOProxy
AsServer
socketIOProxyImplementation
::
ServiceType
->
Env
->
SocketIOProxy
AsServer
socketIOProxyImplementation
sty
env
=
SocketIOProxy
{
socketIOProxyImplementation
sty
env
=
SocketIOProxy
{
socketIoEp
=
\
_noteId
->
defaultForwardServer
sty
id
id
env
socketIoEp
=
\
_noteId
->
defaultForwardServer
sty
id
entity
identity
env
}
}
removeServiceFromPath
::
ServiceType
->
Request
->
Request
removeServiceFromPath
::
ServiceType
->
Request
->
Request
...
@@ -236,7 +232,7 @@ removeServiceFromPath sty = removeProxyPath (T.pack $ serviceTypeToProxyPath sty
...
@@ -236,7 +232,7 @@ removeServiceFromPath sty = removeProxyPath (T.pack $ serviceTypeToProxyPath sty
slideProxyServer
::
Env
->
FrameId
->
ServerT
Raw
m
slideProxyServer
::
Env
->
FrameId
->
ServerT
Raw
m
slideProxyServer
env
(
FrameId
frameId
)
=
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
where
changePath
::
ByteString
->
ByteString
changePath
::
ByteString
->
ByteString
changePath
_
=
TE
.
encodeUtf8
$
"/p/"
<>
frameId
<>
"#/"
changePath
_
=
TE
.
encodeUtf8
$
"/p/"
<>
frameId
<>
"#/"
...
@@ -253,7 +249,7 @@ publishProxyServer cache env frameId = Tagged $ \req res -> do
...
@@ -253,7 +249,7 @@ publishProxyServer cache env frameId = Tagged $ \req res -> do
Just
nodeId
Just
nodeId
->
do
->
do
-- Using a mock for now.
-- 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
->
Left
_e
->
-- Invalid link, treat this as a normal proxy
-- Invalid link, treat this as a normal proxy
forwardRaw
req
res
forwardRaw
req
res
...
@@ -264,14 +260,14 @@ publishProxyServer cache env frameId = Tagged $ \req res -> do
...
@@ -264,14 +260,14 @@ publishProxyServer cache env frameId = Tagged $ \req res -> do
where
where
forwardRaw
=
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
::
ByteString
->
ByteString
changePath
_
=
TE
.
encodeUtf8
$
"/s/"
<>
(
_FrameId
frameId
)
changePath
_
=
TE
.
encodeUtf8
$
"/s/"
<>
(
_FrameId
frameId
)
-- Generic server forwarder
-- Generic server forwarder
proxyPassServer
::
ServiceType
->
Env
->
ServerT
Raw
m
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
->
ProxyDestination
mkProxyDestination
env
=
fromMaybe
(
panicTrace
"Invalid URI found in the proxied Request."
)
$
do
mkProxyDestination
env
=
fromMaybe
(
panicTrace
"Invalid URI found in the proxied Request."
)
$
do
...
@@ -284,8 +280,8 @@ mkProxyDestination env = fromMaybe (panicTrace "Invalid URI found in the proxied
...
@@ -284,8 +280,8 @@ mkProxyDestination env = fromMaybe (panicTrace "Invalid URI found in the proxied
removeFromReferer
::
T
.
Text
->
Request
->
Request
removeFromReferer
::
T
.
Text
->
Request
->
Request
removeFromReferer
pth
originalRequest
=
removeFromReferer
pth
originalRequest
=
originalRequest
{
requestHeaders
=
(
Prelude
.
map
tweakReferer
(
requestHeaders
originalRequest
)
)
originalRequest
{
requestHeaders
=
map
tweakReferer
(
requestHeaders
originalRequest
)
}
}
where
where
tweakReferer
::
Header
->
Header
tweakReferer
::
Header
->
Header
tweakReferer
(
k
,
v
)
tweakReferer
(
k
,
v
)
...
@@ -295,7 +291,7 @@ removeFromReferer pth originalRequest =
...
@@ -295,7 +291,7 @@ removeFromReferer pth originalRequest =
=
(
k
,
v
)
=
(
k
,
v
)
proxyUrl
::
Env
->
BaseUrl
proxyUrl
::
Env
->
BaseUrl
proxyUrl
env
=
mkProxyUrl
(
env
^.
hasConfig
)
(
env
^.
env_settings
.
microservicesSettings
)
proxyUrl
env
=
mkProxyUrl
(
env
^.
hasConfig
)
notesForwardServer
::
ProxyCache
notesForwardServer
::
ProxyCache
->
FrameId
->
FrameId
...
@@ -307,7 +303,7 @@ notesForwardServer :: ProxyCache
...
@@ -307,7 +303,7 @@ notesForwardServer :: ProxyCache
notesForwardServer
cache
frameId
mbNodeId
sty
presendModifyRequest
env
=
notesForwardServer
cache
frameId
mbNodeId
sty
presendModifyRequest
env
=
case
mbNodeId
of
case
mbNodeId
of
Nothing
Nothing
->
defaultForwardServer
sty
presendModifyRequest
id
env
->
defaultForwardServer
sty
presendModifyRequest
id
entity
env
Just
nid
Just
nid
->
do
->
do
-- Persist the node id in the cache
-- Persist the node id in the cache
...
@@ -317,7 +313,7 @@ notesForwardServer cache frameId mbNodeId sty presendModifyRequest env =
...
@@ -317,7 +313,7 @@ notesForwardServer cache frameId mbNodeId sty presendModifyRequest env =
where
where
setFrameIdCookie
::
FrameId
->
NodeId
->
(
ResponseHeaders
->
ResponseHeaders
)
setFrameIdCookie
::
FrameId
->
NodeId
->
(
ResponseHeaders
->
ResponseHeaders
)
setFrameIdCookie
(
FrameId
(
T
.
unpack
->
fid
))
(
UnsafeMkNodeId
nid
)
origHeaders
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
in
sk
:
origHeaders
defaultForwardServerWithSettings
::
ServiceType
defaultForwardServerWithSettings
::
ServiceType
...
@@ -326,7 +322,7 @@ defaultForwardServerWithSettings :: ServiceType
...
@@ -326,7 +322,7 @@ defaultForwardServerWithSettings :: ServiceType
->
WaiProxySettings
->
WaiProxySettings
->
ServerT
Raw
m
->
ServerT
Raw
m
defaultForwardServerWithSettings
sty
presendModifyRequest
env
proxySettings
=
defaultForwardServerWithSettings
sty
presendModifyRequest
env
proxySettings
=
Tagged
$
waiProxyToSettings
forwardRequest
(
proxySettings
)
(
env
^.
env_manager
)
Tagged
$
waiProxyToSettings
forwardRequest
proxySettings
(
env
^.
env_manager
)
where
where
proxyDestination
::
ProxyDestination
proxyDestination
::
ProxyDestination
...
@@ -360,7 +356,7 @@ defaultForwardServer sty presendModifyRequest mapRespHeaders env =
...
@@ -360,7 +356,7 @@ defaultForwardServer sty presendModifyRequest mapRespHeaders env =
defaultForwardServerWithSettings
sty
presendModifyRequest
env
$
defaultForwardServerWithSettings
sty
presendModifyRequest
env
$
defaultWaiProxySettings
{
defaultWaiProxySettings
{
wpsProcessBody
=
\
_req
_res
->
Just
$
replaceRelativeLinks
proxyDestination
proxyPath
wpsProcessBody
=
\
_req
_res
->
Just
$
replaceRelativeLinks
proxyDestination
proxyPath
,
wpsModifyResponseHeaders
=
\
_req
_res
->
(
mapRespHeaders
.
tweakResponseHeaders
)
,
wpsModifyResponseHeaders
=
\
_req
_res
->
mapRespHeaders
.
tweakResponseHeaders
,
wpsRedirectCounts
=
5
,
wpsRedirectCounts
=
5
}
}
where
where
...
@@ -382,7 +378,7 @@ noCache hdrs = (hCacheControl, fromString "no-cache") : filter ((/=) hCacheContr
...
@@ -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
-- | Tweak the response headers so that they will have a bit more permissive
-- 'Content-Security-Policy'.
-- 'Content-Security-Policy'.
tweakResponseHeaders
::
ResponseHeaders
->
ResponseHeaders
tweakResponseHeaders
::
ResponseHeaders
->
ResponseHeaders
tweakResponseHeaders
=
Prelude
.
map
tweakHeader
tweakResponseHeaders
=
map
tweakHeader
where
where
tweakHeader
(
k
,
v
)
tweakHeader
(
k
,
v
)
|
k
==
"Content-Security-Policy"
|
k
==
"Content-Security-Policy"
...
...
test-data/test_config.toml
View file @
890a8076
...
@@ -15,6 +15,7 @@ enabled = false
...
@@ -15,6 +15,7 @@ enabled = false
[secrets]
[secrets]
master_user
=
"gargantua"
master_user
=
"gargantua"
secret_key
=
"test_key"
secret_key
=
"test_key"
jwk_file
=
"test.jwk"
[paths]
[paths]
data_filepath
=
"~/.garg"
data_filepath
=
"~/.garg"
...
...
test/Test/API/Notifications.hs
View file @
890a8076
...
@@ -11,7 +11,6 @@ Portability : POSIX
...
@@ -11,7 +11,6 @@ Portability : POSIX
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE QuasiQuotes #-}
module
Test.API.Notifications
(
module
Test.API.Notifications
(
tests
tests
...
@@ -28,11 +27,9 @@ import Gargantext.Core.Config.Types (NotificationsConfig(..))
...
@@ -28,11 +27,9 @@ import Gargantext.Core.Config.Types (NotificationsConfig(..))
import
Network.WebSockets.Client
qualified
as
WS
import
Network.WebSockets.Client
qualified
as
WS
import
Network.WebSockets.Connection
qualified
as
WS
import
Network.WebSockets.Connection
qualified
as
WS
import
Prelude
import
Prelude
import
System.Timeout
qualified
as
Timeout
import
Test.API.Setup
(
withTestDBAndPort
)
-- , setupEnvironment, createAliceAndBob)
import
Test.API.Setup
(
withTestDBAndPort
)
-- , setupEnvironment, createAliceAndBob)
import
Test.Hspec
import
Test.Hspec
import
Test.Instances
()
import
Test.Instances
()
import
Text.RawString.QQ
(
r
)
tests
::
NotificationsConfig
->
Spec
tests
::
NotificationsConfig
->
Spec
...
...
test/Test/API/Setup.hs
View file @
890a8076
...
@@ -13,18 +13,11 @@ import Data.Streaming.Network (bindPortTCP)
...
@@ -13,18 +13,11 @@ import Data.Streaming.Network (bindPortTCP)
import
Gargantext.API
(
makeApp
)
import
Gargantext.API
(
makeApp
)
import
Gargantext.API.Admin.EnvTypes
(
Mode
(
Mock
),
Env
(
..
))
import
Gargantext.API.Admin.EnvTypes
(
Mode
(
Mock
),
Env
(
..
))
import
Gargantext.API.Admin.Settings
import
Gargantext.API.Admin.Settings
import
Gargantext.API.Admin.Types
import
Gargantext.API.Errors.Types
import
Gargantext.API.Errors.Types
import
Gargantext.API.Prelude
import
Gargantext.API.Prelude
import
Gargantext.Core.AsyncUpdates.CentralExchange
qualified
as
CE
import
Gargantext.Core.Config
(
_gc_secrets
,
gc_frontend_config
,
gc_jobs
,
hasConfig
)
import
Gargantext.Core.AsyncUpdates.Dispatcher
qualified
as
D
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
),
jc_js_job_timeout
,
jc_js_id_timeout
,
fc_appPort
,
jwtSettings
)
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.Utils
(
readConfig
)
import
Gargantext.Core.Config.Utils
(
readConfig
)
import
Gargantext.Core.NLP
import
Gargantext.Core.NodeStory
import
Gargantext.Core.NodeStory
import
Gargantext.Core.Types.Individu
import
Gargantext.Core.Types.Individu
import
Gargantext.Database.Action.Flow
import
Gargantext.Database.Action.Flow
...
@@ -32,7 +25,7 @@ import Gargantext.Database.Action.User.New
...
@@ -32,7 +25,7 @@ import Gargantext.Database.Action.User.New
import
Gargantext.Database.Admin.Config
(
userMaster
)
import
Gargantext.Database.Admin.Config
(
userMaster
)
import
Gargantext.Database.Admin.Trigger.Init
import
Gargantext.Database.Admin.Trigger.Init
import
Gargantext.Database.Admin.Types.Hyperdata
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.Table.Node
(
getOrMkList
)
import
Gargantext.Database.Query.Tree.Root
(
MkCorpusUser
(
..
))
import
Gargantext.Database.Query.Tree.Root
(
MkCorpusUser
(
..
))
import
Gargantext.MicroServices.ReverseProxy
(
microServicesProxyApp
)
import
Gargantext.MicroServices.ReverseProxy
(
microServicesProxyApp
)
...
@@ -61,9 +54,9 @@ newTestEnv :: TestEnv -> Logger (GargM Env BackendInternalError) -> Warp.Port ->
...
@@ -61,9 +54,9 @@ newTestEnv :: TestEnv -> Logger (GargM Env BackendInternalError) -> Warp.Port ->
newTestEnv
testEnv
logger
port
=
do
newTestEnv
testEnv
logger
port
=
do
tomlFile
@
(
SettingsFile
sf
)
<-
fakeTomlPath
tomlFile
@
(
SettingsFile
sf
)
<-
fakeTomlPath
!
manager_env
<-
newTlsManager
!
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"
)
prios
<-
withLogger
()
$
\
ioLogger
->
Jobs
.
readPrios
ioLogger
(
sf
<>
".jobs"
)
let
prios'
=
Jobs
.
applyPrios
prios
Jobs
.
defaultPrios
let
prios'
=
Jobs
.
applyPrios
prios
Jobs
.
defaultPrios
!
self_url_env
<-
parseBaseUrl
$
"http://0.0.0.0:"
<>
show
port
!
self_url_env
<-
parseBaseUrl
$
"http://0.0.0.0:"
<>
show
port
...
@@ -78,6 +71,7 @@ newTestEnv testEnv logger port = do
...
@@ -78,6 +71,7 @@ newTestEnv testEnv logger port = do
&
Jobs
.
l_jsJobTimeout
.~
(
fromIntegral
$
config_env
^.
hasConfig
^.
gc_jobs
.
jc_js_job_timeout
)
&
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
.
l_jsIDTimeout
.~
(
fromIntegral
$
config_env
^.
hasConfig
^.
gc_jobs
.
jc_js_id_timeout
)
!
jobs_env
<-
Jobs
.
newJobEnv
jobs_settings
prios'
manager_env
!
jobs_env
<-
Jobs
.
newJobEnv
jobs_settings
prios'
manager_env
!
_env_jwt_settings
<-
jwtSettings
(
_gc_secrets
config_env
)
-- !central_exchange <- forkIO CE.gServer
-- !central_exchange <- forkIO CE.gServer
-- !dispatcher <- D.dispatcher
-- !dispatcher <- D.dispatcher
...
@@ -92,12 +86,11 @@ newTestEnv testEnv logger port = do
...
@@ -92,12 +86,11 @@ newTestEnv testEnv logger port = do
,
_env_jobs
=
jobs_env
,
_env_jobs
=
jobs_env
,
_env_self_url
=
self_url_env
,
_env_self_url
=
self_url_env
,
_env_config
=
config_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_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_dispatcher
=
Prelude
.
error
"dispatcher not needed, but forced somewhere (check StrictData)"
-- , _env_central_exchange = central_exchange
-- , _env_central_exchange = central_exchange
-- , _env_dispatcher = dispatcher
-- , _env_dispatcher = dispatcher
,
_env_jwt_settings
}
}
-- | Run the gargantext server on a random port, picked by Warp, which allows
-- | 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
...
@@ -76,7 +76,7 @@ setup = do
bootstrapDB
db
pool
gargConfig
bootstrapDB
db
pool
gargConfig
ugen
<-
emptyCounter
ugen
<-
emptyCounter
test_nodeStory
<-
fromDBNodeStoryEnv
pool
test_nodeStory
<-
fromDBNodeStoryEnv
pool
stgs
<-
devSettings
devJwkFile
=<<
fakeTomlPath
let
stgs
=
devSettings
withLoggerHoisted
Mock
$
\
logger
->
do
withLoggerHoisted
Mock
$
\
logger
->
do
pure
$
TestEnv
{
test_db
=
DBHandle
pool
db
pure
$
TestEnv
{
test_db
=
DBHandle
pool
db
,
test_config
=
gargConfig
,
test_config
=
gargConfig
...
...
test/Test/Database/Types.hs
View file @
890a8076
...
@@ -31,10 +31,11 @@ import Gargantext.API.Admin.Orchestrator.Types
...
@@ -31,10 +31,11 @@ import Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Admin.Types
import
Gargantext.API.Admin.Types
import
Gargantext.API.Errors.Types
import
Gargantext.API.Errors.Types
import
Gargantext.API.Prelude
import
Gargantext.API.Prelude
import
Gargantext.Core.Config
(
HasConfig
(
..
))
import
Gargantext.Core.Mail.Types
(
HasMail
(
..
))
import
Gargantext.Core.Mail.Types
(
HasMail
(
..
))
import
Gargantext.Core.NLP
(
HasNLPServer
(
..
))
import
Gargantext.Core.NLP
(
HasNLPServer
(
..
))
import
Gargantext.Core.NodeStory
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.Database.Query.Table.Node.Error
import
Gargantext.Core.Config
import
Gargantext.Core.Config
import
Gargantext.Core.Config.Mail
(
MailConfig
(
..
),
LoginType
(
NoAuth
))
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)
...
@@ -28,8 +28,7 @@ import Network.HTTP.Types.Header (hAccept, hAuthorization, hContentType)
import
Network.Wai.Handler.Warp
(
Port
)
import
Network.Wai.Handler.Warp
(
Port
)
import
Network.Wai.Test
(
SResponse
(
..
))
import
Network.Wai.Test
(
SResponse
(
..
))
import
Prelude
qualified
import
Prelude
qualified
import
Servant.Client
(
ClientEnv
,
baseUrlPort
,
defaultMakeClientRequest
,
makeClientRequest
,
mkClientEnv
,
parseBaseUrl
,
runClientM
)
import
Servant.Client
(
ClientEnv
,
baseUrlPort
,
mkClientEnv
,
parseBaseUrl
,
runClientM
)
import
Servant.Client.Core.Request
(
addHeader
)
import
System.Timeout
qualified
as
Timeout
import
System.Timeout
qualified
as
Timeout
import
Test.API.Routes
(
auth_api
,
mkUrl
)
import
Test.API.Routes
(
auth_api
,
mkUrl
)
import
Test.Hspec.Expectations
import
Test.Hspec.Expectations
...
...
test/Test/Utils/Jobs.hs
View file @
890a8076
...
@@ -303,8 +303,6 @@ newTestEnv = do
...
@@ -303,8 +303,6 @@ newTestEnv = do
,
_env_scrapers
=
Prelude
.
error
"scrapers not needed, but forced somewhere (check StrictData)"
,
_env_scrapers
=
Prelude
.
error
"scrapers not needed, but forced somewhere (check StrictData)"
,
_env_jobs
=
myEnv
,
_env_jobs
=
myEnv
,
_env_config
,
_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_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_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