Verified Commit 63594ceb authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski

Merge branch '304-dev-toml-config-rewrite' into 238-dev-async-job-worker

parents 1b83db03 0d0b33f0
Pipeline #6604 failed with stages
in 13 minutes and 21 seconds
......@@ -34,6 +34,7 @@ _darcs
*.pdf
*.sql
*.ini
*.toml
!test-data/test_config.ini
# Runtime
......
## Version 0.0.7.2.1
* [FRONT][DESIGN][[Graph explorer] Search and associated documents (#262)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/262)
* [BACK][FIX][Problem at parsing TSV (#380)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/380)
* [BACK][FEAT][[Node terms] institutes missing with HAL request (#330)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/330)
## Version 0.0.7.2
* [FRONT][FEAT][Graph Explorer Legend (#683)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/683)
......
......@@ -118,7 +118,7 @@ $ ./bin/install
From inside a Nix shell:
```shell
n$ cabal run gargantext-server -- --ini gargantext.ini --run Prod
n$ cabal run gargantext-server -- --toml gargantext-settings.toml --run Prod
```
### Initializing and running
......@@ -135,16 +135,23 @@ The initialization schema should be loaded automatically from `devops/postgres/s
#### Create configuration file
```shell
$ cp gargantext.ini_toModify gargantext.ini
$ cp gargantext-settings.toml_toModify gargantext-settings.toml
```
> `.gitignore` excludes this file, so you don't need to worry about committing it by mistake, and you can change the passwords in `gargantext.ini` safely.
**NOTE** If you had the `gargantext.ini` file before, you can automatically generate toml with:
```shell
cabal v2-run gargantext-cli -- ini --ini-path ./gargantext.ini > gargantext-settings.toml
```
> `.gitignore` excludes this file, so you don't need to worry about
> committing it by mistake, and you can change the passwords in
> `gargantext-settings.toml` safely.
#### Create master user
From within the Nix shell:
```shell
n$ gargantext-cli init --ini-path gargantext.ini
n$ gargantext-cli init
```
The master user's name is automatically set to `gargantua`, but you will be prompted for their password and email address.
......@@ -153,7 +160,7 @@ The master user's name is automatically set to `gargantua`, but you will be prom
Make sure you know where `gargantext-server` is (probably in `~/.local/bin/` or `.cabal/bin/`). If the location is in your `$PATH`, just run:
```shell
$ gargantext-server -- --ini gargantext.ini --run Prod
$ gargantext-server -- --run Prod
```
(If the location is not in your `$PATH`, just prefix `gargantext-server` with the path to it.)
......@@ -200,7 +207,7 @@ the following:
### Multi-User with Graphical User Interface (Server Mode)
``` shell
$ ~/.local/bin/stack --docker exec gargantext-server -- --ini "gargantext.ini" --run Prod
$ ~/.local/bin/stack --docker exec gargantext-server -- --run Prod
```
Then you can log in with `user1` / `1resu`
......@@ -314,7 +321,7 @@ $ psql < gargandb.dump
Maybe you need to restore the gargantua password
```shell
$ ALTER ROLE gargantua PASSWORD 'yourPasswordIn_gargantext.ini'
$ ALTER ROLE gargantua PASSWORD 'yourPasswordIn_gargantext-settings.toml'
```
Maybe you need to change the port to 5433 for database connection in your gargantext.ini file.
......
......@@ -48,7 +48,7 @@ simpleServer = do
_ <- bind s ceBind
putText "[simpleServer] receiving"
forever $ do
mr <- recvMalloc s 1024
mr <- recv s
C.putStrLn mr
-- case mr of
-- Nothing -> pure ()
......
......@@ -19,8 +19,8 @@ import Options.Applicative
import Prelude (String)
adminCLI :: AdminArgs -> IO ()
adminCLI (AdminArgs iniPath settingsPath mails) = do
withDevEnv iniPath settingsPath $ \env -> do
adminCLI (AdminArgs settingsPath mails) = do
withDevEnv settingsPath $ \env -> do
x <- runCmdDev env ((newUsers $ NE.map cs (NE.fromList mails)) :: Cmd'' DevEnv BackendInternalError (NonEmpty UserId))
putStrLn (show x :: Text)
......@@ -29,7 +29,7 @@ adminCmd = command "admin" (info (helper <*> fmap CLISub admin_p) (progDesc "Cre
admin_p :: Parser CLICmd
admin_p = fmap CCMD_admin $ AdminArgs
<$> ini_p <*> settings_p
<$> settings_p
<*> ( option (maybeReader emails_p) ( long "emails"
<> metavar "email1,email2,..."
<> help "A comma-separated list of emails."
......
......@@ -39,7 +39,7 @@ import qualified Data.Text as T
importCLI :: ImportArgs -> IO ()
importCLI (ImportArgs fun user name iniPath settingsPath limit corpusPath) = do
importCLI (ImportArgs fun user name settingsPath limit corpusPath) = do
let
tt = Multi EN
format = TsvGargV3
......@@ -53,7 +53,7 @@ importCLI (ImportArgs fun user name iniPath settingsPath limit corpusPath) = do
annuaire :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
annuaire = flowAnnuaire (MkCorpusUserNormalCorpusName (UserName $ cs user) "Annuaire") (Multi EN) corpusPath DevJobHandle
withDevEnv iniPath settingsPath $ \env -> do
withDevEnv settingsPath $ \env -> do
void $ case fun of
IF_corpus
-> runCmdGargDev env corpus
......@@ -75,7 +75,6 @@ import_p = fmap CCMD_import $ ImportArgs
) )
<*> ( option str ( long "user") )
<*> ( option str ( long "name") )
<*> ini_p
<*> settings_p
<*> (fmap Limit ( option auto ( long "limit" <> metavar "INT" <> help "The limit for the query") ))
<*> ( option str ( long "corpus-path" <> help "Path to corpus file") )
......
{-|
Module : Ini.hs
Description : Gargantext Ini file
Copyright : (c) CNRS, 2024-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Import a corpus binary.
-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
module CLI.Ini where
import CLI.Types
import Data.Text qualified as T
import Database.PostgreSQL.Simple qualified as PGS
import Gargantext.Core.Config qualified as Config
import Gargantext.Core.Config.Ini.Ini qualified as Ini
import Gargantext.Core.Config.Ini.Mail qualified as IniMail
import Gargantext.Core.Config.Ini.NLP qualified as IniNLP
import Gargantext.Core.Config.Types qualified as CTypes
import Gargantext.Prelude
import Options.Applicative
import Servant.Client.Core (parseBaseUrl)
import Toml qualified
iniCLI :: IniArgs -> IO ()
iniCLI (IniArgs iniPath) = do
-- putStrLn $ "ini path: " <> iniPath
ini <- Ini.readConfig iniPath
iniMail <- IniMail.readConfig iniPath
iniNLP <- IniNLP.readConfig iniPath
-- putStrLn (show ini :: Text)
connInfo <- Ini.readDBConfig iniPath
let c = convertConfigs ini iniMail iniNLP connInfo
-- putStrLn (show c :: Text)
putStrLn (show (Toml.encode c) :: Text)
iniCmd :: HasCallStack => Mod CommandFields CLI
iniCmd = command "ini" (info (helper <*> fmap CLISub ini_p) (progDesc "Parse .ini file and output a corresponding .toml file."))
ini_p :: Parser CLICmd
ini_p = fmap CCMD_ini $ IniArgs
<$> strOption ( long "ini-path"
<> help "Path to ini file" )
convertConfigs :: Ini.GargConfig -> IniMail.MailConfig -> IniNLP.NLPConfig -> PGS.ConnectInfo -> Config.GargConfig
convertConfigs ini@(Ini.GargConfig { .. }) iniMail nlpConfig connInfo =
Config.GargConfig { _gc_secrets = CTypes.SecretsConfig { _s_master_user = _gc_masteruser
, _s_secret_key = _gc_secretkey }
, _gc_datafilepath
, _gc_mail_config = iniMail
, _gc_nlp_config = nlpConfig
, _gc_frontend_config = mkFrontendConfig ini
, _gc_database_config = connInfo
, _gc_notifications_config = defaultNotificationsConfig
, _gc_frames = CTypes.FramesConfig { _f_write_url = _gc_frame_write_url
, _f_calc_url = _gc_frame_calc_url
, _f_visio_url = _gc_frame_visio_url
, _f_searx_url = _gc_frame_searx_url
, _f_istex_url = _gc_frame_istex_url }
, _gc_jobs = CTypes.JobsConfig { _jc_max_docs_parsers = _gc_max_docs_parsers
, _jc_max_docs_scrapers = _gc_max_docs_scrapers
, _jc_js_job_timeout = _gc_js_job_timeout
, _jc_js_id_timeout = _gc_js_id_timeout }
, _gc_apis = CTypes.APIsConfig { _ac_pubmed_api_key = _gc_pubmed_api_key
, _ac_epo_api_url = _gc_epo_api_url }
}
mkFrontendConfig :: Ini.GargConfig -> CTypes.FrontendConfig
mkFrontendConfig (Ini.GargConfig { .. }) =
CTypes.FrontendConfig { _fc_url = _gc_url
, _fc_backend_name = _gc_backend_name
, _fc_url_backend_api = _gc_url_backend_api
, _fc_jwt_settings = "TODO"
, _fc_cors
, _fc_microservices}
where
_fc_cors = CTypes.CORSSettings { _corsAllowedOrigins = [
toCORSOrigin "https://demo.gargantext.org"
, toCORSOrigin "https://formation.gargantext.org"
, toCORSOrigin "https://academia.sub.gargantext.org"
, toCORSOrigin "https://cnrs.gargantext.org"
, toCORSOrigin "https://imt.sub.gargantext.org"
, toCORSOrigin "https://helloword.gargantext.org"
, toCORSOrigin "https://complexsystems.gargantext.org"
, toCORSOrigin "https://europa.gargantext.org"
, toCORSOrigin "https://earth.sub.gargantext.org"
, toCORSOrigin "https://health.sub.gargantext.org"
, toCORSOrigin "https://msh.sub.gargantext.org"
, toCORSOrigin "https://dev.sub.gargantext.org"
, toCORSOrigin "http://localhost:8008"
, toCORSOrigin "http://localhost:8108"
, toCORSOrigin "http://localhost:3000"
]
, _corsAllowedHosts = []
, _corsUseOriginsForHosts = True }
_fc_microservices = CTypes.MicroServicesSettings { _msProxyPort = 8009
, _msProxyEnabled = False }
toCORSOrigin :: Text -> CTypes.CORSOrigin
toCORSOrigin url =
case parseBaseUrl (T.unpack url) of
Nothing -> panicTrace $ "Cannot parse base url for: " <> url
Just b -> CTypes.CORSOrigin b
defaultNotificationsConfig :: CTypes.NotificationsConfig
defaultNotificationsConfig =
CTypes.NotificationsConfig { _nc_central_exchange_bind = "tcp://*:5560"
, _nc_central_exchange_connect = "tcp://localhost:5560"
, _nc_dispatcher_bind = "tcp://*:5561"
, _nc_dispatcher_connect = "tcp://localhost:5561" }
......@@ -18,12 +18,13 @@ module CLI.Init where
import CLI.Parsers
import CLI.Types
import Data.List.NonEmpty qualified as NE
import Gargantext.API.Admin.Settings
import Gargantext.API.Admin.Types
import Gargantext.API.Dev (withDevEnv, runCmdDev)
import Gargantext.API.Errors.Types
import Gargantext.API.Node () -- instances only
import Gargantext.Core.Config (GargConfig(..), readConfig)
import Gargantext.Core.Config (GargConfig(..))
import Gargantext.Core.Config.Types (SecretsConfig(..))
import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.Core.Types.Individu (User(..), arbitraryNewUsers, NewUser(..), arbitraryUsername, GargPassword(..))
import Gargantext.Database.Action.Flow (getOrMkRoot, getOrMkRootWithCorpus)
import Gargantext.Database.Admin.Trigger.Init (initFirstTriggers, initLastTriggers)
......@@ -39,15 +40,15 @@ import Options.Applicative
initCLI :: InitArgs -> IO ()
initCLI (InitArgs iniPath settingsPath) = do
initCLI (InitArgs settingsPath) = do
putStrLn ("Enter master user (gargantua) _password_ :" :: Text)
password <- getLine
putStrLn ("Enter master user (gargantua) _email_ :" :: Text)
email <- getLine
cfg <- readConfig (_IniFile iniPath)
let secret = _gc_secretkey cfg
cfg <- readConfig settingsPath
let secret = _s_secret_key $ _gc_secrets cfg
let createUsers :: forall env. HasSettings env => DBCmd' env BackendInternalError Int64
createUsers = insertNewUsers (NewUser "gargantua" (cs email) (GargPassword $ cs password)
......@@ -69,7 +70,7 @@ initCLI (InitArgs iniPath settingsPath) = do
_triggers <- initLastTriggers masterListId
pure (masterUserId, masterRootId, masterCorpusId, masterListId)
withDevEnv iniPath settingsPath $ \env -> do
withDevEnv settingsPath $ \env -> do
_ <- runCmdDev env (initFirstTriggers secret :: DBCmd BackendInternalError [Int64])
_ <- runCmdDev env createUsers
x <- runCmdDev env initMaster
......@@ -81,4 +82,4 @@ initCmd = command "init" (info (helper <*> fmap CLISub init_p) (progDesc "Initia
init_p :: Parser CLICmd
init_p = fmap CCMD_init $ InitArgs
<$> ini_p <*> settings_p
<$> settings_p
......@@ -16,7 +16,6 @@ module CLI.Invitations where
import CLI.Parsers
import CLI.Types
import Gargantext.API.Admin.Settings
import Gargantext.API.Admin.Types
import Gargantext.API.Dev (withDevEnv, runCmdDev)
import Gargantext.API.Errors.Types
......@@ -24,7 +23,6 @@ import Gargantext.API.Node () -- instances only
import Gargantext.API.Node.Share qualified as Share
import Gargantext.API.Node.Share.Types qualified as Share
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET
import Gargantext.Core.Config (readConfig)
import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.Types
import Gargantext.Core.Types.Individu (User(..))
......@@ -34,8 +32,8 @@ import Options.Applicative
import Prelude (String)
invitationsCLI :: InvitationsArgs -> IO ()
invitationsCLI (InvitationsArgs iniPath settingsPath user node_id email) = do
_cfg <- readConfig (_IniFile iniPath)
invitationsCLI (InvitationsArgs settingsPath user node_id email) = do
-- _cfg <- readConfig settingsPath
let invite :: ( HasSettings env
, CmdRandom env BackendInternalError m
......@@ -43,7 +41,7 @@ invitationsCLI (InvitationsArgs iniPath settingsPath user node_id email) = do
, CET.HasCentralExchangeNotification env ) => m Int
invite = Share.api (UserName $ cs user) node_id (Share.ShareTeamParams $ cs email)
withDevEnv iniPath settingsPath $ \env -> do
withDevEnv settingsPath $ \env -> do
void $ runCmdDev env invite
invitationsCmd :: HasCallStack => Mod CommandFields CLI
......@@ -51,8 +49,7 @@ invitationsCmd = command "invitations" (info (helper <*> fmap CLISub invitations
invitations_p :: Parser CLICmd
invitations_p = fmap CCMD_invitations $ InvitationsArgs
<$> ini_p
<*> settings_p
<$> settings_p
<*> ( strOption ( long "user" ) )
<*> ( option (eitherReader node_p) ( long "node-id" <> metavar "POSITIVE-INT" <> help "The node ID.") )
<*> ( strOption ( long "email" <> help "The email address.") )
......
......@@ -4,19 +4,15 @@
module CLI.Parsers where
import Prelude
import Gargantext.API.Admin.Settings
import Gargantext.Core.Config.Types (SettingsFile(..))
import Options.Applicative
ini_p :: Parser IniFile
ini_p = maybe (IniFile "gargantext.ini") IniFile <$>
optional ( strOption ( long "ini-path"
<> metavar "FILEPATH"
<> help "Location of the .ini file"
) )
settings_p :: Parser SettingsFile
settings_p = maybe (SettingsFile "gargantext-settings.toml") SettingsFile <$>
optional ( strOption ( long "settings-path"
<> short 'c'
<> metavar "FILEPATH"
<> help "Location of the gargantext-settings toml file"
<> value "gargantext-settings.toml"
<> showDefault
<> help "Location of the gargantext-settings.toml file"
) )
......@@ -3,7 +3,7 @@ module CLI.Types where
import Data.String
import Data.Text (Text)
import Gargantext.API.Admin.Settings
import Gargantext.Core.Config.Types (SettingsFile(..))
import Gargantext.Core.Types (NodeId)
import Gargantext.Core.Types.Query
import Prelude
......@@ -26,8 +26,7 @@ data ObfuscateDBArgs = ObfuscateDBArgs {
} deriving (Show, Eq)
data AdminArgs = AdminArgs
{ iniPath :: !IniFile
, settingsPath :: !SettingsFile
{ settingsPath :: !SettingsFile
, emails :: [String]
} deriving (Show, Eq)
......@@ -41,20 +40,21 @@ data ImportArgs = ImportArgs
{ imp_function :: !ImportFunction
, imp_user :: !Text
, imp_name :: !Text
, imp_ini :: !IniFile
, imp_settings :: !SettingsFile
, imp_limit :: !Limit
, imp_corpus_path :: !FilePath
} deriving (Show, Eq)
data IniArgs = IniArgs
{ ini_path :: !FilePath
} deriving (Show, Eq)
data InitArgs = InitArgs
{ init_ini :: !IniFile
, init_settings :: !SettingsFile
{ init_settings :: !SettingsFile
} deriving (Show, Eq)
data InvitationsArgs = InvitationsArgs
{ inv_path :: !IniFile
, inv_settings :: !SettingsFile
{ inv_settings :: !SettingsFile
, inv_user :: !Text
, inv_node_id :: !NodeId
, inv_email :: !Text
......@@ -65,8 +65,7 @@ data PhyloArgs = PhyloArgs
} deriving (Show, Eq)
data UpgradeArgs = UpgradeArgs
{ upgrade_ini :: !IniFile
, upgrade_settings :: !SettingsFile
{ upgrade_settings :: !SettingsFile
} deriving (Show, Eq)
data GoldenFileDiffArgs = GoldenFileDiffArgs
......@@ -91,6 +90,7 @@ data CLICmd
| CCMD_obfuscate_db !ObfuscateDBArgs
| CCMD_admin !AdminArgs
| CCMD_import !ImportArgs
| CCMD_ini !IniArgs
| CCMD_init !InitArgs
| CCMD_invitations !InvitationsArgs
| CCMD_phylo !PhyloArgs
......
......@@ -19,16 +19,17 @@ module CLI.Upgrade where
import CLI.Types
import CLI.Parsers
import Data.List qualified as List (cycle, concat, take, unlines)
import Gargantext.API.Admin.Settings
import Gargantext.API.Dev (withDevEnv)
import Gargantext.API.Node () -- instances only
import Gargantext.Core.Config (GargConfig(..), readConfig)
import Gargantext.Core.Config (GargConfig(..))
import Gargantext.Core.Config.Types (SecretsConfig(..))
import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.Prelude
import Options.Applicative
import Prelude qualified
upgradeCLI :: UpgradeArgs -> IO ()
upgradeCLI (UpgradeArgs iniPath settingsFile) = do
upgradeCLI (UpgradeArgs settingsFile) = do
let ___ = putStrLn ((List.concat
$ List.take 72
......@@ -47,10 +48,10 @@ upgradeCLI (UpgradeArgs iniPath settingsFile) = do
_ok <- getLine
cfg <- readConfig (_IniFile iniPath)
let _secret = _gc_secretkey cfg
cfg <- readConfig settingsFile
let _secret = _s_secret_key $ _gc_secrets cfg
withDevEnv iniPath settingsFile $ \_env -> do
withDevEnv settingsFile $ \_env -> do
-- _ <- runCmdDev env addIndex
-- _ <- runCmdDev env refreshIndex
......@@ -97,5 +98,4 @@ upgradeCmd = command "upgrade" (info (helper <*> fmap CLISub upgrade_p) (progDes
upgrade_p :: Parser CLICmd
upgrade_p = fmap CCMD_upgrade $ UpgradeArgs
<$> ini_p
<*> settings_p
<$> settings_p
......@@ -26,6 +26,7 @@ import Options.Applicative
import CLI.Admin (adminCLI, adminCmd)
import CLI.FileDiff (fileDiffCLI, fileDiffCmd)
import CLI.Import (importCLI, importCmd)
import CLI.Ini (iniCLI, iniCmd)
import CLI.Init (initCLI, initCmd)
import CLI.Invitations (invitationsCLI, invitationsCmd)
import CLI.Phylo (phyloCLI, phyloCmd)
......@@ -46,6 +47,8 @@ runCLI = \case
-> adminCLI args
CLISub (CCMD_import args)
-> importCLI args
CLISub (CCMD_ini args)
-> iniCLI args
CLISub (CCMD_init args)
-> initCLI args
CLISub (CCMD_invitations args)
......@@ -78,6 +81,7 @@ allOptions = subparser (
obfuscateDBCmd <>
adminCmd <>
importCmd <>
iniCmd <>
initCmd <>
invitationsCmd <>
phyloCmd <>
......
......@@ -15,7 +15,7 @@ Script to start gargantext with different modes (Dev, Prod, Mock).
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- {-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeFamilies #-}
......@@ -28,10 +28,10 @@ import GHC.IO.Encoding
import Gargantext.API (startGargantext) -- , startGargantextMock)
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Settings
import Gargantext.Core.Config.Types (SettingsFile(..))
import Gargantext.Prelude
import Gargantext.System.Logging
import Options.Generic
import Prelude (String)
import System.Exit (exitSuccess)
import qualified Paths_gargantext as PG -- cabal magic build module
......@@ -45,9 +45,7 @@ data MyOptions w =
<?> "Possible modes: Dev | Mock | Prod"
, port :: w ::: Maybe Int
<?> "By default: 8008"
, ini :: w ::: Maybe Text
<?> "Ini-file path of gargantext.ini"
, settings :: w ::: Maybe String
, toml :: w ::: Maybe FilePath
<?> "By default: gargantext-settings.toml"
, version :: w ::: Bool
<?> "Show version number and exit"
......@@ -64,7 +62,7 @@ main = withLogger () $ \ioLogger -> do
setLocaleEncoding utf8
currentLocale <- getLocaleEncoding
MyOptions myMode myPort myIniFile mb_settingsFile myVersion <- unwrapRecord
MyOptions myMode myPort mb_tomlFile myVersion <- unwrapRecord
"Gargantext server"
---------------------------------------------------------------
if myVersion then do
......@@ -77,18 +75,14 @@ main = withLogger () $ \ioLogger -> do
Just p -> p
Nothing -> 8008
myIniFile' = case myIniFile of
Nothing -> panicTrace "[ERROR] gargantext.ini needed"
Just i -> IniFile $ unpack i
settingsFile = SettingsFile $ case mb_settingsFile of
tomlFile = SettingsFile $ case mb_tomlFile of
Nothing -> "gargantext-settings.toml"
Just i -> i
---------------------------------------------------------------
let start = case myMode of
Mock -> panicTrace "[ERROR] Mock mode unsupported"
_ -> startGargantext myMode myPort' myIniFile' settingsFile
_ -> startGargantext myMode myPort' tomlFile
logMsg ioLogger INFO $ "Starting with " <> show myMode <> " mode."
logMsg ioLogger INFO $ "Machine locale: " <> show currentLocale
start
......
......@@ -18,9 +18,8 @@ fi
# with the `sha256sum` result calculated on the `cabal.project` and
# `cabal.project.freeze`. This ensures the files stay deterministic so that CI
# cache can kick in.
expected_cabal_project_hash="9c487a789f77d9a96b4ac6a4b6268a075a72b8a391d987ba12194a46d96f6ee8"
expected_cabal_project_freeze_hash="50f3ccea242400c48bd9cec7286bd07c8223c87c043e09576dd5fef0949f982a"
expected_cabal_project_hash="ebcccf8bd6ad8ea5adad45f63c7c1eb2026439fe19bd06840d5d962e8ce05c38"
expected_cabal_project_freeze_hash="cd6fd302c204416ec84428dacab6d0e311a42ebd4b8db6227dcc57ccc8a6705a"
cabal --store-dir=$STORE_DIR v2-build --dry-run
......
......@@ -93,7 +93,7 @@ source-repository-package
source-repository-package
type: git
location: https://gitlab.iscpif.fr/gargantext/crawlers/hal.git
tag: 1dbd939257d33126e49d2679375553df1f2eebc5
tag: d54812d52c9d1f86d331a991b3a87c9a8b4379cf
source-repository-package
type: git
......@@ -165,10 +165,11 @@ source-repository-package
location: https://github.com/robstewart57/rdf4h.git
tag: 4fd2edf30c141600ffad6d730cc4c1c08a6dbce4
-- FIXME(adn) Compat-shim while we wait for upstream to catch-up
source-repository-package
type: git
location: https://github.com/garganscript/nanomsg-haskell
tag: 23be4130804d86979eaee5caffe323a1c7f2b0d6
tag: 5868db564d7d3c4568ccd11c852292b834d26c55
-- source-repository-package
-- type: git
......@@ -200,6 +201,11 @@ source-repository-package
location: https://gitlab.iscpif.fr/gargantext/haskell-throttle
tag: 02f5ed9ee2d6cce45161addf945b88bc6adf9059
source-repository-package
type: git
location: https://github.com/glguy/toml-parser
tag: toml-parser-2.0.1.0
allow-older: *
allow-newer: *
......
......@@ -487,7 +487,6 @@ constraints: any.Cabal ==3.8.1.0,
any.scientific ==0.3.7.0,
scientific -bytestring-builder -integer-simple,
any.securemem ==0.1.10,
any.selective ==0.7,
any.semialign ==1.3,
semialign +semigroupoids,
any.semigroupoids ==5.3.7,
......@@ -613,8 +612,7 @@ constraints: any.Cabal ==3.8.1.0,
any.tls ==1.6.0,
tls +compat -hans +network,
any.tmp-postgres ==1.34.1.0,
any.tomland ==1.3.3.2,
tomland -build-play-tomland -build-readme,
any.toml-parser ==2.0.1.0,
any.transformers ==0.5.6.2,
any.transformers-base ==0.4.6,
transformers-base +orphaninstances,
......@@ -650,7 +648,6 @@ constraints: any.Cabal ==3.8.1.0,
any.utility-ht ==0.0.17,
any.uuid ==1.3.15,
any.uuid-types ==1.0.5.1,
any.validation-selective ==0.2.0.0,
any.validity ==0.12.0.2,
any.vault ==0.3.1.5,
vault +useghc,
......
[frontend]
# Main url serving the FrontEnd
url = "http://localhost"
backend_name = "localhost"
# Main API url serving the BackEnd
url_backend_api = "http://localhost:8008/api/v1.0"
jwt_settings = "TODO"
[frontend.cors]
allowed-origins = [
"https://demo.gargantext.org"
, "https://formation.gargantext.org"
, "https://academia.sub.gargantext.org"
, "https://cnrs.gargantext.org"
, "https://imt.sub.gargantext.org"
, "https://helloword.gargantext.org"
, "https://complexsystems.gargantext.org"
, "https://europa.gargantext.org"
, "https://earth.sub.gargantext.org"
, "https://health.sub.gargantext.org"
, "https://msh.sub.gargantext.org"
, "https://dev.sub.gargantext.org"
, "http://localhost:8008"
, "http://localhost:8108"
, "http://localhost:3000"
]
use-origins-for-hosts = true
[frontend.microservices.proxy]
port = 8009
enabled = false
[secrets]
# Needed to instantiate the first users and first data
master_user = "gargantua"
# SECURITY WARNING: keep the secret key used in production secret!
# SECRET_KEY is the seed, from which hashes for passwords and hackmd
# frame_id seeds are computed.
secret_key = "something_speciaL"
[paths]
# Data path to local files
data_filepath = FILEPATH_TO_CHANGE
[apis]
[apis.pubmed]
api_key = ENTER_PUBMED_API_KEY
[apis.epo]
api_url = EPO_API_URL
[external]
[external.frames]
# FRAMES (i.e. iframe sources used in various places on the frontend)
#write_url = "http://write.frame.gargantext.org/"
write_url = URL_TO_CHANGE
#calc_url = "http://calc.frame.gargantext.org/"
calc_url = URL_TO_CHANGE
visio_url = URL_TO_CHANGE
searx_url = URL_TO_CHANGE
istex_url = URL_TO_CHANGE
[jobs]
#MAX_DOCS_PARSERS = 100
max_docs_parsers = 4000
max_docs_scrapers = 4000
# in seconds
js_job_timeout = 6000
js_id_timeout = 6000
[database]
# PostgreSQL access
host = "127.0.0.1"
port = 5432
name = "gargandbV5"
user = "gargantua"
pass = PASSWORD_TO_CHANGE
[logs]
log_file = "/var/log/gargantext/backend.log"
log_level = "LevelDebug"
log_formatter = "verbose"
[mail]
#port = 25
#host = localhost
#user = gargantext
#password =
#from =
# NoAuth | Normal | SSL | TLS | STARTTLS
#login_type = NoAuth
# Emails From address (sent by smtp)
mail_from = "username@gargantext.org"
smtp_host = "localhost"
# if remote smtp host
# HOST_USER = user
# HOST_password = password
[notifications]
central-exchange = { bind = "tcp://*:5560", connect = "tcp://localhost:5560" }
dispatcher = { bind = "tcp://*:5561", connect = "tcp://localhost:5561" }
[nlp]
# Possible choices (see Gargantext.Core.NLP):
# - spacy:// (for http:// Spacy)
# - spacys:// (for https:// Spacy)
# - corenlp:// (for http:// CoreNLP)
# - corenlps:// (for https:// CoreNLP)
# - johnsnow:// (for http:// JohnSnow)
# - johnsnows:// (for https:// JohnSnow)
EN = "spacy://localhost:8000"
FR = "spacy://localhost:8001"
......@@ -5,7 +5,7 @@ cabal-version: 3.4
-- see: https://github.com/sol/hpack
name: gargantext
version: 0.0.7.2
version: 0.0.7.2.1
synopsis: Search, map, share
description: Please see README.md
category: Data
......@@ -109,9 +109,6 @@ library
Gargantext.API.Admin.EnvTypes
Gargantext.API.Admin.Orchestrator.Types
Gargantext.API.Admin.Settings
Gargantext.API.Admin.Settings.CORS
Gargantext.API.Admin.Settings.MicroServices
Gargantext.API.Admin.Settings.TOML
Gargantext.API.Admin.Types
Gargantext.API.Auth.PolicyCheck
Gargantext.API.Count.Types
......@@ -171,15 +168,20 @@ library
Gargantext.Core.AsyncUpdates
Gargantext.Core.AsyncUpdates.CentralExchange
Gargantext.Core.AsyncUpdates.CentralExchange.Types
Gargantext.Core.AsyncUpdates.Constants
Gargantext.Core.AsyncUpdates.Dispatcher
Gargantext.Core.AsyncUpdates.Dispatcher.Subscriptions
Gargantext.Core.AsyncUpdates.Dispatcher.Types
Gargantext.Core.AsyncUpdates.Dispatcher.WebSocket
Gargantext.Core.AsyncUpdates.Nanomsg
Gargantext.Core.Config
Gargantext.Core.Config.Ini.Ini
Gargantext.Core.Config.Ini.Mail
Gargantext.Core.Config.Ini.NLP
Gargantext.Core.Config.Mail
Gargantext.Core.Config.NLP
Gargantext.Core.Config.Types
Gargantext.Core.Config.Utils
Gargantext.Core.Config.Worker
Gargantext.Core.Mail.Types
Gargantext.Core.Methods.Similarities
Gargantext.Core.Methods.Similarities.Conditional
......@@ -247,7 +249,6 @@ library
Gargantext.Core.Worker.Env
Gargantext.Core.Worker.Jobs
Gargantext.Core.Worker.Jobs.Types
Gargantext.Core.Worker.TOML
Gargantext.Database.Action.Flow
Gargantext.Database.Action.Flow.Types
Gargantext.Database.Action.Metrics.TFICF
......@@ -703,7 +704,7 @@ library
, transformers ^>= 0.5.6.2
, transformers-base ^>= 0.4.6
, tree-diff
, tomland >= 1.3.3.2
, toml-parser >= 2.0.1.0 && < 3
, tuple ^>= 0.3.0.2
, unordered-containers ^>= 0.2.16.0
, unicode-collation >= 0.1.3.6
......@@ -739,6 +740,7 @@ executable gargantext-cli
CLI.FileDiff
CLI.FilterTermsAndCooc
CLI.Import
CLI.Ini
CLI.Init
CLI.Invitations
CLI.ObfuscateDB
......@@ -777,15 +779,18 @@ executable gargantext-cli
, protolude ^>= 0.3.3
, servant
, servant-auth
, servant-client-core >= 0.18.3 && < 0.20
, servant-routes < 0.2
, servant-websockets >= 2.0.0 && < 2.1
, shelly
, split ^>= 0.2.3.4
, text ^>= 1.2.4.1
, time ^>= 1.9.3
, toml-parser >= 2.0.1.0 && < 3
, tree-diff
, unordered-containers ^>= 0.2.16.0
, vector ^>= 0.7.3
ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmissing-signatures -Wunused-binds -Wunused-imports -Werror -freduction-depth=300 -fprint-potential-instances
executable gargantext-server
import:
......@@ -809,27 +814,6 @@ executable gargantext-server
, text ^>= 1.2.4.1
, unordered-containers ^>= 0.2.16.0
, vector ^>= 0.7.3
executable gargantext-central-exchange
import:
defaults
main-is: Main.hs
other-modules:
Paths_gargantext
hs-source-dirs:
bin/gargantext-central-exchange
build-depends:
bytestring ^>= 0.10.12.0
, gargantext
, gargantext-prelude
, nanomsg-haskell >= 0.2.4 && < 0.3
-- , nng-haskell
, optparse-applicative >= 0.18.1.0 && < 0.19
, optparse-generic ^>= 1.4.7
, postgresql-simple ^>= 0.6.4
, text ^>= 1.2.4.1
, unordered-containers ^>= 0.2.16.0
, vector ^>= 0.7.3
common testDependencies
build-depends:
......@@ -892,7 +876,7 @@ common testDependencies
, split
, stm ^>= 2.5.0.1
, streaming-commons
, tasty ^>= 1.4.2.1
, tasty >= 1.5 && < 1.6
, tasty-golden
, tasty-hspec
, tasty-hunit
......@@ -916,7 +900,7 @@ common testDependencies
, shelly >= 1.9 && < 2
, stm ^>= 2.5.0.1
, streaming-commons
, tasty ^>= 1.4.2.1
, tasty >= 1.5 && < 1.6
, tasty-hspec
, tasty-hunit
, tasty-quickcheck
......@@ -1012,6 +996,7 @@ test-suite garg-test-hspec
Test.Database.Operations.NodeStory
Test.Database.Setup
Test.Database.Types
Test.Instances
Test.Server.ReverseProxy
Test.Types
Test.Utils
......
......@@ -44,17 +44,15 @@ import Data.Text.Encoding qualified as TE
import Data.Text.IO (putStrLn)
import Data.Validity
import Gargantext.API.Admin.Auth.Types (AuthContext)
import Gargantext.API.Admin.EnvTypes (Env, Mode(..))
import Gargantext.API.Admin.Settings (newEnv, IniFile(..), SettingsFile)
import Gargantext.API.Admin.Settings.CORS
import Gargantext.API.Admin.Settings.MicroServices
import Gargantext.API.Admin.EnvTypes (Env, Mode(..), _env_config)
import Gargantext.API.Admin.Settings (newEnv)
import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings, corsSettings, microservicesSettings)
import Gargantext.API.Middleware (logStdoutDevSanitised)
import Gargantext.API.Routes.Named (API)
import Gargantext.API.Routes.Named.EKG
import Gargantext.API.Server.Named (server)
-- import Gargantext.API.Server.Named.EKG
import Gargantext.Core.AsyncUpdates.Constants qualified as AUConstants
import Gargantext.Core.Config (_gc_notifications_config)
import Gargantext.Core.Config.Types (CORSOrigin(..), CORSSettings, NotificationsConfig(..), SettingsFile(..), corsAllowedOrigins, msProxyPort)
import Gargantext.Database.Prelude qualified as DB
import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp)
import Gargantext.Prelude hiding (putStrLn)
......@@ -72,12 +70,12 @@ import System.Cron.Schedule qualified as Cron
-- import System.FilePath
-- | startGargantext takes as parameters port number and Ini file.
startGargantext :: Mode -> PortNumber -> IniFile -> SettingsFile -> IO ()
startGargantext mode port iniFile settingsFile = withLoggerHoisted mode $ \logger -> do
env <- newEnv logger port iniFile settingsFile
startGargantext :: Mode -> PortNumber -> SettingsFile -> IO ()
startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerHoisted mode $ \logger -> do
env <- newEnv logger port sf
let proxyPort = env ^. settings.microservicesSettings.msProxyPort
runDbCheck env
portRouteInfo port proxyPort
portRouteInfo (_gc_notifications_config $ _env_config env) port proxyPort
app <- makeApp env
mid <- makeGargMiddleware (env ^. settings.corsSettings) mode
periodicActions <- schedulePeriodicActions env
......@@ -94,12 +92,12 @@ startGargantext mode port iniFile settingsFile = withLoggerHoisted mode $ \logge
case r of
Right True -> pure ()
_ -> panicTrace $
"You must run 'gargantext-init " <> pack (_IniFile iniFile) <>
"You must run 'gargantext-init " <> pack settingsFile <>
"' before running gargantext-server (only the first time)."
oneHour = Clock.fromNanoSecs 3600_000_000_000
portRouteInfo :: PortNumber -> PortNumber -> IO ()
portRouteInfo mainPort proxyPort = do
portRouteInfo :: NotificationsConfig -> PortNumber -> PortNumber -> IO ()
portRouteInfo nc mainPort proxyPort = do
putStrLn "=========================================================================================================="
putStrLn " GarganText Main Routes"
putStrLn "=========================================================================================================="
......@@ -107,8 +105,8 @@ portRouteInfo mainPort proxyPort = do
putStrLn $ " - Swagger UI (API documentation)...........: " <> "http://localhost:" <> toUrlPiece mainPort <> "/swagger-ui"
putStrLn $ " - Playground GraphQL (API documentation)...: " <> "http://localhost:" <> toUrlPiece mainPort <> "/gql"
putStrLn $ " - Microservices proxy .....................: " <> "http://localhost:" <> toUrlPiece proxyPort
putStrLn $ " - Central exchange.........................: " <> "nanomsg: " <> pack AUConstants.ceBind
putStrLn $ " - Dispatcher internal......................: " <> "nanomsg: " <> pack AUConstants.dispatcherBind
putStrLn $ " - Central exchange.........................: " <> "nanomsg: " <> _nc_central_exchange_bind nc
putStrLn $ " - Dispatcher internal......................: " <> "nanomsg: " <> _nc_dispatcher_bind nc
putStrLn $ " - WebSocket address........................: " <> "ws://localhost:" <> toUrlPiece mainPort <> "/ws"
putStrLn "=========================================================================================================="
......
......@@ -44,7 +44,8 @@ import Gargantext.API.Job
import Gargantext.API.Prelude (GargM, IsGargServer)
import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET
import Gargantext.Core.AsyncUpdates.Dispatcher.Types (Dispatcher, HasDispatcher(..))
import Gargantext.Core.AsyncUpdates.Dispatcher (Dispatcher)
import Gargantext.Core.AsyncUpdates.Dispatcher.Types (HasDispatcher(..))
import Gargantext.Core.Mail.Types (HasMail, mailSettings)
import Gargantext.Core.NLP (NLPServerMap, HasNLPServer(..))
import Gargantext.Core.NodeStory
......@@ -210,7 +211,7 @@ instance HasMail Env where
instance HasNLPServer Env where
nlpServer = env_nlp
instance HasDispatcher Env where
instance HasDispatcher Env Dispatcher where
hasDispatcher = env_dispatcher
instance Servant.Job.Core.HasEnv Env (Job JobLog JobLog) where
......@@ -223,7 +224,9 @@ instance Jobs.MonadJob (GargM Env err) GargJob (Seq JobLog) JobLog where
getJobEnv = asks (view env_jobs)
instance CET.HasCentralExchangeNotification Env where
ce_notify m = liftBase $ CE.notify m
ce_notify m = do
nc <- asks (view env_config)
liftBase $ CE.notify (_gc_notifications_config nc) m
-- | The /concrete/ 'JobHandle' in use with our 'GargM' (production) monad. Its
-- constructor it's not exported, to not leak internal details of its implementation.
......@@ -346,7 +349,9 @@ data DevEnv = DevEnv
makeLenses ''DevEnv
instance CET.HasCentralExchangeNotification DevEnv where
ce_notify m = liftBase $ CE.notify m
ce_notify m = do
nc <- asks (view dev_env_config)
liftBase $ CE.notify (_gc_notifications_config nc) m
-- | Our /mock/ job handle.
data DevJobHandle = DevJobHandle
......
......@@ -27,18 +27,17 @@ import Data.Pool (Pool)
import Data.Pool qualified as Pool
import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Settings.TOML (GargTomlSettings(..), loadGargTomlSettings)
import Gargantext.API.Admin.Types
import Gargantext.API.Errors.Types
import Gargantext.API.Prelude
import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
import Gargantext.Core.AsyncUpdates.Dispatcher qualified as D
import Gargantext.Core.Config (gc_js_job_timeout, gc_js_id_timeout, readConfig)
import Gargantext.Core.Config.Mail qualified as Mail
import Gargantext.Core.Config.NLP qualified as NLP
import Gargantext.Core.Config (GargConfig(..), gc_jobs)
import Gargantext.Core.Config.Types (SettingsFile(..), _fc_cors, _fc_microservices, jc_js_job_timeout, jc_js_id_timeout)
import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.Core.NLP (nlpServerMap)
import Gargantext.Core.NodeStory
import Gargantext.Database.Prelude (databaseParameters, hasConfig)
import Gargantext.Database.Prelude (hasConfig)
import Gargantext.Prelude
import Gargantext.System.Logging
import Gargantext.Utils.Jobs qualified as Jobs
......@@ -57,21 +56,21 @@ import System.IO.Temp (withTempFile)
newtype JwkFile = JwkFile { _JwkFile :: FilePath }
deriving (Show, Eq, IsString)
newtype SettingsFile = SettingsFile { _SettingsFile :: FilePath }
deriving (Show, Eq, IsString)
newtype IniFile = IniFile { _IniFile :: FilePath }
deriving (Show, Eq, IsString)
devSettings :: JwkFile -> SettingsFile -> IO Settings
devSettings (JwkFile jwkFile) (SettingsFile settingsFile) = do
devSettings (JwkFile jwkFile) settingsFile = do
jwkExists <- doesFileExist jwkFile
when (not jwkExists) $ writeKey jwkFile
jwk <- readKey jwkFile
GargTomlSettings{..} <- loadGargTomlSettings settingsFile
-- GargTomlSettings{..} <- loadGargTomlSettings settingsFile
gc@(GargConfig {}) <- readConfig settingsFile
pure $ Settings
{ _corsSettings = _gargCorsSettings
, _microservicesSettings = _gargMicroServicesSettings
{ -- _corsSettings = _gargCorsSettings
_corsSettings = _fc_cors $ _gc_frontend_config gc
-- , _microservicesSettings = _gargMicroServicesSettings
, _microservicesSettings = _fc_microservices $ _gc_frontend_config gc
, _appPort = 3000
, _logLevelLimit = LevelDebug
-- , _dbServer = "localhost"
......@@ -79,7 +78,7 @@ devSettings (JwkFile jwkFile) (SettingsFile settingsFile) = do
, _scrapydUrl = fromMaybe (panicTrace "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800"
, _cookieSettings = defaultCookieSettings { cookieXsrfSetting = Just xsrfCookieSetting } -- TODO-SECURITY tune
, _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune
, _workerSettings = _gargWorkerSettings
, _workerSettings = _gc_worker gc
}
where
xsrfCookieSetting = defaultXsrfCookieSettings { xsrfExcludeGet = True }
......@@ -186,35 +185,31 @@ readRepoEnv repoDir = do
devJwkFile :: JwkFile
devJwkFile = JwkFile "dev.jwk"
newEnv :: Logger (GargM Env BackendInternalError) -> PortNumber -> IniFile -> SettingsFile -> IO Env
newEnv logger port (IniFile file) settingsFile = do
newEnv :: Logger (GargM Env BackendInternalError) -> PortNumber -> SettingsFile -> IO Env
newEnv logger port settingsFile@(SettingsFile sf) = do
!manager_env <- newTlsManager
!settings' <- devSettings devJwkFile settingsFile <&> appPort .~ port -- TODO read from 'file'
when (port /= settings' ^. appPort) $
panicTrace "TODO: conflicting settings of port"
!config_env <- readConfig file
prios <- withLogger () $ \ioLogger -> Jobs.readPrios ioLogger (file <> ".jobs")
!config_env <- readConfig settingsFile
prios <- withLogger () $ \ioLogger -> Jobs.readPrios ioLogger (sf <> ".jobs")
let prios' = Jobs.applyPrios prios Jobs.defaultPrios
putStrLn ("Overrides: " <> show prios :: Text)
putStrLn ("New priorities: " <> show prios' :: Text)
!self_url_env <- parseBaseUrl $ "http://0.0.0.0:" <> show port
dbParam <- databaseParameters file
!pool <- newPool dbParam
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath config_env)
!pool <- newPool $ _gc_database_config config_env
!nodeStory_env <- fromDBNodeStoryEnv pool
!scrapers_env <- newJobEnv defaultSettings manager_env
secret <- Jobs.genSecret
let jobs_settings = (Jobs.defaultJobSettings 1 secret)
& Jobs.l_jsJobTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_job_timeout)
& Jobs.l_jsIDTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_id_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_env <- Jobs.newJobEnv jobs_settings prios' manager_env
!config_mail <- Mail.readConfig file
!nlp_env <- nlpServerMap <$> NLP.readConfig file
!central_exchange <- forkIO CE.gServer
!dispatcher <- D.dispatcher
!central_exchange <- forkIO $ CE.gServer (_gc_notifications_config config_env)
!dispatcher <- D.newDispatcher (_gc_notifications_config config_env)
{- An 'Env' by default doesn't have strict fields, but when constructing one in production
we want to force them to WHNF to avoid accumulating unnecessary thunks.
......@@ -229,8 +224,8 @@ newEnv logger port (IniFile file) settingsFile = do
, _env_jobs = jobs_env
, _env_self_url = self_url_env
, _env_config = config_env
, _env_mail = config_mail
, _env_nlp = nlp_env
, _env_mail = _gc_mail_config config_env
, _env_nlp = nlpServerMap $ _gc_nlp_config config_env
, _env_central_exchange = central_exchange
, _env_dispatcher = dispatcher
}
......
{--| Support in Gargantext for CORS (Cross-origin resource sharing) --}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module Gargantext.API.Admin.Settings.CORS where
import Prelude
import Control.Arrow
import Data.Text qualified as T
import Toml
import Control.Lens hiding (iso, (.=))
import Servant.Client.Core
import Data.Maybe (fromMaybe)
newtype CORSOrigin = CORSOrigin { _CORSOrigin :: BaseUrl }
deriving (Show, Eq)
data CORSSettings =
CORSSettings {
_corsAllowedOrigins :: [CORSOrigin]
, _corsAllowedHosts :: [CORSOrigin]
-- | If 'True', we will reuse the origin whitelist
-- as the allowed hosts as well. This allows, for example,
-- to connect from \"demo.gargantext.org\" to \"dev.sub.gargantext.org\"
-- and vice-versa.
, _corsUseOriginsForHosts :: !Bool
} deriving (Show, Eq)
corsOriginCodec :: TomlBiMap CORSOrigin AnyValue
corsOriginCodec = _Orig >>> _Text
where
_Orig :: BiMap e CORSOrigin T.Text
_Orig = iso (T.pack . showBaseUrl . _CORSOrigin)
(\(T.unpack -> u) -> CORSOrigin . fromMaybe (error $ "invalid origin: " <> u) . parseBaseUrl $ u)
corsSettingsCodec :: TomlCodec CORSSettings
corsSettingsCodec = CORSSettings
<$> Toml.arrayOf corsOriginCodec "allowed-origins" .= _corsAllowedOrigins
<*> pure mempty -- FIXME(adn) Currently we don't need to support this field.
<*> Toml.bool "use-origins-for-hosts" .= _corsUseOriginsForHosts
makeLenses ''CORSSettings
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.API.Admin.Settings.MicroServices where
import Prelude
import Control.Lens.TH
import Data.Text qualified as T
import Gargantext.Core.Config
import Servant.Client.Core.BaseUrl
import Toml
data MicroServicesSettings =
MicroServicesSettings {
-- | The port where the microservices proxy will be listening on.
_msProxyPort :: !Int
, _msProxyEnabled :: !Bool
} deriving (Show, Eq)
microServicesSettingsCodec :: TomlCodec MicroServicesSettings
microServicesSettingsCodec = MicroServicesSettings
<$> Toml.int "port" .= _msProxyPort
<*> Toml.bool "enabled" .= _msProxyEnabled
mkProxyUrl :: GargConfig -> MicroServicesSettings -> BaseUrl
mkProxyUrl GargConfig{..} MicroServicesSettings{..} =
case parseBaseUrl (T.unpack _gc_url) of
Nothing -> BaseUrl Http "localhost" 80 ""
Just bh -> bh { baseUrlPort = _msProxyPort }
makeLenses ''MicroServicesSettings
......@@ -5,9 +5,8 @@ module Gargantext.API.Admin.Types where
import Control.Lens
import Control.Monad.Logger (LogLevel)
import GHC.Enum
import Gargantext.API.Admin.Settings.CORS
import Gargantext.API.Admin.Settings.MicroServices
import Gargantext.Core.Worker.TOML
import Gargantext.Core.Config.Worker (WorkerSettings)
import Gargantext.Core.Config.Types
import Gargantext.Prelude
import Servant.Auth.Server (JWTSettings, CookieSettings(..))
import Servant.Client (BaseUrl)
......
......@@ -33,6 +33,7 @@ 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 Prelude
import Servant
import Servant.API.Routes
......@@ -139,7 +140,7 @@ check (AuthenticatedUser loggedUserNodeId loggedUserUserId) = \case
-> enforce err403 $ (loggedUserUserId == requestedUserId)
AC_master_user _requestedNodeId
-> do
masterUsername <- _gc_masteruser <$> view hasConfig
masterUsername <- _s_master_user . _gc_secrets <$> view hasConfig
masterNodeId <- getRootId (UserName masterUsername)
enforce err403 $ masterNodeId == loggedUserNodeId
AC_node_descendant nodeId
......
......@@ -17,54 +17,48 @@ import Control.Monad (fail)
import Data.Pool (withResource)
import Database.PostgreSQL.Simple qualified as PGS
import Gargantext.API.Admin.EnvTypes ( DevEnv(..), Mode(Dev) )
import Gargantext.API.Admin.Settings ( devJwkFile, devSettings, newPool, SettingsFile (..), IniFile (..) )
import Gargantext.API.Admin.Settings ( devJwkFile, devSettings, newPool )
import Gargantext.API.Errors.Types ( BackendInternalError )
import Gargantext.API.Prelude ( GargM )
import Gargantext.Core.Config (_gc_database_config, _gc_mail_config, _gc_nlp_config)
import Gargantext.Core.Config.Types (SettingsFile(..))
import Gargantext.Core.NLP (nlpServerMap)
import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
import Gargantext.Database.Prelude (Cmd', Cmd'', connPool, databaseParameters, runCmd)
import Gargantext.Database.Prelude (Cmd', Cmd'', connPool, runCmd)
import Gargantext.Prelude
import Gargantext.Core.Config (readConfig)
import Gargantext.Core.Config.Mail qualified as Mail
import Gargantext.Core.Config.NLP qualified as NLP
import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.System.Logging ( withLoggerHoisted )
import Servant ( ServerError )
-------------------------------------------------------------------
withDevEnv :: IniFile -> SettingsFile -> (DevEnv -> IO a) -> IO a
withDevEnv (IniFile iniPath) settingsFile k = withLoggerHoisted Dev $ \logger -> do
withDevEnv :: SettingsFile -> (DevEnv -> IO a) -> IO a
withDevEnv settingsFile k = withLoggerHoisted Dev $ \logger -> do
env <- newDevEnv logger
k env -- `finally` cleanEnv env
where
newDevEnv logger = do
cfg <- readConfig iniPath
dbParam <- databaseParameters iniPath
cfg <- readConfig settingsFile
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
pool <- newPool dbParam
pool <- newPool (_gc_database_config cfg)
nodeStory_env <- fromDBNodeStoryEnv pool
setts <- devSettings devJwkFile settingsFile
mail <- Mail.readConfig iniPath
nlp_config <- NLP.readConfig iniPath
pure $ DevEnv
{ _dev_env_pool = pool
, _dev_env_logger = logger
, _dev_env_nodeStory = nodeStory_env
, _dev_env_settings = setts
, _dev_env_config = cfg
, _dev_env_mail = mail
, _dev_env_nlp = nlpServerMap nlp_config
, _dev_env_mail = _gc_mail_config cfg
, _dev_env_nlp = nlpServerMap (_gc_nlp_config cfg)
}
defaultIniFile :: IniFile
defaultIniFile = IniFile "gargantext.ini"
defaultSettingsFile :: SettingsFile
defaultSettingsFile = SettingsFile "gargantext-settings.toml"
-- | Run Cmd Sugar for the Repl (GHCI)
runCmdRepl :: Show err => Cmd'' DevEnv err a -> IO a
runCmdRepl f = withDevEnv defaultIniFile defaultSettingsFile $ \env -> runCmdDev env f
runCmdRepl f = withDevEnv defaultSettingsFile $ \env -> runCmdDev env f
runCmdReplServantErr :: Cmd'' DevEnv ServerError a -> IO a
runCmdReplServantErr = runCmdRepl
......@@ -88,7 +82,7 @@ runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServerError a -> IO a
runCmdDevServantErr = runCmdDev
runCmdReplEasy :: Cmd'' DevEnv BackendInternalError a -> IO a
runCmdReplEasy f = withDevEnv defaultIniFile defaultSettingsFile $ \env -> runCmdDev env f
runCmdReplEasy f = withDevEnv defaultSettingsFile $ \env -> runCmdDev env f
-- | Execute a function that takes PSQL.Connection from the DB pool as
-- first parameter.
......
......@@ -28,6 +28,7 @@ import Data.Swagger ( ToSchema(..) )
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import EPO.API.Client.Types qualified as EPO
import Gargantext.API.Admin.Orchestrator.Types qualified as API
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.Ngrams (commitStatePatch, Versioned(..))
import Gargantext.API.Node.Corpus.New.Types ( FileFormat(..), FileType(..) )
......@@ -36,10 +37,11 @@ import Gargantext.API.Node.Corpus.Types ( Datafield(Web), database2origin )
import Gargantext.API.Node.Corpus.Update (addLanguageToCorpus)
import Gargantext.API.Node.Types
import Gargantext.Core (withDefaultLanguage, defaultLanguage)
import Gargantext.Core.Config (gc_jobs)
import Gargantext.Core.Config.Types (jc_max_docs_parsers)
import Gargantext.Core.NodeStory (HasNodeStoryImmediateSaver, HasNodeArchiveStoryImmediateSaver, currentVersion, NgramsStatePatch')
import Gargantext.API.Admin.Orchestrator.Types qualified as API
import Gargantext.Core.Text.Corpus.Query qualified as API
import Gargantext.Core.Text.Corpus.Parsers qualified as Parser (FileType(..), parseFormatC, _ParseFormatError)
import Gargantext.Core.Text.Corpus.Query qualified as API
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Action.Flow (flowCorpus, getDataText, flowDataText, TermType(..){-, allDataOrigins-})
......@@ -57,7 +59,6 @@ import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserNormalCorpusIds))
import Gargantext.Database.Schema.Node (node_hyperdata)
import Gargantext.Prelude
import Gargantext.Core.Config (gc_max_docs_parsers)
import Gargantext.System.Logging ( logLocM, LogLevel(..) )
import Gargantext.Utils.Jobs.Monad (JobHandle, MonadJobStatus(..))
......@@ -237,7 +238,7 @@ addToCorpusWithForm user cid nwf jobHandle = do
let l = nwf ^. wf_lang . non defaultLanguage
addLanguageToCorpus cid l
limit' <- view $ hasConfig . gc_max_docs_parsers
limit' <- view $ hasConfig . gc_jobs . jc_max_docs_parsers
let limit = fromIntegral limit' :: Integer
let
parseC = case (nwf ^. wf_filetype) of
......
......@@ -21,7 +21,10 @@ import Data.Text qualified as Text
import Data.Time.Calendar (Day, toGregorian)
import Data.Time.Format (defaultTimeLocale, formatTime, parseTimeM)
import Data.Tuple.Select (sel1, sel2, sel3)
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Config (GargConfig(..))
import Gargantext.Core.Config.Types (FramesConfig(..))
import Gargantext.Core.NLP (HasNLPServer, nlpServerGet)
import Gargantext.Core.NodeStory.Types ( HasNodeStory )
import Gargantext.Core.Text.Corpus.Query qualified as Query
......@@ -43,12 +46,11 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Tree.Error (HasTreeError)
import Gargantext.Database.Query.Tree.Root (getOrMkRootWithCorpus, MkCorpusUser (MkCorpusUserMaster))
import Gargantext.Prelude hiding (All)
import Gargantext.Core.Config (GargConfig(..))
import Gargantext.Utils.Jobs.Monad (JobHandle, MonadJobStatus(..))
import Network.HTTP.Client
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Prelude qualified
import Gargantext.API.Admin.Types (HasSettings)
langToSearx :: Lang -> Text
langToSearx x = Text.toLower acronym <> "-" <> acronym
......@@ -188,7 +190,7 @@ triggerSearxSearch user cId q l jobHandle = do
-- printDebug "[triggerSearxSearch] l" l
cfg <- view hasConfig
uId <- getUserId user
let surl = _gc_frame_searx_url cfg
let surl = _f_searx_url $ _gc_frames cfg
-- printDebug "[triggerSearxSearch] surl" surl
listId <- getOrMkList cId uId
......@@ -229,4 +231,5 @@ hyperdataDocumentFromSearxResult l (SearxResult { _sr_content, _sr_engine, _sr_p
, _hd_publication_hour = Nothing
, _hd_publication_minute = Nothing
, _hd_publication_second = Nothing
, _hd_language_iso2 = Just $ T.pack $ show l }
, _hd_language_iso2 = Just $ T.pack $ show l
, _hd_institutes_tree = Nothing}
......@@ -85,7 +85,8 @@ documentUpload nId doc = do
, _hd_publication_hour = Nothing
, _hd_publication_minute = Nothing
, _hd_publication_second = Nothing
, _hd_language_iso2 = Just $ view du_language doc }
, _hd_language_iso2 = Just $ view du_language doc
, _hd_institutes_tree = Nothing }
let lang = EN
ncs <- view $ nlpServerGet lang
......
......@@ -156,6 +156,7 @@ hyperdataDocumentFromFrameWrite lang paragraphSize (node, contents) =
, _hd_publication_hour = Nothing
, _hd_publication_minute = Nothing
, _hd_publication_second = Nothing
, _hd_language_iso2 = Just $ T.pack $ show lang }
, _hd_language_iso2 = Just $ T.pack $ show lang
, _hd_institutes_tree = Nothing }
) (text2titleParagraphs paragraphSize ctxts)
)
......@@ -10,7 +10,8 @@ import Data.Validity qualified as V
import Gargantext.API.Admin.Types (appPort, settings, Settings)
import Gargantext.API.Prelude
import Gargantext.API.Routes.Named.Share qualified as Named
import Gargantext.Core.Config (gc_url, GargConfig)
import Gargantext.Core.Config (GargConfig, gc_frontend_config)
import Gargantext.Core.Config.Types (fc_url)
import Gargantext.Core.Types (NodeType, NodeId, unNodeId, _ValidationError)
import Gargantext.Database.Prelude (HasConfig (hasConfig), CmdCommon)
import Gargantext.Prelude
......@@ -39,7 +40,7 @@ get_url :: Maybe NodeType
-> Settings
-> Either String Named.ShareLink
get_url nt id gc stgs = do
let urlHost = T.unpack $ gc ^. gc_url
let urlHost = T.unpack $ gc ^. gc_frontend_config . fc_url
let urlPort = stgs ^. appPort
t <- maybe (Left "Invalid node Type") Right nt
i <- maybe (Left "Invalid node ID") Right id
......
......@@ -31,12 +31,13 @@ import Gargantext.API.Node.Corpus.New qualified as New
import Gargantext.API.Prelude
import Gargantext.API.Routes.Named.Annuaire qualified as Named
import Gargantext.API.Routes.Named.Corpus qualified as Named
import Gargantext.Core.Config (gc_jobs)
import Gargantext.Core.Config.Types (jc_max_docs_scrapers)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Worker.Jobs qualified as Jobs
import Gargantext.Core.Worker.Jobs.Types qualified as Jobs
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Prelude (HasConfig(..))
import Gargantext.Prelude
import Gargantext.Core.Config (gc_max_docs_scrapers)
import Gargantext.Utils.Jobs (serveJobsAPI)
import Servant
import Servant.Auth.Swagger ()
......@@ -57,7 +58,7 @@ waitAPI n = do
addCorpusWithQuery :: User -> Named.AddWithQuery (AsServerT (GargM Env BackendInternalError))
addCorpusWithQuery user = Named.AddWithQuery $ \cid -> AsyncJobs $
serveJobsAPI AddCorpusQueryJob $ \jHandle q -> do
limit <- view $ hasConfig . gc_max_docs_scrapers
limit <- view $ hasConfig . gc_jobs . jc_max_docs_scrapers
New.addToCorpusWithQuery user cid q (Just $ fromIntegral limit) jHandle
{- let log' x = do
printDebug "addToCorpusWithQuery" x
......
......@@ -18,14 +18,15 @@ import Gargantext.API.Auth.PolicyCheck ()
import Gargantext.API.Errors
import Gargantext.API.GraphQL as GraphQL
import Gargantext.API.Prelude (GargM)
import Gargantext.API.Server.Named.Public (serverPublicGargAPI)
import Gargantext.API.Routes.Named
import Gargantext.API.Server.Named.Public (serverPublicGargAPI)
import Gargantext.API.Swagger (swaggerDoc)
import Gargantext.API.ThrowAll (serverPrivateGargAPI)
import Gargantext.Core.AsyncUpdates.Dispatcher.WebSocket qualified as Dispatcher
import Gargantext.Core.Config (gc_frontend_config)
import Gargantext.Core.Config.Types (fc_url_backend_api)
import Gargantext.Database.Prelude (hasConfig)
import Gargantext.Prelude hiding (Handler, catch)
import Gargantext.Core.Config (gc_url_backend_api)
import Gargantext.System.Logging (logLocM, LogLevel(..))
import Paths_gargantext qualified as PG -- cabal magic build module
import Servant
......@@ -40,7 +41,7 @@ serverGargAPI env
, gargForgotPasswordAsyncAPI = forgotPasswordAsync
, gargVersionAPI = gargVersion
, gargPrivateAPI = serverPrivateGargAPI
, gargPublicAPI = serverPublicGargAPI (env ^. hasConfig . gc_url_backend_api)
, gargPublicAPI = serverPublicGargAPI (env ^. hasConfig . gc_frontend_config . fc_url_backend_api)
}
where
gargVersion :: GargVersion (AsServerT (GargM Env BackendInternalError))
......
......@@ -14,17 +14,22 @@ https://dev.sub.gargantext.org/#/share/Notes/187918
-}
module Gargantext.Core.AsyncUpdates.CentralExchange where
module Gargantext.Core.AsyncUpdates.CentralExchange (
gServer
, notify
) where
import Control.Concurrent.Async qualified as Async
import Control.Concurrent.STM.TChan qualified as TChan
import Data.Aeson qualified as Aeson
import Data.ByteString.Lazy qualified as BSL
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Gargantext.Core.AsyncUpdates.CentralExchange.Types
import Gargantext.Core.AsyncUpdates.Constants (ceBind, ceConnect, dispatcherConnect)
import Gargantext.Core.Config.Types (NotificationsConfig(..))
import Gargantext.Prelude
import Gargantext.System.Logging (LogLevel(DEBUG), withLogger, logMsg)
import Nanomsg (Pull(..), Push(..), bind, connect, recvMalloc, send, withSocket)
import Gargantext.System.Logging (LogLevel(..), withLogger, logMsg)
import Nanomsg (Pull(..), Push(..), bind, connect, recv, sendNonblocking, withSocket)
{-
......@@ -39,12 +44,12 @@ with many users having updates.
-}
gServer :: IO ()
gServer = do
gServer :: NotificationsConfig -> IO ()
gServer (NotificationsConfig { .. }) = do
withSocket Pull $ \s -> do
withSocket Push $ \s_dispatcher -> do
_ <- bind s ceBind
_ <- connect s_dispatcher dispatcherConnect
_ <- bind s $ T.unpack _nc_central_exchange_bind
_ <- connect s_dispatcher $ T.unpack _nc_dispatcher_connect
tChan <- TChan.newTChanIO
......@@ -53,11 +58,13 @@ gServer = do
-- | the 'tChan' and calls Dispatcher accordingly. This is to
-- | make reading nanomsg as fast as possible.
void $ Async.concurrently (worker s_dispatcher tChan) $ do
forever $ do
-- putText "[central_exchange] receiving"
r <- recvMalloc s 1024
-- C.putStrLn $ "[central_exchange] " <> r
atomically $ TChan.writeTChan tChan r
withLogger () $ \ioLogger -> do
forever $ do
-- putText "[central_exchange] receiving"
r <- recv s
logMsg ioLogger INFO $ "[central_exchange] received: " <> show r
-- C.putStrLn $ "[central_exchange] " <> r
atomically $ TChan.writeTChan tChan r
where
worker s_dispatcher tChan = do
withLogger () $ \ioLogger -> do
......@@ -67,9 +74,9 @@ gServer = do
Just _ujp@(UpdateJobProgress _s) -> do
-- logMsg ioLogger DEBUG $ "[central_exchange] " <> show ujp
-- send the same message that we received
send s_dispatcher r
void $ sendNonblocking s_dispatcher r
Just (UpdateTreeFirstLevel node_id) -> do
logMsg ioLogger DEBUG $ "[central_exchange] update tree: " <> show node_id
logMsg ioLogger INFO $ "[central_exchange] update tree: " <> show node_id
-- putText $ "[central_exchange] sending that to the dispatcher: " <> show node_id
-- To make this more robust, use withAsync so we don't
-- block the main thread (send is blocking)
......@@ -85,14 +92,16 @@ gServer = do
-- gargantext-server but maybe it can be a separate
-- process, independent of the server.
-- send the same message that we received
send s_dispatcher r
void $ sendNonblocking s_dispatcher r
_ -> logMsg ioLogger DEBUG $ "[central_exchange] unknown message"
notify :: CEMessage -> IO ()
notify ceMessage = do
notify :: NotificationsConfig -> CEMessage -> IO ()
notify (NotificationsConfig { _nc_central_exchange_connect }) ceMessage = do
Async.withAsync (pure ()) $ \_ -> do
withSocket Push $ \s -> do
_ <- connect s ceConnect
_ <- connect s $ T.unpack _nc_central_exchange_connect
let str = Aeson.encode ceMessage
send s $ BSL.toStrict str
withLogger () $ \ioLogger ->
logMsg ioLogger INFO $ "[central_exchange] sending: " <> (T.unpack $ TE.decodeUtf8 $ BSL.toStrict str)
void $ sendNonblocking s $ BSL.toStrict str
{-|
Module : Gargantext.Core.AsyncUpdates.Constants
Description : Various constants
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
Docs:
https://dev.sub.gargantext.org/#/share/Notes/187918
-}
module Gargantext.Core.AsyncUpdates.Constants where
import Prelude qualified
-- NOTE IDP is fast and we're on local network so it shouldn't be a
-- problem with dropping packets. Otherwise, use TCP
-- https://nanomsg.org
-- | Bind address for central exchange (for tcp: tcp://*:5560)
ceBind :: Prelude.String
ceBind = "ipc:///tmp/central-exchange.ipc"
-- ceBind = "tcp://*:5560"
-- | Connect address for central exchange (for tcp: tcp://localhost:5560)
ceConnect :: Prelude.String
ceConnect = "ipc:///tmp/central-exchange.ipc"
-- ceConnect = "tcp://localhost:5560"
-- | Bind address for dispatcher (for tcp: tcp://*:5561)
dispatcherBind :: Prelude.String
dispatcherBind = "ipc:///tmp/dispatcher.ipc"
-- dispatcherBind = "tcp://*:5561"
-- | Connect address for dispatcher (for tcp: tcp://localhost:5561)
dispatcherConnect :: Prelude.String
dispatcherConnect = "ipc:///tmp/dispatcher.ipc"
-- dispatcherConnect = "tcp://localhost:5561"
......@@ -16,20 +16,28 @@ https://dev.sub.gargantext.org/#/share/Notes/187918
{-# LANGUAGE TypeOperators #-}
module Gargantext.Core.AsyncUpdates.Dispatcher where
module Gargantext.Core.AsyncUpdates.Dispatcher (
Dispatcher -- opaque
, newDispatcher
, terminateDispatcher
-- * Querying a dispatcher
, dispatcherSubscriptions
) where
import Control.Concurrent.Async qualified as Async
import Control.Concurrent.STM.TChan qualified as TChan
import Control.Concurrent.Throttle (throttle)
import Data.Aeson qualified as Aeson
import Data.ByteString.Lazy qualified as BSL
import Data.Text qualified as T
import DeferredFolds.UnfoldlM qualified as UnfoldlM
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CETypes
import Gargantext.Core.AsyncUpdates.Constants as AUConstants
import Gargantext.Core.AsyncUpdates.Dispatcher.Types
import Gargantext.Core.Config.Types (NotificationsConfig(..))
import Gargantext.Prelude
import Gargantext.System.Logging (LogLevel(DEBUG), withLogger, logMsg)
import Nanomsg (Pull(..), bind, recvMalloc, withSocket)
import Nanomsg (Pull(..), bind, recv, withSocket)
import Network.WebSockets qualified as WS
import Servant.Job.Types (JobStatus(_job_id))
import StmContainers.Set qualified as SSet
......@@ -42,15 +50,26 @@ Dispatcher is a service, which provides couple of functionalities:
- dispatches these messages to connected users
-}
dispatcher :: IO Dispatcher
dispatcher = do
data Dispatcher =
Dispatcher { d_subscriptions :: SSet.Set Subscription
-- , d_ws_server :: WSAPI AsServer
, d_ce_listener :: ThreadId
}
terminateDispatcher :: Dispatcher -> IO ()
terminateDispatcher = killThread . d_ce_listener
dispatcherSubscriptions :: Dispatcher -> SSet.Set Subscription
dispatcherSubscriptions = d_subscriptions
newDispatcher :: NotificationsConfig -> IO Dispatcher
newDispatcher nc = do
subscriptions <- SSet.newIO
-- let server = wsServer authSettings subscriptions
d_ce_listener <- forkIO (dispatcherListener subscriptions)
d_ce_listener <- forkIO (dispatcherListener nc subscriptions)
pure $ Dispatcher { d_subscriptions = subscriptions
-- , d_ws_server = server
......@@ -61,10 +80,10 @@ dispatcher = do
-- | This is a nanomsg socket listener. We want to read the messages
-- | as fast as possible and then process them gradually in a separate
-- | thread.
dispatcherListener :: SSet.Set Subscription -> IO ()
dispatcherListener subscriptions = do
dispatcherListener :: NotificationsConfig -> SSet.Set Subscription -> IO ()
dispatcherListener (NotificationsConfig { _nc_dispatcher_bind }) subscriptions = do
withSocket Pull $ \s -> do
_ <- bind s AUConstants.dispatcherBind
_ <- bind s $ T.unpack _nc_dispatcher_bind
tChan <- TChan.newTChanIO
......@@ -77,7 +96,7 @@ dispatcherListener subscriptions = do
void $ Async.concurrently (Async.replicateConcurrently 5 $ worker tChan throttleTChan) $ do
forever $ do
-- putText "[dispatcher_listener] receiving"
r <- recvMalloc s 1024
r <- recv s
-- C.putStrLn $ "[dispatcher_listener] " <> r
atomically $ TChan.writeTChan tChan r
where
......@@ -135,8 +154,8 @@ sendDataMessageThrottled (conn, msg) =
-- CETypes.CEMessage.
-- For example, we can add CEMessage.Broadcast to propagate a
-- notification to all connections.
filterCEMessageSubs :: CETypes.CEMessage -> [Subscription] -> [Subscription]
filterCEMessageSubs ceMessage subscriptions = filter (ceMessageSubPred ceMessage) subscriptions
_filterCEMessageSubs :: CETypes.CEMessage -> [Subscription] -> [Subscription]
_filterCEMessageSubs ceMessage subscriptions = filter (ceMessageSubPred ceMessage) subscriptions
ceMessageSubPred :: CETypes.CEMessage -> Subscription -> Bool
ceMessageSubPred (CETypes.UpdateJobProgress js) (Subscription { s_topic }) =
......
......@@ -34,7 +34,6 @@ import Gargantext.API.Admin.Orchestrator.Types (JobLog)
import Gargantext.API.Admin.Types (jwtSettings, Settings, jwtSettings)
import Gargantext.API.Prelude (IsGargServer)
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CETypes
import Gargantext.Core.AsyncUpdates.Constants as AUConstants
import Gargantext.Core.Types (NodeId, UserId)
import Gargantext.Prelude
import GHC.Conc (TVar, newTVarIO, readTVar, writeTVar)
......@@ -201,15 +200,8 @@ instance ToJSON WSRequest where
, "token" .= token ]
toJSON WSDeauthorize = Aeson.object [ "request" .= ( "deauthorize" :: Text ) ]
data Dispatcher =
Dispatcher { d_subscriptions :: SSet.Set Subscription
-- , d_ws_server :: WSAPI AsServer
, d_ce_listener :: ThreadId
}
class HasDispatcher env where
hasDispatcher :: Getter env Dispatcher
class HasDispatcher env dispatcher where
hasDispatcher :: Getter env dispatcher
-- | A notification is sent to clients who subscribed to specific topics
......
......@@ -27,6 +27,7 @@ import Gargantext.API.Admin.Types (HasSettings(settings), Settings, jwtSettings)
import Gargantext.API.Prelude (IsGargServer)
import Gargantext.Core.AsyncUpdates.Dispatcher.Subscriptions
import Gargantext.Core.AsyncUpdates.Dispatcher.Types
import Gargantext.Core.AsyncUpdates.Dispatcher (Dispatcher, dispatcherSubscriptions)
import Gargantext.Prelude
import Gargantext.System.Logging (LogLevel(DEBUG), logMsg, withLogger)
import Network.WebSockets qualified as WS
......@@ -42,15 +43,15 @@ newtype WSAPI mode = WSAPI {
} deriving Generic
wsServer :: ( IsGargServer env err m, HasDispatcher env, HasSettings env ) => WSAPI (AsServerT m)
wsServer :: ( IsGargServer env err m, HasDispatcher env Dispatcher, HasSettings env ) => WSAPI (AsServerT m)
wsServer = WSAPI { wsAPIServer = streamData }
where
streamData :: ( IsGargServer env err m, HasDispatcher env, HasSettings env )
streamData :: ( IsGargServer env err m, HasDispatcher env Dispatcher, HasSettings env )
=> WS.PendingConnection -> m ()
streamData pc = do
authSettings <- view settings
d <- view hasDispatcher
let subscriptions = d_subscriptions d
let subscriptions = dispatcherSubscriptions d
key <- getWSKey pc
c <- liftBase $ WS.acceptRequest pc
let ws = WSKeyConnection (key, c)
......
......@@ -18,109 +18,99 @@ module Gargantext.Core.Config (
GargConfig(..)
-- * Lenses
, gc_backend_name
, gc_datafilepath
, gc_epo_api_url
, gc_frame_calc_url
, gc_frame_istex_url
, gc_frame_searx_url
, gc_frame_visio_url
, gc_frame_write_url
, gc_js_id_timeout
, gc_js_job_timeout
, gc_masteruser
, gc_max_docs_parsers
, gc_max_docs_scrapers
, gc_pubmed_api_key
, gc_repofilepath
, gc_secretkey
, gc_url
, gc_url_backend_api
-- * Utility functions
, readIniFile'
, readConfig
, val
, gc_frontend_config
, gc_mail_config
, gc_database_config
, gc_nlp_config
, gc_notifications_config
, gc_frames
, gc_jobs
, gc_secrets
, gc_apis
, gc_worker
, mkProxyUrl
) where
import Data.Ini (readIniFile, lookupValue, Ini)
import Data.Text as T
import Prelude (read)
import Database.PostgreSQL.Simple qualified as PSQL
import Gargantext.Core.Config.Mail (MailConfig)
import Gargantext.Core.Config.NLP (NLPConfig)
import Gargantext.Core.Config.Worker (WorkerSettings)
import Gargantext.Core.Config.Types
import Gargantext.Prelude
import Servant.Client (BaseUrl(..), Scheme(Http), parseBaseUrl)
import Toml.Schema
-- | strip a given character from end of string
stripRight :: Char -> T.Text -> T.Text
stripRight c s = if T.last s == c then stripRight c (T.take (T.length s - 1) s) else s
data GargConfig = GargConfig { _gc_backend_name :: !T.Text
, _gc_url :: !T.Text
, _gc_url_backend_api :: !T.Text
, _gc_masteruser :: !T.Text
, _gc_secretkey :: !T.Text
, _gc_datafilepath :: !FilePath
, _gc_repofilepath :: !FilePath
, _gc_frame_write_url :: !T.Text
, _gc_frame_calc_url :: !T.Text
, _gc_frame_visio_url :: !T.Text
, _gc_frame_searx_url :: !T.Text
, _gc_frame_istex_url :: !T.Text
, _gc_max_docs_parsers :: !Integer
, _gc_max_docs_scrapers :: !Integer
, _gc_pubmed_api_key :: !T.Text
, _gc_js_job_timeout :: !Integer
, _gc_js_id_timeout :: !Integer
, _gc_epo_api_url :: !T.Text
-- stripRight :: Char -> T.Text -> T.Text
-- stripRight c s = if T.last s == c then stripRight c (T.take (T.length s - 1) s) else s
data GargConfig = GargConfig { _gc_datafilepath :: !FilePath
-- , _gc_repofilepath :: !FilePath
, _gc_frontend_config :: !FrontendConfig
, _gc_mail_config :: !MailConfig
, _gc_database_config :: !PSQL.ConnectInfo
, _gc_nlp_config :: !NLPConfig
, _gc_notifications_config :: !NotificationsConfig
, _gc_frames :: !FramesConfig
, _gc_jobs :: !JobsConfig
, _gc_secrets :: !SecretsConfig
, _gc_apis :: !APIsConfig
, _gc_worker :: !WorkerSettings
}
deriving (Generic, Show)
makeLenses ''GargConfig
readIniFile' :: FilePath -> IO Ini
readIniFile' fp = do
ini <- readIniFile fp
case ini of
Left e -> panicTrace $ T.pack $ "ini file not found " <> show e
Right ini' -> pure ini'
val :: Ini -> Text -> Text -> Text
val ini section key = do
case (lookupValue section key ini) of
Left e -> panicTrace $ "ERROR: add " <> key <> " in section \"" <> section <> "\" to your gargantext.ini. " <> show e
Right p' -> p'
readConfig :: FilePath -> IO GargConfig
readConfig fp = do
ini <- readIniFile' fp
let val' = val ini "gargantext"
pure $ GargConfig
{ _gc_backend_name = cs $ val' "BACKEND_NAME"
, _gc_url = stripRight '/' $ val' "URL"
, _gc_url_backend_api = stripRight '/' $ val' "URL_BACKEND_API"
, _gc_masteruser = val' "MASTER_USER"
, _gc_secretkey = val' "SECRET_KEY"
, _gc_datafilepath = cs $ val' "DATA_FILEPATH"
, _gc_repofilepath = cs $ val' "REPO_FILEPATH"
, _gc_frame_write_url = stripRight '/' $ val' "FRAME_WRITE_URL"
, _gc_frame_calc_url = stripRight '/' $ val' "FRAME_CALC_URL"
, _gc_frame_visio_url = stripRight '/' $ val' "FRAME_VISIO_URL"
, _gc_frame_searx_url = stripRight '/' $ val' "FRAME_SEARX_URL"
, _gc_frame_istex_url = stripRight '/' $ val' "FRAME_ISTEX_URL"
, _gc_max_docs_parsers = read $ cs $ val' "MAX_DOCS_PARSERS"
, _gc_max_docs_scrapers = read $ cs $ val' "MAX_DOCS_SCRAPERS"
, _gc_pubmed_api_key = val' "PUBMED_API_KEY"
, _gc_js_job_timeout = read $ cs $ val' "JS_JOB_TIMEOUT"
, _gc_js_id_timeout = read $ cs $ val' "JS_ID_TIMEOUT"
, _gc_epo_api_url = cs $ val' "EPO_API_URL"
}
instance FromValue GargConfig where
fromValue = parseTableFromValue $ do
_gc_frontend_config <- reqKey "frontend"
_gc_mail_config <- reqKey "mail"
db_config <- reqKey "database"
_gc_nlp_config <- reqKey "nlp"
_gc_secrets <- reqKey "secrets"
_gc_datafilepath <- reqKeyOf "paths" $ parseTableFromValue $ reqKey "data_filepath"
_gc_frames <- reqKeyOf "external" $ parseTableFromValue $ reqKey "frames"
_gc_jobs <- reqKey "jobs"
_gc_apis <- reqKey "apis"
_gc_notifications_config <- reqKey "notifications"
_gc_worker <- reqKey "worker"
return $ GargConfig { _gc_datafilepath
, _gc_jobs
, _gc_apis
, _gc_frontend_config
, _gc_mail_config
, _gc_database_config = unTOMLConnectInfo db_config
, _gc_nlp_config
, _gc_notifications_config
, _gc_frames
, _gc_secrets
, _gc_worker }
instance ToValue GargConfig where
toValue = defaultTableToValue
instance ToTable GargConfig where
toTable (GargConfig { .. }) =
table [ "frontend" .= _gc_frontend_config
, "secrets" .= _gc_secrets
, "paths" .= table [ "data_filepath" .= _gc_datafilepath ]
, "apis" .= _gc_apis
, "external" .= table [ "frames" .= _gc_frames ]
, "jobs" .= _gc_jobs
, "database" .= TOMLConnectInfo _gc_database_config
, "mail" .= _gc_mail_config
, "notifications" .= _gc_notifications_config
, "nlp" .= _gc_nlp_config
-- TODO
-- , "worker" .= _gc_worker
]
mkProxyUrl :: GargConfig -> MicroServicesSettings -> BaseUrl
mkProxyUrl GargConfig{..} MicroServicesSettings{..} =
case parseBaseUrl (T.unpack $ _fc_url _gc_frontend_config) of
Nothing -> BaseUrl Http "localhost" 80 ""
Just bh -> bh { baseUrlPort = _msProxyPort }
{-|
Module : Gargantext.Core.Config.Ini.Ini
Description : Textmining Collaborative Platform
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Configuration for the gargantext server
-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Core.Config.Ini.Ini (
-- * Types
GargConfig(..)
-- * Lenses
, gc_backend_name
, gc_datafilepath
, gc_epo_api_url
, gc_frame_calc_url
, gc_frame_istex_url
, gc_frame_searx_url
, gc_frame_visio_url
, gc_frame_write_url
, gc_js_id_timeout
, gc_js_job_timeout
, gc_masteruser
, gc_max_docs_parsers
, gc_max_docs_scrapers
, gc_pubmed_api_key
, gc_repofilepath
, gc_secretkey
, gc_url
, gc_url_backend_api
-- * Utility functions
, readIniFile'
, readConfig
, val
, readDBConfig
) where
import Data.Ini (readIniFile, lookupValue, Ini)
import Data.Text as T
import Database.PostgreSQL.Simple qualified as PGS
import Prelude (read)
import Gargantext.Prelude
-- | strip a given character from end of string
stripRight :: Char -> T.Text -> T.Text
stripRight c s = if T.last s == c then stripRight c (T.take (T.length s - 1) s) else s
data GargConfig = GargConfig { _gc_backend_name :: !T.Text
, _gc_url :: !T.Text
, _gc_url_backend_api :: !T.Text
, _gc_masteruser :: !T.Text
, _gc_secretkey :: !T.Text
, _gc_datafilepath :: !FilePath
, _gc_repofilepath :: !FilePath
, _gc_frame_write_url :: !T.Text
, _gc_frame_calc_url :: !T.Text
, _gc_frame_visio_url :: !T.Text
, _gc_frame_searx_url :: !T.Text
, _gc_frame_istex_url :: !T.Text
, _gc_max_docs_parsers :: !Integer
, _gc_max_docs_scrapers :: !Integer
, _gc_pubmed_api_key :: !T.Text
, _gc_js_job_timeout :: !Integer
, _gc_js_id_timeout :: !Integer
, _gc_epo_api_url :: !T.Text
}
deriving (Generic, Show)
makeLenses ''GargConfig
readIniFile' :: FilePath -> IO Ini
readIniFile' fp = do
ini <- readIniFile fp
case ini of
Left e -> panicTrace $ T.pack $ "ini file not found " <> show e
Right ini' -> pure ini'
val :: Ini -> Text -> Text -> Text
val ini section key = do
case (lookupValue section key ini) of
Left e -> panicTrace $ "ERROR: add " <> key <> " in section \"" <> section <> "\" to your gargantext.ini. " <> show e
Right p' -> p'
readConfig :: FilePath -> IO GargConfig
readConfig fp = do
ini <- readIniFile' fp
let val' = val ini "gargantext"
pure $ GargConfig
{ _gc_backend_name = cs $ val' "BACKEND_NAME"
, _gc_url = stripRight '/' $ val' "URL"
, _gc_url_backend_api = stripRight '/' $ val' "URL_BACKEND_API"
, _gc_masteruser = val' "MASTER_USER"
, _gc_secretkey = val' "SECRET_KEY"
, _gc_datafilepath = cs $ val' "DATA_FILEPATH"
, _gc_repofilepath = cs $ val' "REPO_FILEPATH"
, _gc_frame_write_url = stripRight '/' $ val' "FRAME_WRITE_URL"
, _gc_frame_calc_url = stripRight '/' $ val' "FRAME_CALC_URL"
, _gc_frame_visio_url = stripRight '/' $ val' "FRAME_VISIO_URL"
, _gc_frame_searx_url = stripRight '/' $ val' "FRAME_SEARX_URL"
, _gc_frame_istex_url = stripRight '/' $ val' "FRAME_ISTEX_URL"
, _gc_max_docs_parsers = read $ cs $ val' "MAX_DOCS_PARSERS"
, _gc_max_docs_scrapers = read $ cs $ val' "MAX_DOCS_SCRAPERS"
, _gc_pubmed_api_key = val' "PUBMED_API_KEY"
, _gc_js_job_timeout = read $ cs $ val' "JS_JOB_TIMEOUT"
, _gc_js_id_timeout = read $ cs $ val' "JS_ID_TIMEOUT"
, _gc_epo_api_url = cs $ val' "EPO_API_URL"
}
readDBConfig :: FilePath -> IO PGS.ConnectInfo
readDBConfig fp = do
ini <- readIniFile' fp
let val' = val ini "database"
let dbPortRaw = val' "DB_PORT"
let dbPort =
case (readMaybe dbPortRaw :: Maybe Word16) of
Nothing -> panicTrace $ "DB_PORT incorrect: " <> dbPortRaw
Just d -> d
pure $ PGS.ConnectInfo { PGS.connectHost = cs $ val' "DB_HOST"
, PGS.connectPort = dbPort
, PGS.connectUser = cs $ val' "DB_USER"
, PGS.connectPassword = cs $ val' "DB_PASS"
, PGS.connectDatabase = cs $ val' "DB_NAME" }
{-|
Module : Gargantext.Core.Config.Ini.Mail
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Core.Config.Ini.Mail (
-- * Types
GargMail(..)
, LoginType(..)
, MailConfig(..)
-- * Utility functions
, gargMail
, readConfig
-- * Lenses
, mc_mail_from
, mc_mail_host
, mc_mail_login_type
, mc_mail_password
, mc_mail_port
, mc_mail_user
)
where
import Data.Maybe
import Data.Text (unpack)
import Gargantext.Core.Config.Ini.Ini (readIniFile', val)
import Gargantext.Core.Config.Mail (LoginType(..), MailConfig(..))
import Gargantext.Prelude
import Network.Mail.Mime (plainPart)
import Network.Mail.SMTP hiding (htmlPart, STARTTLS)
import Prelude (read)
type Email = Text
type Name = Text
readConfig :: FilePath -> IO MailConfig
readConfig fp = do
ini <- readIniFile' fp
let val' = val ini "mail"
pure $ MailConfig { _mc_mail_host = cs $ val' "MAIL_HOST"
, _mc_mail_port = read $ cs $ val' "MAIL_PORT"
, _mc_mail_user = cs $ val' "MAIL_USER"
, _mc_mail_from = cs $ val' "MAIL_FROM"
, _mc_mail_password = cs $ val' "MAIL_PASSWORD"
, _mc_mail_login_type = read $ cs $ val' "MAIL_LOGIN_TYPE"
}
data GargMail = GargMail { gm_to :: Email
, gm_name :: Maybe Name
, gm_subject :: Text
, gm_body :: Text
}
-- | TODO add parameters to gargantext.ini
gargMail :: MailConfig -> GargMail -> IO ()
gargMail (MailConfig {..}) (GargMail { .. }) = do
let host = unpack _mc_mail_host
user = unpack _mc_mail_user
password = unpack _mc_mail_password
case _mc_mail_login_type of
NoAuth -> sendMail host mail
Normal -> sendMailWithLogin' host _mc_mail_port user password mail
SSL -> sendMailWithLoginTLS' host _mc_mail_port user password mail
TLS -> sendMailWithLoginTLS' host _mc_mail_port user password mail
STARTTLS -> sendMailWithLoginSTARTTLS' host _mc_mail_port user password mail
where
mail = simpleMail sender receiver cc bcc gm_subject [plainPart $ cs gm_body]
sender = Address (Just "GarganText Email") _mc_mail_from
receiver = [Address gm_name gm_to]
cc = []
bcc = []
makeLenses ''MailConfig
{-|
Module : Gargantext.Core.Config.Ini.NLP
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Core.Config.Ini.NLP (
-- * Types
NLPConfig(..)
-- * Utility functions
, readConfig
-- * Lenses
, nlp_default
, nlp_languages
)
where
import Data.Ini qualified as Ini
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Text qualified as T
import Gargantext.Core.Config.Ini.Ini (readIniFile', val)
import Gargantext.Core.Config.NLP (NLPConfig(..))
import Gargantext.Prelude
import Gargantext.Prelude.Utils (listToMaybeAll)
import Network.URI (parseURI)
iniSection :: Text
iniSection = "nlp"
readConfig :: FilePath -> IO NLPConfig
readConfig fp = do
ini <- readIniFile' fp
let val' = val ini iniSection
let lang_default_text = "EN" -- Change this value by one of your choice: "All", "FR", or "EN"
let m_nlp_default = parseURI $ cs $ val' lang_default_text
let m_nlp_keys = filter (\k -> k `notElem` [lang_default_text]) $ fromRight [] $ Ini.keys iniSection ini
let m_nlp_other = listToMaybeAll $ (\k -> (,) k <$> (parseURI $ cs $ val' k)) <$> m_nlp_keys
let mRet = NLPConfig <$> m_nlp_default <*> (Map.fromList <$> m_nlp_other)
case mRet of
Nothing -> panicTrace $ T.concat [ "Cannot read config file: _nlp_default = "
, T.pack $ show m_nlp_default
, ", _nlp_other = "
, T.pack $ show m_nlp_other ]
Just ret -> pure ret
makeLenses ''NLPConfig
......@@ -19,7 +19,6 @@ module Gargantext.Core.Config.Mail (
-- * Utility functions
, gargMail
, readConfig
-- * Lenses
, mc_mail_from
......@@ -31,15 +30,16 @@ module Gargantext.Core.Config.Mail (
)
where
import Control.Monad.Fail (fail)
import Data.Maybe
import Data.Text (unpack)
import Data.Text qualified as T
import Gargantext.Core.Config (readIniFile', val)
import Gargantext.Prelude
import Network.Mail.Mime (plainPart)
import Network.Mail.SMTP hiding (htmlPart, STARTTLS)
import Network.Socket (PortNumber)
import Prelude (read)
import Toml
import Toml.Schema
type Email = Text
......@@ -48,6 +48,19 @@ type Name = Text
data LoginType = NoAuth | Normal | SSL | TLS | STARTTLS
deriving (Generic, Eq, Show, Read)
instance FromValue LoginType where
fromValue (Toml.Text' _ t) =
case t of
"NoAuth" -> return NoAuth
"Normal" -> return Normal
"SSL" -> return SSL
"TLS" -> return TLS
"STARTTLS" -> return STARTTLS
_ -> fail ("Cannot parse login type from " <> T.unpack t)
fromValue _ = fail ("Expected text for login type")
instance ToValue LoginType where
toValue v = toValue (show v :: Text)
data MailConfig = MailConfig { _mc_mail_host :: !T.Text
, _mc_mail_port :: !PortNumber
, _mc_mail_user :: !T.Text
......@@ -56,19 +69,50 @@ data MailConfig = MailConfig { _mc_mail_host :: !T.Text
, _mc_mail_from :: !T.Text
}
deriving (Generic, Show)
readConfig :: FilePath -> IO MailConfig
readConfig fp = do
ini <- readIniFile' fp
let val' = val ini "mail"
pure $ MailConfig { _mc_mail_host = cs $ val' "MAIL_HOST"
, _mc_mail_port = read $ cs $ val' "MAIL_PORT"
, _mc_mail_user = cs $ val' "MAIL_USER"
, _mc_mail_from = cs $ val' "MAIL_FROM"
, _mc_mail_password = cs $ val' "MAIL_PASSWORD"
, _mc_mail_login_type = read $ cs $ val' "MAIL_LOGIN_TYPE"
}
instance FromValue MailConfig where
fromValue = parseTableFromValue $ do
_mc_mail_host <- reqKey "host"
port <- reqKey "port" :: ParseTable l Int
_mc_mail_user <- reqKey "user"
_mc_mail_password <- reqKey "password"
_mc_mail_login_type <- reqKey "login_type"
_mc_mail_from <- reqKey "from"
return $ MailConfig { _mc_mail_port = fromIntegral port, .. }
instance ToValue MailConfig where
toValue = defaultTableToValue
instance ToTable MailConfig where
toTable (MailConfig { .. }) = table [ "port" .= (fromIntegral _mc_mail_port :: Int)
, "host" .= _mc_mail_host
, "user" .= _mc_mail_user
, "password" .= _mc_mail_password
, "from" .= _mc_mail_from
, "login_type" .= _mc_mail_login_type ]
-- readConfig :: SettingsFile -> IO MailConfig
-- readConfig (SettingsFile fp) = do
-- eRes <- Toml.decodeFileEither mailCodec fp
-- case eRes of
-- Left err -> panicTrace ("Error reading TOML file (mail): " <> show err :: Text)
-- Right config -> return config
-- mailCodec :: Toml.TomlCodec MailConfig
-- mailCodec = MailConfig
-- <$> Toml.text "mail.host" .= _mc_mail_host
-- <*> Toml.read "mail.port" .= _mc_mail_port
-- <*> Toml.text "mail.user" .= _mc_mail_user
-- <*> Toml.text "mail.password" .= _mc_mail_password
-- <*> Toml.read "mail.login_type" .= _mc_mail_login_type
-- <*> Toml.text "mail.from" .= _mc_mail_from
-- pure $ MailConfig { _mc_mail_host = cs $ val' "MAIL_HOST"
-- , _mc_mail_port = read $ cs $ val' "MAIL_PORT"
-- , _mc_mail_user = cs $ val' "MAIL_USER"
-- , _mc_mail_from = cs $ val' "MAIL_FROM"
-- , _mc_mail_password = cs $ val' "MAIL_PASSWORD"
-- , _mc_mail_login_type = read $ cs $ val' "MAIL_LOGIN_TYPE"
-- }
data GargMail = GargMail { gm_to :: Email
......
......@@ -9,15 +9,13 @@ Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- orphan 'FromValue URI' instance
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Core.Config.NLP (
-- * Types
NLPConfig(..)
-- * Utility functions
, readConfig
-- * Lenses
, nlp_default
, nlp_languages
......@@ -25,41 +23,73 @@ module Gargantext.Core.Config.NLP (
)
where
import Data.Ini qualified as Ini
import Control.Monad.Fail (fail)
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Text qualified as T
import Gargantext.Core.Config (readIniFile', val)
import Gargantext.Prelude
import Gargantext.Prelude.Utils (listToMaybeAll)
import Network.URI (URI)
import Network.URI (parseURI)
import Network.URI (URI, parseURI)
import Toml
import Toml.Schema
instance FromValue URI where
fromValue (Toml.Text' _ t) =
case parseURI (T.unpack t) of
Nothing -> fail ("Cannot parse URI " <> T.unpack t)
Just uri -> return uri
fromValue _ = fail ("Expected text for URI")
instance ToValue URI where
toValue v = toValue (show v :: Text)
data NLPConfig = NLPConfig { _nlp_default :: URI
, _nlp_languages :: (Map.Map T.Text URI) }
, _nlp_languages :: Map.Map T.Text URI }
deriving (Generic, Show)
iniSection :: Text
iniSection = "nlp"
instance FromValue NLPConfig where
fromValue v = do
_nlp_default <- parseTableFromValue (reqKey "EN") v
-- _nlp_languages <- fromValue <$> getTable
MkTable t <- parseTableFromValue getTable v
_nlp_languages <- mapM fromValue (snd <$> t)
return $ NLPConfig { .. }
instance ToValue NLPConfig where
toValue = defaultTableToValue
instance ToTable NLPConfig where
toTable (NLPConfig { .. }) =
table [ k .= v | (k, v) <- Map.toList _nlp_languages ]
-- readConfig :: SettingsFile -> IO NLPConfig
-- readConfig (SettingsFile fp) = do
-- eRes <- Toml.decodeFileEither nlpCodec fp
-- case eRes of
-- Left err -> panicTrace ("Error reading TOML file (nlp): " <> show err)
-- Right config -> return config
-- nlpCodec :: Toml.TomlCodec NLPConfig
-- nlpCodec = NLPConfig
-- <$> uriToml "nlp.EN" .= _nlp_default
-- <*> Toml.tableMap Toml._KeyText uriToml "nlp" .= _nlp_languages
readConfig :: FilePath -> IO NLPConfig
readConfig fp = do
ini <- readIniFile' fp
let val' = val ini iniSection
let lang_default_text = "EN" -- Change this value by one of your choice: "All", "FR", or "EN"
-- readConfig :: FilePath -> IO NLPConfig
-- readConfig fp = do
-- ini <- readIniFile' fp
-- let val' = val ini iniSection
-- let lang_default_text = "EN" -- Change this value by one of your choice: "All", "FR", or "EN"
let m_nlp_default = parseURI $ cs $ val' lang_default_text
-- let m_nlp_default = parseURI $ cs $ val' lang_default_text
let m_nlp_keys = filter (\k -> k `notElem` [lang_default_text]) $ fromRight [] $ Ini.keys iniSection ini
let m_nlp_other = listToMaybeAll $ (\k -> (,) k <$> (parseURI $ cs $ val' k)) <$> m_nlp_keys
-- let m_nlp_keys = filter (\k -> k `notElem` [lang_default_text]) $ fromRight [] $ Ini.keys iniSection ini
-- let m_nlp_other = listToMaybeAll $ (\k -> (,) k <$> (parseURI $ cs $ val' k)) <$> m_nlp_keys
let mRet = NLPConfig <$> m_nlp_default <*> (Map.fromList <$> m_nlp_other)
-- let mRet = NLPConfig <$> m_nlp_default <*> (Map.fromList <$> m_nlp_other)
case mRet of
Nothing -> panicTrace $ T.concat [ "Cannot read config file: _nlp_default = "
, T.pack $ show m_nlp_default
, ", _nlp_other = "
, T.pack $ show m_nlp_other ]
Just ret -> pure ret
-- case mRet of
-- Nothing -> panicTrace $ T.concat [ "Cannot read config file: _nlp_default = "
-- , T.pack $ show m_nlp_default
-- , ", _nlp_other = "
-- , T.pack $ show m_nlp_other ]
-- Just ret -> pure ret
makeLenses ''NLPConfig
This diff is collapsed.
{-|
Module : Gargantext.Core.Config.Utils
Description :
Copyright : (c) CNRS, 2024-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
module Gargantext.Core.Config.Utils (
readConfig
)
where
import Gargantext.Core.Config.Types (SettingsFile(..))
import Gargantext.Prelude
-- import Network.URI (URI)
-- import Network.URI (parseURI)
import Toml
import Toml.Schema
readConfig :: FromValue a => SettingsFile -> IO a
readConfig (SettingsFile fp) = do
c <- readFile fp
case decode c of
Failure err -> panicTrace ("Error reading TOML file: " <> show err)
Success _ r -> return r
-- _URI :: Toml.TomlBiMap URI Text
-- _URI = Toml.BiMap (Right . show) parseURI'
-- where
-- parseURI' :: Text -> Either Toml.TomlBiMapError URI
-- parseURI' t =
-- case parseURI (T.unpack t) of
-- Nothing -> Left $ Toml.ArbitraryError "Cannot parse URI"
-- Just u -> Right u
-- uriToml :: Toml.Key -> Toml.TomlCodec URI
-- uriToml = Toml.match (_URI >>> Toml._Text)
-- _Word16 :: Toml.TomlBiMap Word16 Toml.AnyValue
-- _Word16 = Toml._BoundedInteger >>> Toml._Integer
-- word16Toml :: Toml.Key -> Toml.TomlCodec Word16
-- word16Toml = Toml.match _Word16
......@@ -15,12 +15,13 @@ import Control.Lens (view)
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.List qualified as List
import Data.Text (splitOn)
import Gargantext.Core.Config (gc_frontend_config)
import Gargantext.Core.Config.Types (fc_url, fc_backend_name)
import Gargantext.Core.Config.Mail (gargMail, GargMail(..), MailConfig)
import Gargantext.Core.Types.Individu
import Gargantext.Database.Prelude (HasConfig(..))
import Gargantext.Database.Schema.User (UserLight(..))
import Gargantext.Prelude
import Gargantext.Core.Config (gc_url, gc_backend_name)
import Gargantext.Core.Config.Mail (gargMail, GargMail(..), MailConfig)
import Network.URI.Encode (encodeText)
......@@ -74,7 +75,8 @@ mail mailCfg model = do
let
(m,u) = email_to model
subject = email_subject model
body = emailWith (ServerAddress (view gc_backend_name cfg) (view gc_url cfg)) model
body = emailWith (ServerAddress (view (gc_frontend_config . fc_backend_name) cfg)
(view (gc_frontend_config . fc_url) cfg)) model
liftBase $ gargMail mailCfg (GargMail { gm_to = m
, gm_name = Just u
, gm_subject = subject
......
......@@ -68,3 +68,4 @@ nlpServerMap (NLPConfig { .. }) =
((\lang ->
uncurryMaybeSecond (lang, Map.lookup (show lang) _nlp_languages >>= nlpServerConfigFromURI ))
<$> allLangs)
......@@ -119,7 +119,8 @@ toDoc l (Arxiv.Result { abstract
, _hd_publication_hour = Nothing
, _hd_publication_minute = Nothing
, _hd_publication_second = Nothing
, _hd_language_iso2 = Just $ (Text.pack . show) l }
, _hd_language_iso2 = Just $ (Text.pack . show) l
, _hd_institutes_tree = Nothing }
where
authors :: [Ax.Author] -> Maybe Text
authors [] = Nothing
......
......@@ -61,7 +61,8 @@ toDoc lang (EPO.HyperdataDocument { .. }) =
, _hd_publication_hour = Nothing
, _hd_publication_minute = Nothing
, _hd_publication_second = Nothing
, _hd_language_iso2 = Just $ iso639ToText lang }
, _hd_language_iso2 = Just $ iso639ToText lang
, _hd_institutes_tree = Nothing }
where
authors_ = if null authors
......
......@@ -53,7 +53,7 @@ toDoc' la (HAL.Document { .. }) = do
, _hd_page = Nothing
, _hd_title = Just $ unwords _document_title
, _hd_authors = Just $ foldl' (\x y -> if x == "" then y else x <> ", " <> y) "" _document_authors_names
, _hd_institutes = Just $ foldl' (\x y -> if x == "" then y else x <> ", " <> y) "" $ _document_authors_affiliations <> map show _document_struct_id
, _hd_institutes = Just $ foldl' (\x y -> if x == "" then y else x <> ", " <> y) "" $ zipWith (\affialition structId -> affialition <> " | " <> structId) _document_authors_affiliations $ map show _document_struct_id
, _hd_source = Just $ maybe "Nothing" identity _document_source
, _hd_abstract = Just abstract
, _hd_publication_date = fmap show utctime
......@@ -63,4 +63,5 @@ toDoc' la (HAL.Document { .. }) = do
, _hd_publication_hour = Nothing
, _hd_publication_minute = Nothing
, _hd_publication_second = Nothing
, _hd_language_iso2 = Just $ show la }
, _hd_language_iso2 = Just $ show la
, _hd_institutes_tree = Just _document_institutes_tree }
......@@ -94,4 +94,5 @@ isidoreToDoc lang (IsidoreDoc t a d u s as) = do
, _hd_publication_minute = Nothing
, _hd_publication_second = Nothing
, _hd_language_iso2 = Just . Text.pack . show $ lang
, _hd_institutes_tree = Nothing
}
......@@ -50,7 +50,8 @@ toDoc (OA.Work { .. } ) =
, _hd_publication_hour = Nothing -- TODO
, _hd_publication_minute = Nothing -- TODO
, _hd_publication_second = Nothing -- TODO
, _hd_language_iso2 = language }
, _hd_language_iso2 = language
, _hd_institutes_tree = Nothing }
where
firstPage :: OA.Biblio -> Maybe Int
firstPage OA.Biblio { first_page } = (readMaybe . T.unpack) =<< first_page
......
......@@ -131,7 +131,8 @@ toDoc l (PubMedDoc.PubMed { pubmed_article = PubMedDoc.PubMedArticle t j as aus
, _hd_publication_hour = Nothing
, _hd_publication_minute = Nothing
, _hd_publication_second = Nothing
, _hd_language_iso2 = Just $ (Text.pack . show) l }
, _hd_language_iso2 = Just $ (Text.pack . show) l
, _hd_institutes_tree = Nothing }
where
authors :: [PubMedDoc.Author] -> Maybe Text
authors [] = Nothing
......
......@@ -267,7 +267,8 @@ toDoc ff d = do
, _hd_publication_hour = Nothing
, _hd_publication_minute = Nothing
, _hd_publication_second = Nothing
, _hd_language_iso2 = Just $ (DT.pack . show) lang }
, _hd_language_iso2 = Just $ (DT.pack . show) lang
, _hd_institutes_tree = Nothing }
-- printDebug "[G.C.T.C.Parsers] HyperdataDocument" hd
pure hd
......
......@@ -95,6 +95,7 @@ publiToHyperdata y (Publi a s t txt) =
, _hd_publication_minute = Nothing
, _hd_publication_second = Nothing
, _hd_language_iso2 = Just $ DT.pack $ show FR
, _hd_institutes_tree = Nothing
}
-------------------------------------------------------------
......
......@@ -56,6 +56,7 @@ gitlabIssue2hyperdataDocument issue = HyperdataDocument
, _hd_publication_minute = Just (todMin tod)
, _hd_publication_second = Just (round $ todSec tod)
, _hd_language_iso2 = Just $ (DT.pack . show) lang
, _hd_institutes_tree = Nothing
}
where lang = EN
date = _issue_created issue
......
......@@ -89,7 +89,8 @@ instance ToHyperdataDocument GrandDebatReference
, _hd_publication_hour = Nothing
, _hd_publication_minute = Nothing
, _hd_publication_second = Nothing
, _hd_language_iso2 = Just $ Text.pack $ show FR }
, _hd_language_iso2 = Just $ Text.pack $ show FR
, _hd_institutes_tree = Nothing }
where
toAbstract = Text.intercalate " . " . (filter (/= "") . map toSentence)
toSentence (GrandDebatResponse _id _qtitle _qvalue r) = case r of
......
......@@ -135,6 +135,7 @@ bind2doc l [ link', date, langDoc, authors, _source, publisher, title, abstract
, _hd_publication_hour = Nothing
, _hd_publication_minute = Nothing
, _hd_publication_second = Nothing
, _hd_language_iso2 = unbound l langDoc }
, _hd_language_iso2 = unbound l langDoc
, _hd_institutes_tree = Nothing }
bind2doc _ _ = undefined
......@@ -50,5 +50,6 @@ toDoc la (ISTEX.Document i t a ab d s) = do
, _hd_publication_minute = Nothing
, _hd_publication_second = Nothing
, _hd_language_iso2 = Just $ (T.pack . show) la
, _hd_institutes_tree = Nothing
}
......@@ -75,7 +75,8 @@ toDoc (TsvGargV3 did dt _ dpy dpm dpd dab dau) =
, _hd_publication_hour = Nothing
, _hd_publication_minute = Nothing
, _hd_publication_second = Nothing
, _hd_language_iso2 = Nothing }
, _hd_language_iso2 = Nothing
, _hd_institutes_tree = Nothing }
---------------------------------------------------------------
-- | Types Conversions
......@@ -537,7 +538,8 @@ tsvHal2doc (TsvHal { .. }) =
, _hd_publication_hour = Nothing
, _hd_publication_minute = Nothing
, _hd_publication_second = Nothing
, _hd_language_iso2 = Nothing }
, _hd_language_iso2 = Nothing
, _hd_institutes_tree = Nothing }
tsv2doc :: TsvDoc -> HyperdataDocument
......@@ -560,7 +562,8 @@ tsv2doc (TsvDoc { .. })
, _hd_publication_hour = Nothing
, _hd_publication_minute = Nothing
, _hd_publication_second = Nothing
, _hd_language_iso2 = Nothing }
, _hd_language_iso2 = Nothing
, _hd_institutes_tree = Nothing }
where
pubYear = fromMIntOrDec defaultYear tsv_publication_year
pubMonth = fromMaybe defaultMonth tsv_publication_month
......@@ -588,9 +591,9 @@ parseTsv' bs = (V.toList . V.map tsv2doc . snd) <$> readTsvLazyBS Comma bs
parseTsv' :: BL.ByteString -> Either Text [HyperdataDocument]
parseTsv' bs = do
let
result = case readTsvLazyBS Comma bs of
Left _err -> readTsvLazyBS Tab bs
Right res -> Right res
result = case (testCorrectFile bs) of
Left _err -> Left _err
Right del -> readTsvLazyBS del bs
V.toList . V.map tsv2doc . snd <$> result
parseTsvC :: BL.ByteString
......@@ -598,9 +601,9 @@ parseTsvC :: BL.ByteString
parseTsvC bs =
(\(_h, rs) -> (fromIntegral $ V.length rs, yieldMany rs .| mapC tsv2doc)) <$> eResult
where
eResult = case readTsvLazyBS Comma bs of
Left _err -> readTsvLazyBS Tab bs
Right res -> Right res
eResult = case (testCorrectFile bs) of
Left _err -> Left _err
Right del -> readTsvLazyBS del bs
------------------------------------------------------------------------
-- Tsv v3 weighted for phylo
......
......@@ -93,7 +93,8 @@ wikiPageToDocument m wr = do
, _hd_publication_hour = hour
, _hd_publication_minute = minute
, _hd_publication_second = sec
, _hd_language_iso2 = iso2 }
, _hd_language_iso2 = iso2
, _hd_institutes_tree = Nothing }
wikidataSelect :: Int -> IO [WikiResult]
......
......@@ -28,7 +28,7 @@ import Gargantext.API.Ngrams.Types (NgramsElement, NgramsTerm(..))
import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.NodeStory.Types ( HasNodeStory )
import Gargantext.Core.Text (size)
import Gargantext.Core.Text.List.Group ( toGroupedTree, setScoresWithMap )
import Gargantext.Core.Text.List.Group ( toGroupedTree, setScoresWithMap, toGroupedTreeInstitutes )
import Gargantext.Core.Text.List.Group.Prelude
import Gargantext.Core.Text.List.Group.WithStem
import Gargantext.Core.Text.List.Social ( FlowSocialListWith, flowSocialList )
......@@ -38,7 +38,7 @@ import Gargantext.Core.Text.Ngrams (NgramsType(..), Ngrams(..))
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Types.Main ( ListType(..) )
import Gargantext.Data.HashMap.Strict.Utils qualified as HashMap
import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsUser, getContextsByNgramsOnlyUser)
import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsUser, getContextsByNgramsOnlyUser, getTreeInstitutesUser)
import Gargantext.Database.Action.Metrics.TFICF (getTficf_withSample)
import Gargantext.Database.Admin.Types.Node ( MasterCorpusId, UserCorpusId, ContextId )
import Gargantext.Database.Prelude (DBCmd)
......@@ -77,18 +77,64 @@ buildNgramsLists :: ( HasNodeStory env err m
-> m (Map NgramsType [NgramsElement])
buildNgramsLists user uCid mCid mfslw gp = do
ngTerms <- buildNgramsTermsList user uCid mCid mfslw gp (NgramsTerms, MapListSize goodMapListSize)
instTerms <- buildNgramsInstList user uCid mfslw GroupIdentity (Institutes, MapListSize 300, MaxListSize 1000)
othersTerms <- mapM (buildNgramsOthersList user uCid mfslw GroupIdentity)
[ (Authors , MapListSize 9, MaxListSize 1000)
, (Sources , MapListSize 9, MaxListSize 1000)
, (Institutes, MapListSize 9, MaxListSize 1000)
]
pure $ Map.unions $ [ngTerms] <> othersTerms
pure $ Map.unions $ [ngTerms] <> othersTerms <> [instTerms]
newtype MapListSize = MapListSize { unMapListSize :: Int }
newtype MaxListSize = MaxListSize { unMaxListSize :: Int }
buildNgramsInstList :: ( HasNodeError err
, HasNLPServer env
, HasNodeStory env err m
, HasTreeError err
)
=> User
-> UserCorpusId
-> Maybe FlowSocialListWith
-> GroupParams
-> (NgramsType, MapListSize, MaxListSize)
-> m (Map NgramsType [NgramsElement])
buildNgramsInstList user uCid mfslw _groupParams (nt, MapListSize mapListSize, MaxListSize maxListSize) = do
allTerms :: HashMap NgramsTerm (Set ContextId) <- getContextsByNgramsUser uCid nt
institutesTree :: HashMap Text [Text] <- getTreeInstitutesUser uCid nt
-- PrivateFirst for first developments since Public NodeMode is not implemented yet
socialLists :: FlowCont NgramsTerm FlowListScores
<- flowSocialList mfslw user nt ( FlowCont HashMap.empty
$ HashMap.fromList
$ List.zip (HashMap.keys allTerms)
(repeat mempty)
)
let
groupedWithList = toGroupedTreeInstitutes {- groupParams -} socialLists allTerms institutesTree
(stopTerms, tailTerms) = HashMap.partition ((== Just StopTerm) . viewListType)
$ view flc_scores groupedWithList
(mapTerms, tailTerms') = HashMap.partition ((== Just MapTerm) . viewListType) tailTerms
listSize = mapListSize - List.length mapTerms
(mapTerms', candiTerms) = both HashMap.fromList
$ List.splitAt listSize
$ List.take maxListSize
$ List.sortOn (Down . viewScore . snd)
$ HashMap.toList tailTerms'
pure $ Map.fromList [( nt, List.take maxListSize $ toNgramsElement stopTerms
<> toNgramsElement mapTerms
<> toNgramsElement (setListType (Just MapTerm ) mapTerms')
<> toNgramsElement (setListType (Just CandidateTerm) candiTerms)
)]
buildNgramsOthersList :: ( HasNodeError err
, HasNLPServer env
, HasNodeStory env err m
......
......@@ -20,20 +20,29 @@ import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Gargantext.API.Ngrams.Types (NgramsTerm(..))
import Gargantext.Core.Text.List.Group.Prelude
import Gargantext.Core.Text.List.Group.WithScores ( groupWithScores' )
import Gargantext.Core.Text.List.Group.WithScores ( groupWithScores', groupWithScoresInstitutes' )
import Gargantext.Core.Text.List.Social.Prelude ( FlowListScores, FlowCont )
import Gargantext.Prelude
------------------------------------------------------------------------
toGroupedTree :: (Ord a, Monoid a, HasSize a)
=> FlowCont NgramsTerm FlowListScores
-> HashMap NgramsTerm a
-> FlowCont NgramsTerm (GroupedTreeScores a)
-> FlowCont NgramsTerm (GroupedTreeScores a) -- a = (Set ContextId)
toGroupedTree flc scores =
groupWithScores' flc scoring
where
scoring t = fromMaybe mempty $ HashMap.lookup t scores
toGroupedTreeInstitutes :: (Ord a, Monoid a, HasSize a)
=> FlowCont NgramsTerm FlowListScores
-> HashMap NgramsTerm a
-> HashMap Text [Text]
-> FlowCont NgramsTerm (GroupedTreeScores a) -- a = (Set ContextId)
toGroupedTreeInstitutes flc scores institutesTree =
groupWithScoresInstitutes' flc scoring institutesTree
where
scoring t = fromMaybe mempty $ HashMap.lookup t scores
------------------------------------------------------------------------
setScoresWithMap :: (Ord a, Ord b, Monoid b) => HashMap NgramsTerm b
-> HashMap NgramsTerm (GroupedTreeScores a)
......
......@@ -40,7 +40,23 @@ groupWithScores' flc scores = FlowCont groups orphans
-- orphans should be filtered already then becomes empty
orphans = mempty
groupWithScoresInstitutes':: (Eq a, Ord a, Monoid a, HasSize a)
=> FlowCont NgramsTerm FlowListScores
-> (NgramsTerm -> a)
-> HashMap Text [Text]
-> FlowCont NgramsTerm (GroupedTreeScores a)
groupWithScoresInstitutes' flc scores institutesTree = FlowCont (groups institutesTree) orphans
where
-- parent/child relation is inherited from social lists
groups institutesTree' = HashMap.filter ((0 <) . viewScore)
$ toGroupedTreeInstitutes' institutesTree'
$ toMapMaybeParent scores
$ view flc_scores flc <> view flc_cont flc
-- orphans should be filtered already then becomes empty
orphans = mempty
------------------------------------------------------------------------
toMapMaybeParent :: (Eq a, Ord a, Monoid a)
......@@ -72,6 +88,14 @@ toGroupedTree' m = case HashMap.lookup Nothing m of
Nothing -> mempty
Just m' -> toGroupedTree'' m m'
toGroupedTreeInstitutes' :: Eq a
=> HashMap Text [Text]
-> HashMap (Maybe Parent) (HashMap NgramsTerm (GroupedTreeScores a))
-> HashMap Parent (GroupedTreeScores a)
toGroupedTreeInstitutes' institutesTree m = case HashMap.lookup Nothing m of
Nothing -> mempty
Just m' -> toGroupedTreeInstitutes'' m m' institutesTree
filterGroupedTree :: (GroupedTreeScores a -> Bool)
-> HashMap Parent (GroupedTreeScores a)
-> HashMap Parent (GroupedTreeScores a)
......@@ -93,3 +117,40 @@ toGroupedTree'' m notEmpty
)
v
toGroupedTreeInstitutes'' :: Eq a => HashMap (Maybe Parent) (HashMap NgramsTerm (GroupedTreeScores a))
-> HashMap NgramsTerm (GroupedTreeScores a)
-> HashMap Text [Text]
-> HashMap Parent (GroupedTreeScores a)
toGroupedTreeInstitutes'' m notEmpty institutesTree
| notEmpty == mempty = mempty
| otherwise = HashMap.mapWithKey (addGroup institutesTree m) notEmpty
where
addGroup :: (Eq score)
=> HashMap Text [Text]
-> HashMap (Maybe Parent) (HashMap NgramsTerm (GroupedTreeScores score))
-> Parent
-> GroupedTreeScores score
-> GroupedTreeScores score
addGroup institutesTree' dict' key val =
over gts'_children
( toGroupedTree'' dict'
. case HashMap.lookup (unNgramsTerm key) institutesTree' of
Nothing -> HashMap.union ( fromMaybe mempty
$ HashMap.lookup (Just key) dict'
)
Just children
-> HashMap.union
(foldl (\acc child
-> HashMap.union acc
$ HashMap.singleton (NgramsTerm child) GroupedTreeScores
{ _gts'_score= _gts'_score val
, _gts'_listType= _gts'_listType val
, _gts'_children= HashMap.empty
}
) HashMap.empty children
)
. HashMap.union ( fromMaybe mempty
$ HashMap.lookup (Just key) dict'
)
)
val
\ No newline at end of file
......@@ -27,10 +27,10 @@ import Gargantext.API.Admin.Auth (forgotUserPassword)
import Gargantext.API.Admin.Auth.Types (ForgotPasswordAsyncParams(..))
import Gargantext.API.Node.Corpus.New (addToCorpusWithForm)
import Gargantext.API.Node.New (postNode')
import Gargantext.Core.Config.Worker (WorkerDefinition(..), wdToRedisConnectInfo)
import Gargantext.Core.Worker.Env
import Gargantext.Core.Worker.Jobs
import Gargantext.Core.Worker.Jobs.Types (Job(..))
import Gargantext.Core.Worker.TOML (WorkerDefinition(..), wdToRedisConnectInfo)
import Gargantext.Database.Query.Table.User (getUsersWithEmail)
import Gargantext.Prelude
import Gargantext.Utils.Jobs.Monad ( MonadJobStatus(noJobHandle) )
......
......@@ -24,17 +24,18 @@ import Data.Text qualified as T
import Database.PostgreSQL.Simple (Connection)
import Gargantext.API.Admin.EnvTypes (ConcreteJobHandle, Env, GargJob, Mode(Dev), modeToLoggingLevels)
import Gargantext.API.Admin.Orchestrator.Types (JobLog, noJobLog)
import Gargantext.API.Admin.Settings ( devJwkFile, devSettings, newPool, SettingsFile (..), IniFile (..) )
import Gargantext.API.Admin.Settings ( devJwkFile, devSettings, newPool )
import Gargantext.API.Admin.Types (HasSettings(..), Settings(..))
import Gargantext.API.Prelude (GargM)
import Gargantext.Core.Config (GargConfig(..), readConfig)
import Gargantext.Core.Config (GargConfig(..))
import Gargantext.Core.Config.Mail qualified as Mail
import Gargantext.Core.Config.NLP qualified as NLP
import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.Core.Config.Types (SettingsFile(..))
import Gargantext.Core.Mail.Types (HasMail(..))
import Gargantext.Core.NLP (HasNLPServer(..), NLPServerMap, nlpServerMap)
import Gargantext.Core.NodeStory (HasNodeStoryEnv(..), HasNodeStoryImmediateSaver(..), HasNodeArchiveStoryImmediateSaver(..), NodeStoryEnv, fromDBNodeStoryEnv, nse_saver_immediate, nse_archive_saver_immediate)
import Gargantext.Core.Types (HasValidationError(..))
import Gargantext.Database.Prelude (HasConfig(..), HasConnectionPool(..), databaseParameters)
import Gargantext.Database.Prelude (HasConfig(..), HasConnectionPool(..))
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Database.Query.Tree.Error (HasTreeError(..))
import Gargantext.Prelude hiding (to)
......@@ -56,29 +57,26 @@ data WorkerEnv = WorkerEnv
}
withWorkerEnv :: IniFile -> SettingsFile -> (WorkerEnv -> IO a) -> IO a
withWorkerEnv (IniFile iniPath) settingsFile k = withLoggerHoisted Dev $ \logger -> do
withWorkerEnv :: SettingsFile -> (WorkerEnv -> IO a) -> IO a
withWorkerEnv settingsFile k = withLoggerHoisted Dev $ \logger -> do
env <- newWorkerEnv logger
k env -- `finally` cleanEnv env
where
newWorkerEnv logger = do
cfg <- readConfig iniPath
dbParam <- databaseParameters iniPath
cfg <- readConfig settingsFile
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
pool <- newPool dbParam
pool <- newPool $ _gc_database_config cfg
nodeStory_env <- fromDBNodeStoryEnv pool
setts <- devSettings devJwkFile settingsFile
mail <- Mail.readConfig iniPath
nlp_config <- NLP.readConfig iniPath
pure $ WorkerEnv
{ _w_env_pool = pool
, _w_env_logger = logger
, _w_env_nodeStory = nodeStory_env
, _w_env_settings = setts
, _w_env_config = cfg
, _w_env_mail = mail
, _w_env_nlp = nlpServerMap nlp_config
, _w_env_mail = _gc_mail_config cfg
, _w_env_nlp = nlpServerMap $ _gc_nlp_config cfg
}
instance HasConfig WorkerEnv where
......
......@@ -21,8 +21,8 @@ import Async.Worker.Types (HasWorkerBroker)
import Control.Lens (view)
import Database.Redis qualified as Redis
import Gargantext.API.Admin.Types (HasSettings, settings, workerSettings)
import Gargantext.Core.Config.Worker (WorkerSettings(..), WorkerDefinition(..), wdToRedisConnectInfo)
import Gargantext.Core.Worker.Jobs.Types (Job(..))
import Gargantext.Core.Worker.TOML (WorkerSettings(..), WorkerDefinition(..), wdToRedisConnectInfo)
import Gargantext.Database.Prelude (Cmd')
import Gargantext.Prelude
......
{-|
Module : Gargantext.Core.Worker.TOML
Description : Worker TOML file config
Copyright : (c) CNRS, 2024
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
module Gargantext.Core.Worker.TOML where
import Async.Worker.Broker.Types qualified as Broker
import Data.Text qualified as T
import Database.Redis qualified as Redis
import Gargantext.Prelude
import Toml
type WorkerName = Text
data WorkerSettings =
WorkerSettings {
_wsDefinitions :: ![WorkerDefinition]
} deriving (Show, Eq)
data WorkerDefinition =
WorkerDefinition {
_wdName :: !WorkerName
, _wdQueue :: !Broker.Queue
, _wdBroker :: !WorkerBroker
} deriving (Show, Eq)
data WorkerBroker =
WorkerBrokerRedis WorkerRedis
-- TODO Add WorkerBrokerPGMQ
deriving (Show, Eq)
data WorkerRedis =
WorkerRedis {
_wrHost :: !Text
, _wrPort :: !Int
} deriving (Show, Eq)
workerSettingsCodec :: TomlCodec WorkerSettings
workerSettingsCodec = WorkerSettings
<$> Toml.list workerDefinitionCodec "definitions" .= _wsDefinitions
workerDefinitionCodec :: TomlCodec WorkerDefinition
workerDefinitionCodec = WorkerDefinition
<$> Toml.text "name" .= _wdName
<*> (Broker.Queue <$> Toml.text "queue") .= (Broker._Queue <$> _wdQueue)
<*> Toml.table workerBrokerCodec "broker.redis" .= _wdBroker
workerBrokerCodec :: TomlCodec WorkerBroker
workerBrokerCodec =
Toml.dimatch matchWorkerBrokerRedis WorkerBrokerRedis workerRedisCodec
matchWorkerBrokerRedis :: WorkerBroker -> Maybe WorkerRedis
matchWorkerBrokerRedis (WorkerBrokerRedis wr) = Just wr
workerRedisCodec :: TomlCodec WorkerRedis
workerRedisCodec = WorkerRedis
<$> Toml.text "host" .= _wrHost
<*> Toml.int "port" .= _wrPort
wdToRedisConnectInfo :: WorkerDefinition -> Maybe Redis.ConnectInfo
wdToRedisConnectInfo (WorkerDefinition { _wdBroker = WorkerBrokerRedis (WorkerRedis { .. }) }) =
Just $ Redis.defaultConnectInfo { Redis.connectHost = T.unpack _wrHost
, Redis.connectPort = Redis.PortNumber $ fromIntegral _wrPort }
findDefinitionByName :: WorkerSettings -> WorkerName -> Maybe WorkerDefinition
findDefinitionByName (WorkerSettings { _wsDefinitions }) workerName =
head $ filter (\wd -> _wdName wd == workerName) _wsDefinitions
-- wdToRedisBrokerInitParams :: WorkerDefinition -> Maybe BRedis.RedisBrokerInitParams
-- wdToRedisBrokerInitParams wd = BRedis.RedisBrokerInitParams <$> (wdToRedisConnectInfo wd)
......@@ -66,6 +66,8 @@ import EPO.API.Client.Types qualified as EPO
import Gargantext.API.Ngrams.Tools (getTermsWith)
import Gargantext.Core (Lang(..), NLPServerConfig, withDefaultLanguage)
import Gargantext.Core.AsyncUpdates.CentralExchange.Types (HasCentralExchangeNotification(ce_notify), CEMessage(..))
import Gargantext.Core.Config (GargConfig(..))
import Gargantext.Core.Config.Types (APIsConfig(..))
import Gargantext.Core.Ext.IMTUser (readFile_Annuaire)
import Gargantext.Core.NLP (HasNLPServer, nlpServerGet)
import Gargantext.Core.NodeStory.Types (HasNodeStory)
......@@ -103,7 +105,6 @@ import Gargantext.Database.Query.Tree.Root (MkCorpusUser(..), getOrMkRoot, getOr
import Gargantext.Database.Schema.Ngrams ( indexNgrams, text2ngrams )
import Gargantext.Database.Schema.Node (node_hyperdata)
import Gargantext.Prelude hiding (to)
import Gargantext.Core.Config (GargConfig(..))
import Gargantext.System.Logging ( logLocM, LogLevel(DEBUG), MonadLogger )
import Gargantext.Utils.Jobs.Monad ( JobHandle, MonadJobStatus(..) )
import PUBMED.Types qualified as PUBMED
......@@ -138,7 +139,7 @@ getDataText :: (HasNodeError err, HasSettings env)
-> DBCmd' env err (Either API.GetCorpusError DataText)
getDataText (ExternalOrigin api) la q mPubmedAPIKey mAuthKey li = do
cfg <- view hasConfig
eRes <- liftBase $ API.get api (_tt_lang la) q mPubmedAPIKey mAuthKey (_gc_epo_api_url cfg) li
eRes <- liftBase $ API.get api (_tt_lang la) q mPubmedAPIKey mAuthKey (_ac_epo_api_url $ _gc_apis cfg) li
pure $ DataNew <$> eRes
getDataText (InternalOrigin _) la q _ _ _li = do
(_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus MkCorpusUserMaster (Nothing :: Maybe HyperdataCorpus)
......
......@@ -30,6 +30,7 @@ import Gargantext.API.Ngrams.Types (NgramsTerm(..))
import Gargantext.Core ( HasDBid(toDBid) )
import Gargantext.Core.Text.Ngrams (NgramsType(..))
import Gargantext.Data.HashMap.Strict.Utils as HM ( unionsWith )
import Gargantext.Database.Admin.Types.Hyperdata.Document
import Gargantext.Database.Admin.Types.Node (ListId, CorpusId, NodeId(..), ContextId (..), MasterCorpusId, NodeType(NodeDocument), UserCorpusId, DocId)
import Gargantext.Database.Prelude (DBCmd, runPGSQuery)
import Gargantext.Database.Schema.Ngrams () -- toDBid instance
......@@ -91,6 +92,34 @@ getContextsByNgramsUser cId nt =
GROUP BY cng.context_id, ng.terms
|]
getTreeInstitutesUser :: HasDBid NodeType
=> CorpusId
-> NgramsType
-> DBCmd err (HashMap Text [Text])
getTreeInstitutesUser cId nt =
HM.unionsWith (++) . map (\(_, hd) -> HM.fromList $ map (\(p, c) -> (p, [c])) $ Map.toList $ fromMaybe Map.empty (_hd_institutes_tree hd)) <$> selectHyperDataByContextUser cId nt
selectHyperDataByContextUser :: HasDBid NodeType
=> CorpusId
-> NgramsType
-> DBCmd err [(ContextId, HyperdataDocument)]
selectHyperDataByContextUser cId' nt' =
runPGSQuery queryHyperDataByContextUser
( cId'
, toDBid nt'
)
queryHyperDataByContextUser :: DPS.Query
queryHyperDataByContextUser = [sql|
SELECT cng.context_id, c.hyperdata FROM context_node_ngrams cng
JOIN ngrams ng ON cng.ngrams_id = ng.id
JOIN nodes_contexts nc ON nc.context_id = cng.context_id
JOIN contexts c ON nc.context_id = c.id
WHERE nc.node_id = ? -- CorpusId
AND cng.ngrams_type = ? -- NgramsTypeId
AND nc.category > 0 -- is not in Trash
GROUP BY cng.context_id, c.hyperdata
|]
------------------------------------------------------------------------
getOccByNgramsOnlyFast_withSample :: HasDBid NodeType
......@@ -215,7 +244,7 @@ queryNgramsOccurrencesOnlyByContextUser_withSample = [sql|
GROUP BY cng.node_id, ir.terms
|]
-- queryNgramsOccurrencesOnlyByContextUser_withSample :: DPS.Query
-- queryNgramsOccurrencesOnlyByContextUser_withSample = [sql|
-- WITH nodes_sample AS (SELECT c.id FROM contexts c TABLESAMPLE SYSTEM_ROWS (?)
......
......@@ -22,10 +22,10 @@ module Gargantext.Database.Action.Node
import Control.Lens (view)
import Data.Text qualified as T
import Gargantext.API.Admin.Settings.MicroServices
import Gargantext.API.Admin.Types (settings, _microservicesSettings, HasSettings)
import Gargantext.Core
import Gargantext.Core.Config (GargConfig(..))
import Gargantext.Core.Config (GargConfig(..), mkProxyUrl)
import Gargantext.Core.Config.Types (FramesConfig(..), MicroServicesSettings(..), SecretsConfig(..))
import Gargantext.Core.Types (Name)
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Hyperdata.Default
......@@ -101,7 +101,7 @@ mkNodeWithParent_ConfigureHyperdata _ _ _ _ = nodeError NotImplYet
internalNotesProxy :: GargConfig -> MicroServicesSettings -> T.Text
internalNotesProxy cfg msSettings
| _msProxyEnabled msSettings = T.pack $ showBaseUrl proxyUrl <> "/notes"
| otherwise = _gc_frame_write_url cfg
| otherwise = _f_write_url $ _gc_frames cfg
where
proxyUrl = mkProxyUrl cfg msSettings
......@@ -123,11 +123,11 @@ mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
stt <- view settings
u <- case nt of
Notes -> pure $ internalNotesProxy cfg (_microservicesSettings stt)
Calc -> pure $ _gc_frame_calc_url cfg
NodeFrameVisio -> pure $ _gc_frame_visio_url cfg
Calc -> pure $ _f_calc_url $ _gc_frames cfg
NodeFrameVisio -> pure $ _f_visio_url $ _gc_frames cfg
_ -> nodeError NeedsConfiguration
let
s = _gc_secretkey cfg
s = _s_secret_key $ _gc_secrets cfg
hd = HyperdataFrame u (hash $ s <> (show nodeId))
_ <- updateHyperdata nodeId hd
pure [nodeId]
......
......@@ -36,6 +36,7 @@ data HyperdataDocument = HyperdataDocument { _hd_bdd :: !(Maybe T
, _hd_publication_minute :: !(Maybe Int)
, _hd_publication_second :: !(Maybe Int)
, _hd_language_iso2 :: !(Maybe Text)
, _hd_institutes_tree :: !(Maybe (Map Text Text))
}
deriving (Show, Generic)
......@@ -53,7 +54,7 @@ defaultHyperdataDocument = case decode docExample of
Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing
Nothing Nothing Nothing
Nothing Nothing Nothing Nothing
where
docExample :: ByteString
......@@ -120,7 +121,7 @@ arbitraryHyperdataDocuments =
toHyperdataDocument' (t1,t2) =
HyperdataDocument Nothing Nothing Nothing Nothing (Just t1)
Nothing Nothing (Just t2) Nothing Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing Nothing
......
......@@ -23,17 +23,16 @@ import Data.ByteString qualified as DB
import Data.List qualified as DL
import Data.Pool (Pool, withResource)
import Data.Profunctor.Product.Default (Default)
import Data.Text (pack, unpack)
import Database.PostgreSQL.Simple (Connection, connect)
import Database.PostgreSQL.Simple (Connection)
import Database.PostgreSQL.Simple qualified as PGS
import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
import Database.PostgreSQL.Simple.Internal (Field)
import Database.PostgreSQL.Simple.Types (Query(..))
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET
import Gargantext.Core.Config (GargConfig)
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Prelude
import Gargantext.Core.Config (GargConfig, readIniFile', val)
import Opaleye (Unpackspec, showSql, FromFields, Select, runSelect, SqlJsonb, DefaultFromField, toFields, matchMaybe, MaybeFields)
import Opaleye.Aggregate (countRows)
import Opaleye.Internal.Constant qualified
......@@ -121,8 +120,7 @@ mkCmd k = do
pool <- view connPool
liftBase $ withResource pool (liftBase . k)
runCmd :: (HasConnectionPool env)
=> env
runCmd :: env
-> Cmd'' env err a
-> IO (Either err a)
runCmd env m = runExceptT $ runReaderT m env
......@@ -183,24 +181,9 @@ execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> DBCmd err Int64
execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
------------------------------------------------------------------------
databaseParameters :: FilePath -> IO PGS.ConnectInfo
databaseParameters fp = do
ini <- readIniFile' fp
let val' key = unpack $ val ini "database" key
let dbPortRaw = val' "DB_PORT"
let dbPort = case (readMaybe dbPortRaw :: Maybe Word16) of
Nothing -> panicTrace $ "DB_PORT incorrect: " <> (pack dbPortRaw)
Just d -> d
pure $ PGS.ConnectInfo { PGS.connectHost = val' "DB_HOST"
, PGS.connectPort = dbPort
, PGS.connectUser = val' "DB_USER"
, PGS.connectPassword = val' "DB_PASS"
, PGS.connectDatabase = val' "DB_NAME"
}
connectGargandb :: FilePath -> IO Connection
connectGargandb fp = databaseParameters fp >>= \params -> connect params
-- connectGargandb :: SettingsFile -> IO Connection
-- connectGargandb sf = readConfig sf >>= \params -> connect (DBConfig.unTOMLConnectInfo params)
fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
fromField' field mb = do
......
......@@ -33,13 +33,13 @@ import Data.Text.Encoding qualified as TE
import GHC.Generics
import Gargantext.API.Admin.Auth.Types (AuthContext)
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Settings.MicroServices
import Gargantext.API.Admin.Types
import Gargantext.API.Node.ShareURL qualified as Share
import Gargantext.API.Routes.Named.Private
import Gargantext.API.Routes.Named.Share (ShareLink(..))
import Gargantext.API.ThrowAll (throwAllRoutes)
import Gargantext.Core.Config (gc_frame_write_url)
import Gargantext.Core.Config (gc_frames, mkProxyUrl)
import Gargantext.Core.Config.Types (f_write_url)
import Gargantext.Database.Admin.Types.Node (NodeType(..), NodeId (..))
import Gargantext.Database.Prelude (hasConfig)
import Gargantext.Prelude hiding (Handler)
......@@ -275,7 +275,7 @@ proxyPassServer sty env = defaultForwardServer sty id id env
mkProxyDestination :: Env -> ProxyDestination
mkProxyDestination env = fromMaybe (panicTrace "Invalid URI found in the proxied Request.") $ do
baseUrl <- parseBaseUrl (T.unpack $ env ^. hasConfig . gc_frame_write_url)
baseUrl <- parseBaseUrl (T.unpack $ env ^. hasConfig . gc_frames . f_write_url)
pure $ ProxyDestination baseUrl
--
......
......@@ -45,8 +45,6 @@
- "stemmer-0.5.2"
- "taggy-0.2.1"
- "taggy-lens-0.1.2"
- "tomland-1.3.3.2"
- "validation-selective-0.2.0.0"
- "vector-0.12.3.0"
- "wai-3.2.4"
- "wai-util-0.8"
......@@ -114,10 +112,14 @@
git: "https://github.com/fpringle/servant-routes.git"
subdirs:
- .
- commit: 23be4130804d86979eaee5caffe323a1c7f2b0d6
- commit: 5868db564d7d3c4568ccd11c852292b834d26c55
git: "https://github.com/garganscript/nanomsg-haskell"
subdirs:
- .
- commit: 4a291783f4aa83548eac5009e16e8bdcb5ddc667
git: "https://github.com/glguy/toml-parser"
subdirs:
- .
- commit: 4fd2edf30c141600ffad6d730cc4c1c08a6dbce4
git: "https://github.com/robstewart57/rdf4h.git"
subdirs:
......@@ -134,7 +136,7 @@
git: "https://gitlab.iscpif.fr/gargantext/crawlers/epo-proxy-api.git"
subdirs:
- .
- commit: 1dbd939257d33126e49d2679375553df1f2eebc5
- commit: d54812d52c9d1f86d331a991b3a87c9a8b4379cf
git: "https://gitlab.iscpif.fr/gargantext/crawlers/hal.git"
subdirs:
- .
......@@ -555,9 +557,6 @@ flags:
compat: true
hans: false
network: true
tomland:
"build-play-tomland": false
"build-readme": false
"transformers-base":
orphaninstances: true
"transformers-compat":
......
[frontend]
url = "http://localhost"
backend_name = "localhost"
url_backend_api = "http://localhost:8008/api/v1.0"
jwt_settings = "TODO"
[frontend.cors]
allowed-origins = []
use-origins-for-hosts = true
[frontend.microservices.proxy]
port = 8009
enabled = false
[secrets]
master_user = "gargantua"
secret_key = "test_key"
[paths]
data_filepath = "~/.garg"
#repo_filepath = "~/.garg"
[apis]
[apis.pubmed]
api_key = "no_key"
[apis.epo]
api_url = ""
[external]
[external.frames]
write_url = "URL_TO_CHANGE"
calc_url = "URL_TO_CHANGE"
visio_url = "URL_TO_CHANGE"
searx_url = "URL_TO_CHANGE"
istex_url = "URL_TO_CHANGE"
[jobs]
max_docs_parsers = 1000000
max_docs_scrapers = 10000
js_job_timeout = 1800
js_id_timeout = 1800
[database]
host = "127.0.0.1"
port = 5432
user = "gargantua"
pass = "gargantua_test"
name = "gargandb_test"
[mail]
port = 25
host = "localhost"
user = "gargantext"
password = ""
from = ""
# NoAuth | Normal | SSL | TLS | STARTTLS
login_type = "Normal"
[notifications]
central-exchange = { bind = "tcp://*:15560", connect = "tcp://localhost:15560" }
dispatcher = { bind = "tcp://*:15561", connect = "tcp://localhost:15561" }
[nlp]
EN = "corenlp://localhost:9000"
FR = "spacy://localhost:8001"
All = "corenlp://localhost:9000"
module Test.API where
import Gargantext.Core.Config.Types (NotificationsConfig)
import Prelude
import Test.Hspec
import qualified Test.API.Authentication as Auth
......@@ -10,8 +11,8 @@ import qualified Test.API.Notifications as Notifications
import qualified Test.API.Private as Private
import qualified Test.API.UpdateList as UpdateList
tests :: Spec
tests = describe "API" $ do
tests :: NotificationsConfig -> Spec
tests _nc = describe "API" $ do
Auth.tests
Private.tests
GraphQL.tests
......@@ -19,4 +20,4 @@ tests = describe "API" $ do
UpdateList.tests
-- | TODO This would work if I managed to get forking dispatcher &
-- exchange listeners properly
-- Notifications.tests
-- Notifications.tests nc
......@@ -18,12 +18,13 @@ module Test.API.Notifications (
) where
import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Concurrent.STM.TChan qualified as TChan
import Control.Concurrent.STM.TVar qualified as TVar
import Control.Monad.STM (atomically)
import Data.Aeson qualified as Aeson
import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET
import Gargantext.Core.AsyncUpdates.Dispatcher.Types qualified as DT
import Gargantext.Core.Config.Types (NotificationsConfig(..))
import Network.WebSockets.Client qualified as WS
import Network.WebSockets.Connection qualified as WS
import Prelude
......@@ -34,41 +35,47 @@ import Test.Instances ()
import Text.RawString.QQ (r)
tests :: Spec
tests = sequential $ aroundAll withTestDBAndPort $ do
tests :: NotificationsConfig -> Spec
tests nc = sequential $ aroundAll withTestDBAndPort $ do
describe "Dispatcher, Central Exchange, WebSockets" $ do
it "simple WS notification works" $ \((_testEnv, port), _) -> do
tchan <- TChan.newTChanIO
tvar <- TVar.newTVarIO Nothing
-- setup a websocket connection
let wsConnect = do
putStrLn $ "Creating WS client (port " <> show port <> ")"
WS.runClient "127.0.0.1" port "/ws" $ \conn -> do
WS.sendTextData conn $ Aeson.encode (DT.WSSubscribe $ DT.UpdateTree 0)
d <- WS.receiveData conn
atomically $ TChan.writeTChan tchan (Aeson.eitherDecode d)
putStrLn ("received: " <> show d)
atomically $ TVar.writeTVar tvar (Aeson.decode d)
putStrLn "After WS client"
-- wait a bit to settle
putStrLn "settling a bit initially"
threadDelay 1000000
threadDelay (500 * millisecond)
putStrLn "forking wsConnection"
wsConnection <- forkIO $ wsConnect
-- wait a bit to connect
threadDelay 1000000
threadDelay (500 * millisecond)
putStrLn "settling a bit for connection"
threadDelay 1000000
threadDelay (500 * millisecond)
let msg = CET.UpdateTreeFirstLevel 0
putStrLn "Notifying CE"
CE.notify msg
CE.notify nc msg
threadDelay (500 * millisecond)
putStrLn "Reading tvar with timeout"
d <- Timeout.timeout 1000000 (atomically $ TChan.readTChan tchan)
d <- TVar.readTVarIO tvar
putStrLn "Killing wsConnection thread"
killThread wsConnection
putStrLn "Checking d"
d `shouldBe` (Just $ Right msg)
d `shouldBe` (Just msg)
millisecond :: Int
millisecond = 1000
......@@ -22,6 +22,8 @@ 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.NLP
import Gargantext.Core.NodeStory
import Gargantext.Core.Types.Individu
......@@ -50,20 +52,19 @@ import Prelude
import Servant.Auth.Client ()
import Servant.Client
import Servant.Job.Async qualified as ServantAsync
import Test.Database.Setup (withTestDB, fakeIniPath, testEnvToPgConnectionInfo, fakeSettingsPath)
import Test.Database.Setup (withTestDB, fakeTomlPath, testEnvToPgConnectionInfo)
import Test.Database.Types
import UnliftIO qualified
newTestEnv :: TestEnv -> Logger (GargM Env BackendInternalError) -> Warp.Port -> IO Env
newTestEnv testEnv logger port = do
file <- fakeIniPath
settingsP <- SettingsFile <$> fakeSettingsPath
tomlFile@(SettingsFile sf) <- fakeTomlPath
!manager_env <- newTlsManager
!settings' <- devSettings devJwkFile settingsP <&> appPort .~ port
!settings' <- devSettings devJwkFile tomlFile <&> appPort .~ port
!config_env <- readConfig file
prios <- withLogger () $ \ioLogger -> Jobs.readPrios ioLogger (file <> ".jobs")
!config_env <- readConfig tomlFile
prios <- withLogger () $ \ioLogger -> Jobs.readPrios ioLogger (sf <> ".jobs")
let prios' = Jobs.applyPrios prios Jobs.defaultPrios
!self_url_env <- parseBaseUrl $ "http://0.0.0.0:" <> show port
dbParam <- pure $ testEnvToPgConnectionInfo testEnv
......@@ -74,11 +75,9 @@ newTestEnv testEnv logger port = do
secret <- Jobs.genSecret
let jobs_settings = (Jobs.defaultJobSettings 1 secret)
& Jobs.l_jsJobTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_job_timeout)
& Jobs.l_jsIDTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_id_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_env <- Jobs.newJobEnv jobs_settings prios' manager_env
!config_mail <- Mail.readConfig file
!nlp_env <- nlpServerMap <$> NLP.readConfig file
-- !central_exchange <- forkIO CE.gServer
-- !dispatcher <- D.dispatcher
......@@ -93,8 +92,8 @@ newTestEnv testEnv logger port = do
, _env_jobs = jobs_env
, _env_self_url = self_url_env
, _env_config = config_env
, _env_mail = config_mail
, _env_nlp = nlp_env
, _env_mail = _gc_mail_config config_env
, _env_nlp = nlpServerMap $ _gc_nlp_config config_env
, _env_central_exchange = Prelude.error "central exchange not needed, but forced somewhere (check StrictData)"
, _env_dispatcher = Prelude.error "dispatcher not needed, but forced somewhere (check StrictData)"
-- , _env_central_exchange = central_exchange
......
{-# LANGUAGE TupleSections #-}
module Test.Database.Setup (
withTestDB
, fakeIniPath
, fakeSettingsPath
, fakeTomlPath
, testEnvToPgConnectionInfo
) where
......@@ -17,6 +16,8 @@ import Database.PostgreSQL.Simple.Options qualified as Opts
import Database.Postgres.Temp qualified as Tmp
import Gargantext.API.Admin.EnvTypes (Mode(Mock))
import Gargantext.API.Admin.Settings
import Gargantext.Core.Config.Types (SettingsFile(..))
import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
import Gargantext.Prelude
import Gargantext.Core.Config
......@@ -33,11 +34,8 @@ dbUser = "gargantua"
dbPassword = "gargantua_test"
dbName = "gargandb_test"
fakeIniPath :: IO FilePath
fakeIniPath = getDataFileName "test-data/test_config.ini"
fakeSettingsPath :: IO FilePath
fakeSettingsPath = getDataFileName "test-data/gargantext-settings.toml"
fakeTomlPath :: IO SettingsFile
fakeTomlPath = SettingsFile <$> getDataFileName "test-data/test_config.toml"
gargDBSchema :: IO FilePath
gargDBSchema = getDataFileName "devops/postgres/schema.sql"
......@@ -72,13 +70,13 @@ setup = do
case res of
Left err -> Prelude.fail $ show err
Right db -> do
gargConfig <- fakeIniPath >>= readConfig
gargConfig <- fakeTomlPath >>= readConfig
pool <- createPool (PG.connectPostgreSQL (Tmp.toConnectionString db))
(PG.close) 2 60 2
bootstrapDB db pool gargConfig
ugen <- emptyCounter
test_nodeStory <- fromDBNodeStoryEnv pool
stgs <- devSettings devJwkFile =<< (SettingsFile <$> fakeSettingsPath)
stgs <- devSettings devJwkFile =<< fakeTomlPath
withLoggerHoisted Mock $ \logger -> do
pure $ TestEnv { test_db = DBHandle pool db
, test_config = gargConfig
......
......@@ -232,5 +232,5 @@ waitUntil pred' timeoutMs = do
if p
then return ()
else do
threadDelay 50
threadDelay 50000
performTest
......@@ -4,12 +4,12 @@ module Main where
import Gargantext.Prelude hiding (isInfixOf)
import Control.Concurrent (forkIO, killThread)
import Control.Monad
import Data.Text (isInfixOf)
import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
import Gargantext.Core.AsyncUpdates.Dispatcher qualified as D
import Gargantext.Core.AsyncUpdates.Dispatcher.Types qualified as DT
import Gargantext.Core.Config.Types (NotificationsConfig(..))
import Shelly hiding (FilePath)
import System.IO
import System.Process
......@@ -22,6 +22,7 @@ import qualified Test.Database.Operations as DB
startCoreNLPServer :: IO ProcessHandle
startCoreNLPServer = do
putText "calling start core nlp"
devNull <- openFile "/dev/null" WriteMode
let p = proc "./startServer.sh" []
(_, _, _, hdl) <- (createProcess $ p { cwd = Just "devops/coreNLP/stanford-corenlp-current"
......@@ -39,21 +40,32 @@ startCoreNLPServer = do
pure hdl
stopCoreNLPServer :: ProcessHandle -> IO ()
stopCoreNLPServer = interruptProcessGroupOf
stopCoreNLPServer ph = do
putText "calling stop core nlp"
interruptProcessGroupOf ph
putText "calling stop core nlp - done"
withNotifications :: ((NotificationsConfig, ThreadId, D.Dispatcher) -> IO a) -> IO a
withNotifications = bracket startNotifications stopNotifications
where
startNotifications :: IO (NotificationsConfig, ThreadId, D.Dispatcher)
startNotifications = do
central_exchange <- forkIO $ CE.gServer nc
dispatcher <- D.newDispatcher nc
pure (nc, central_exchange, dispatcher)
stopNotifications :: (NotificationsConfig, ThreadId, D.Dispatcher) -> IO ()
stopNotifications (_nc, central_exchange, dispatcher) = do
putText "calling stop notifications"
killThread central_exchange
D.terminateDispatcher dispatcher
putText "calling stop notifications - done"
startNotifications :: IO (ThreadId, DT.Dispatcher)
startNotifications = do
central_exchange <- forkIO CE.gServer
dispatcher <- D.dispatcher
nc :: NotificationsConfig
nc = NotificationsConfig { _nc_central_exchange_bind = "tcp://*:15560"
, _nc_central_exchange_connect = "tcp://localhost:15560"
, _nc_dispatcher_bind = "tcp://*:15561"
, _nc_dispatcher_connect = "tcp://localhost:15561" }
pure (central_exchange, dispatcher)
stopNotifications :: (ThreadId, DT.Dispatcher) -> IO ()
stopNotifications (central_exchange, dispatcher) = do
killThread central_exchange
killThread $ DT.d_ce_listener dispatcher
-- It's especially important to use Hspec for DB tests, because,
-- unlike 'tasty', 'Hspec' has explicit control over parallelism,
-- and it's important that DB tests are run according to a very
......@@ -70,9 +82,11 @@ main = do
hSetBuffering stdout NoBuffering
-- TODO Ideally remove start/stop notifications and use
-- Test/API/Setup to initialize this in env
bracket startNotifications stopNotifications $ \_ -> do
withNotifications $ \(nc, _, _) -> do
bracket startCoreNLPServer stopCoreNLPServer $ \_ -> hspec $ do
API.tests
API.tests nc
ReverseProxy.tests
DB.tests
DB.nodeStoryTests
runIO $ putText "tests finished"
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment