Commit 206c847b authored by Alexandre Delanoë's avatar Alexandre Delanoë

Merge remote-tracking branch 'origin/304-dev-toml-config-rewrite-and-update-deps' into dev

parents 9a75d273 9e1d7ebf
......@@ -34,6 +34,7 @@ _darcs
*.pdf
*.sql
*.ini
*.toml
!test-data/test_config.ini
# Runtime
......
......@@ -118,9 +118,61 @@ $ ./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
```
#### Upgrading haskell packages
We use `gargantext.cabal`, `cabal.project` and `cabal.project.freeze`
as the source of truth. Ouf ot that, we generate the `stack.yaml` file
for those who prefer to use Stack.
Upgrading packages can be a pain sometimes, with cabal.
Here are some tips:
- Manually remove entries from your `cabal.project.freeze` to make the
build a bit more "elastic";
- Lock the hackage-index state in the `cabal.project`, so that the
solver won't try to pull newer dependencies;
- Specify constraints you want directly when building like `cabal
v2-build --constraint tasty==x.y.z.w`
- Generate another `.freeze` with `cabal v2-freeze` once you got the
new build to compile (this is good for small, incremental upgrades)
- Bounds in `.cabal` are definitely respected, but ofc the `.freeze`
takes priority, so you want to maybe use `cabal gen-bounds` when
your `.freeze` still exists, remove the file, try again.
Also, it's helpful to build with `stack build` from time to time. The
warnings are displayed, whenever a different stack lts package is used
than the one defined in `.cabal` file - it's an incentive to upgrade
the `.cabal` file versions.
Occasionally, you can get issues with the `allow-newer: *` constraint
from `cabal.project`. E.g. when I was building with GHC 9.4.7, I had
errors with `hashable-1.5.0`. The solution is:
```shell
cabal v2-build --constraint hashable==1.4.3.0
```
(we don't depend on `hashable` directly, but `allow-newer: *` is so
liberal that a package that is too new is used).
Overall, it's preferred to specify strict constraints in
`gargantext.cabal` file and to do that, one can use `stack ls dependencies`
to have an idea what works.
If you want to see the detailed build info for a given dependency:
```shell
cabal v2-build -v servant-server
```
Also, you might use the `-Wunused-packages` GHC option, to get a
warning about unused packages (make sure though you build all targets
with `cabal v2-build all`).
Also, here is a relevant discussion:
https://discourse.haskell.org/t/whats-your-workflow-to-update-cabal-dependencies/9475
### Initializing and running
#### Start containers for database and NLP software bricks
......@@ -135,16 +187,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 +212,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.)
......@@ -171,6 +230,12 @@ Or, from "outside":
```shell
$ nix-shell --run "cabal v2-test --test-show-details=streaming"
```
If you want to run particular tests, use:
```shell
cabal v2-test garg-test-tasty --test-show-details=streaming --test-option=--pattern='/job status update and tracking/
```
### Working on libraries
When a devlopment is needed on libraries (for instance, the HAL crawler in https://gitlab.iscpif.fr/gargantext/crawlers):
......@@ -200,7 +265,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 +379,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."
......
......@@ -40,7 +40,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
......@@ -54,7 +54,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
......@@ -76,7 +76,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
......@@ -85,6 +84,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)
......@@ -45,6 +46,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)
......@@ -75,6 +78,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="ed85064669c844e43ebc723ed707b7d320d2133dd5d93d3750257e368d7fe254"
expected_cabal_project_freeze_hash="60f10a3fab634a95294568d09926b258d8976027532304460ff1a9f9d1c10fdd"
expected_cabal_project_hash="967fee2ed28f46b12a629ad9821301854d3159975b7297653e50d7fc1f3b8919"
expected_cabal_project_freeze_hash="af825192f1ec47b07e6001dd2556b59991c9e6c50094dc732ee933a41f0dc9bd"
cabal --store-dir=$STORE_DIR v2-build --dry-run
......
-- Generated by stack2cabal
index-state: 2023-12-10T10:34:46Z
-- index-state: 2023-12-10T10:34:46Z
index-state: 2024-09-12T03:02:26Z
with-compiler: ghc-9.4.7
optimization: 2
......@@ -63,7 +64,8 @@ source-repository-package
source-repository-package
type: git
location: https://github.com/chessai/eigen.git
tag: 8fff32a43df743c8c83428a86dd566a0936a4fba
tag: 1790fdf9138970dde0dbabf8b270698145a4a88c
-- tag: 8fff32a43df743c8c83428a86dd566a0936a4fba
source-repository-package
type: git
......@@ -88,7 +90,7 @@ source-repository-package
source-repository-package
type: git
location: https://gitlab.iscpif.fr/gargantext/crawlers/epo-proxy-api.git
tag: 9225d046083853200b9045c8d71161e6a234fc5c
tag: cf4e5004f3b002bdef3fcab95e3559d65cdcd858
source-repository-package
type: git
......@@ -108,7 +110,7 @@ source-repository-package
source-repository-package
type: git
location: https://gitlab.iscpif.fr/gargantext/crawlers/openalex.git
tag: d2df0130575cfd32d6863d77e2ce34c48a1c32fa
tag: 4eec15855207dc74afc75b94c3764eede4de7b55
source-repository-package
type: git
......@@ -165,10 +167,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
......@@ -185,14 +188,51 @@ source-repository-package
location: https://github.com/fpringle/servant-routes.git
tag: 7694f62af6bc1596d754b42af16da131ac403b3a
source-repository-package
type: git
location: https://github.com/glguy/toml-parser
tag: toml-parser-2.0.1.0
source-repository-package
type: git
location: https://gitlab.iscpif.fr/gargantext/haskell-throttle
tag: 02f5ed9ee2d6cce45161addf945b88bc6adf9059
allow-older: *
allow-newer: *
allow-newer:
accelerate-arithmetic:accelerate
, MissingH:base
, accelerate-utility:accelerate
, base:*
, crawlerHAL:servant
, crawlerISTEX:servant
, crawlerPubMed:servant
, crawlerPubMed:servant-client-core
, iso639:aeson
, iso639:text
, morpheus-graphql-app:text
, morpheus-graphql-client:text
, morpheus-graphql-code-gen-utils:text
, morpheus-graphql-code-gen:text
, morpheus-graphql-core:text
, morpheus-graphql-server:text
, morpheus-graphql-subscriptions:text
, morpheus-graphql:text
, servant-client:servant
, servant-client:servant-client-core
, servant-ekg:base
, servant-ekg:hashable
, servant-ekg:servant
, servant-ekg:text
, servant-ekg:time
, servant-xml-conduit:base
, servant-xml-conduit:bytestring
, servant-xml-conduit:servant
, stemmer:base
allow-older: aeson:hashable
, crawlerHAL:servant-client
, haskell-throttle:time
, hsparql:rdf4h
package gargantext
ghc-options: -fwrite-ide-info -hiedir=".stack-work/hiedb"
......
This diff is collapsed.
[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
[microservices.proxy]
port = 8009
enabled = false
[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"
This diff is collapsed.
......@@ -44,16 +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.Types
import Gargantext.API.Admin.EnvTypes (Env, Mode(..), _env_config)
import Gargantext.API.Admin.Settings (newEnv)
import Gargantext.API.Admin.Types (FireWall(..), MicroServicesProxyStatus(..), PortNumber, cookieSettings, jwtSettings, settings, corsSettings, microServicesProxyStatus)
import Gargantext.API.Middleware (logStdoutDevSanitised)
import Gargantext.API.Routes.Named (API)
import Gargantext.API.Routes.Named.EKG
import Gargantext.API.Server.Named (server)
-- import Gargantext.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)
import Gargantext.Database.Prelude qualified as DB
import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp)
import Gargantext.Prelude hiding (putStrLn)
......@@ -71,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 proxyStatus = microServicesProxyStatus (env ^. settings)
runDbCheck env
portRouteInfo port proxyStatus
portRouteInfo (_gc_notifications_config $ _env_config env) port proxyStatus
app <- makeApp env
mid <- makeGargMiddleware (env ^. settings.corsSettings) mode
periodicActions <- schedulePeriodicActions env
......@@ -97,21 +96,22 @@ 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 -> MicroServicesProxyStatus -> IO ()
portRouteInfo mainPort proxyStatus = do
portRouteInfo :: NotificationsConfig -> PortNumber -> MicroServicesProxyStatus -> IO ()
portRouteInfo nc mainPort proxyStatus = do
putStrLn "=========================================================================================================="
putStrLn " GarganText Main Routes"
putStrLn "=========================================================================================================="
putStrLn $ " - Web GarganText Frontend..................: " <> "http://localhost:" <> toUrlPiece mainPort <> "/index.html"
putStrLn $ " - Swagger UI (API documentation)...........: " <> "http://localhost:" <> toUrlPiece mainPort <> "/swagger-ui"
putStrLn $ " - Playground GraphQL (API documentation)...: " <> "http://localhost:" <> toUrlPiece mainPort <> "/gql"
putStrLn $ renderProxyStatus
putStrLn $ " - Central exchange.........................: " <> "nanomsg: " <> pack AUConstants.ceBind
putStrLn $ " - Dispatcher internal......................: " <> "nanomsg: " <> pack AUConstants.dispatcherBind
-- putStrLn $ " - Microservices proxy .....................: " <> "http://localhost:" <> toUrlPiece proxyStatus
putStrLn renderProxyStatus
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 "=========================================================================================================="
where
......
......@@ -40,7 +40,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
......@@ -161,7 +162,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
......@@ -174,7 +175,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
c <- asks (view env_config)
liftBase $ CE.notify (_gc_notifications_config c) 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.
......@@ -297,7 +300,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"
......@@ -185,35 +184,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.
......@@ -228,8 +223,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
}
......
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.API.Admin.Settings.TOML where
import Control.Lens hiding ((.=))
import Data.Text qualified as T
import Gargantext.API.Admin.Settings.CORS
import Gargantext.API.Admin.Settings.MicroServices
import Gargantext.Prelude (panicTrace)
import Gargantext.System.Logging
import Prelude
import Toml
import Servant.Client.Core.BaseUrl
-- | Compatibility bridge until we fix #304 (move to Toml)
data GargTomlSettings = GargTomlSettings
{ _gargCorsSettings :: !CORSSettings
, _gargMicroServicesSettings :: !MicroServicesSettings
}
makeLenses ''GargTomlSettings
settingsCodec :: TomlCodec GargTomlSettings
settingsCodec = GargTomlSettings
<$> (Toml.table corsSettingsCodec "cors" .= _gargCorsSettings)
<*> (Toml.table microServicesSettingsCodec "microservices.proxy" .= _gargMicroServicesSettings)
-- | Extends the 'allowed-origins' in the CORSettings with the URLs embellished
-- with the proxy port.
addProxyToAllowedOrigins :: GargTomlSettings -> GargTomlSettings
addProxyToAllowedOrigins stgs =
stgs & over gargCorsSettings (addProxies $ stgs ^. gargMicroServicesSettings . msProxyPort)
where
addProxies :: Int -> CORSSettings -> CORSSettings
addProxies port cors =
let origins = _corsAllowedOrigins cors
mkUrl (CORSOrigin bh) = CORSOrigin $ bh { baseUrlPort = port }
in cors { _corsAllowedOrigins = origins <> Prelude.map mkUrl origins }
-- | Loads the 'CORSSettings' from the 'toml' file.
loadGargTomlSettings :: FilePath -> IO GargTomlSettings
loadGargTomlSettings tomlFile = do
tomlRes <- Toml.decodeFileEither settingsCodec tomlFile
case tomlRes of
Left errs -> do
withLogger () $ \ioLogger -> do
logMsg ioLogger ERROR $ T.unpack $ "Error, gargantext-settings.toml parsing failed: " <> Toml.prettyTomlDecodeErrors errs
panicTrace "Please fix the errors in your gargantext-settings.toml file."
Right settings0 -> case settings0 ^. gargCorsSettings . corsUseOriginsForHosts of
True -> pure $ addProxyToAllowedOrigins $
settings0 & over (gargCorsSettings . corsAllowedHosts)
(\_ -> (settings0 ^. gargCorsSettings . corsAllowedOrigins))
False -> pure $ addProxyToAllowedOrigins settings0
......@@ -5,11 +5,10 @@ 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.Core.Config.Types
import Gargantext.Prelude
import Servant.Auth.Server (JWTSettings, CookieSettings(..))
import Servant.Client (BaseUrl)
import Gargantext.API.Admin.Settings.MicroServices
type PortNumber = Int
......
......@@ -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.
......
......@@ -21,7 +21,7 @@ module Gargantext.API.Errors (
import Prelude
import Control.Exception
import Control.Exception.Safe
import Data.Aeson qualified as JSON
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
......
......@@ -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
......
......@@ -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
......
......@@ -30,10 +30,11 @@ import Gargantext.API.Node.Corpus.New qualified as New
import Gargantext.API.Prelude
import Gargantext.API.Routes.Named.Annuaire qualified as Named
import Gargantext.API.Routes.Named.Corpus qualified as Named
import Gargantext.Core.Config (gc_jobs)
import Gargantext.Core.Config.Types (jc_max_docs_scrapers)
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, MonadJobStatus(..))
import Servant
import Servant.Auth.Swagger ()
......@@ -54,7 +55,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))
......
......@@ -15,6 +15,7 @@ Portability : POSIX
module Gargantext.Core
where
import Control.Exception.Safe (impureThrow)
import Data.Aeson
import Data.LanguageCodes qualified as ISO639
import Data.Bimap qualified as Bimap
......@@ -25,7 +26,6 @@ import Data.Text (pack)
import Gargantext.Prelude hiding (All)
import Servant.API
import Test.QuickCheck
import Control.Exception (throw)
import Prelude (userError)
------------------------------------------------------------------------
......@@ -180,5 +180,5 @@ fromDBid :: forall a. (HasCallStack, HasDBid a, Typeable a) => Int -> a
fromDBid i = case lookupDBid i of
Nothing ->
let err = userError $ "HasDBid " <> show (typeRep (Proxy :: Proxy a)) <> " not found or not implemented."
in throw $ WithStacktrace callStack err
in impureThrow $ WithStacktrace callStack err
Just v -> v
......@@ -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 DEBUG $ "[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,93 @@ 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
, 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.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
-- Non-strict data so that we can use it in tests
data GargConfig = GargConfig { _gc_datafilepath :: ~FilePath
-- , _gc_repofilepath :: ~FilePath
, _gc_frontend_config :: ~FrontendConfig
, _gc_mail_config :: ~MailConfig
, _gc_database_config :: ~PSQL.ConnectInfo
, _gc_nlp_config :: ~NLPConfig
, _gc_notifications_config :: ~NotificationsConfig
, _gc_frames :: ~FramesConfig
, _gc_jobs :: ~JobsConfig
, _gc_secrets :: ~SecretsConfig
, _gc_apis :: ~APIsConfig
}
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"
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 }
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
]
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)
......@@ -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)
......
......@@ -19,10 +19,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
......@@ -98,7 +98,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
......@@ -120,11 +120,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]
......
......@@ -14,7 +14,7 @@ Portability : POSIX
module Gargantext.Database.Prelude where
import Control.Exception (throw)
import Control.Exception.Safe (throw)
import Control.Lens (Getter, view)
import Control.Monad.Random ( MonadRandom )
import Control.Monad.Trans.Control (MonadBaseControl)
......@@ -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)
......@@ -51,7 +51,7 @@ import Network.Wai
import Network.Wai.Util (redirect')
import Servant hiding (Header)
import Servant.Auth.Server
import Servant.Auth.Server.Internal.AddSetCookie
import Servant.Auth.Server.Internal.AddSetCookie ()
import Servant.Auth.Swagger ()
import Servant.Client.Core.BaseUrl
import Servant.Server.Generic
......@@ -59,13 +59,13 @@ import Text.RE.Replace hiding (Capture)
import Text.RE.TDFA.ByteString
-- See https://github.com/haskell-servant/servant/issues/1601#issue-1338013029
instance {-# OVERLAPPING #-}
( AddSetCookies ('S n) a a
, AddSetCookies ('S n) b b'
)
=> AddSetCookies ('S n) (a :<|> b) (a :<|> b') where
addSetCookies cookies ( a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b
-- -- See https://github.com/haskell-servant/servant/issues/1601#issue-1338013029
-- instance {-# OVERLAPPING #-}
-- ( AddSetCookies ('S n) a a
-- , AddSetCookies ('S n) b b'
-- )
-- => AddSetCookies ('S n) (a :<|> b) (a :<|> b') where
-- addSetCookies cookies ( a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b
--
-- Types
......@@ -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
--
......
......@@ -14,7 +14,7 @@ module Gargantext.System.Logging (
) where
import Language.Haskell.TH hiding (Type)
import Control.Exception.Lifted (bracket)
import Control.Exception.Safe (MonadMask, bracket)
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
import Data.Kind (Type)
......@@ -104,7 +104,7 @@ liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc
-- | exception-safe combinator that creates and destroys a logger.
-- Think about it like a 'bracket' function from 'Control.Exception'.
withLogger :: (MonadBaseControl IO m, MonadIO m, HasLogger m)
withLogger :: (MonadBaseControl IO m, MonadIO m, HasLogger m, MonadMask m)
=> LogInitParams m
-> (Logger m -> m a)
-> m a
......
......@@ -10,7 +10,7 @@ module Gargantext.Utils.Jobs.Internal (
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception
import Control.Exception.Safe
import Control.Lens
import Control.Monad
import Control.Monad.Except
......@@ -20,7 +20,9 @@ import Data.Monoid
import Data.Kind (Type)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Gargantext.Prelude (panicTrace)
import Prelude
import Protolude qualified
import Servant.API.Alternative
import Servant.API.ContentTypes
......@@ -89,19 +91,25 @@ newJob
newJob newJobHandle getenv jobkind f input = do
je <- getJobEnv
env <- getenv
let postCallback m = forM_ (input ^. SJ.job_callback) $ \url ->
let postCallback m = forM_ (input ^. SJ.job_callback) $ \url -> do
C.runClientM (SJ.clientMCallback m)
(C.mkClientEnv (jeManager je) (url ^. SJ.base_url))
pushLog logF = \w -> do
pushLog logF w = do
postCallback (SJ.mkChanEvent w)
logF w
f' jId inp logF = do
r <- f env (newJobHandle jId (liftIO . pushLog logF . Seq.singleton)) inp
case r of
Left e -> postCallback (SJ.mkChanError e) >> throwIO e
Right a -> postCallback (SJ.mkChanResult a) >> pure a
catch (do
r <- f env (newJobHandle jId (liftIO . pushLog logF . Seq.singleton)) inp
case r of
Left e -> postCallback (SJ.mkChanError e) >> throwIO e
Right a -> postCallback (SJ.mkChanResult a) >> pure a)
(\e -> do
-- We don't want jobs to fail silently
Protolude.putText $ Protolude.show (e :: SomeException)
_ <- panicTrace $ Protolude.show (e :: SomeException)
throwIO e)
jid <- queueJob jobkind (input ^. SJ.job_input) f'
pure (SJ.JobStatus jid [] SJ.IsPending Nothing)
......
......@@ -25,7 +25,7 @@ module Gargantext.Utils.Jobs.Map (
import Control.Concurrent
import Control.Concurrent.Async qualified as Async
import Control.Concurrent.STM
import Control.Exception
import Control.Exception.Safe
import Control.Monad
import Data.Map.Strict (Map)
import Data.Time.Clock
......
......@@ -32,7 +32,7 @@ module Gargantext.Utils.Jobs.Monad (
) where
import Control.Concurrent.STM
import Control.Exception
import Control.Exception.Safe
import Control.Monad.Except
import Control.Monad.Reader
import Data.Kind (Type)
......
......@@ -3,7 +3,7 @@ module Gargantext.Utils.Jobs.Queue where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Exception.Safe
import Control.Monad
import Data.Function
import Data.Maybe
......
"allow-newer": true
"extra-deps":
- "HSvm-0.1.1.3.22"
- "JuicyPixels-3.3.9"
- "KMP-0.2.0.0"
- "MissingH-1.4.3.0"
- "MissingH-1.4.3.1"
- "OneTuple-0.4.2"
- "aeson-pretty-0.8.10"
- "alex-3.5.1.0"
- "ansi-terminal-1.0.2"
- "assoc-1.1.1"
- "async-2.2.5"
- "atomic-primops-0.8.8"
- "barbies-2.1.1.0"
- "base-compat-0.13.1"
- "base-compat-batteries-0.13.1"
- "base-orphans-0.9.2"
- "base64-1.0"
- "bifunctors-5.6.2"
- "binary-orphans-1.0.5"
- "blaze-html-0.9.2.0"
- "boring-0.2.2"
- "bzlib-conduit-0.3.0.3"
- "cabal-doctest-1.0.10"
- "cassava-0.5.3.2"
- "cassava-conduit-0.6.6"
- "cborg-0.2.10.0"
- "concurrent-output-1.10.21"
- "conduit-1.3.6"
- "criterion-measurement-0.2.2.0"
- "cron-0.7.1"
- "crypton-1.0.0"
- "crypton-x509-1.7.7"
- "data-fix-0.3.4"
- "dec-0.0.6"
- "deferred-folds-0.9.18.6"
- "full-text-search-0.2.1.4"
- "digest-0.0.2.1"
- "double-conversion-2.0.5.0"
- "extra-1.7.16"
- "fast-logger-3.2.3"
- "fgl-5.8.2.0"
- "file-embed-0.0.16.0"
- "file-embed-lzma-0.1"
- "foldl-1.4.17"
- "free-5.2"
- "fullstop-0.1.4"
- "hgal-2.0.0.2"
- "graphviz-2999.20.2.0"
- "hashable-1.4.4.0"
- "haskell-src-meta-0.8.14"
- "hedgehog-1.5"
- "hslogger-1.3.1.1"
- "hsparql-0.3.8"
- "hspec-2.11.1"
- "hspec-core-2.11.1"
- "hspec-discover-2.11.1"
- "hspec-expectations-0.8.3"
- "hspec-2.11.9"
- "hspec-api-2.11.9"
- "hspec-core-2.11.9"
- "hspec-discover-2.11.9"
- "hspec-expectations-0.8.4"
- "http-accept-0.2"
- "http-api-data-0.5.1"
- "http-conduit-2.3.8.3"
- "http-types-0.12.4"
- "http2-5.0.1"
- "indexed-traversable-0.1.4"
- "invariant-0.6.3"
- "iproute-1.7.14"
- "jose-0.10.0.1"
- "json-stream-0.4.6.0"
- "kan-extensions-5.2.6"
- "language-c-0.9.3"
- "libyaml-0.1.4"
- "libyaml-clib-0.2.5"
- "lifted-async-0.10.2.5"
- "logict-0.8.1.0"
- "lzma-0.0.1.1"
- "math-functions-0.3.4.4"
- "matrix-0.3.6.3"
- "megaparsec-9.6.1"
- "microlens-th-0.4.3.15"
- "mono-traversable-1.0.17.0"
- "monoid-extras-0.6.3"
- "morpheus-graphql-0.24.3"
- "morpheus-graphql-app-0.24.3"
- "morpheus-graphql-client-0.24.3"
......@@ -21,27 +85,78 @@
- "morpheus-graphql-core-0.24.3"
- "morpheus-graphql-server-0.24.3"
- "morpheus-graphql-subscriptions-0.24.3"
- "opaleye-0.9.6.1"
- "mwc-random-0.15.1.0"
- "network-control-0.0.2"
- "old-time-1.1.0.4"
- "ordered-containers-0.2.4"
- "os-string-2.0.6"
- "password-3.0.4.0"
- "postgres-options-0.2.2.0"
- "primitive-0.7.4.0"
- "primitive-extras-0.10.2"
- "primitive-unlifted-2.1.0.0"
- "protolude-0.3.4"
- "psqueues-0.2.8.0"
- "rake-0.0.1"
- "random-1.2.1"
- "random-1.2.1.2"
- "recover-rtti-0.4.3"
- "servant-0.20.1"
- "servant-auth-server-0.4.8.0"
- "servant-auth-swagger-0.2.10.2"
- "servant-client-core-0.20"
- "reflection-2.1.8"
- "resourcet-1.3.0"
- "safe-0.3.21"
- "serialise-0.2.6.1"
- "servant-0.20.2"
- "servant-auth-0.4.2.0"
- "servant-auth-client-0.4.2.0"
- "servant-auth-server-0.4.9.0"
- "servant-auth-swagger-0.2.11.0"
- "servant-client-core-0.20.2"
- "servant-ekg-0.3.1"
- "servant-flatten-0.2"
- "servant-server-0.20"
- "servant-swagger-1.2"
- "servant-server-0.20.2"
- "servant-swagger-1.2.1"
- "servant-swagger-ui-0.3.5.5.0.1"
- "singleton-bool-0.1.8"
- "singletons-3.0.3"
- "some-1.0.6"
- "split-0.2.5"
- "stemmer-0.5.2"
- "stm-containers-1.2.1"
- "stm-hamt-1.2.1"
- "swagger2-2.8.9"
- "tagged-0.8.8"
- "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"
- "tasty-1.5"
- "tasty-bench-0.4"
- "tasty-hspec-1.2.0.4"
- "tasty-hunit-0.10.2"
- "tasty-quickcheck-0.11"
- "text-short-0.1.6"
- "th-compat-0.1.5"
- "these-1.2.1"
- "time-compat-1.9.7"
- "type-equality-1.0.1"
- "typed-process-0.2.12.0"
- "unicode-collation-0.1.3.6"
- "unix-compat-0.7.2"
- "unix-time-0.4.15"
- "unordered-containers-0.2.20"
- "utility-ht-0.0.17.2"
- "uuid-1.3.16"
- "uuid-types-1.0.6"
- "validity-0.12.1.0"
- "vector-0.12.3.1"
- "vector-algorithms-0.9.0.2"
- "wai-3.2.4"
- "wai-app-static-3.1.9"
- "wai-extra-3.1.15"
- "wai-logger-2.4.1"
- "wai-util-0.8"
- "warp-3.3.31"
- "wreq-0.5.4.3"
- "zip-2.0.1"
- "zip-archive-0.4.3.2"
- "zlib-0.7.1.0"
- commit: 2b5d69448557e89002c0179ea1aaf59bb757a6e3
git: "https://github.com/AccelerateHS/accelerate-llvm.git"
subdirs:
......@@ -90,7 +205,7 @@
git: "https://github.com/boolexpr/boolexpr.git"
subdirs:
- .
- commit: 8fff32a43df743c8c83428a86dd566a0936a4fba
- commit: 1790fdf9138970dde0dbabf8b270698145a4a88c
git: "https://github.com/chessai/eigen.git"
subdirs:
- .
......@@ -106,10 +221,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:
......@@ -122,7 +241,7 @@
git: "https://gitlab.iscpif.fr/gargantext/crawlers/arxiv-api.git"
subdirs:
- .
- commit: 9225d046083853200b9045c8d71161e6a234fc5c
- commit: cf4e5004f3b002bdef3fcab95e3559d65cdcd858
git: "https://gitlab.iscpif.fr/gargantext/crawlers/epo-proxy-api.git"
subdirs:
- .
......@@ -138,7 +257,7 @@
git: "https://gitlab.iscpif.fr/gargantext/crawlers/istex.git"
subdirs:
- .
- commit: d2df0130575cfd32d6863d77e2ce34c48a1c32fa
- commit: 4eec15855207dc74afc75b94c3764eede4de7b55
git: "https://gitlab.iscpif.fr/gargantext/crawlers/openalex.git"
subdirs:
- .
......@@ -216,11 +335,10 @@ flags:
"lib-only": false
"ansi-terminal":
example: false
"win32-2-13-1": false
"ansi-wl-pprint":
example: false
assoc:
tagged: true
tagged: false
async:
bench: false
"atomic-primops":
......@@ -231,7 +349,6 @@ flags:
"base-4-8": true
"old-base": false
bifunctors:
semigroups: true
tagged: true
bitvec:
simd: true
......@@ -242,8 +359,6 @@ flags:
c2hs:
base3: true
regression: false
cassava:
"bytestring--lt-0_10_4": false
"cassava-conduit":
small_base: true
cborg:
......@@ -252,9 +367,6 @@ flags:
"bytestring-builder": false
"cipher-aes":
support_aesni: true
citeproc:
executable: false
icu: false
clock:
llvm: false
cmdargs:
......@@ -298,6 +410,12 @@ flags:
support_sse: false
use_target_attributes: true
digest:
have_arm64_crc32c: false
have_builtin_prefetch: false
have_mm_prefetch: false
have_sse42: false
have_strong_getauxval: false
have_weak_getauxval: false
"pkg-config": true
distributive:
semigroups: true
......@@ -314,9 +432,7 @@ flags:
"foldable1-classes-compat":
tagged: true
formatting:
"no-double-conversion": true
"full-text-search":
"build-search-demo": false
"no-double-conversion": false
gargantext:
"no-phylo-debug-logs": false
"test-crypto": false
......@@ -352,7 +468,7 @@ flags:
devel: false
h2spec: false
hxt:
"network-uri": true
"network-uri": false
profile: false
"hxt-charproperties":
profile: false
......@@ -406,6 +522,8 @@ flags:
"mtl-compat":
"two-point-one": false
"two-point-two": false
"mwc-random":
benchpapi: false
network:
devel: false
"optics-core":
......@@ -414,8 +532,6 @@ flags:
process: true
"optparse-simple":
"build-example": false
pandoc:
embed_data_files: false
"parser-combinators":
dev: false
parsers:
......@@ -425,6 +541,8 @@ flags:
password:
argon2: true
bcrypt: true
crypton: false
cryptonite: false
pbkdf2: true
scrypt: true
"postgresql-libpq":
......@@ -481,10 +599,6 @@ flags:
"simple-sendfile":
"allow-bsd": true
fallback: false
skylighting:
executable: false
"skylighting-core":
executable: false
some:
"newtype-unsafe": true
splitmix:
......@@ -500,30 +614,21 @@ flags:
tasty:
unix: true
"tasty-bench":
debug: false
tasty: true
"tasty-golden":
"build-example": false
texmath:
executable: false
server: false
"text-format":
developer: false
"text-metrics":
dev: false
"text-short":
asserts: false
"time-compat":
"old-locale": false
"time-locale-compat":
"old-locale": false
tls:
compat: true
hans: false
network: true
tomland:
"build-play-tomland": false
"build-readme": false
"transformers-base":
orphaninstances: true
"transformers-compat":
......@@ -537,16 +642,6 @@ flags:
"unicode-collation":
doctests: false
executable: false
"unicode-data":
ucd2haskell: false
"unicode-transforms":
"bench-show": false
dev: false
"has-icu": false
"has-llvm": false
"use-gauge": false
"unix-compat":
"old-time": false
"unordered-containers":
debug: false
"uri-bytestring":
......@@ -602,8 +697,8 @@ flags:
executable: false
zlib:
"bundled-c-zlib": false
"non-blocking-ffi": false
"pkg-config": false
"non-blocking-ffi": true
"pkg-config": true
zstd:
standalone: true
packages:
......
[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"
]
use-origins-for-hosts = true
[microservices.proxy]
port = 8009
enabled = false
[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
......@@ -4,7 +4,7 @@ module Test.API.Setup where
import Control.Concurrent.Async qualified as Async
import Control.Concurrent.MVar
import Control.Exception
import Control.Exception.Safe
import Control.Lens
import Control.Monad.Reader
import Data.ByteString.Lazy.Char8 qualified as C8L
......@@ -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
......
......@@ -14,7 +14,7 @@ Portability : POSIX
module Test.Database.Types where
import Control.Exception
import Control.Exception.Safe
import Control.Lens
import Control.Monad.Except
import Control.Monad.Reader
......
......@@ -2,7 +2,8 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Offline.Errors (tests) where
import Control.Exception
import Control.Exception (evaluate)
import Control.Exception.Safe (try)
import Gargantext.Prelude.Error
import Gargantext.Core (fromDBid)
import Gargantext.Database.Admin.Config ()
......@@ -11,6 +12,7 @@ import Prelude
import Test.Tasty
import Test.Tasty.HUnit
tests :: TestTree
tests = testGroup "Errors" [
testCase "fromDBid comes with a CallStack" fromDBid_cs
......
......@@ -5,7 +5,7 @@
module Test.Utils where
import Control.Exception ()
import Control.Exception.Safe ()
import Control.Monad ()
import Data.Aeson qualified as JSON
import Data.Aeson.KeyMap qualified as KM
......@@ -232,5 +232,5 @@ waitUntil pred' timeoutMs = do
if p
then return ()
else do
threadDelay 50
threadDelay 50000
performTest
......@@ -25,6 +25,8 @@ import Gargantext.API.Admin.EnvTypes as EnvTypes
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Errors.Types
import Gargantext.API.Prelude
import Gargantext.Core.Config (GargConfig(..))
import Gargantext.Core.Config.Types (NotificationsConfig(..))
import Gargantext.Prelude
import Gargantext.Utils.Jobs.Error
import Gargantext.Utils.Jobs.Internal (newJob)
......@@ -38,6 +40,7 @@ import Prelude qualified
import Servant.Job.Core qualified as SJ
import Servant.Job.Types qualified as SJ
import System.IO.Unsafe
import System.Timeout (timeout)
import Test.Hspec
import Test.Hspec.Expectations.Contrib (annotate)
import Test.Utils (waitUntil)
......@@ -269,6 +272,23 @@ newTestEnv = do
k <- genSecret
let settings = defaultJobSettings 1 k
myEnv <- newJobEnv settings defaultPrios testTlsManager
let _gc_notifications_config =
NotificationsConfig { _nc_central_exchange_bind = Prelude.error "nc_central_exchange_bind not needed, but forced somewhere (check StrictData)"
, _nc_central_exchange_connect = "tcp://localhost:15510"
, _nc_dispatcher_bind = Prelude.error "nc_dispatcher_bind not needed, but forced somewhere (check StrictData)"
, _nc_dispatcher_connect = Prelude.error "nc_dispatcher_connect not needed, but forced somewhere (check StrictData)" }
let _env_config =
GargConfig { _gc_datafilepath = Prelude.error "gc_datafilepath not needed, but forced somewhere (check StrictData)"
, _gc_frontend_config = Prelude.error "gc_frontend_config not needed, but forced somewhere (check StrictData)"
, _gc_mail_config = Prelude.error "gc_mail_config not needed, but forced somewhere (check StrictData)"
, _gc_database_config = Prelude.error "gc_database_config not needed, but forced somewhere (check StrictData)"
, _gc_nlp_config = Prelude.error "gc_nlp_config not needed, but forced somewhere (check StrictData)"
, _gc_notifications_config
, _gc_frames = Prelude.error "gc_frames not needed, but forced somewhere (check StrictData)"
, _gc_jobs = Prelude.error "gc_jobs not needed, but forced somewhere (check StrictData)"
, _gc_secrets = Prelude.error "gc_secrets not needed, but forced somewhere (check StrictData)"
, _gc_apis = Prelude.error "gc_apis not needed, but forced somewhere (check StrictData)"
}
pure $ Env
{ _env_settings = Prelude.error "env_settings not needed, but forced somewhere (check StrictData)"
, _env_logger = Prelude.error "env_logger not needed, but forced somewhere (check StrictData)"
......@@ -278,7 +298,7 @@ newTestEnv = do
, _env_self_url = Prelude.error "self_url not needed, but forced somewhere (check StrictData)"
, _env_scrapers = Prelude.error "scrapers not needed, but forced somewhere (check StrictData)"
, _env_jobs = myEnv
, _env_config = Prelude.error "config not needed, but forced somewhere (check StrictData)"
, _env_config
, _env_mail = Prelude.error "mail not needed, but forced somewhere (check StrictData)"
, _env_nlp = Prelude.error "nlp not needed, but forced somewhere (check StrictData)"
, _env_central_exchange = Prelude.error "central exchange not needed, but forced somewhere (check StrictData)"
......@@ -342,14 +362,25 @@ testFetchJobStatusNoContention = do
testMarkProgress :: IO ()
testMarkProgress = do
myEnv <- newTestEnv
evts <- newTBQueueIO 7
-- evts <- newTBQueueIO 7
evts <- newTVarIO []
let getStatus hdl = do
liftIO $ threadDelay 100_000
st <- getLatestJobStatus hdl
liftIO $ atomically $ writeTBQueue evts st
readAllEvents = do
allEventsArrived <- isFullTBQueue evts
if allEventsArrived then flushTBQueue evts else retry
-- liftIO $ atomically $ writeTBQueue evts st
liftIO $ atomically $ modifyTVar evts (\xs -> xs ++ [st])
readAllEvents = do
-- We will get thread blocking if there is ANY error in the job
-- Hence we assert the `readAllEvents` test doesn't take too long
mRet <- timeout 1_000_000 $ atomically $ do
-- allEventsArrived <- isFullTBQueue evts
evts' <- readTVar evts
-- STM retry if things failed
-- check allEventsArrived
check (length evts' == 7)
-- flushTBQueue evts
return evts'
return $ fromMaybe [] mRet
withJob_ myEnv $ \hdl _input -> do
markStarted 10 hdl
......@@ -375,7 +406,8 @@ testMarkProgress = do
getStatus hdl
[jl0, jl1, jl2, jl3, jl4, jl5, jl6] <- atomically readAllEvents
evts' <- readAllEvents
let [jl0, jl1, jl2, jl3, jl4, jl5, jl6] = evts'
-- Check the events are what we expect
jl0 `shouldBe` JobLog { _scst_succeeded = Just 0
......
This diff is collapsed.
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