Commit eca8f40d authored by Alexandre Delanoë's avatar Alexandre Delanoë

Merge remote-tracking branch 'origin/adinapoli/issue-381' into dev-merge

parents d9045574 3b114df3
...@@ -54,6 +54,8 @@ data-files: ...@@ -54,6 +54,8 @@ data-files:
test-data/stemming/lancaster.txt test-data/stemming/lancaster.txt
test-data/test_config.ini test-data/test_config.ini
test-data/test_config.toml test-data/test_config.toml
test-data/issue-381/Termes_A_Ajouter_T4SC_Intellixir.tsv
test-data/issue-381/Termes_A_Ajouter_T4SC_Intellixir12.csv
.clippy.dhall .clippy.dhall
-- common options -- common options
...@@ -309,6 +311,7 @@ library ...@@ -309,6 +311,7 @@ library
Gargantext.Orphans.Accelerate Gargantext.Orphans.Accelerate
Gargantext.Orphans.OpenAPI Gargantext.Orphans.OpenAPI
Gargantext.System.Logging Gargantext.System.Logging
Gargantext.System.Logging.Loggers
Gargantext.System.Logging.Types Gargantext.System.Logging.Types
Gargantext.Utils.Dict Gargantext.Utils.Dict
Gargantext.Utils.Jobs.Error Gargantext.Utils.Jobs.Error
...@@ -803,6 +806,7 @@ test-suite garg-test-tasty ...@@ -803,6 +806,7 @@ test-suite garg-test-tasty
other-modules: other-modules:
CLI.Phylo.Common CLI.Phylo.Common
Paths_gargantext Paths_gargantext
Test.API.Private.List
Test.API.Private.Move Test.API.Private.Move
Test.API.Private.Remote Test.API.Private.Remote
Test.API.Private.Share Test.API.Private.Share
...@@ -877,6 +881,7 @@ test-suite garg-test-hspec ...@@ -877,6 +881,7 @@ test-suite garg-test-hspec
Test.API.GraphQL Test.API.GraphQL
Test.API.Notifications Test.API.Notifications
Test.API.Private Test.API.Private
Test.API.Private.List
Test.API.Private.Move Test.API.Private.Move
Test.API.Private.Remote Test.API.Private.Remote
Test.API.Private.Share Test.API.Private.Share
......
...@@ -68,9 +68,3 @@ cradle: ...@@ -68,9 +68,3 @@ cradle:
- path: "./test" - path: "./test"
component: "gargantext:test:garg-test-hspec" component: "gargantext:test:garg-test-hspec"
- path: "./bench/Main.hs"
component: "gargantext:bench:garg-bench"
- path: "./bench/Paths_gargantext.hs"
component: "gargantext:bench:garg-bench"
...@@ -70,29 +70,30 @@ import System.Cron.Schedule qualified as Cron ...@@ -70,29 +70,30 @@ import System.Cron.Schedule qualified as Cron
-- | startGargantext takes as parameters port number and Toml file. -- | startGargantext takes as parameters port number and Toml file.
startGargantext :: Mode -> PortNumber -> SettingsFile -> IO () startGargantext :: Mode -> PortNumber -> SettingsFile -> IO ()
startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerIO mode $ \logger -> do startGargantext mode port sf@(SettingsFile settingsFile) = do
config <- readConfig sf <&> (gc_frontend_config . fc_appPort) .~ port config <- readConfig sf <&> (gc_frontend_config . fc_appPort) .~ port
when (port /= config ^. gc_frontend_config . fc_appPort) $ withLoggerIO (config ^. gc_logging) $ \logger -> do
panicTrace "TODO: conflicting settings of port" when (port /= config ^. gc_frontend_config . fc_appPort) $
withNotifications config $ \dispatcher -> do panicTrace "TODO: conflicting settings of port"
env <- newEnv logger config dispatcher withNotifications config $ \dispatcher -> do
let fc = env ^. env_config . gc_frontend_config env <- newEnv logger config dispatcher
let proxyStatus = microServicesProxyStatus fc let fc = env ^. env_config . gc_frontend_config
runDbCheck env let proxyStatus = microServicesProxyStatus fc
startupInfo config port proxyStatus runDbCheck env
app <- makeApp env startupInfo config port proxyStatus
mid <- makeGargMiddleware (fc ^. fc_cors) mode app <- makeApp env
periodicActions <- schedulePeriodicActions env mid <- makeGargMiddleware (fc ^. fc_cors) mode
periodicActions <- schedulePeriodicActions env
let runServer = run port (mid app) `finally` stopGargantext periodicActions
case proxyStatus of let runServer = run port (mid app) `finally` stopGargantext periodicActions
PXY_disabled case proxyStatus of
-> runServer -- the proxy is disabled, do not spawn the application PXY_disabled
PXY_enabled proxyPort -> runServer -- the proxy is disabled, do not spawn the application
-> do PXY_enabled proxyPort
proxyCache <- InMemory.newCache (Just oneHour) -> do
let runProxy = run proxyPort (mid (microServicesProxyApp proxyCache env)) proxyCache <- InMemory.newCache (Just oneHour)
Async.race_ runServer runProxy let runProxy = run proxyPort (mid (microServicesProxyApp proxyCache env))
Async.race_ runServer runProxy
where runDbCheck env = do where runDbCheck env = do
r <- runExceptT (runReaderT DB.dbCheck env) `catch` r <- runExceptT (runReaderT DB.dbCheck env) `catch`
......
...@@ -38,12 +38,11 @@ module Gargantext.API.Admin.EnvTypes ( ...@@ -38,12 +38,11 @@ module Gargantext.API.Admin.EnvTypes (
import Control.Lens (to, view) import Control.Lens (to, view)
import Data.List ((\\)) import Data.List ((\\))
import Data.Pool (Pool) import Data.Pool (Pool)
import Data.Text qualified as T
import Database.PostgreSQL.Simple (Connection) import Database.PostgreSQL.Simple (Connection)
import Gargantext.API.Admin.Orchestrator.Types (JobLog, noJobLog) import Gargantext.API.Admin.Orchestrator.Types (JobLog, noJobLog)
import Gargantext.API.Errors.Types (BackendInternalError) import Gargantext.API.Errors.Types (BackendInternalError)
import Gargantext.API.Prelude (GargM, IsGargServer) import Gargantext.API.Prelude (GargM, IsGargServer)
import Gargantext.Core.Config (GargConfig(..), gc_mail_config, gc_nlp_config, HasJWTSettings(..), HasConfig(..), HasManager(..), gc_logging, lc_log_level) import Gargantext.Core.Config
import Gargantext.Core.Mail.Types (HasMail, mailSettings) import Gargantext.Core.Mail.Types (HasMail, mailSettings)
import Gargantext.Core.NLP (HasNLPServer(..), nlpServerMap) import Gargantext.Core.NLP (HasNLPServer(..), nlpServerMap)
import Gargantext.Core.NodeStory import Gargantext.Core.NodeStory
...@@ -58,6 +57,7 @@ import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..)) ...@@ -58,6 +57,7 @@ import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
import Network.HTTP.Client (Manager) import Network.HTTP.Client (Manager)
import Servant.Auth.Server (JWTSettings) import Servant.Auth.Server (JWTSettings)
import System.Log.FastLogger qualified as FL import System.Log.FastLogger qualified as FL
import Gargantext.System.Logging.Loggers
data Mode = Dev | Mock | Prod data Mode = Dev | Mock | Prod
...@@ -139,21 +139,13 @@ instance MonadLogger (GargM DevEnv BackendInternalError) where ...@@ -139,21 +139,13 @@ instance MonadLogger (GargM DevEnv BackendInternalError) where
instance HasLogger (GargM DevEnv BackendInternalError) where instance HasLogger (GargM DevEnv BackendInternalError) where
data instance Logger (GargM DevEnv BackendInternalError) = data instance Logger (GargM DevEnv BackendInternalError) =
GargDevLogger { GargDevLogger { _GargDevLogger :: MonadicStdLogger FL.LogStr IO }
dev_logger_mode :: Mode type instance LogInitParams (GargM DevEnv BackendInternalError) = LogConfig
, dev_logger_set :: FL.LoggerSet
}
type instance LogInitParams (GargM DevEnv BackendInternalError) = Mode
type instance LogPayload (GargM DevEnv BackendInternalError) = FL.LogStr type instance LogPayload (GargM DevEnv BackendInternalError) = FL.LogStr
initLogger = \mode -> do initLogger cfg = fmap GargDevLogger $ (liftIO $ monadicStdLogger cfg)
dev_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize destroyLogger = liftIO . _msl_destroy . _GargDevLogger
pure $ GargDevLogger mode dev_logger_set logMsg (GargDevLogger ioLogger) lvl msg = liftIO $ _msl_log_msg ioLogger lvl msg
destroyLogger = \GargDevLogger{..} -> liftIO $ FL.rmLoggerSet dev_logger_set logTxt (GargDevLogger ioLogger) lvl msg = liftIO $ _msl_log_txt ioLogger lvl msg
logMsg = \(GargDevLogger mode logger_set) lvl msg -> do
let pfx = "[" <> show lvl <> "] " :: Text
when (lvl `elem` (modeToLoggingLevels mode)) $
liftIO $ FL.pushLogStrLn logger_set $ FL.toLogStr pfx <> msg
logTxt lgr lvl msg = logMsg lgr lvl (FL.toLogStr $ T.unpack msg)
data DevEnv = DevEnv data DevEnv = DevEnv
{ _dev_env_config :: !GargConfig { _dev_env_config :: !GargConfig
...@@ -225,25 +217,14 @@ instance HasNLPServer DevEnv where ...@@ -225,25 +217,14 @@ instance HasNLPServer DevEnv where
instance IsGargServer Env BackendInternalError (GargM Env BackendInternalError) instance IsGargServer Env BackendInternalError (GargM Env BackendInternalError)
instance HasLogger (GargM Env BackendInternalError) where instance HasLogger (GargM Env BackendInternalError) where
data instance Logger (GargM Env BackendInternalError) = newtype instance Logger (GargM Env BackendInternalError) =
GargLogger { GargLogger { _GargLogger :: MonadicStdLogger FL.LogStr IO }
logger_mode :: Mode type instance LogInitParams (GargM Env BackendInternalError) = LogConfig
, logger_set :: FL.LoggerSet
}
type instance LogInitParams (GargM Env BackendInternalError) = Mode
type instance LogPayload (GargM Env BackendInternalError) = FL.LogStr type instance LogPayload (GargM Env BackendInternalError) = FL.LogStr
initLogger mode = do initLogger cfg = fmap GargLogger $ (liftIO $ monadicStdLogger cfg)
logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize destroyLogger = liftIO . _msl_destroy . _GargLogger
pure $ GargLogger mode logger_set logMsg (GargLogger ioLogger) lvl msg = liftIO $ _msl_log_msg ioLogger lvl msg
destroyLogger (GargLogger{..}) = liftIO $ FL.rmLoggerSet logger_set logTxt (GargLogger ioLogger) lvl msg = liftIO $ _msl_log_txt ioLogger lvl msg
logMsg (GargLogger mode logger_set) lvl msg = do
cfg <- view hasConfig
let minLvl = cfg ^. gc_logging . lc_log_level
when (lvl >= minLvl) $ do
let pfx = "[" <> show lvl <> "] " :: Text
when (lvl `elem` (modeToLoggingLevels mode)) $
liftIO $ FL.pushLogStrLn logger_set $ FL.toLogStr pfx <> msg
logTxt lgr lvl msg = logMsg lgr lvl (FL.toLogStr $ T.unpack msg)
instance MonadLogger (GargM Env BackendInternalError) where instance MonadLogger (GargM Env BackendInternalError) where
getLogger = asks _env_logger getLogger = asks _env_logger
...@@ -16,11 +16,11 @@ import Control.Lens (view) ...@@ -16,11 +16,11 @@ import Control.Lens (view)
import Control.Monad (fail) import Control.Monad (fail)
import Database.PostgreSQL.Simple qualified as PGS import Database.PostgreSQL.Simple qualified as PGS
import Data.Pool (withResource) import Data.Pool (withResource)
import Gargantext.API.Admin.EnvTypes ( DevEnv(..), Mode(Dev) ) import Gargantext.API.Admin.EnvTypes ( DevEnv(..) )
import Gargantext.API.Admin.Settings ( newPool ) import Gargantext.API.Admin.Settings ( newPool )
import Gargantext.API.Errors.Types ( BackendInternalError ) import Gargantext.API.Errors.Types ( BackendInternalError )
import Gargantext.API.Prelude ( GargM ) import Gargantext.API.Prelude ( GargM )
import Gargantext.Core.Config (_gc_database_config) import Gargantext.Core.Config (_gc_database_config, gc_logging)
import Gargantext.Core.Config.Types (SettingsFile(..)) import Gargantext.Core.Config.Types (SettingsFile(..))
import Gargantext.Core.Config.Utils (readConfig) import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.Core.NodeStory (fromDBNodeStoryEnv) import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
...@@ -32,14 +32,14 @@ import Servant ( ServerError ) ...@@ -32,14 +32,14 @@ import Servant ( ServerError )
------------------------------------------------------------------- -------------------------------------------------------------------
withDevEnv :: SettingsFile -> (DevEnv -> IO a) -> IO a withDevEnv :: SettingsFile -> (DevEnv -> IO a) -> IO a
withDevEnv settingsFile k = withLoggerIO Dev $ \logger -> do withDevEnv settingsFile k = do
env <- newDevEnv logger cfg <- readConfig settingsFile
k env -- `finally` cleanEnv env withLoggerIO (cfg ^. gc_logging) $ \logger -> do
env <- newDevEnv logger cfg
k env -- `finally` cleanEnv env
where where
newDevEnv logger = do newDevEnv logger cfg = do
cfg <- readConfig settingsFile
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
pool <- newPool (_gc_database_config cfg) pool <- newPool (_gc_database_config cfg)
nodeStory_env <- fromDBNodeStoryEnv pool nodeStory_env <- fromDBNodeStoryEnv pool
manager <- newTlsManager manager <- newTlsManager
......
...@@ -21,21 +21,21 @@ import Data.ByteString.Lazy qualified as BSL ...@@ -21,21 +21,21 @@ import Data.ByteString.Lazy qualified as BSL
import Data.Csv qualified as Tsv import Data.Csv qualified as Tsv
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap import Data.HashMap.Strict qualified as HashMap
import Data.Map.Strict qualified as Map
import Data.Map.Strict (toList) import Data.Map.Strict (toList)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set import Data.Set qualified as Set
import Data.Text (concat, pack, splitOn) import Data.Text (concat, pack, splitOn)
import Data.Vector qualified as Vec
import Data.Vector (Vector) import Data.Vector (Vector)
import Data.Vector qualified as Vec
import Gargantext.API.Admin.EnvTypes (Env) import Gargantext.API.Admin.EnvTypes (Env)
import Gargantext.API.Errors.Types (BackendInternalError(InternalServerError)) import Gargantext.API.Errors.Types (BackendInternalError(InternalServerError))
import Gargantext.API.Ngrams.List.Types (_wjf_data, _wtf_data)
import Gargantext.API.Ngrams.Prelude (getNgramsList)
import Gargantext.API.Ngrams (setListNgrams) import Gargantext.API.Ngrams (setListNgrams)
import Gargantext.API.Ngrams.List.Types (_wjf_data, _wtf_data, _wtf_name)
import Gargantext.API.Ngrams.Prelude (getNgramsList)
import Gargantext.API.Ngrams.Types import Gargantext.API.Ngrams.Types
import Gargantext.API.Prelude (GargM, serverError, HasServerError) import Gargantext.API.Prelude (GargM, serverError, HasServerError)
import Gargantext.API.Routes.Named.List qualified as Named import Gargantext.API.Routes.Named.List qualified as Named
import Gargantext.API.Worker (serveWorkerAPI, serveWorkerAPIEJob) import Gargantext.API.Worker (serveWorkerAPI, serveWorkerAPIM)
import Gargantext.Core.NodeStory.Types ( HasNodeStory ) import Gargantext.Core.NodeStory.Types ( HasNodeStory )
import Gargantext.Core.Text.Ngrams (Ngrams, NgramsType(NgramsTerms)) import Gargantext.Core.Text.Ngrams (Ngrams, NgramsType(NgramsTerms))
import Gargantext.Core.Types.Main (ListType(..)) import Gargantext.Core.Types.Main (ListType(..))
...@@ -47,13 +47,12 @@ import Gargantext.Database.Schema.Ngrams ( text2ngrams, NgramsId ) ...@@ -47,13 +47,12 @@ import Gargantext.Database.Schema.Ngrams ( text2ngrams, NgramsId )
import Gargantext.Database.Schema.Node (_node_parent_id) import Gargantext.Database.Schema.Node (_node_parent_id)
import Gargantext.Database.Types (Indexed(..)) import Gargantext.Database.Types (Indexed(..))
import Gargantext.Prelude hiding (concat, toList) import Gargantext.Prelude hiding (concat, toList)
import Gargantext.System.Logging (logLocM, MonadLogger) import Gargantext.System.Logging
import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..)) import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
import Prelude qualified import Prelude qualified
import Protolude qualified as P import Protolude qualified as P
import Servant import Servant
import Servant.Server.Generic (AsServerT) import Servant.Server.Generic (AsServerT)
import Gargantext.System.Logging (LogLevel(..))
getAPI :: Named.GETAPI (AsServerT (GargM Env BackendInternalError)) getAPI :: Named.GETAPI (AsServerT (GargM Env BackendInternalError))
...@@ -159,11 +158,12 @@ tsvAPI = tsvPostAsync ...@@ -159,11 +158,12 @@ tsvAPI = tsvPostAsync
tsvPostAsync :: Named.TSVAPI (AsServerT (GargM Env BackendInternalError)) tsvPostAsync :: Named.TSVAPI (AsServerT (GargM Env BackendInternalError))
tsvPostAsync = tsvPostAsync =
Named.TSVAPI { Named.TSVAPI {
updateListTSVEp = \lId -> serveWorkerAPIEJob $ \p -> updateListTSVEp = \lId -> serveWorkerAPIM $ \p -> do
$(logLocM) DEBUG $ "Started to upload " <> (_wtf_name p)
case ngramsListFromTSVData (_wtf_data p) of case ngramsListFromTSVData (_wtf_data p) of
Left err -> Left $ InternalServerError $ err500 { errReasonPhrase = err } Left err -> throwError $ InternalServerError $ err500 { errReasonPhrase = err }
Right ngramsList -> Right $ Jobs.JSONPost { _jp_list_id = lId Right ngramsList -> pure $ Jobs.JSONPost { _jp_list_id = lId
, _jp_ngrams_list = ngramsList } , _jp_ngrams_list = ngramsList }
} }
-- | Tries converting a text file into an 'NgramList', so that we can reuse the -- | Tries converting a text file into an 'NgramList', so that we can reuse the
...@@ -181,7 +181,8 @@ ngramsListFromTSVData tsvData = case decodeTsv of ...@@ -181,7 +181,8 @@ ngramsListFromTSVData tsvData = case decodeTsv of
decodeTsv = Vec.catMaybes <$> decodeTsv = Vec.catMaybes <$>
Tsv.decodeWithP tsvToNgramsTableMap Tsv.decodeWithP tsvToNgramsTableMap
(Tsv.defaultDecodeOptions { Tsv.decDelimiter = fromIntegral (P.ord '\t') }) (Tsv.defaultDecodeOptions { Tsv.decDelimiter = fromIntegral (P.ord '\t') })
Tsv.HasHeader -- Don't use an header, make it lenient in case the 'forms' are missing.
Tsv.NoHeader
binaryData binaryData
-- | Converts a plain TSV 'Record' into an NgramsTableMap -- | Converts a plain TSV 'Record' into an NgramsTableMap
...@@ -189,6 +190,9 @@ tsvToNgramsTableMap :: Tsv.Record -> Tsv.Parser (Maybe NgramsTableMap) ...@@ -189,6 +190,9 @@ tsvToNgramsTableMap :: Tsv.Record -> Tsv.Parser (Maybe NgramsTableMap)
tsvToNgramsTableMap record = case Vec.toList record of tsvToNgramsTableMap record = case Vec.toList record of
(map P.decodeUtf8 -> [status, label, forms]) (map P.decodeUtf8 -> [status, label, forms])
-> pure $ Just $ conv status label forms -> pure $ Just $ conv status label forms
-- Garg #381: alias the forms to the empty text.
(map P.decodeUtf8 -> [status, label])
-> pure $ Just $ conv status label mempty
-- WARNING: This silently ignores errors (#433) -- WARNING: This silently ignores errors (#433)
_ -> pure Nothing _ -> pure Nothing
......
...@@ -32,10 +32,15 @@ data WorkerAPI contentType input mode = WorkerAPI ...@@ -32,10 +32,15 @@ data WorkerAPI contentType input mode = WorkerAPI
serveWorkerAPI :: IsGargServer env err m serveWorkerAPI :: IsGargServer env err m
=> (input -> Job) => (input -> Job)
-> WorkerAPI contentType input (AsServerT m) -> WorkerAPI contentType input (AsServerT m)
serveWorkerAPI f = WorkerAPI { workerAPIPost } serveWorkerAPI f = serveWorkerAPIM (pure . f)
serveWorkerAPIM :: IsGargServer env err m
=> (input -> m Job)
-> WorkerAPI contentType input (AsServerT m)
serveWorkerAPIM mkJob = WorkerAPI { workerAPIPost }
where where
workerAPIPost i = do workerAPIPost i = do
let job = f i job <- mkJob i
logM DEBUG $ "[serveWorkerAPI] sending job " <> show job logM DEBUG $ "[serveWorkerAPI] sending job " <> show job
mId <- sendJob job mId <- sendJob job
pure $ JobInfo { _ji_message_id = mId pure $ JobInfo { _ji_message_id = mId
......
...@@ -16,37 +16,27 @@ module Gargantext.Core.Config.Utils ( ...@@ -16,37 +16,27 @@ module Gargantext.Core.Config.Utils (
import Gargantext.Core.Config.Types (SettingsFile(..)) import Gargantext.Core.Config.Types (SettingsFile(..))
import Gargantext.Prelude import Gargantext.Prelude
-- import Network.URI (URI)
-- import Network.URI (parseURI)
import Toml import Toml
import Toml.Schema import Gargantext.Core.Config
import System.Environment (lookupEnv)
import Gargantext.System.Logging.Types (parseLogLevel)
import qualified Data.Text as T
readConfig :: FromValue a => SettingsFile -> IO a readConfig :: SettingsFile -> IO GargConfig
readConfig (SettingsFile fp) = do readConfig (SettingsFile fp) = do
c <- readFile fp c <- readFile fp
case decode c of case decode c of
Failure err -> panicTrace ("Error reading TOML file: " <> show err) Failure err -> panicTrace ("Error reading TOML file: " <> show err)
Success _ r -> return r Success _ r -> do
-- Ovverride the log level based on the GGTX_LOG_LEVEL (if set)
mLvl <- lookupEnv "GGTX_LOG_LEVEL"
-- _URI :: Toml.TomlBiMap URI Text case mLvl of
-- _URI = Toml.BiMap (Right . show) parseURI' Nothing -> pure r
-- where Just s ->
-- parseURI' :: Text -> Either Toml.TomlBiMapError URI case parseLogLevel (T.pack s) of
-- parseURI' t = Left err -> do
-- case parseURI (T.unpack t) of putStrLn $ "unknown log level " <> s <> ": " <> T.unpack err <> " , ignoring GGTX_LOG_LEVEL"
-- Nothing -> Left $ Toml.ArbitraryError "Cannot parse URI" pure r
-- Just u -> Right u Right lvl' -> pure $ r & gc_logging . lc_log_level .~ lvl'
-- 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
...@@ -54,7 +54,9 @@ data TsvList = TsvList ...@@ -54,7 +54,9 @@ data TsvList = TsvList
instance FromNamedRecord TsvList where instance FromNamedRecord TsvList where
parseNamedRecord r = TsvList <$> r .: "status" parseNamedRecord r = TsvList <$> r .: "status"
<*> r .: "label" <*> r .: "label"
<*> r .: "forms" -- Issue #381: be lenient in the forms
-- field, if missing, default to the empty text.
<*> (fromMaybe mempty <$> r .: "forms")
instance ToNamedRecord TsvList where instance ToNamedRecord TsvList where
toNamedRecord (TsvList s l f) = toNamedRecord (TsvList s l f) =
......
...@@ -24,15 +24,13 @@ import Control.Lens.TH ...@@ -24,15 +24,13 @@ import Control.Lens.TH
import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Data.Pool qualified as Pool import Data.Pool qualified as Pool
import Data.Text qualified as T
import Database.PostgreSQL.Simple qualified as PSQL import Database.PostgreSQL.Simple qualified as PSQL
import Gargantext.API.Admin.EnvTypes (Mode(Dev), modeToLoggingLevels)
import Gargantext.API.Admin.Orchestrator.Types (JobLog, noJobLog) import Gargantext.API.Admin.Orchestrator.Types (JobLog, noJobLog)
import Gargantext.API.Job (RemainingSteps(..), jobLogStart, jobLogProgress, jobLogFailures, jobLogComplete, addErrorEvent, jobLogFailTotal, jobLogFailTotalWithMessage, jobLogAddMore) import Gargantext.API.Job (RemainingSteps(..), jobLogStart, jobLogProgress, jobLogFailures, jobLogComplete, addErrorEvent, jobLogFailTotal, jobLogFailTotalWithMessage, jobLogAddMore)
import Gargantext.API.Prelude (GargM) import Gargantext.API.Prelude (GargM)
import Gargantext.Core.Notifications.CentralExchange qualified as CE import Gargantext.Core.Notifications.CentralExchange qualified as CE
import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
import Gargantext.Core.Config (GargConfig(..), HasConfig(..), gc_logging) import Gargantext.Core.Config (GargConfig(..), HasConfig(..), gc_logging, LogConfig)
import Gargantext.Core.Config.Mail qualified as Mail import Gargantext.Core.Config.Mail qualified as Mail
import Gargantext.Core.Config.Utils (readConfig) import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.Core.Config.Types (SettingsFile(..)) import Gargantext.Core.Config.Types (SettingsFile(..))
...@@ -50,6 +48,7 @@ import Gargantext.Utils.Jobs.Monad ( MonadJobStatus(..), JobHandle ) ...@@ -50,6 +48,7 @@ import Gargantext.Utils.Jobs.Monad ( MonadJobStatus(..), JobHandle )
import GHC.IO.Exception (IOException(..), IOErrorType(OtherError)) import GHC.IO.Exception (IOException(..), IOErrorType(OtherError))
import Prelude qualified import Prelude qualified
import System.Log.FastLogger qualified as FL import System.Log.FastLogger qualified as FL
import Gargantext.System.Logging.Loggers
data WorkerEnv = WorkerEnv data WorkerEnv = WorkerEnv
...@@ -70,13 +69,14 @@ data WorkerJobState = WorkerJobState ...@@ -70,13 +69,14 @@ data WorkerJobState = WorkerJobState
withWorkerEnv :: SettingsFile -> (WorkerEnv -> IO a) -> IO a withWorkerEnv :: SettingsFile -> (WorkerEnv -> IO a) -> IO a
withWorkerEnv settingsFile k = withLoggerIO Dev $ \logger -> do withWorkerEnv settingsFile k = do
env <- newWorkerEnv logger cfg <- readConfig settingsFile
k env -- `finally` cleanEnv env withLoggerIO (cfg ^. gc_logging) $ \logger -> do
env <- newWorkerEnv logger cfg
k env -- `finally` cleanEnv env
where where
newWorkerEnv logger = do newWorkerEnv logger cfg = do
cfg <- readConfig settingsFile
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg) --nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
-- pool <- newPool $ _gc_database_config cfg -- pool <- newPool $ _gc_database_config cfg
let dbConfig = _gc_database_config cfg let dbConfig = _gc_database_config cfg
...@@ -97,22 +97,14 @@ instance HasConfig WorkerEnv where ...@@ -97,22 +97,14 @@ instance HasConfig WorkerEnv where
hasConfig = to _w_env_config hasConfig = to _w_env_config
instance HasLogger (GargM WorkerEnv IOException) where instance HasLogger (GargM WorkerEnv IOException) where
data instance Logger (GargM WorkerEnv IOException) = newtype instance Logger (GargM WorkerEnv IOException) =
GargWorkerLogger { GargWorkerLogger { _GargWorkerLogger :: MonadicStdLogger FL.LogStr IO }
w_logger_mode :: Mode type instance LogInitParams (GargM WorkerEnv IOException) = LogConfig
, w_logger_set :: FL.LoggerSet
}
type instance LogInitParams (GargM WorkerEnv IOException) = Mode
type instance LogPayload (GargM WorkerEnv IOException) = FL.LogStr type instance LogPayload (GargM WorkerEnv IOException) = FL.LogStr
initLogger mode = do initLogger cfg = fmap GargWorkerLogger $ (liftIO $ monadicStdLogger cfg)
w_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize destroyLogger = liftIO . _msl_destroy . _GargWorkerLogger
pure $ GargWorkerLogger mode w_logger_set logMsg (GargWorkerLogger ioLogger) lvl msg = liftIO $ _msl_log_msg ioLogger lvl msg
destroyLogger (GargWorkerLogger{..}) = liftIO $ FL.rmLoggerSet w_logger_set logTxt (GargWorkerLogger ioLogger) lvl msg = liftIO $ _msl_log_txt ioLogger lvl msg
logMsg (GargWorkerLogger mode logger_set) lvl msg = do
let pfx = "[" <> show lvl <> "] " :: Text
when (lvl `elem` (modeToLoggingLevels mode)) $
liftIO $ FL.pushLogStrLn logger_set $ FL.toLogStr pfx <> msg
logTxt lgr lvl msg = logMsg lgr lvl (FL.toLogStr $ T.unpack msg)
instance HasConnectionPool WorkerEnv where instance HasConnectionPool WorkerEnv where
connPool = to _w_env_pool connPool = to _w_env_pool
...@@ -182,29 +174,20 @@ newtype WorkerMonad a = ...@@ -182,29 +174,20 @@ newtype WorkerMonad a =
, MonadFail ) , MonadFail )
instance HasLogger WorkerMonad where instance HasLogger WorkerMonad where
data instance Logger WorkerMonad = newtype instance Logger WorkerMonad =
WorkerMonadLogger { WorkerMonadLogger { _WorkerMonadLogger :: MonadicStdLogger FL.LogStr IO }
wm_logger_mode :: Mode type instance LogInitParams WorkerMonad = LogConfig
, wm_logger_set :: FL.LoggerSet
}
type instance LogInitParams WorkerMonad = Mode
type instance LogPayload WorkerMonad = FL.LogStr type instance LogPayload WorkerMonad = FL.LogStr
initLogger mode = do initLogger cfg = fmap WorkerMonadLogger $ (liftIO $ monadicStdLogger cfg)
wm_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize destroyLogger = liftIO . _msl_destroy . _WorkerMonadLogger
pure $ WorkerMonadLogger mode wm_logger_set logMsg (WorkerMonadLogger ioLogger) lvl msg = liftIO $ _msl_log_msg ioLogger lvl msg
destroyLogger (WorkerMonadLogger{..}) = liftIO $ FL.rmLoggerSet wm_logger_set logTxt (WorkerMonadLogger ioLogger) lvl msg = liftIO $ _msl_log_txt ioLogger lvl msg
logMsg (WorkerMonadLogger mode logger_set) lvl msg = do
let pfx = "[" <> show lvl <> "] " :: Text
when (lvl `elem` (modeToLoggingLevels mode)) $
liftIO $ FL.pushLogStrLn logger_set $ FL.toLogStr pfx <> msg
logTxt lgr lvl msg = logMsg lgr lvl (FL.toLogStr $ T.unpack msg)
instance MonadLogger WorkerMonad where instance MonadLogger WorkerMonad where
getLogger = do getLogger = do
env <- ask env <- ask
let (GargWorkerLogger { .. }) = _w_env_logger env let (GargWorkerLogger lgr) = _w_env_logger env
pure $ WorkerMonadLogger { wm_logger_mode = w_logger_mode pure $ WorkerMonadLogger lgr
, wm_logger_set = w_logger_set }
runWorkerMonad :: WorkerEnv -> WorkerMonad a -> IO a runWorkerMonad :: WorkerEnv -> WorkerMonad a -> IO a
runWorkerMonad env m = do runWorkerMonad env m = do
......
...@@ -13,17 +13,15 @@ module Gargantext.System.Logging ( ...@@ -13,17 +13,15 @@ module Gargantext.System.Logging (
) where ) where
import Gargantext.System.Logging.Types import Gargantext.System.Logging.Types
import Gargantext.System.Logging.Loggers
import Control.Exception.Safe (MonadMask, bracket) import Control.Exception.Safe (MonadMask, bracket)
import Control.Monad (when)
import Gargantext.Core.Config (LogConfig(..)) import Gargantext.Core.Config (LogConfig(..))
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Control import Control.Monad.Trans.Control
import Data.Text qualified as T import Data.Text qualified as T
import Data.Time.Clock (getCurrentTime)
import Language.Haskell.TH hiding (Type) import Language.Haskell.TH hiding (Type)
import Language.Haskell.TH.Syntax qualified as TH import Language.Haskell.TH.Syntax qualified as TH
import Prelude import Prelude
import System.Environment (lookupEnv)
-- | A variant of 'logTxt' that doesn't require passing an explicit 'Logger'. -- | A variant of 'logTxt' that doesn't require passing an explicit 'Logger'.
...@@ -86,25 +84,10 @@ withLoggerIO params act = bracket (initLogger params) destroyLogger act ...@@ -86,25 +84,10 @@ withLoggerIO params act = bracket (initLogger params) destroyLogger act
-- | A plain logger in the IO monad, waiting for more serious logging solutions like -- | A plain logger in the IO monad, waiting for more serious logging solutions like
-- the one described in https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/229 -- the one described in https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/229
instance HasLogger IO where instance HasLogger IO where
data instance Logger IO = IOLogger LogLevel data instance Logger IO = IOLogger { _IOLogger :: IOStdLogger }
type instance LogInitParams IO = LogConfig type instance LogInitParams IO = LogConfig
type instance LogPayload IO = String type instance LogPayload IO = String
initLogger LogConfig{..} = do initLogger cfg = fmap IOLogger $ (liftIO $ ioStdLogger cfg)
-- let the env var take precedence over the LogConfig one. destroyLogger = liftIO . _iosl_destroy . _IOLogger
mLvl <- liftIO $ lookupEnv "GGTX_LOG_LEVEL" logMsg (IOLogger ioLogger) = _iosl_log_msg ioLogger
lvl <- case mLvl of logTxt (IOLogger ioLogger) lvl msg = liftIO $ _iosl_log_txt ioLogger lvl msg
Nothing -> pure _lc_log_level
Just s ->
case parseLogLevel (T.pack s) of
Left err -> do
liftIO $ putStrLn $ "unknown log level " <> s <> ": " <> T.unpack err <> " , ignoring GGTX_LOG_LEVEL"
pure $ _lc_log_level
Right lvl' -> pure lvl'
pure $ IOLogger lvl
destroyLogger _ = pure ()
logMsg (IOLogger minLvl) lvl msg = do
t <- getCurrentTime
when (lvl >= minLvl) $ do
let pfx = "[" <> show t <> "] [" <> show lvl <> "] "
putStrLn $ pfx <> msg
logTxt lgr lvl msg = logMsg lgr lvl (T.unpack msg)
{-| Canned loggers to avoid reinventing the wheel every time. -}
module Gargantext.System.Logging.Loggers (
ioStdLogger
, IOStdLogger -- opaque, you can't build it directly, use 'ioStdLogger'
, _iosl_log_level
, _iosl_destroy
, _iosl_log_msg
, _iosl_log_txt
, monadicStdLogger
, _msl_log_level
, _msl_destroy
, _msl_log_msg
, _msl_log_txt
, MonadicStdLogger
) where
import Control.Monad
import Control.Monad.IO.Class
import Data.Text qualified as T
import Data.Time
import Gargantext.Core.Config
import Gargantext.System.Logging.Types
import Prelude
import System.Log.FastLogger qualified as FL
data IOStdLogger =
IOStdLogger { _iosl_log_level :: LogLevel
, _iosl_destroy :: IO ()
, _iosl_log_msg :: LogLevel -> String -> IO ()
, _iosl_log_txt :: LogLevel -> T.Text -> IO ()
}
ioStdLogger :: LogConfig -> IO IOStdLogger
ioStdLogger LogConfig{..} = do
let minLvl = _lc_log_level
let log_msg lvl msg = do
t <- getCurrentTime
when (lvl >= minLvl) $ do
let pfx = "[" <> show t <> "] [" <> show lvl <> "] "
putStrLn $ pfx <> msg
pure $ IOStdLogger
{ _iosl_log_level = minLvl
, _iosl_destroy = pure ()
, _iosl_log_msg = log_msg
, _iosl_log_txt = \lvl msg -> log_msg lvl (T.unpack msg)
}
-- | A monadic standard logger powered by fast-logger underneath.
data MonadicStdLogger payload m =
MonadicStdLogger { _msl_log_level :: LogLevel
, _msl_loggers :: [FL.LoggerSet]
, _msl_destroy :: m ()
, _msl_log_msg :: LogLevel -> payload -> m ()
, _msl_log_txt :: LogLevel -> T.Text -> m ()
}
monadicStdLogger :: MonadIO m => LogConfig -> IO (MonadicStdLogger FL.LogStr m)
monadicStdLogger LogConfig{..} = do
let minLvl = _lc_log_level
stdout_logger <- FL.newStderrLoggerSet FL.defaultBufSize
let log_msg lvl msg = liftIO $ do
t <- getCurrentTime
when (lvl >= minLvl) $ do
let pfx = "[" <> show t <> "] [" <> show lvl <> "] "
FL.pushLogStrLn stdout_logger $ FL.toLogStr pfx <> msg
pure $ MonadicStdLogger
{ _msl_log_level = minLvl
, _msl_loggers = [stdout_logger]
, _msl_destroy = liftIO $ FL.rmLoggerSet stdout_logger
, _msl_log_msg = log_msg
, _msl_log_txt = \lvl msg -> log_msg lvl (FL.toLogStr $ T.unpack msg)
}
status label
map impact-point analysis
map Simulated Destructive Re-Entry Conditions
map Passive Space-Debris Trajectories
map error-proofing mechanisms
map on-orbit life extension
map tether-gripper mechanism
map Field-Programmable Gate Arrays (FPGA)
map self-repair modular robot
map space-debris impact
map self-repairing
map in-orbit servicing
map online self-repairing
map triple-module redundancy systems
map model-based system engineering
map low-thrust orbital transfer
map space-borne orbit debris surveillance
map atmospheric re-entry
map demisable tanks' re-entry
map non-cooperative spacecraft
map model-based approaches
map model-based methods
map impact-induced electrical anomalies
map Low-Cost Deorbit System
map tape-shaped tethers
map self-repair
map self-healing material
map vision-based navigation
map model-based process
status,label
map,impact-point analysis
map,Simulated Destructive Re-Entry Conditions
map,Passive Space-Debris Trajectories
map,error-proofing mechanisms
map,on-orbit life extension
map,tether-gripper mechanism
map,Field-Programmable Gate Arrays (FPGA)
map,self-repair modular robot
map,space-debris impact
map,self-repairing
map,in-orbit servicing
map,online self-repairing
map,triple-module redundancy systems
map,model-based system engineering
map,low-thrust orbital transfer
map,space-borne orbit debris surveillance
map,atmospheric re-entry
map,demisable tanks' re-entry
map,non-cooperative spacecraft
map,model-based approaches
map,model-based methods
map,impact-induced electrical anomalies
map,Low-Cost Deorbit System
map,tape-shaped tethers
map,self-repair
map,self-healing material
map,vision-based navigation
map,model-based process
...@@ -23,6 +23,7 @@ import Test.API.Private.Move qualified as Move ...@@ -23,6 +23,7 @@ import Test.API.Private.Move qualified as Move
import Test.API.Private.Remote qualified as Remote import Test.API.Private.Remote qualified as Remote
import Test.API.Private.Share qualified as Share import Test.API.Private.Share qualified as Share
import Test.API.Private.Table qualified as Table import Test.API.Private.Table qualified as Table
import Test.API.Private.List qualified as List
import Test.API.Routes (mkUrl, get_node, get_tree) import Test.API.Routes (mkUrl, get_node, get_tree)
import Test.API.Setup (withTestDBAndPort, dbEnvSetup, SpecContext (..)) import Test.API.Setup (withTestDBAndPort, dbEnvSetup, SpecContext (..))
import Test.Hspec import Test.Hspec
...@@ -114,3 +115,5 @@ tests = sequential $ do ...@@ -114,3 +115,5 @@ tests = sequential $ do
Move.tests Move.tests
describe "Remote API" $ do describe "Remote API" $ do
Remote.tests Remote.tests
describe "List API" $ do
List.tests
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Test.API.Private.List (
tests
) where
import Data.Aeson.QQ
import Data.Text.IO qualified as TIO
import Gargantext.API.Ngrams.List.Types
import Gargantext.API.Ngrams.Types qualified as APINgrams
import Gargantext.API.Node.Corpus.New.Types qualified as FType
import Gargantext.Core.Config
import Gargantext.Core.Types
import Gargantext.Core.Types.Individu
import Gargantext.Prelude
import Paths_gargantext
import Servant.Client.Streaming
import Test.API.Prelude (newCorpusForUser, checkEither)
import Test.API.Routes
import Test.API.Setup
import Test.Database.Types
import Test.Hspec (Spec, it, aroundAll, describe, sequential)
import Test.Hspec.Expectations
import Test.Hspec.Wai.Internal (withApplication)
import Test.Utils
import Fmt
tests :: Spec
tests = sequential $ aroundAll withTestDBAndPort $ do
describe "Prelude" $ do
it "setup DB triggers" $ \SpecContext{..} -> do
setupEnvironment _sctx_env
-- Let's create the Alice user.
void $ createAliceAndBob _sctx_env
describe "Importing terms as TSV" $ do
it "[#381] should work (and return a non-empty list of ngrams" $ \(SpecContext testEnv port app _) -> do
cId <- newCorpusForUser testEnv "alice"
let log_cfg = (test_config testEnv) ^. gc_logging
withApplication app $ do
withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
([listId] :: [NodeId]) <- protectedJSON token "POST" (mkUrl port ("/node/" <> build cId)) [aesonQQ|{"pn_typename":"NodeList","pn_name":"Testing"}|]
-- Upload the CSV doc
simpleNgrams <- liftIO (TIO.readFile =<< getDataFileName "test-data/issue-381/Termes_A_Ajouter_T4SC_Intellixir.tsv")
let params = WithTextFile { _wtf_filetype = FType.TSV
, _wtf_data = simpleNgrams
, _wtf_name = "simple.tsv" }
ji <- checkEither $ liftIO $ runClientM (add_tsv_to_list token listId params) clientEnv
_ <- pollUntilWorkFinished log_cfg port ji
-- Now check that we can retrieve the ngrams, and the ngrams list is not empty!
liftIO $ do
eRes <- checkEither $ runClientM (get_table_ngrams token cId APINgrams.Terms listId 50 Nothing (Just MapTerm) Nothing Nothing Nothing Nothing) clientEnv
let (APINgrams.NgramsTable terms) = APINgrams._vc_data eRes
length terms `shouldSatisfy` (>= 1)
...@@ -7,11 +7,11 @@ module Test.API.Private.Remote ( ...@@ -7,11 +7,11 @@ module Test.API.Private.Remote (
) where ) where
import Control.Lens import Control.Lens
import Gargantext.API.Admin.EnvTypes (Mode(..))
import Gargantext.API.Errors import Gargantext.API.Errors
import Gargantext.API (makeApp) import Gargantext.API (makeApp)
import Gargantext.API.Routes.Client (remoteExportClient) import Gargantext.API.Routes.Client (remoteExportClient)
import Gargantext.API.Routes.Named.Remote (RemoteExportRequest(..)) import Gargantext.API.Routes.Named.Remote (RemoteExportRequest(..))
import Gargantext.Core.Config
import Gargantext.Core.Types.Individu import Gargantext.Core.Types.Individu
import Gargantext.Core.Types (NodeId(UnsafeMkNodeId)) import Gargantext.Core.Types (NodeId(UnsafeMkNodeId))
import Gargantext.Prelude import Gargantext.Prelude
...@@ -32,10 +32,10 @@ withTwoServerInstances :: (SpecContext (TestEnv,Wai.Application,Warp.Port) -> IO ...@@ -32,10 +32,10 @@ withTwoServerInstances :: (SpecContext (TestEnv,Wai.Application,Warp.Port) -> IO
withTwoServerInstances action = withTwoServerInstances action =
withTestDB $ \testEnv1 -> do withTestDB $ \testEnv1 -> do
withTestDB $ \testEnv2 -> do withTestDB $ \testEnv2 -> do
garg1App <- withLoggerIO Mock $ \ioLogger -> do garg1App <- withLoggerIO (log_cfg testEnv1) $ \ioLogger -> do
env <- newTestEnv testEnv1 ioLogger server1Port env <- newTestEnv testEnv1 ioLogger server1Port
makeApp env makeApp env
garg2App <- withLoggerIO Mock $ \ioLogger -> do garg2App <- withLoggerIO (log_cfg testEnv2) $ \ioLogger -> do
env <- newTestEnv testEnv2 ioLogger server2Port env <- newTestEnv testEnv2 ioLogger server2Port
makeApp env makeApp env
...@@ -45,6 +45,7 @@ withTwoServerInstances action = ...@@ -45,6 +45,7 @@ withTwoServerInstances action =
where where
server1Port = 8008 server1Port = 8008
server2Port = 9008 server2Port = 9008
log_cfg te = (test_config te) ^. gc_logging
tests :: Spec tests :: Spec
tests = sequential $ aroundAll withTwoServerInstances $ do tests = sequential $ aroundAll withTwoServerInstances $ do
......
...@@ -20,7 +20,7 @@ import Control.Monad.Reader ...@@ -20,7 +20,7 @@ import Control.Monad.Reader
import Data.ByteString.Lazy.Char8 qualified as C8L import Data.ByteString.Lazy.Char8 qualified as C8L
import Data.Cache qualified as InMemory import Data.Cache qualified as InMemory
import Data.Streaming.Network (bindPortTCP) import Data.Streaming.Network (bindPortTCP)
import Gargantext.API.Admin.EnvTypes (Mode(Mock), Env (..), env_dispatcher) import Gargantext.API.Admin.EnvTypes (Env (..), env_dispatcher)
import Gargantext.API.Errors.Types import Gargantext.API.Errors.Types
import Gargantext.API (makeApp) import Gargantext.API (makeApp)
import Gargantext.API.Prelude import Gargantext.API.Prelude
...@@ -112,7 +112,7 @@ nc = NotificationsConfig { _nc_central_exchange_bind = "tcp://*:15560" ...@@ -112,7 +112,7 @@ nc = NotificationsConfig { _nc_central_exchange_bind = "tcp://*:15560"
withTestDBAndPort :: (SpecContext () -> IO ()) -> IO () withTestDBAndPort :: (SpecContext () -> IO ()) -> IO ()
withTestDBAndPort action = withTestDB $ \testEnv -> do withTestDBAndPort action = withTestDB $ \testEnv -> do
withNotifications (cfg testEnv) $ \dispatcher -> do withNotifications (cfg testEnv) $ \dispatcher -> do
withLoggerIO Mock $ \ioLogger -> do withLoggerIO (log_cfg testEnv) $ \ioLogger -> do
env <- newTestEnv testEnv ioLogger 8080 env <- newTestEnv testEnv ioLogger 8080
<&> env_dispatcher .~ dispatcher <&> env_dispatcher .~ dispatcher
app <- makeApp env app <- makeApp env
...@@ -147,11 +147,11 @@ withTestDBAndPort action = withTestDB $ \testEnv -> do ...@@ -147,11 +147,11 @@ withTestDBAndPort action = withTestDB $ \testEnv -> do
withBackendServerAndProxy :: (((TestEnv, Warp.Port, Warp.Port)) -> IO ()) -> IO () withBackendServerAndProxy :: (((TestEnv, Warp.Port, Warp.Port)) -> IO ()) -> IO ()
withBackendServerAndProxy action = withBackendServerAndProxy action =
withTestDB $ \testEnv -> do withTestDB $ \testEnv -> do
gargApp <- withLoggerIO Mock $ \ioLogger -> do gargApp <- withLoggerIO (log_cfg testEnv) $ \ioLogger -> do
env <- newTestEnv testEnv ioLogger 8080 env <- newTestEnv testEnv ioLogger 8080
makeApp env makeApp env
proxyCache <- InMemory.newCache Nothing proxyCache <- InMemory.newCache Nothing
proxyApp <- withLoggerIO Mock $ \ioLogger -> do proxyApp <- withLoggerIO (log_cfg testEnv) $ \ioLogger -> do
env <- newTestEnv testEnv ioLogger 8080 env <- newTestEnv testEnv ioLogger 8080
pure $ microServicesProxyApp proxyCache env pure $ microServicesProxyApp proxyCache env
...@@ -160,6 +160,8 @@ withBackendServerAndProxy action = ...@@ -160,6 +160,8 @@ withBackendServerAndProxy action =
action (testEnv, serverPort, proxyPort) action (testEnv, serverPort, proxyPort)
where where
proxyPort = 8090 proxyPort = 8090
cfg te = test_config te
log_cfg te = (cfg te) ^. gc_logging
setupEnvironment :: TestEnv -> IO () setupEnvironment :: TestEnv -> IO ()
setupEnvironment env = flip runReaderT env $ runTestMonad $ do setupEnvironment env = flip runReaderT env $ runTestMonad $ do
......
...@@ -18,7 +18,6 @@ import Database.PostgreSQL.Simple qualified as PG ...@@ -18,7 +18,6 @@ import Database.PostgreSQL.Simple qualified as PG
import Database.PostgreSQL.Simple.Options qualified as Client import Database.PostgreSQL.Simple.Options qualified as Client
import Database.PostgreSQL.Simple.Options qualified as Opts import Database.PostgreSQL.Simple.Options qualified as Opts
import Database.Postgres.Temp qualified as Tmp import Database.Postgres.Temp qualified as Tmp
import Gargantext.API.Admin.EnvTypes (Mode(Mock))
import Gargantext.Core.Config import Gargantext.Core.Config
import Gargantext.Core.Config.Types (SettingsFile(..)) import Gargantext.Core.Config.Types (SettingsFile(..))
import Gargantext.Core.Config.Utils (readConfig) import Gargantext.Core.Config.Utils (readConfig)
...@@ -88,6 +87,7 @@ setup = do ...@@ -88,6 +87,7 @@ setup = do
<&> (gc_worker . wsDatabase .~ (connInfo { PG.connectDatabase = "pgmq_test" })) <&> (gc_worker . wsDatabase .~ (connInfo { PG.connectDatabase = "pgmq_test" }))
-- putText $ "[setup] database: " <> show (gargConfig ^. gc_database_config) -- putText $ "[setup] database: " <> show (gargConfig ^. gc_database_config)
-- putText $ "[setup] worker db: " <> show (gargConfig ^. gc_worker . wsDatabase) -- putText $ "[setup] worker db: " <> show (gargConfig ^. gc_worker . wsDatabase)
let log_cfg = gargConfig ^. gc_logging
let idleTime = 60.0 let idleTime = 60.0
let maxResources = 2 let maxResources = 2
let poolConfig = defaultPoolConfig (PG.connectPostgreSQL (Tmp.toConnectionString db)) let poolConfig = defaultPoolConfig (PG.connectPostgreSQL (Tmp.toConnectionString db))
...@@ -98,7 +98,7 @@ setup = do ...@@ -98,7 +98,7 @@ setup = do
bootstrapDB db pool gargConfig bootstrapDB db pool gargConfig
ugen <- emptyCounter ugen <- emptyCounter
test_nodeStory <- fromDBNodeStoryEnv pool test_nodeStory <- fromDBNodeStoryEnv pool
withLoggerIO Mock $ \logger -> do withLoggerIO log_cfg $ \logger -> do
let wPoolConfig = defaultPoolConfig (PG.connectPostgreSQL (Tmp.toConnectionString db)) let wPoolConfig = defaultPoolConfig (PG.connectPostgreSQL (Tmp.toConnectionString db))
PG.close PG.close
...@@ -107,7 +107,7 @@ setup = do ...@@ -107,7 +107,7 @@ setup = do
wPool <- newPool (setNumStripes (Just 2) wPoolConfig) wPool <- newPool (setNumStripes (Just 2) wPoolConfig)
wNodeStory <- fromDBNodeStoryEnv wPool wNodeStory <- fromDBNodeStoryEnv wPool
_w_env_job_state <- newTVarIO Nothing _w_env_job_state <- newTVarIO Nothing
withLoggerIO Mock $ \wioLogger -> do withLoggerIO log_cfg $ \wioLogger -> do
let wEnv = WorkerEnv { _w_env_config = gargConfig let wEnv = WorkerEnv { _w_env_config = gargConfig
, _w_env_logger = wioLogger , _w_env_logger = wioLogger
, _w_env_pool = wPool , _w_env_pool = wPool
......
...@@ -22,11 +22,9 @@ import Control.Monad.Trans.Control ...@@ -22,11 +22,9 @@ import Control.Monad.Trans.Control
import Data.IORef import Data.IORef
import Data.Map qualified as Map import Data.Map qualified as Map
import Data.Pool import Data.Pool
import Data.Text qualified as T
import Database.PostgreSQL.Simple qualified as PG import Database.PostgreSQL.Simple qualified as PG
import Database.Postgres.Temp qualified as Tmp import Database.Postgres.Temp qualified as Tmp
import Gargantext hiding (to) import Gargantext hiding (to)
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Orchestrator.Types import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Errors.Types import Gargantext.API.Errors.Types
import Gargantext.API.Prelude import Gargantext.API.Prelude
...@@ -36,6 +34,7 @@ import Gargantext.Core.Mail.Types (HasMail(..)) ...@@ -36,6 +34,7 @@ import Gargantext.Core.Mail.Types (HasMail(..))
import Gargantext.Core.NLP (HasNLPServer(..)) import Gargantext.Core.NLP (HasNLPServer(..))
import Gargantext.Core.NodeStory import Gargantext.Core.NodeStory
import Gargantext.System.Logging (HasLogger(..), Logger, MonadLogger(..)) import Gargantext.System.Logging (HasLogger(..), Logger, MonadLogger(..))
import Gargantext.System.Logging.Loggers
import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..)) import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
import Network.URI (parseURI) import Network.URI (parseURI)
import Prelude qualified import Prelude qualified
...@@ -132,22 +131,11 @@ instance MonadLogger (GargM TestEnv BackendInternalError) where ...@@ -132,22 +131,11 @@ instance MonadLogger (GargM TestEnv BackendInternalError) where
getLogger = asks test_logger getLogger = asks test_logger
instance HasLogger (GargM TestEnv BackendInternalError) where instance HasLogger (GargM TestEnv BackendInternalError) where
data instance Logger (GargM TestEnv BackendInternalError) = newtype instance Logger (GargM TestEnv BackendInternalError) =
GargTestLogger { GargTestLogger { _GargTestLogger :: MonadicStdLogger FL.LogStr IO }
test_logger_mode :: Mode type instance LogInitParams (GargM TestEnv BackendInternalError) = LogConfig
, test_logger_set :: FL.LoggerSet
}
type instance LogInitParams (GargM TestEnv BackendInternalError) = Mode
type instance LogPayload (GargM TestEnv BackendInternalError) = FL.LogStr type instance LogPayload (GargM TestEnv BackendInternalError) = FL.LogStr
initLogger mode = do initLogger cfg = fmap GargTestLogger $ (liftIO $ monadicStdLogger cfg)
test_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize destroyLogger = liftIO . _msl_destroy . _GargTestLogger
pure $ GargTestLogger mode test_logger_set logMsg (GargTestLogger ioLogger) lvl msg = liftIO $ _msl_log_msg ioLogger lvl msg
destroyLogger GargTestLogger{..} = liftIO $ FL.rmLoggerSet test_logger_set logTxt (GargTestLogger ioLogger) lvl msg = liftIO $ _msl_log_txt ioLogger lvl msg
logMsg (GargTestLogger mode logger_set) lvl msg = do
cfg <- view hasConfig
let minLvl = cfg ^. gc_logging . lc_log_level
when (lvl >= minLvl) $ do
let pfx = "[" <> show lvl <> "] " :: Text
when (lvl `elem` (modeToLoggingLevels mode)) $
liftIO $ FL.pushLogStrLn logger_set $ FL.toLogStr pfx <> msg
logTxt lgr lvl msg = logMsg lgr lvl (FL.toLogStr $ T.unpack msg)
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