Skip to content

haskell-gargantext
haskell-gargantext
Commit c8a05344 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

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

parents 047df32b 333bfac9
Hide whitespace changes
Inline Side-by-side
Showing with 489 additions and 362 deletions
bin/gargantext-cli/CLI/Ini.hs
View file @ c8a05344
......@@ -19,17 +19,17 @@ Import a corpus binary.
module CLI.Ini where
import CLI.Types
import Control.Monad.Logger (LogLevel(LevelDebug))
import Data.Text qualified as T
import Data.Text.IO qualified as T (writeFile)
import Database.PostgreSQL.Simple qualified as PGS
import Gargantext.Core.Config qualified as Config
import Data.Text.IO qualified as T (writeFile)
import Data.Text qualified as T
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 qualified as Config
import Gargantext.Core.Config.Types qualified as CTypes
import Gargantext.Core.Config.Worker (WorkerSettings(..), WorkerDefinition(..))
import Gargantext.Prelude
import Gargantext.System.Logging (LogLevel(..))
import Options.Applicative
import Servant.Client.Core (parseBaseUrl)
import Toml qualified
......@@ -87,7 +87,10 @@ convertConfigs ini@(Ini.GargConfig { .. }) iniMail nlpConfig connInfo =
, _wsDefaultVisibilityTimeout = 1
, _wsDefaultDelay = 0
, _wsDatabase = connInfo { PGS.connectDatabase = "pgmq"} }
, _gc_log_level = LevelDebug
, _gc_logging = Config.LogConfig {
_lc_log_level = INFO
, _lc_log_file = Nothing
}
}
where
_ac_scrapyd_url =
......
bin/gargantext-cli/CLI/Server.hs
View file @ c8a05344
......@@ -12,31 +12,39 @@ Portability : POSIX
module CLI.Server where
import Data.Version (showVersion)
import CLI.Parsers (settings_p)
import CLI.Types
import CLI.Worker (runAllWorkers)
import GHC.IO.Encoding (setLocaleEncoding, utf8)
import Gargantext.API (startGargantext)
import Control.Monad.IO.Class
import Data.Version (showVersion)
import Gargantext.API.Admin.EnvTypes (Mode(..))
import Gargantext.API (startGargantext)
import Gargantext.Core.Config
import Gargantext.Core.Config.Types (_SettingsFile)
import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.Prelude
import Gargantext.System.Logging (withLogger, logMsg, LogLevel(..), Logger)
import Gargantext.System.Logging
import GHC.IO.Encoding (setLocaleEncoding, utf8)
import Options.Applicative
import Paths_gargantext qualified as PG -- cabal magic build module
withServerCLILogger :: ServerArgs
-> (Logger IO -> IO a)
-> IO a
withServerCLILogger ServerArgs{..} f = do
cfg <- liftIO $ readConfig server_toml
withLogger (cfg ^. gc_logging) $ \logger -> f logger
serverCLI :: CLIServer -> IO ()
serverCLI (CLIS_start serverArgs) = withLogger () $ \ioLogger ->
serverCLI (CLIS_start serverArgs) = withServerCLILogger serverArgs $ \ioLogger ->
startServerCLI ioLogger serverArgs
serverCLI (CLIS_startAll serverArgs@(ServerArgs { .. })) = withLogger () $ \ioLogger -> do
serverCLI (CLIS_startAll serverArgs@(ServerArgs { .. })) = withServerCLILogger serverArgs $ \ioLogger -> do
withAsync (startServerCLI ioLogger serverArgs) $ \aServer -> do
runAllWorkers ioLogger server_toml
wait aServer
serverCLI (CLIS_version) = withLogger () $ \ioLogger -> do
serverCLI (CLIS_version) = withLogger (LogConfig Nothing DEBUG) $ \ioLogger -> do
-- Sets the locale to avoid encoding issues like in #284.
setLocaleEncoding utf8
logMsg ioLogger INFO $ "Version: " <> showVersion PG.version
......@@ -58,13 +66,13 @@ serverParser = hsubparser (
start_p :: Parser CLIServer
start_p = fmap CLIS_start $ ServerArgs
<$> mode_p
<$> mode_p
<*> port_p
<*> settings_p
start_all_p :: Parser CLIServer
start_all_p = fmap CLIS_startAll $ ServerArgs
<$> mode_p
<$> mode_p
<*> port_p
<*> settings_p
......@@ -81,7 +89,7 @@ port_p = option auto ( long "port"
<> showDefault
<> value 8008
<> help "Port" )
version_p :: Parser CLIServer
version_p = pure CLIS_version
......
bin/gargantext-cli/CLI/Worker.hs
View file @ c8a05344
......@@ -19,7 +19,7 @@ import CLI.Parsers
import Control.Concurrent.Async (forConcurrently_)
import Data.List qualified as List (cycle, concat, take)
import Data.Text qualified as T
import Gargantext.Core.Config (hasConfig, gc_worker)
import Gargantext.Core.Config (hasConfig, gc_worker, gc_logging)
import Gargantext.Core.Config.Types (SettingsFile(..))
import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.Core.Config.Worker (WorkerDefinition(..), WorkerSettings(..), findDefinitionByName)
......@@ -67,8 +67,9 @@ workerCLI (CLIW_run (WorkerArgs { .. })) = do
withPGMQWorkerCtrlC env wd $ \a _state -> do
-- _ <- runReaderT (sendJob Ping) env
wait a
workerCLI (CLIW_runAll (WorkerAllArgs { .. })) = withLogger () $ \ioLogger -> do
runAllWorkers ioLogger worker_toml
workerCLI (CLIW_runAll (WorkerAllArgs { .. })) = withWorkerEnv worker_toml $ \env -> do
let log_cfg = env ^. hasConfig . gc_logging
withLogger log_cfg $ \ioLogger -> runAllWorkers ioLogger worker_toml
workerCLI (CLIW_stats (WorkerStatsArgs { .. })) = do
putStrLn ("worker toml: " <> _SettingsFile ws_toml)
......
gargantext-settings.toml_toModify
View file @ c8a05344
......@@ -102,7 +102,7 @@ pass = PASSWORD_TO_CHANGE
[logs]
log_file = "/var/log/gargantext/backend.log"
log_level = "LevelDebug"
log_level = "info"
log_formatter = "verbose"
......
gargantext.cabal
View file @ c8a05344
......@@ -97,7 +97,7 @@ flag test-crypto
-- debug output for the phylo code, so that it doesn't
-- hinder its performance.
flag no-phylo-debug-logs
default: False
default: True
manual: True
flag enable-benchmarks
......@@ -308,6 +308,7 @@ library
Gargantext.Orphans.Accelerate
Gargantext.Orphans.OpenAPI
Gargantext.System.Logging
Gargantext.System.Logging.Types
Gargantext.Utils.Dict
Gargantext.Utils.Jobs.Error
Gargantext.Utils.Jobs.Monad
......@@ -695,7 +696,6 @@ executable gargantext
, gargantext-prelude
, haskell-bee
, MonadRandom ^>= 0.6
, monad-logger ^>= 0.3.36
, optparse-applicative
, postgresql-simple >= 0.6.4 && <= 0.7.0.0
, servant >= 0.20.1 && < 0.21
......
hie.yaml
View file @ c8a05344
......@@ -4,61 +4,61 @@ cradle:
component: "lib:gargantext"
- path: "./bin/gargantext-cli/Main.hs"
component: "gargantext:exe:gargantext-cli"
component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Admin.hs"
component: "gargantext:exe:gargantext-cli"
component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/FileDiff.hs"
component: "gargantext:exe:gargantext-cli"
component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/FilterTermsAndCooc.hs"
component: "gargantext:exe:gargantext-cli"
component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Import.hs"
component: "gargantext:exe:gargantext-cli"
component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Ini.hs"
component: "gargantext:exe:gargantext-cli"
component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Init.hs"
component: "gargantext:exe:gargantext-cli"
component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Invitations.hs"
component: "gargantext:exe:gargantext-cli"
component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/ObfuscateDB.hs"
component: "gargantext:exe:gargantext-cli"
component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Parsers.hs"
component: "gargantext:exe:gargantext-cli"
component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Phylo.hs"
component: "gargantext:exe:gargantext-cli"
component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Phylo/Common.hs"
component: "gargantext:exe:gargantext-cli"
component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Phylo/Profile.hs"
component: "gargantext:exe:gargantext-cli"
component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Server/Routes.hs"
component: "gargantext:exe:gargantext-cli"
component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Types.hs"
component: "gargantext:exe:gargantext-cli"
component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Upgrade.hs"
component: "gargantext:exe:gargantext-cli"
component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/Paths_gargantext.hs"
component: "gargantext:exe:gargantext-cli"
component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-server/Main.hs"
component: "gargantext:exe:gargantext-server"
component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-server/Paths_gargantext.hs"
component: "gargantext:exe:gargantext-server"
component: "gargantext:exe:gargantext"
- path: "./test"
component: "gargantext:test:garg-test-tasty"
......
src/Gargantext/API.hs
View file @ c8a05344
......@@ -48,14 +48,14 @@ import Gargantext.API.Middleware (logStdoutDevSanitised)
import Gargantext.API.Routes.Named (API)
import Gargantext.API.Routes.Named.EKG (EkgAPI)
import Gargantext.API.Server.Named (server)
import Gargantext.Core.Config (gc_notifications_config, gc_frontend_config)
import Gargantext.Core.Config
import Gargantext.Core.Config.Types (CORSOrigin(..), CORSSettings, MicroServicesProxyStatus(..), NotificationsConfig(..), PortNumber, SettingsFile(..), corsAllowedOrigins, fc_appPort, fc_cors, fc_cookie_settings, microServicesProxyStatus)
import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.Core.Notifications (withNotifications)
import Gargantext.Database.Prelude qualified as DB
import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp)
import Gargantext.Prelude hiding (putStrLn, to)
import Gargantext.System.Logging (withLoggerHoisted)
import Gargantext.System.Logging (withLoggerIO, renderLogLevel)
import Network.HTTP.Types hiding (Query)
import Network.Wai (Middleware, Request, requestHeaders)
import Network.Wai.Handler.Warp hiding (defaultSettings)
......@@ -70,21 +70,20 @@ import System.Cron.Schedule qualified as Cron
-- | startGargantext takes as parameters port number and Toml file.
startGargantext :: Mode -> PortNumber -> SettingsFile -> IO ()
startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerHoisted mode $ \logger -> do
startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerIO mode $ \logger -> do
config <- readConfig sf <&> (gc_frontend_config . fc_appPort) .~ port
when (port /= config ^. gc_frontend_config . fc_appPort) $
panicTrace "TODO: conflicting settings of port"
let nc = config ^. gc_notifications_config
withNotifications nc $ \dispatcher -> do
withNotifications config $ \dispatcher -> do
env <- newEnv logger config dispatcher
let fc = env ^. env_config . gc_frontend_config
let proxyStatus = microServicesProxyStatus fc
runDbCheck env
portRouteInfo nc port proxyStatus
startupInfo config port proxyStatus
app <- makeApp env
mid <- makeGargMiddleware (fc ^. fc_cors) mode
periodicActions <- schedulePeriodicActions env
let runServer = run port (mid app) `finally` stopGargantext periodicActions
case proxyStatus of
PXY_disabled
......@@ -94,7 +93,7 @@ startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerHoisted mod
proxyCache <- InMemory.newCache (Just oneHour)
let runProxy = run proxyPort (mid (microServicesProxyApp proxyCache env))
Async.race_ runServer runProxy
where runDbCheck env = do
r <- runExceptT (runReaderT DB.dbCheck env) `catch`
(\(err :: SomeException) -> pure $ Left err)
......@@ -106,11 +105,12 @@ startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerHoisted mod
Left err -> panicTrace $ "Unexpected exception:" <> show err
oneHour = Clock.fromNanoSecs 3600_000_000_000
portRouteInfo :: NotificationsConfig -> PortNumber -> MicroServicesProxyStatus -> IO ()
portRouteInfo nc mainPort proxyStatus = do
startupInfo :: GargConfig -> PortNumber -> MicroServicesProxyStatus -> IO ()
startupInfo config mainPort proxyStatus = do
putStrLn "=========================================================================================================="
putStrLn " GarganText Main Routes"
putStrLn " GarganText Server"
putStrLn "=========================================================================================================="
putStrLn $ " - Log Level ...............................: " <> renderLogLevel ll
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"
......@@ -121,6 +121,8 @@ portRouteInfo nc mainPort proxyStatus = do
putStrLn $ " - WebSocket address........................: " <> "ws://localhost:" <> toUrlPiece mainPort <> "/ws"
putStrLn "=========================================================================================================="
where
nc = config ^. gc_notifications_config
ll = config ^. gc_logging . lc_log_level
renderProxyStatus = case proxyStatus of
PXY_disabled ->
" - Microservices proxy .....................: DISABLED (enable in gargantext-settings.toml)"
......
src/Gargantext/API/Admin/EnvTypes.hs
View file @ c8a05344
......@@ -25,7 +25,7 @@ module Gargantext.API.Admin.EnvTypes (
, env_jwt_settings
, env_pool
, env_nodeStory
, menv_firewall
, dev_env_logger
......@@ -43,7 +43,7 @@ import Database.PostgreSQL.Simple (Connection)
import Gargantext.API.Admin.Orchestrator.Types (JobLog, noJobLog)
import Gargantext.API.Errors.Types (BackendInternalError)
import Gargantext.API.Prelude (GargM, IsGargServer)
import Gargantext.Core.Config (GargConfig(..), gc_mail_config, gc_nlp_config, HasJWTSettings(..), HasConfig(..), HasManager(..))
import Gargantext.Core.Config (GargConfig(..), gc_mail_config, gc_nlp_config, HasJWTSettings(..), HasConfig(..), HasManager(..), gc_logging, lc_log_level)
import Gargantext.Core.Mail.Types (HasMail, mailSettings)
import Gargantext.Core.NLP (HasNLPServer(..), nlpServerMap)
import Gargantext.Core.NodeStory
......@@ -73,28 +73,6 @@ modeToLoggingLevels = \case
-- For production, accepts everything but DEBUG.
Prod -> [minBound .. maxBound] \\ [DEBUG]
instance MonadLogger (GargM Env BackendInternalError) where
getLogger = asks _env_logger
instance HasLogger (GargM Env BackendInternalError) where
data instance Logger (GargM Env BackendInternalError) =
GargLogger {
logger_mode :: Mode
, logger_set :: FL.LoggerSet
}
type instance LogInitParams (GargM Env BackendInternalError) = Mode
type instance LogPayload (GargM Env BackendInternalError) = FL.LogStr
initLogger mode = do
logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
pure $ GargLogger mode logger_set
destroyLogger (GargLogger{..}) = liftIO $ FL.rmLoggerSet logger_set
logMsg (GargLogger 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)
-- Do /not/ treat the data types of this type as strict, because it's convenient
-- to be able to partially initialise things like an 'Env' during tests, without
-- having to specify /everything/. This means that when we /construct/ an 'Env',
......@@ -142,7 +120,7 @@ instance HasDispatcher Env Dispatcher where
instance CET.HasCentralExchangeNotification Env where
ce_notify m = do
c <- asks (view env_config)
liftBase $ CE.notify (_gc_notifications_config c) m
liftBase $ CE.notify c m
instance HasManager Env where
gargHttpManager = env_manager
......@@ -190,7 +168,7 @@ makeLenses ''DevEnv
instance CET.HasCentralExchangeNotification DevEnv where
ce_notify m = do
nc <- asks (view dev_env_config)
liftBase $ CE.notify (_gc_notifications_config nc) m
liftBase $ CE.notify nc m
-- | Our /mock/ job handle.
data DevJobHandle = DevJobHandle
......@@ -244,5 +222,28 @@ instance HasManager DevEnv where
instance HasNLPServer DevEnv where
nlpServer = dev_env_config . gc_nlp_config . (to nlpServerMap)
instance IsGargServer Env BackendInternalError (GargM Env BackendInternalError)
instance HasLogger (GargM Env BackendInternalError) where
data instance Logger (GargM Env BackendInternalError) =
GargLogger {
logger_mode :: Mode
, logger_set :: FL.LoggerSet
}
type instance LogInitParams (GargM Env BackendInternalError) = Mode
type instance LogPayload (GargM Env BackendInternalError) = FL.LogStr
initLogger mode = do
logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
pure $ GargLogger mode logger_set
destroyLogger (GargLogger{..}) = liftIO $ FL.rmLoggerSet logger_set
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
getLogger = asks _env_logger
src/Gargantext/API/Admin/Settings.hs
View file @ c8a05344
......@@ -62,7 +62,7 @@ settingsFromEnvironment =
Settings <$> (encodeUtf8 <$> reqSetting "ALLOWED_ORIGIN")
<*> (encodeUtf8 <$> reqSetting "ALLOWED_HOST")
<*> optSetting "PORT" 3000
<*> (parseLogLevel <$> optSetting "LOG_LEVEL" "warn")
<*> (parseLogLevel <$> optSetting "GGTX_LOG_LEVEL" "warn")
<*> reqSetting "DB_SERVER"
<*> (parseJwk <$> reqSetting "JWT_SECRET")
<*> optSetting "SEND_EMAIL" SendEmailViaAws
......
src/Gargantext/API/Dev.hs
View file @ c8a05344
......@@ -26,13 +26,13 @@ import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
import Gargantext.Database.Prelude (Cmd, CmdRandom, connPool, runCmd)
import Gargantext.Prelude
import Gargantext.System.Logging ( withLoggerHoisted )
import Gargantext.System.Logging ( withLoggerIO )
import Network.HTTP.Client.TLS (newTlsManager)
import Servant ( ServerError )
-------------------------------------------------------------------
withDevEnv :: SettingsFile -> (DevEnv -> IO a) -> IO a
withDevEnv settingsFile k = withLoggerHoisted Dev $ \logger -> do
withDevEnv settingsFile k = withLoggerIO Dev $ \logger -> do
env <- newDevEnv logger
k env -- `finally` cleanEnv env
......
src/Gargantext/API/Ngrams.hs
View file @ c8a05344
......@@ -21,6 +21,7 @@ add get
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
......@@ -84,13 +85,13 @@ module Gargantext.API.Ngrams
import Control.Lens (view, (^..), (+~), (%~), msumOf, at, ix, _Just, Each(..), (%%~), ifolded, to, withIndex, over)
import Data.Aeson.Text qualified as DAT
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Map.Strict.Patch qualified as PM
import Data.Map.Strict qualified as Map
import Data.Patch.Class (Action(act), Transformable(..), ours)
import Data.Set qualified as Set
import Data.Text (isInfixOf, toLower, unpack)
import Data.Text.Lazy.IO as DTL ( writeFile )
import Formatting (hprint, int, (%))
import Formatting (sformat, int, (%))
import Gargantext.API.Ngrams.Tools (getNodeStory)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.NodeStory (ArchiveList, HasNodeStory, HasNodeArchiveStoryImmediateSaver(..), HasNodeStoryImmediateSaver(..), NgramsStatePatch', a_history, a_state, a_version, currentVersion)
......@@ -99,8 +100,9 @@ import Gargantext.Core.Types (ListType(..), NodeId, ListId, TODO, assertValid, H
import Gargantext.Core.Types.Query (Limit(..), Offset(..), MinSize(..), MaxSize(..))
import Gargantext.Database.Action.Metrics.NgramsByContext (getOccByNgramsOnlyFast)
import Gargantext.Database.Query.Table.Ngrams ( text2ngrams, insertNgrams )
import Gargantext.Prelude hiding (log, to, toLower, (%), isInfixOf)
import Gargantext.Prelude.Clock (hasTime, getTime)
import Gargantext.Prelude hiding (log, to, toLower, (%), isInfixOf)
import Gargantext.System.Logging
import Text.Collate qualified as Unicode
......@@ -517,7 +519,9 @@ unicodeDUCETSorter :: Text -> Text -> Ordering
unicodeDUCETSorter = Unicode.collate Unicode.rootCollator
getTableNgrams :: forall env err m.
( HasNodeStory env err m )
( HasNodeStory env err m
, MonadLogger m
)
=> NodeId
-> ListId
-> TabType
......@@ -531,7 +535,9 @@ getTableNgrams nodeId listId tabType searchQuery = do
-- | Helper function to get the ngrams table with scores.
getNgramsTable' :: forall env err m.
( HasNodeStory env err m )
( HasNodeStory env err m
, MonadLogger m
)
=> NodeId
-> ListId
-> NgramsType
......@@ -544,7 +550,9 @@ getNgramsTable' nId listId ngramsType = do
-- | Helper function to set scores on an `NgramsTable`.
setNgramsTableScores :: forall env err m t.
( Each t t NgramsElement NgramsElement
, HasNodeStory env err m )
, HasNodeStory env err m
, MonadLogger m
)
=> NodeId
-> ListId
-> NgramsType
......@@ -555,12 +563,9 @@ setNgramsTableScores nId listId ngramsType table = do
occurrences <- getOccByNgramsOnlyFast nId listId ngramsType
--printDebug "[setNgramsTableScores] occurrences" occurrences
t2 <- getTime
liftBase $ do
let ngrams_terms = table ^.. each . ne_ngrams
-- printDebug "ngrams_terms" ngrams_terms
hprint stderr
("getTableNgrams/setScores #ngrams=" % int % " time=" % hasTime % "\n")
(length ngrams_terms) t1 t2
let ngrams_terms = table ^.. each . ne_ngrams
$(logLocM) DEBUG $ "ngrams_terms: " <> show ngrams_terms
$(logLocM) DEBUG $ sformat ("getTableNgrams/setScores #ngrams=" % int % " time=" % hasTime % "\n") (length ngrams_terms) t1 t2
let
setOcc ne = ne & ne_occurrences .~ Set.fromList (msumOf (ix (ne ^. ne_ngrams)) occurrences)
......@@ -580,7 +585,7 @@ needsScores (Just ScoreAsc) = True
needsScores (Just ScoreDesc) = True
needsScores _ = False
getTableNgramsCorpus :: ( HasNodeStory env err m )
getTableNgramsCorpus :: ( HasNodeStory env err m, MonadLogger m )
=> NodeId
-> TabType
-> ListId
......
src/Gargantext/API/Server/Named/Ngrams.hs
View file @ c8a05344
......@@ -9,8 +9,8 @@ module Gargantext.API.Server.Named.Ngrams (
import Control.Lens ((%%~))
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Gargantext.API.Admin.Auth (withNamedAccess)
import Gargantext.API.Admin.Auth.Types (AuthenticatedUser, PathId (..))
import Gargantext.API.Admin.Auth (withNamedAccess)
import Gargantext.API.Admin.EnvTypes (Env)
import Gargantext.API.Errors.Types (BackendInternalError)
import Gargantext.API.Metrics qualified as Metrics
......@@ -25,11 +25,12 @@ import Gargantext.Core.Types.Query (Limit(..), Offset(..))
import Gargantext.Core.Worker.Jobs.Types qualified as Jobs
import Gargantext.Database.Admin.Config (userMaster)
import Gargantext.Database.Query.Table.Ngrams ( selectNgramsByDoc )
import Gargantext.Database.Query.Table.Node (getNode)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node (getNode)
import Gargantext.Database.Query.Table.Node.Select ( selectNodesWithUsername )
import Gargantext.Database.Schema.Node (node_id, node_parent_id, node_user_id)
import Gargantext.Prelude
import Gargantext.System.Logging
import Gargantext.Utils.Jobs.Monad (JobHandle, MonadJobStatus(..), markFailedNoErr)
import Servant.Server.Generic (AsServerT)
......@@ -150,7 +151,7 @@ tableNgramsPostChartsAsync utn jobHandle = do
-}
scoresRecomputeTableNgrams :: forall env err m.
( HasNodeStory env err m, HasNodeError err )
( HasNodeStory env err m, HasNodeError err, MonadLogger m )
=> NodeId -> TabType -> ListId -> m Int
scoresRecomputeTableNgrams nId tabType listId = do
tableMap <- getNgramsTableMap listId ngramsType
......@@ -163,7 +164,9 @@ scoresRecomputeTableNgrams nId tabType listId = do
-- | Text search is deactivated for now for ngrams by doc only
getTableNgramsDoc :: ( HasNodeStory env err m
, HasNodeError err )
, HasNodeError err
, MonadLogger m
)
=> DocId -> TabType
-> ListId -> Limit -> Maybe Offset
-> Maybe ListType
......
src/Gargantext/API/Worker.hs
View file @ c8a05344
......@@ -36,7 +36,7 @@ serveWorkerAPI f = WorkerAPI { workerAPIPost }
where
workerAPIPost i = do
let job = f i
logM DDEBUG $ "[serveWorkerAPI] sending job " <> show job
logM DEBUG $ "[serveWorkerAPI] sending job " <> show job
mId <- sendJob job
pure $ JobInfo { _ji_message_id = mId
, _ji_mNode_id = getWorkerMNodeId job }
......@@ -54,4 +54,4 @@ serveWorkerAPIEJob f = WorkerAPI { workerAPIPost }
mId <- sendJob job
pure $ JobInfo { _ji_message_id = mId
, _ji_mNode_id = getWorkerMNodeId job }
src/Gargantext/Core/Config.hs
View file @ c8a05344
......@@ -12,10 +12,12 @@ Configuration for the gargantext server
-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE LambdaCase #-}
module Gargantext.Core.Config (
-- * Types
GargConfig(..)
, LogConfig(..)
-- * Lenses
, gc_datafilepath
......@@ -29,7 +31,9 @@ module Gargantext.Core.Config (
, gc_secrets
, gc_apis
, gc_worker
, gc_log_level
, gc_logging
, lc_log_level
, lc_log_file
, mkProxyUrl
......@@ -39,24 +43,43 @@ module Gargantext.Core.Config (
) where
import Control.Lens (Getter)
import Control.Monad.Logger (LogLevel(LevelDebug))
import Data.Text as T
import Gargantext.System.Logging.Types (LogLevel, parseLogLevel)
import Database.PostgreSQL.Simple qualified as PSQL
import Data.Text as T
import Gargantext.Core.Config.Mail (MailConfig)
import Gargantext.Core.Config.NLP (NLPConfig)
import Gargantext.Core.Config.Worker (WorkerSettings)
import Gargantext.Core.Config.Types
import Gargantext.Core.Config.Worker (WorkerSettings)
import Gargantext.Prelude
import Network.HTTP.Client qualified as HTTP
import Servant.Auth.Server (JWTSettings)
import Servant.Client (BaseUrl(..), Scheme(Http), parseBaseUrl)
import Toml.Schema
import Toml.Schema.FromValue (typeError)
-- | 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 LogConfig = LogConfig
{ _lc_log_file :: Maybe FilePath
, _lc_log_level :: !LogLevel
} deriving Show
instance FromValue LogConfig where
fromValue = parseTableFromValue $ do
_lc_log_file <- optKey "log_file"
_lc_log_level <- reqKeyOf "log_level" parse_log_level
pure LogConfig{..}
parse_log_level :: Value' l -> Matcher l LogLevel
parse_log_level = \case
Text' a txt -> case parseLogLevel txt of
Left err -> typeError (T.unpack err) (Text' a txt)
Right ll -> pure ll
xs -> typeError "parse_log_level" xs
-- Non-strict data so that we can use it in tests
data GargConfig = GargConfig { _gc_datafilepath :: ~FilePath
-- , _gc_repofilepath :: ~FilePath
......@@ -70,12 +93,10 @@ data GargConfig = GargConfig { _gc_datafilepath :: ~FilePath
, _gc_secrets :: ~SecretsConfig
, _gc_apis :: ~APIsConfig
, _gc_worker :: ~WorkerSettings
, _gc_log_level :: ~LogLevel
, _gc_logging :: ~LogConfig
}
deriving (Generic, Show)
makeLenses ''GargConfig
instance FromValue GargConfig where
fromValue = parseTableFromValue $ do
_gc_frontend_config <- reqKey "frontend"
......@@ -89,7 +110,7 @@ instance FromValue GargConfig where
_gc_apis <- reqKey "apis"
_gc_notifications_config <- reqKey "notifications"
_gc_worker <- reqKey "worker"
let _gc_log_level = LevelDebug
_gc_logging <- reqKey "logs"
return $ GargConfig { _gc_datafilepath
, _gc_jobs
, _gc_apis
......@@ -101,7 +122,7 @@ instance FromValue GargConfig where
, _gc_frames
, _gc_secrets
, _gc_worker
, _gc_log_level }
, _gc_logging }
instance ToValue GargConfig where
toValue = defaultTableToValue
instance ToTable GargConfig where
......@@ -139,3 +160,11 @@ class HasJWTSettings env where
class HasManager env where
gargHttpManager :: Getter env HTTP.Manager
--
-- Lenses
--
makeLenses ''LogConfig
makeLenses ''GargConfig
src/Gargantext/Core/Notifications.hs
View file @ c8a05344
......@@ -12,14 +12,14 @@ Portability : POSIX
module Gargantext.Core.Notifications
where
import Gargantext.Core.Config.Types (NotificationsConfig)
import Gargantext.Core.Config (GargConfig)
import Gargantext.Core.Notifications.CentralExchange qualified as CE
import Gargantext.Core.Notifications.Dispatcher qualified as D
import Protolude
withNotifications :: NotificationsConfig -> (D.Dispatcher -> IO a) -> IO a
withNotifications nc cb =
D.withDispatcher nc $ \dispatcher -> do
withAsync (CE.gServer nc) $ \_ce -> do
withNotifications :: GargConfig -> (D.Dispatcher -> IO a) -> IO a
withNotifications gc cb =
D.withDispatcher gc $ \dispatcher -> do
withAsync (CE.gServer gc) $ \_ce -> do
cb dispatcher
src/Gargantext/Core/Notifications/CentralExchange.hs
View file @ c8a05344
......@@ -11,7 +11,7 @@ https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
Docs:
https://dev.sub.gargantext.org/#/share/Notes/187918
-}
module Gargantext.Core.Notifications.CentralExchange (
......@@ -23,15 +23,16 @@ 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 Data.Text qualified as T
import Gargantext.Core.Config (GargConfig, gc_notifications_config, gc_logging)
import Gargantext.Core.Config.Types (NotificationsConfig(..))
import Gargantext.Core.Notifications.CentralExchange.Types
import Gargantext.Prelude
import Gargantext.System.Logging (LogLevel(..), withLogger, logMsg)
import Nanomsg (Pull(..), Push(..), bind, connect, recv, send, withSocket)
import System.Timeout (timeout)
{-
Central exchange is a service, which gathers messages from various
......@@ -42,18 +43,18 @@ The primary goal is to be able to read as many messages as possible
and then send them to the Dispatcher. Although nanomsg does some
message buffering, we don't want these messages to pile up, especially
with many users having updates.
-}
gServer :: NotificationsConfig -> IO ()
gServer (NotificationsConfig { .. }) = do
gServer :: GargConfig -> IO ()
gServer cfg = do
withSocket Pull $ \s -> do
withSocket Push $ \s_dispatcher -> do
withLogger () $ \ioLogger -> do
logMsg ioLogger DDEBUG $ "[central_exchange] binding to " <> T.unpack _nc_central_exchange_bind
withLogger log_cfg $ \ioLogger -> do
logMsg ioLogger DEBUG $ "[central_exchange] binding to " <> T.unpack _nc_central_exchange_bind
_ <- bind s $ T.unpack _nc_central_exchange_bind
withLogger () $ \ioLogger -> do
logMsg ioLogger DDEBUG $ "[central_exchange] connecting to " <> T.unpack _nc_dispatcher_bind
withLogger log_cfg $ \ioLogger -> do
logMsg ioLogger DEBUG $ "[central_exchange] connecting to " <> T.unpack _nc_dispatcher_bind
_ <- connect s_dispatcher $ T.unpack _nc_dispatcher_connect
tChan <- TChan.newTChanIO
......@@ -63,16 +64,18 @@ gServer (NotificationsConfig { .. }) = 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
withLogger () $ \ioLogger -> do
withLogger log_cfg $ \ioLogger -> do
forever $ do
-- putText "[central_exchange] receiving"
r <- recv s
logMsg ioLogger DDEBUG $ "[central_exchange] received: " <> show r
logMsg ioLogger DEBUG $ "[central_exchange] received: " <> show r
-- C.putStrLn $ "[central_exchange] " <> r
atomically $ TChan.writeTChan tChan r
where
NotificationsConfig{..} = cfg ^. gc_notifications_config
log_cfg = cfg ^. gc_logging
worker s_dispatcher tChan = do
withLogger () $ \ioLogger -> do
withLogger log_cfg $ \ioLogger -> do
forever $ do
r <- atomically $ TChan.readTChan tChan
case Aeson.decode (BSL.fromStrict r) of
......@@ -81,10 +84,10 @@ gServer (NotificationsConfig { .. }) = do
-- 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)
-- NOTE: If we're flooded with messages, and send is
-- slow, we might be spawning many threads...
-- NOTE: Currently we just forward the message that we
-- got. So in theory central exchange isn't needed (we
-- could ping dispatcher directly). However, I think
......@@ -102,16 +105,19 @@ gServer (NotificationsConfig { .. }) = do
void $ timeout 100_000 $ send s_dispatcher r
Nothing ->
logMsg ioLogger ERROR $ "[central_exchange] cannot decode message: " <> show r
notify :: NotificationsConfig -> CEMessage -> IO ()
notify (NotificationsConfig { _nc_central_exchange_connect }) ceMessage = do
notify :: GargConfig -> CEMessage -> IO ()
notify cfg ceMessage = do
Async.withAsync (pure ()) $ \_ -> do
withSocket Push $ \s -> do
_ <- connect s $ T.unpack _nc_central_exchange_connect
let str = Aeson.encode ceMessage
withLogger () $ \ioLogger ->
logMsg ioLogger DDEBUG $ "[central_exchange] sending: " <> (T.unpack $ TE.decodeUtf8 $ BSL.toStrict str)
withLogger log_cfg $ \ioLogger ->
logMsg ioLogger DEBUG $ "[central_exchange] sending: " <> (T.unpack $ TE.decodeUtf8 $ BSL.toStrict str)
-- err <- sendNonblocking s $ BSL.toStrict str
-- putText $ "[notify] err: " <> show err
void $ timeout 100_000 $ send s $ BSL.toStrict str
where
NotificationsConfig { _nc_central_exchange_connect } = cfg ^. gc_notifications_config
log_cfg = cfg ^. gc_logging
src/Gargantext/Core/Notifications/Dispatcher.hs
View file @ c8a05344
......@@ -11,7 +11,7 @@ https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
Docs:
https://dev.sub.gargantext.org/#/share/Notes/187918
-}
module Gargantext.Core.Notifications.Dispatcher (
......@@ -38,6 +38,7 @@ import Gargantext.System.Logging (LogLevel(..), withLogger, logMsg)
import Nanomsg (Pull(..), bind, recv, withSocket)
import Network.WebSockets qualified as WS
import StmContainers.Set qualified as SSet
import Gargantext.Core.Config
{-
......@@ -45,7 +46,7 @@ Dispatcher is a service, which provides couple of functionalities:
- handles WebSocket connections and manages them
- accepts messages from central exchange
- dispatches these messages to connected users
-}
data Dispatcher =
......@@ -55,23 +56,23 @@ data Dispatcher =
dispatcherSubscriptions :: Dispatcher -> SSet.Set Subscription
dispatcherSubscriptions = d_subscriptions
withDispatcher :: NotificationsConfig -> (Dispatcher -> IO a) -> IO a
withDispatcher nc cb = do
withDispatcher :: GargConfig -> (Dispatcher -> IO a) -> IO a
withDispatcher cfg cb = do
subscriptions <- SSet.newIO
Async.withAsync (dispatcherListener nc subscriptions) $ \_a -> do
Async.withAsync (dispatcherListener cfg subscriptions) $ \_a -> do
let dispatcher = Dispatcher { d_subscriptions = subscriptions }
cb dispatcher
-- | 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 :: NotificationsConfig -> SSet.Set Subscription -> IO ()
dispatcherListener (NotificationsConfig { _nc_dispatcher_bind }) subscriptions = do
dispatcherListener :: GargConfig -> SSet.Set Subscription -> IO ()
dispatcherListener config subscriptions = do
withSocket Pull $ \s -> do
withLogger () $ \ioLogger -> do
logMsg ioLogger DDEBUG $ "[dispatcherListener] binding to " <> T.unpack _nc_dispatcher_bind
withLogger log_cfg $ \ioLogger -> do
logMsg ioLogger DEBUG $ "[dispatcherListener] binding to " <> T.unpack _nc_dispatcher_bind
_ <- bind s $ T.unpack _nc_dispatcher_bind
tChan <- TChan.newTChanIO
......@@ -81,7 +82,7 @@ dispatcherListener (NotificationsConfig { _nc_dispatcher_bind }) subscriptions =
-- NOTE I'm not sure that we need more than 1 worker here, but in
-- theory, the worker can perform things like user authentication,
-- DB queries etc so it can be slow sometimes.
Async.withAsync (throttle 500_000 throttleTChan sendDataMessageThrottled) $ \_ -> do
Async.withAsync (throttle 500_000 throttleTChan (sendDataMessageThrottled log_cfg)) $ \_ -> do
void $ Async.concurrently (Async.replicateConcurrently 5 $ worker tChan throttleTChan) $ do
forever $ do
-- putText "[dispatcher_listener] receiving"
......@@ -89,20 +90,22 @@ dispatcherListener (NotificationsConfig { _nc_dispatcher_bind }) subscriptions =
-- C.putStrLn $ "[dispatcher_listener] " <> r
atomically $ TChan.writeTChan tChan r
where
NotificationsConfig { _nc_dispatcher_bind } = config ^. gc_notifications_config
log_cfg = config ^. gc_logging
worker tChan throttleTChan = do
-- tId <- myThreadId
forever $ do
r <- atomically $ TChan.readTChan tChan
-- putText $ "[" <> show tId <> "] received a message: " <> decodeUtf8 r
case Aeson.decode (BSL.fromStrict r) of
Nothing ->
withLogger () $ \ioL ->
withLogger log_cfg $ \ioL ->
logMsg ioL DEBUG "[dispatcher_listener] unknown message from central exchange"
Just ceMessage -> do
withLogger () $ \ioL ->
logMsg ioL DDEBUG $ "[dispatcher_listener] received " <> show ceMessage
withLogger log_cfg $ \ioL ->
logMsg ioL DEBUG $ "[dispatcher_listener] received " <> show ceMessage
-- subs <- atomically $ readTVar subscriptions
filteredSubs <- atomically $ do
let subs' = UnfoldlM.filter (pure . ceMessageSubPred ceMessage) $ SSet.unfoldlM subscriptions
......@@ -161,10 +164,10 @@ sendNotification throttleTChan ceMessage sub = do
-- | The "true" message sending to websocket. After it was withheld
-- for a while (for throttling), it is finally sent here
sendDataMessageThrottled :: (WS.Connection, WS.DataMessage) -> IO ()
sendDataMessageThrottled (conn, msg) = do
withLogger () $ \ioL ->
logMsg ioL DDEBUG $ "[sendDataMessageThrottled] dispatching notification: " <> show msg
sendDataMessageThrottled :: LogConfig -> (WS.Connection, WS.DataMessage) -> IO ()
sendDataMessageThrottled log_cfg (conn, msg) = do
withLogger log_cfg $ \ioL ->
logMsg ioL DEBUG $ "[sendDataMessageThrottled] dispatching notification: " <> show msg
WS.sendDataMessage conn msg
......
src/Gargantext/Core/Notifications/Dispatcher/WebSocket.hs
View file @ c8a05344
......@@ -11,13 +11,18 @@ https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
Docs:
https://dev.sub.gargantext.org/#/share/Notes/187918
-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.Core.Notifications.Dispatcher.WebSocket where
module Gargantext.Core.Notifications.Dispatcher.WebSocket (
-- * Types
WSAPI(..)
-- * Functions
, wsServer
) where
import Control.Concurrent.Async qualified as Async
import Control.Exception.Safe qualified as Exc
......@@ -29,7 +34,7 @@ import Gargantext.API.Prelude (IsGargServer)
import Gargantext.Core.Notifications.Dispatcher.Subscriptions
import Gargantext.Core.Notifications.Dispatcher.Types
import Gargantext.Core.Notifications.Dispatcher (Dispatcher, dispatcherSubscriptions)
import Gargantext.Core.Config (HasJWTSettings(jwtSettings))
import Gargantext.Core.Config (HasJWTSettings(jwtSettings), HasConfig (..), LogConfig, gc_logging)
import Gargantext.Prelude
import Gargantext.System.Logging (LogLevel(..), logMsg, withLogger, logM)
import Network.WebSockets qualified as WS
......@@ -39,7 +44,7 @@ import Servant.Auth.Server (JWTSettings, verifyJWT)
import Servant.Server.Generic (AsServerT)
import StmContainers.Set as SSet
newtype WSAPI mode = WSAPI {
wsAPIServer :: mode :- "ws" :> Summary "WebSocket endpoint" :> WS.WebSocketPending
} deriving Generic
......@@ -55,12 +60,13 @@ wsServer = WSAPI { wsAPIServer = streamData }
=> WS.PendingConnection -> m ()
streamData pc = Exc.catches (do
jwtS <- view jwtSettings
log_cfg <- view (hasConfig . gc_logging)
d <- view hasDispatcher
let subscriptions = dispatcherSubscriptions d
key <- getWSKey pc
key <- getWSKey log_cfg pc
c <- liftBase $ WS.acceptRequest pc
let ws = WSKeyConnection (key, c)
_ <- liftBase $ Async.concurrently (wsLoop jwtS subscriptions ws) (pingLoop ws)
_ <- liftBase $ Async.concurrently (wsLoop log_cfg jwtS subscriptions ws) (pingLoop ws)
-- _ <- liftIO $ Async.withAsync (pure ()) (\_ -> wsLoop ws)
pure ()
) [ Exc.Handler $ \(err :: WS.ConnectionException) ->
......@@ -71,7 +77,7 @@ wsServer = WSAPI { wsAPIServer = streamData }
logM ERROR $ "[wsServer] error: " <> show err
Exc.throw err ]
-- | Send a ping control frame periodically, otherwise the
-- | connection is dropped. NOTE that 'onPing' message is not
-- | supported in the JS API: either the browser supports this or
......@@ -84,17 +90,17 @@ pingLoop ws = do
WS.sendPing (wsConn ws) ("" :: Text)
threadDelay $ 10 * 1000000
wsLoop :: JWTSettings -> SSet.Set Subscription -> WSKeyConnection -> IO a
wsLoop jwtS subscriptions ws = flip finally disconnect $ do
withLogger () $ \ioLogger -> do
wsLoop :: LogConfig -> JWTSettings -> SSet.Set Subscription -> WSKeyConnection -> IO a
wsLoop log_cfg jwtS subscriptions ws = flip finally disconnect $ do
withLogger log_cfg $ \ioLogger -> do
logMsg ioLogger DEBUG "[wsLoop] connecting"
wsLoop' CUPublic ioLogger
where
wsLoop' user ioLogger = do
dm <- WS.receiveDataMessage (wsConn ws)
newUser <- case dm of
WS.Text dm' _ -> do
case Aeson.decode dm' of
......@@ -132,25 +138,25 @@ wsLoop jwtS subscriptions ws = flip finally disconnect $ do
_ -> do
logMsg ioLogger DEBUG "[wsLoop] binary ws messages not supported"
return user
wsLoop' newUser ioLogger
disconnect = do
withLogger () $ \ioLogger -> do
withLogger log_cfg $ \ioLogger -> do
logMsg ioLogger DEBUG "[wsLoop] disconnecting..."
_ss <- removeSubscriptionsForWSKey subscriptions ws
-- putText $ "[wsLoop] subscriptions: " <> show (show <$> ss)
return ()
getWSKey :: MonadBase IO m => WS.PendingConnection -> m ByteString
getWSKey pc = do
getWSKey :: MonadBase IO m => LogConfig -> WS.PendingConnection -> m ByteString
getWSKey log_cfg pc = do
let reqHead = WS.pendingRequest pc
-- WebSocket specification says that a pending request should send
-- some unique, Sec-WebSocket-Key string. We use this to compare
-- connections (WS.Connection doesn't implement an Eq instance).
liftBase $ withLogger () $ \ioLogger -> do
liftBase $ withLogger log_cfg $ \ioLogger -> do
logMsg ioLogger DEBUG $ "[wsLoop, getWSKey] headers: " <> show (WS.requestHeaders reqHead)
let mKey = head $ filter (\(k, _) -> k == "Sec-WebSocket-Key") $ WS.requestHeaders reqHead
let key' = snd $ fromMaybe (panicTrace "Sec-WebSocket-Key not found!") mKey
......
src/Gargantext/Core/Worker.hs
View file @ c8a05344
......@@ -37,7 +37,7 @@ import Gargantext.API.Node.New (postNode')
import Gargantext.API.Node.Update.Types (UpdateNodeParams(..), Granularity (..))
import Gargantext.API.Node.Update (updateNode)
import Gargantext.API.Server.Named.Ngrams (tableNgramsPostChartsAsync)
import Gargantext.Core.Config (hasConfig, gc_database_config, gc_jobs, gc_notifications_config, gc_worker)
import Gargantext.Core.Config (hasConfig, gc_database_config, gc_jobs, gc_worker, gc_logging)
import Gargantext.Core.Config.Types (jc_max_docs_scrapers)
import Gargantext.Core.Config.Worker (WorkerDefinition(..))
import Gargantext.Core.Notifications.CentralExchange qualified as CE
......@@ -83,7 +83,7 @@ notifyJobStarted env (W.State { name }) bm = do
let mId = messageId bm
let j = toA $ getMessage bm
let job = W.job j
withLogger () $ \ioL ->
withLogger (env ^. w_env_config . gc_logging) $ \ioL ->
logMsg ioL DEBUG $ "[notifyJobStarted] [" <> name <> " :: " <> show mId <> "] starting job: " <> show j
let ji = JobInfo { _ji_message_id = messageId bm
, _ji_mNode_id = getWorkerMNodeId job }
......@@ -99,7 +99,7 @@ notifyJobFinished env (W.State { name }) bm = do
let mId = messageId bm
let j = toA $ getMessage bm
let job = W.job j
withLogger () $ \ioL ->
withLogger (env ^. w_env_config . gc_logging) $ \ioL ->
logMsg ioL DEBUG $ "[notifyJobFinished] [" <> name <> " :: " <> show mId <> "] finished job: " <> show j
let ji = JobInfo { _ji_message_id = messageId bm
, _ji_mNode_id = getWorkerMNodeId job }
......@@ -115,7 +115,7 @@ notifyJobTimeout env (W.State { name }) bm = do
let mId = messageId bm
let j = toA $ getMessage bm
let job = W.job j
withLogger () $ \ioL ->
withLogger (env ^. w_env_config . gc_logging) $ \ioL ->
logMsg ioL ERROR $ "[notifyJobTimeout] [" <> name <> " :: " <> show mId <> "] job timed out: " <> show j
let ji = JobInfo { _ji_message_id = messageId bm
, _ji_mNode_id = getWorkerMNodeId job }
......@@ -132,7 +132,7 @@ notifyJobFailed env (W.State { name }) bm exc = do
let mId = messageId bm
let j = toA $ getMessage bm
let job = W.job j
withLogger () $ \ioL ->
withLogger (env ^. w_env_config . gc_logging) $ \ioL ->
logMsg ioL ERROR $ "[notifyJobFailed] [" <> name <> " :: " <> show mId <> "] failed job: " <> show j <> " --- ERROR: " <> show exc
let ji = JobInfo { _ji_message_id = messageId bm
, _ji_mNode_id = getWorkerMNodeId job }
......@@ -148,7 +148,7 @@ notifyJobKilled _ _ Nothing = pure ()
notifyJobKilled env (W.State { name }) (Just bm) = do
let j = toA $ getMessage bm
let job = W.job j
withLogger () $ \ioL ->
withLogger (env ^. w_env_config . gc_logging) $ \ioL ->
logMsg ioL ERROR $ "[notifyJobKilled] [" <> name <> "] failed job: " <> show j
let ji = JobInfo { _ji_message_id = messageId bm
, _ji_mNode_id = getWorkerMNodeId job }
......@@ -213,33 +213,33 @@ performAction env _state bm = do
let ji = JobInfo { _ji_message_id = messageId bm
, _ji_mNode_id = getWorkerMNodeId job }
let jh = WorkerJobHandle { _w_job_info = ji }
case job of
Ping -> runWorkerMonad env $ do
$(logLocM) DEBUG "[performAction] ping"
liftIO $ CE.notify (env ^. (to _w_env_config) . gc_notifications_config) CET.Ping
liftIO $ CE.notify (env ^. (to _w_env_config)) CET.Ping
-- | flow action for a single contact
AddContact { .. } -> runWorkerMonad env $ do
$(logLocM) DEBUG $ "[performAction] add contact"
addContact _ac_user _ac_node_id _ac_args jh
-- | Send a file with documents and index them in corpus
AddCorpusFormAsync { .. } -> runWorkerMonad env $ do
$(logLocM) DEBUG $ "[performAction] add corpus form"
addToCorpusWithForm _acf_user _acf_cid _acf_args jh
-- | Perform external API search query and index documents in corpus
AddCorpusWithQuery { .. } -> runWorkerMonad env $ do
$(logLocM) DEBUG "[performAction] add corpus with query"
let limit = Just $ fromIntegral $ env ^. hasConfig . gc_jobs . jc_max_docs_scrapers
addToCorpusWithQuery _acq_user _acq_cid _acq_args limit jh
-- | Add to annuaire, from given file (not implemented yet)
AddToAnnuaireWithForm { .. } -> runWorkerMonad env $ do
$(logLocM) DEBUG "[performAction] add to annuaire with form"
Annuaire.addToAnnuaireWithForm _aawf_annuaire_id _aawf_args jh
-- | Saves file to 'data_filepath' (in TOML), adds this file as a node
AddWithFile { .. } -> runWorkerMonad env $ do
$(logLocM) DEBUG "[performAction] add with file"
......
src/Gargantext/Core/Worker/Env.hs
View file @ c8a05344
......@@ -10,6 +10,7 @@ Portability : POSIX
-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-} -- orphan HasNodeError IOException
......@@ -19,6 +20,7 @@ module Gargantext.Core.Worker.Env where
import Control.Concurrent.STM.TVar (TVar, modifyTVar, newTVarIO, readTVarIO)
import Control.Lens (prism', to, view)
import Control.Lens.TH
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Maybe (fromJust)
import Data.Pool qualified as Pool
......@@ -30,7 +32,7 @@ import Gargantext.API.Job (RemainingSteps(..), jobLogStart, jobLogProgress, jobL
import Gargantext.API.Prelude (GargM)
import Gargantext.Core.Notifications.CentralExchange qualified as CE
import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
import Gargantext.Core.Config (GargConfig(..), HasConfig(..))
import Gargantext.Core.Config (GargConfig(..), HasConfig(..), gc_logging)
import Gargantext.Core.Config.Mail qualified as Mail
import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.Core.Config.Types (SettingsFile(..))
......@@ -43,7 +45,7 @@ import Gargantext.Database.Prelude (HasConnectionPool(..))
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Database.Query.Tree.Error (HasTreeError(..))
import Gargantext.Prelude hiding (to)
import Gargantext.System.Logging (HasLogger(..), Logger, LogLevel(..), MonadLogger(..), withLogger, logMsg, withLoggerHoisted)
import Gargantext.System.Logging (HasLogger(..), Logger, LogLevel(..), MonadLogger(..), withLogger, logMsg, withLoggerIO)
import Gargantext.Utils.Jobs.Monad ( MonadJobStatus(..), JobHandle )
import GHC.IO.Exception (IOException(..), IOErrorType(OtherError))
import Prelude qualified
......@@ -68,7 +70,7 @@ data WorkerJobState = WorkerJobState
withWorkerEnv :: SettingsFile -> (WorkerEnv -> IO a) -> IO a
withWorkerEnv settingsFile k = withLoggerHoisted Dev $ \logger -> do
withWorkerEnv settingsFile k = withLoggerIO Dev $ \logger -> do
env <- newWorkerEnv logger
k env -- `finally` cleanEnv env
......@@ -137,9 +139,9 @@ instance CET.HasCentralExchangeNotification WorkerEnv where
ce_notify m = do
c <- asks (view $ to _w_env_config)
liftBase $ do
withLogger () $ \ioL ->
logMsg ioL DDEBUG $ "[ce_notify]: " <> show (_gc_notifications_config c) <> " :: " <> show m
CE.notify (_gc_notifications_config c) m
withLogger (c ^. gc_logging) $ \ioL ->
logMsg ioL DEBUG $ "[ce_notify]: " <> show (_gc_notifications_config c) <> " :: " <> show m
CE.notify c m
---------
instance HasValidationError IOException where
......@@ -236,7 +238,7 @@ instance MonadJobStatus WorkerMonad where
Nothing -> jobLogFailures steps latest
Just msg -> addErrorEvent msg (jobLogFailures steps latest))
markComplete jh = updateJobProgress jh jobLogComplete
markFailed mb_msg jh =
markFailed mb_msg jh =
updateJobProgress jh (\latest -> case mb_msg of
Nothing -> jobLogFailTotal latest
Just msg -> jobLogFailTotalWithMessage msg latest)
......@@ -264,4 +266,6 @@ updateJobProgress (WorkerJobHandle (ji@JobInfo { _ji_message_id })) f = do
in
Just (WorkerJobState { _wjs_job_info = ji
, _wjs_job_log = f initJobLog })
makeLenses ''WorkerEnv
src/Gargantext/Core/Worker/Jobs.hs
View file @ c8a05344
......@@ -15,7 +15,7 @@ module Gargantext.Core.Worker.Jobs where
import Async.Worker qualified as W
import Control.Lens (view)
import Gargantext.Core.Config (gc_database_config, gc_worker, HasConfig(..), GargConfig)
import Gargantext.Core.Config (gc_database_config, gc_worker, HasConfig(..), GargConfig, gc_logging)
import Gargantext.Core.Config.Worker (WorkerSettings(..), WorkerDefinition(..))
import Gargantext.Core.Worker.Broker (initBrokerWithDBCreate)
import Gargantext.Core.Worker.Jobs.Types (Job(..))
......@@ -44,7 +44,7 @@ sendJobWithCfg gcConfig job = do
b <- initBrokerWithDBCreate (gcConfig ^. gc_database_config) ws
let queueName = _wdQueue wd
let job' = (updateJobData job $ W.mkDefaultSendJob' b queueName job) { W.delay = _wsDefaultDelay }
withLogger () $ \ioL ->
withLogger (gcConfig ^. gc_logging) $ \ioL ->
logMsg ioL DEBUG $ "[sendJob] sending job " <> show job <> " (delay " <> show (W.delay job') <> ")"
W.sendJob' job'
......
src/Gargantext/System/Logging.hs
View file @ c8a05344
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gargantext.System.Logging (
LogLevel(..)
, HasLogger(..)
, MonadLogger(..)
module Gargantext.System.Logging.Types
, logM
, logLocM
, logLoc
, withLogger
, withLoggerHoisted
, withLoggerIO
) where
import Gargantext.System.Logging.Types
import Control.Exception.Safe (MonadMask, bracket)
import Control.Monad (when)
import Gargantext.Core.Config (LogConfig(..))
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
import Data.Kind (Type)
import Data.Text qualified as T
import Data.Time.Clock (getCurrentTime)
import Language.Haskell.TH hiding (Type)
import Language.Haskell.TH.Syntax qualified as TH
import Prelude
import System.Environment (lookupEnv)
import Text.Read (readMaybe)
data LogLevel =
-- | Detailed debug messages
DDEBUG
-- | Debug messages
| DEBUG
-- | Information
| INFO
-- | Normal runtime conditions
| NOTICE
-- | General Warnings
| WARNING
-- | General Errors
| ERROR
-- | Severe situations
| CRITICAL
-- | Take immediate action
| ALERT
-- | System is unusable
| EMERGENCY
deriving (Show, Eq, Ord, Enum, Bounded, Read)
-- | This is a barebore logging interface which we
-- can extend to plug a proper logging library, without
-- the details of the logger cropping up everywhere in
-- the rest of the codebase.
class HasLogger m where
data family Logger m :: Type
type family LogInitParams m :: Type
type family LogPayload m :: Type
initLogger :: LogInitParams m -> (forall m1. MonadIO m1 => m1 (Logger m))
destroyLogger :: Logger m -> (forall m1. MonadIO m1 => m1 ())
logMsg :: Logger m -> LogLevel -> LogPayload m -> m ()
logTxt :: Logger m -> LogLevel -> T.Text -> m ()
-- | Separate typeclass to get hold of a 'Logger' from within a monad.
-- We keey 'HasLogger' and 'MonadLogger' separate to enforce compositionality,
-- i.e. we can still give instances to 'HasLogger' for things like 'IO' without
-- having to force actually acquiring a logger for those monads.
class HasLogger m => MonadLogger m where
getLogger :: m (Logger m)
-- | A variant of 'logTxt' that doesn't require passing an explicit 'Logger'.
logM :: (Monad m, MonadLogger m) => LogLevel -> T.Text -> m ()
logM level msg = do
......@@ -119,26 +77,29 @@ withLogger params = bracket (initLogger params) destroyLogger
-- | Like 'withLogger', but it allows creating a 'Logger' that can run in
-- a different monad from within an 'IO' action.
withLoggerHoisted :: (MonadBaseControl IO m, HasLogger m)
=> LogInitParams m
-> (Logger m -> IO a)
-> IO a
withLoggerHoisted params act = bracket (initLogger params) destroyLogger act
withLoggerIO :: (MonadBaseControl IO m, HasLogger m)
=> LogInitParams m
-> (Logger m -> IO a)
-> IO a
withLoggerIO params act = bracket (initLogger params) destroyLogger act
-- | 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
instance HasLogger IO where
data instance Logger IO = IOLogger LogLevel
type instance LogInitParams IO = ()
type instance LogInitParams IO = LogConfig
type instance LogPayload IO = String
initLogger () = do
mLvl <- liftIO $ lookupEnv "LOG_LEVEL"
let lvl = case mLvl of
Nothing -> INFO
initLogger LogConfig{..} = do
-- let the env var take precedence over the LogConfig one.
mLvl <- liftIO $ lookupEnv "GGTX_LOG_LEVEL"
lvl <- case mLvl of
Nothing -> pure _lc_log_level
Just s ->
case readMaybe s of
Nothing -> error $ "unknown log level " <> s
Just lvl' -> lvl'
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
......
src/Gargantext/System/Logging/Types.hs 0 → 100644
View file @ c8a05344
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
module Gargantext.System.Logging.Types (
LogLevel(..)
, HasLogger(..)
, MonadLogger(..)
, parseLogLevel
, renderLogLevel
, prop_loglevel_roundtrip
) where
import Control.Monad.IO.Class
import Data.Kind (Type)
import Data.Text qualified as T
import Prelude
data LogLevel =
-- | Debug messages
DEBUG
-- | Information
| INFO
-- | Normal runtime conditions
| WARNING
-- | General Errors
| ERROR
deriving (Show, Eq, Ord, Enum, Bounded, Read)
renderLogLevel :: LogLevel -> T.Text
renderLogLevel = \case
DEBUG -> "debug"
INFO -> "info"
WARNING -> "warning"
ERROR -> "error"
parseLogLevel :: T.Text -> Either T.Text LogLevel
parseLogLevel = \case
"debug" -> Right DEBUG
"info" -> Right INFO
"warning" -> Right WARNING
"warn" -> Right WARNING
"error" -> Right ERROR
xs -> Left ("Invalid log level found: " <> xs)
prop_loglevel_roundtrip :: LogLevel -> Bool
prop_loglevel_roundtrip ll = (parseLogLevel . renderLogLevel $ ll) == Right ll
-- | This is a barebore logging interface which we
-- can extend to plug a proper logging library, without
-- the details of the logger cropping up everywhere in
-- the rest of the codebase.
class HasLogger m where
data family Logger m :: Type
type family LogInitParams m :: Type
type family LogPayload m :: Type
initLogger :: LogInitParams m -> (forall m1. MonadIO m1 => m1 (Logger m))
destroyLogger :: Logger m -> (forall m1. MonadIO m1 => m1 ())
logMsg :: Logger m -> LogLevel -> LogPayload m -> m ()
logTxt :: Logger m -> LogLevel -> T.Text -> m ()
-- | Separate typeclass to get hold of a 'Logger' from within a monad.
-- We keey 'HasLogger' and 'MonadLogger' separate to enforce compositionality,
-- i.e. we can still give instances to 'HasLogger' for things like 'IO' without
-- having to force actually acquiring a logger for those monads.
class HasLogger m => MonadLogger m where
getLogger :: m (Logger m)
test-data/test_config.toml
View file @ c8a05344
......@@ -52,6 +52,10 @@ user = "gargantua"
pass = "gargantua_test"
name = "gargandb_test"
[logs]
log_file = "/var/log/gargantext/backend.log"
log_level = "warn"
[mail]
port = 25
host = "localhost"
......
test/Test/API/Notifications.hs
View file @ c8a05344
......@@ -14,24 +14,24 @@ Portability : POSIX
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.API.Notifications (
tests
) where
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM.TChan
import Control.Concurrent.STM.TSem (newTSem, signalTSem, TSem)
import Control.Concurrent (threadDelay)
import Control.Lens ((^.))
import Control.Monad (void)
import Control.Monad.STM (atomically)
import Control.Monad (void)
import Data.Aeson qualified as Aeson
import Data.ByteString qualified as BS
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Text qualified as T
import Fmt ((+|), (|+))
import Gargantext.API.Admin.Auth.Types (AuthResponse, authRes_token, authRes_tree_id)
import Gargantext.Core.Config (gc_notifications_config)
import Gargantext.Core.Config (gc_logging, LogConfig)
import Gargantext.Core.Notifications.CentralExchange qualified as CE
import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
import Gargantext.Core.Notifications.Dispatcher.Types qualified as DT
......@@ -47,9 +47,9 @@ import Test.Database.Types (test_config)
import Test.Hspec
import Test.Hspec.Wai.Internal (withApplication)
import Test.Instances ()
import Text.RawString.QQ (r)
import Test.Utils (protected, waitForTChanValue, waitForTSem, withValidLoginA)
import Test.Utils.Notifications (withAsyncWSConnection)
import Test.Utils (protected, waitForTChanValue, waitForTSem, withValidLoginA)
import Text.RawString.QQ (r)
......@@ -57,10 +57,11 @@ tests :: Spec
tests = sequential $ around withTestDBAndPort $ do
describe "Notifications" $ do
it "ping WS notification works" $ \(SpecContext testEnv port _app _) -> do
let nc = (test_config testEnv) ^. gc_notifications_config
let cfg = test_config testEnv
let log_cfg = (test_config testEnv) ^. gc_logging
-- withLogger () $ \ioL -> do
-- logMsg ioL DEBUG $ "[ping WS notification works] nc: " <> show nc
let topic = DT.Ping
-- This semaphore is used to inform the main thread that the WS
-- client has subscribed. I think it's better to use async
......@@ -68,34 +69,35 @@ tests = sequential $ around withTestDBAndPort $ do
wsTSem <- atomically $ newTSem 0
tchan <- newTChanIO :: IO (TChan (Maybe DT.Notification))
withAsyncWSConnection ("127.0.0.1", port) (wsConnection topic wsTSem tchan) $ \_a -> do
withAsyncWSConnection ("127.0.0.1", port) (wsConnection log_cfg topic wsTSem tchan) $ \_a -> do
-- wait for ws process to inform us about topic subscription
waitForTSem wsTSem 500
threadDelay 300_000
CE.notify nc $ CET.Ping
CE.notify cfg $ CET.Ping
-- the ping value that should come from the notification
waitForTChanValue tchan (Just DT.NPing) 1_000
it "ping WS unsubscribe works" $ \(SpecContext testEnv port _app _) -> do
let nc = (test_config testEnv) ^. gc_notifications_config
let cfg = test_config testEnv
let log_cfg = (test_config testEnv) ^. gc_logging
let topic = DT.Ping
-- Setup a WS client connection. Subscribe to a topic and
-- confirm the notification works. Then unsubscribe from it, and
-- check that a new notification didn't arrive.
wsTSem <- atomically $ newTSem 0
tchan <- newTChanIO :: IO (TChan (Maybe DT.Notification))
-- setup a websocket connection
let wsConnect conn = withLogger () $ \_ioL -> do
let wsConnect conn = withLogger log_cfg $ \_ioL -> do
-- logMsg ioL DEBUG $ "[wsConnect] subscribing topic: " <> show topic
WS.sendTextData conn $ Aeson.encode (DT.WSSubscribe topic)
-- inform the test process that we sent the subscription request
atomically $ signalTSem wsTSem
-- logMsg ioL DEBUG $ "[wsConnect] waiting for notification"
d <- WS.receiveData conn
-- logMsg ioL DEBUG $ "[wsConnect] received " <> show d
......@@ -116,13 +118,13 @@ tests = sequential $ around withTestDBAndPort $ do
Nothing -> atomically $ writeTChan tchan Nothing
-- | write something incorrect so the test will fail
Just _ -> atomically $ writeTChan tchan (Just DT.NPing)
withAsyncWSConnection ("127.0.0.1", port) wsConnect $ \_a -> do
-- wait for ws process to inform us about topic subscription
waitForTSem wsTSem 500
threadDelay 300_000
CE.notify nc $ CET.Ping
CE.notify cfg $ CET.Ping
-- the ping value that should come from the notification
waitForTChanValue tchan (Just DT.NPing) 1_000
......@@ -130,26 +132,24 @@ tests = sequential $ around withTestDBAndPort $ do
-- wait for lock from ws (it should have unsubscribed by now)
waitForTSem wsTSem 500
-- send the notification (which the client shouldn't receive)
CE.notify nc $ CET.Ping
CE.notify cfg $ CET.Ping
-- wait for the value
waitForTChanValue tchan Nothing 1_000
describe "Update tree notifications" $ do
it "simple WS notification works" $ \(SpecContext testEnv port _app _) -> do
let nc = (test_config testEnv) ^. gc_notifications_config
let topic = DT.UpdateTree 0
wsTSem <- atomically $ newTSem 0 -- initially locked
tchan <- newTChanIO :: IO (TChan (Maybe DT.Notification))
withAsyncWSConnection ("127.0.0.1", port) (wsConnection topic wsTSem tchan) $ \_a -> do
withAsyncWSConnection ("127.0.0.1", port) (wsConnection (test_config testEnv ^. gc_logging) topic wsTSem tchan) $ \_a -> do
waitForTSem wsTSem 500
let nodeId = 0
CE.notify nc $ CET.UpdateTreeFirstLevel nodeId
CE.notify (test_config testEnv) $ CET.UpdateTreeFirstLevel nodeId
waitForTChanValue tchan (Just $ DT.NUpdateTree nodeId) 1_000
it "WS notification on node creation works" $ \ctx@(SpecContext _testEnv port app _) -> do
checkNotification ctx $ \authRes -> do
let token = authRes ^. authRes_token
......@@ -157,20 +157,20 @@ tests = sequential $ around withTestDBAndPort $ do
let query = [r| {"pn_name": "test", "pn_typename": "NodeCorpus"} |]
void $ withApplication app $ do
protected token "POST" (mkUrl port $ "/node/" +| treeId |+ "") query
it "WS notification on node deletion works" $ \ctx@(SpecContext testEnv port app _) -> do
checkNotification ctx $ \authRes -> do
let token = authRes ^. authRes_token
cId <- newCorpusForUser testEnv "alice"
void $ withApplication app $ do
protected token "DELETE" (mkUrl port $ "/node/" +| cId |+ "") ""
it "WS notification on node rename works" $ \ctx@(SpecContext testEnv port app _) -> do
checkNotification ctx $ \authRes -> do
let token = authRes ^. authRes_token
cId <- newCorpusForUser testEnv "alice"
void $ withApplication app $ do
let query = [r| {"name": "newName"} |]
protected token "PUT" (mkUrl port $ "/node/" +| cId |+ "/rename") query
......@@ -180,7 +180,7 @@ tests = sequential $ around withTestDBAndPort $ do
let token = authRes ^. authRes_token
cId <- newCorpusForUser testEnv "alice"
cId2 <- newCorpusForUser testEnv "alice"
void $ withApplication app $ do
let query = BS.fromStrict $ TE.encodeUtf8 $ "[" <> (T.pack $ show cId2) <> "]"
protected token "PUT" (mkUrl port $ "/node/" +| cId |+ "/move/" +| cId2 |+ "" ) query
......@@ -193,9 +193,9 @@ tests = sequential $ around withTestDBAndPort $ do
checkNotification :: SpecContext a
-> (AuthResponse -> IO ())
-> IO ()
checkNotification ctx@(SpecContext _testEnv port _app _) act = do
checkNotification ctx@(SpecContext testEnv port _app _) act = do
_ <- dbEnvSetup ctx
withValidLoginA port "alice" (GargPassword "alice") $ \_clientEnv authRes -> do
-- Subscribe to user tree notifications
let treeId = authRes ^. authRes_tree_id
......@@ -204,26 +204,28 @@ checkNotification ctx@(SpecContext _testEnv port _app _) act = do
wsTSem <- atomically $ newTSem 0 -- initially locked
tchan <- newTChanIO :: IO (TChan (Maybe DT.Notification))
withAsyncWSConnection ("127.0.0.1", port) (wsConnection topic wsTSem tchan) $ \_a -> do
withAsyncWSConnection ("127.0.0.1", port) (wsConnection log_cfg topic wsTSem tchan) $ \_a -> do
waitForTSem wsTSem 500
act authRes
waitForTChanValue tchan (Just $ DT.NUpdateTree treeId) 1_000
waitForTChanValue tchan (Just $ DT.NUpdateTree treeId) 1_000
where
log_cfg = (test_config testEnv) ^. gc_logging
wsConnection :: DT.Topic
wsConnection :: LogConfig
-> DT.Topic
-> TSem
-> TChan (Maybe DT.Notification)
-> WS.Connection
-> IO ()
wsConnection topic wsTSem tchan conn = withLogger () $ \_ioL -> do
wsConnection log_cfg topic wsTSem tchan conn = withLogger log_cfg $ \_ioL -> do
-- logMsg ioL DEBUG $ "[wsConnect] subscribing topic: " <> show topic
WS.sendTextData conn $ Aeson.encode (DT.WSSubscribe topic)
-- inform the test process that we sent the subscription request
atomically $ signalTSem wsTSem
-- logMsg ioL DEBUG $ "[wsConnect] waiting for notification"
d <- WS.receiveData conn
-- logMsg ioL DEBUG $ "[wsConnect] received " <> show d
......
test/Test/API/Private/Remote.hs
View file @ c8a05344
......@@ -32,10 +32,10 @@ withTwoServerInstances :: (SpecContext (TestEnv,Wai.Application,Warp.Port) -> IO
withTwoServerInstances action =
withTestDB $ \testEnv1 -> do
withTestDB $ \testEnv2 -> do
garg1App <- withLoggerHoisted Mock $ \ioLogger -> do
garg1App <- withLoggerIO Mock $ \ioLogger -> do
env <- newTestEnv testEnv1 ioLogger server1Port
makeApp env
garg2App <- withLoggerHoisted Mock $ \ioLogger -> do
garg2App <- withLoggerIO Mock $ \ioLogger -> do
env <- newTestEnv testEnv2 ioLogger server2Port
makeApp env
......
test/Test/API/Setup.hs
View file @ c8a05344
......@@ -20,13 +20,15 @@ import Control.Monad.Reader
import Data.ByteString.Lazy.Char8 qualified as C8L
import Data.Cache qualified as InMemory
import Data.Streaming.Network (bindPortTCP)
import Gargantext.API (makeApp)
import Gargantext.API.Admin.EnvTypes (Mode(Mock), Env (..), env_dispatcher)
import Gargantext.API.Errors.Types
import Gargantext.API (makeApp)
import Gargantext.API.Prelude
import Gargantext.Core.Notifications (withNotifications)
import Gargantext.Core.Config (gc_logging)
import Gargantext.Core.Config (gc_notifications_config)
import Gargantext.Core.Config (_gc_secrets, gc_frontend_config)
import Gargantext.Core.Config.Types (NotificationsConfig(..), fc_appPort, jwtSettings)
import Gargantext.Core.Notifications (withNotifications)
import Gargantext.Core.Types.Individu
import Gargantext.Database.Action.Flow
import Gargantext.Database.Action.User.New
......@@ -44,10 +46,10 @@ import Network.HTTP.Client.TLS (newTlsManager)
import Network.HTTP.Types
import Network.Wai (Application, responseLBS)
import Network.Wai.Handler.Warp.Internal
import Network.WebSockets qualified as WS
import Network.Wai.Handler.Warp qualified as Warp
import Network.Wai.Handler.Warp (runSettingsSocket)
import Network.Wai qualified as Wai
import Network.WebSockets qualified as WS
import Prelude hiding (show)
import Servant.Auth.Client ()
import Test.Database.Setup (withTestDB)
......@@ -108,9 +110,9 @@ nc = NotificationsConfig { _nc_central_exchange_bind = "tcp://*:15560"
-- | Run the gargantext server on a random port, picked by Warp, which allows
-- for concurrent tests to be executed in parallel, if we need to.
withTestDBAndPort :: (SpecContext () -> IO ()) -> IO ()
withTestDBAndPort action = withNotifications nc $ \dispatcher -> do
withTestDB $ \testEnv -> do
withLoggerHoisted Mock $ \ioLogger -> do
withTestDBAndPort action = withTestDB $ \testEnv -> do
withNotifications (cfg testEnv) $ \dispatcher -> do
withLoggerIO Mock $ \ioLogger -> do
env <- newTestEnv testEnv ioLogger 8080
<&> env_dispatcher .~ dispatcher
app <- makeApp env
......@@ -124,30 +126,32 @@ withTestDBAndPort action = withNotifications nc $ \dispatcher -> do
[ Handler $ \(err :: WS.ConnectionException) ->
case err of
WS.CloseRequest _ _ ->
withLogger () $ \ioLogger' ->
withLogger (log_cfg testEnv) $ \ioLogger' ->
logTxt ioLogger' DEBUG "[withTestDBAndPort] CloseRequest caught"
WS.ConnectionClosed ->
withLogger () $ \ioLogger' ->
withLogger (log_cfg testEnv) $ \ioLogger' ->
logTxt ioLogger' DEBUG "[withTestDBAndPort] ConnectionClosed caught"
_ -> do
withLogger () $ \ioLogger' ->
withLogger (log_cfg testEnv) $ \ioLogger' ->
logTxt ioLogger' ERROR $ "[withTestDBAndPort] unknown exception: " <> show err
throw err
-- re-throw any other exceptions
, Handler $ \(err :: SomeException) -> throw err ]
where
cfg te = (test_config te) & gc_notifications_config .~ nc
log_cfg te = (cfg te) ^. gc_logging
-- | Starts the backend server /and/ the microservices proxy, the former at
-- a random port, the latter at a predictable port.
withBackendServerAndProxy :: (((TestEnv, Warp.Port, Warp.Port)) -> IO ()) -> IO ()
withBackendServerAndProxy action =
withTestDB $ \testEnv -> do
gargApp <- withLoggerHoisted Mock $ \ioLogger -> do
gargApp <- withLoggerIO Mock $ \ioLogger -> do
env <- newTestEnv testEnv ioLogger 8080
makeApp env
proxyCache <- InMemory.newCache Nothing
proxyApp <- withLoggerHoisted Mock $ \ioLogger -> do
proxyApp <- withLoggerIO Mock $ \ioLogger -> do
env <- newTestEnv testEnv ioLogger 8080
pure $ microServicesProxyApp proxyCache env
......@@ -186,7 +190,7 @@ dbEnvSetup ctx = do
_ <- createAliceAndBob testEnv
pure ctx
-- show the full exceptions during testing, rather than shallowing them under a generic
-- "Something went wrong".
showDebugExceptions :: SomeException -> Wai.Response
......
test/Test/API/UpdateList.hs
View file @ c8a05344
......@@ -27,21 +27,21 @@ module Test.API.UpdateList (
import Control.Lens (mapped, over)
import Control.Monad.Fail (fail)
import Data.Aeson qualified as JSON
import Data.Aeson.QQ
import Data.Aeson qualified as JSON
import Data.ByteString.Lazy qualified as BSL
import Data.Map.Strict qualified as Map
import Data.Map.Strict.Patch qualified as PM
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Data.Text qualified as T
import Fmt
import Gargantext.API.Admin.Auth.Types (Token)
import Gargantext.API.Errors
import Gargantext.API.HashedResponse
import Gargantext.API.Ngrams qualified as APINgrams
import Gargantext.API.Ngrams.List ( ngramsListFromTSVData )
import Gargantext.API.Ngrams.List.Types (WithJsonFile(..), WithTextFile(..))
import Gargantext.API.Ngrams qualified as APINgrams
import Gargantext.API.Ngrams.Types
import Gargantext.API.Node.Corpus.New.Types qualified as FType
import Gargantext.API.Node.Types
......@@ -50,6 +50,7 @@ import Gargantext.API.Routes.Named.Corpus
import Gargantext.API.Routes.Named.Node
import Gargantext.API.Routes.Named.Private
import Gargantext.API.Worker (workerAPIPost)
import Gargantext.Core.Config
import Gargantext.Core qualified as Lang
import Gargantext.Core.Text.Corpus.Query (RawQuery(..))
import Gargantext.Core.Text.List.Social
......@@ -62,6 +63,7 @@ import Gargantext.Database.Query.Facet qualified as Facet
import Gargantext.Prelude hiding (get)
import Network.Wai.Handler.Warp qualified as Wai
import Paths_gargantext (getDataFileName)
import qualified Prelude
import Servant.Client.Streaming
import System.FilePath
import Test.API.Prelude (checkEither, newCorpusForUser, newPrivateFolderForUser)
......@@ -74,16 +76,16 @@ import Test.Hspec.Wai.JSON (json)
import Test.Types (JobPollHandle(..))
import Test.Utils (pollUntilWorkFinished, protectedJSON, withValidLogin)
import Text.Printf (printf)
import qualified Prelude
uploadJSONList :: Wai.Port
uploadJSONList :: LogConfig
-> Wai.Port
-> Token
-> CorpusId
-> FilePath
-> ClientEnv
-> WaiSession () ListId
uploadJSONList port token cId pathToNgrams clientEnv = do
uploadJSONList log_cfg port token cId pathToNgrams clientEnv = do
([listId] :: [NodeId]) <- protectedJSON token "POST" (mkUrl port ("/node/" <> build cId)) [aesonQQ|{"pn_typename":"NodeList","pn_name":"Testing"}|]
-- Upload the JSON doc
simpleNgrams' <- liftIO (TIO.readFile =<< getDataFileName pathToNgrams)
......@@ -100,7 +102,7 @@ uploadJSONList port token cId pathToNgrams clientEnv = do
-- j' <- pollUntilFinished token port mkPollUrl j
ji <- checkEither $ liftIO $ runClientM (add_form_to_list token listId params) clientEnv
-- liftIO (_jph_status j' `shouldBe` "IsFinished")
ji' <- pollUntilWorkFinished port ji
ji' <- pollUntilWorkFinished log_cfg port ji
liftIO $ ji' `shouldBe` ji
pure listId
......@@ -115,9 +117,10 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
it "allows uploading a JSON ngrams file" $ \(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 <- uploadJSONList port token cId "test-data/ngrams/simple.json" clientEnv
listId <- uploadJSONList log_cfg port token cId "test-data/ngrams/simple.json" clientEnv
-- Now check that we can retrieve the ngrams
liftIO $ do
......@@ -139,6 +142,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
it "does not create duplicates when uploading JSON (#313)" $ \(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
-- this term is imported from the .json file
......@@ -146,7 +150,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
-- this is the new term, under which importedTerm will be grouped
let newTerm = NgramsTerm "new abelian group"
listId <- uploadJSONList port token cId "test-data/ngrams/simple.json" clientEnv
listId <- uploadJSONList log_cfg port token cId "test-data/ngrams/simple.json" clientEnv
let checkNgrams expected = do
eng <- liftIO $ runClientM (get_table_ngrams token cId APINgrams.Terms listId 10 Nothing (Just MapTerm) Nothing Nothing Nothing Nothing) clientEnv
......@@ -187,7 +191,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
-- finally, upload the list again, the group should be as
-- it was before (the bug in #313 was that "abelian group"
-- was created again as a term with no parent)
_ <- uploadJSONList port token cId "test-data/ngrams/simple.json" clientEnv
_ <- uploadJSONList log_cfg port token cId "test-data/ngrams/simple.json" clientEnv
-- old (imported) term shouldn't become parentless
-- (#313 error was that we had [newTerm, importedTerm] instead)
......@@ -211,6 +215,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
it "allows uploading a CSV ngrams file" $ \(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"}|]
......@@ -220,7 +225,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
, _wtf_data = simpleNgrams
, _wtf_name = "simple.tsv" }
ji <- checkEither $ liftIO $ runClientM (add_tsv_to_list token listId params) clientEnv
_ <- pollUntilWorkFinished port ji
_ <- pollUntilWorkFinished log_cfg port ji
-- Now check that we can retrieve the ngrams
liftIO $ do
......@@ -258,6 +263,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
void $ createFortranDocsList testEnv port clientEnv token
it "doesn't use trashed documents for score calculation (#385)" $ \(SpecContext testEnv port app _) -> do
let log_cfg = (test_config testEnv) ^. gc_logging
withApplication app $ do
withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
corpusId <- createFortranDocsList testEnv port clientEnv token
......@@ -276,7 +282,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
pure tr1
termsNodeId <- uploadJSONList port token corpusId "test-data/ngrams/GarganText_NgramsTerms-nodeId-177.json" clientEnv
termsNodeId <- uploadJSONList log_cfg port token corpusId "test-data/ngrams/GarganText_NgramsTerms-nodeId-177.json" clientEnv
liftIO $ do
-- Now let's check the score for the \"fortran\" ngram.
......@@ -344,19 +350,26 @@ createDocsList testDataPath testEnv port clientEnv token = do
simpleDocs <- liftIO (TIO.readFile =<< getDataFileName testDataPath)
let newWithForm = mkNewWithForm simpleDocs (T.pack $ takeBaseName testDataPath)
ji <- checkEither $ liftIO $ runClientM (add_file_async token corpusId newWithForm) clientEnv
ji' <- pollUntilWorkFinished port ji
ji' <- pollUntilWorkFinished log_cfg port ji
liftIO $ ji' `shouldBe` ji
pure corpusId
where
log_cfg = (test_config testEnv) ^. gc_logging
createFortranDocsList :: TestEnv -> Int -> ClientEnv -> Token -> WaiSession () CorpusId
createFortranDocsList testEnv port =
createDocsList "test-data/ngrams/GarganText_DocsList-nodeId-177.json" testEnv port
updateNode :: Int -> ClientEnv -> Token -> NodeId -> WaiSession () ()
updateNode port clientEnv token nodeId = do
updateNode :: LogConfig
-> Int
-> ClientEnv
-> Token
-> NodeId
-> WaiSession () ()
updateNode log_cfg port clientEnv token nodeId = do
let params = UpdateNodeParamsTexts Both
ji <- checkEither $ liftIO $ runClientM (update_node token nodeId params) clientEnv
ji' <- pollUntilWorkFinished port ji
ji' <- pollUntilWorkFinished log_cfg port ji
liftIO $ ji' `shouldBe` ji
mkNewWithForm :: T.Text -> T.Text -> NewWithForm
......
test/Test/Database/Setup.hs
View file @ c8a05344
......@@ -2,7 +2,7 @@
module Test.Database.Setup (
withTestDB
, fakeTomlPath
, testTomlPath
, testEnvToPgConnectionInfo
) where
......@@ -28,7 +28,7 @@ import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
import Gargantext.Core.Worker (initWorkerState)
import Gargantext.Core.Worker.Env (WorkerEnv(..))
import Gargantext.Prelude
import Gargantext.System.Logging (withLoggerHoisted)
import Gargantext.System.Logging (withLoggerIO)
import Paths_gargantext
import Prelude qualified
import Shelly hiding (FilePath, run)
......@@ -43,8 +43,8 @@ dbUser = "gargantua"
dbPassword = "gargantua_test"
dbName = "gargandb_test"
fakeTomlPath :: IO SettingsFile
fakeTomlPath = SettingsFile <$> getDataFileName "test-data/test_config.toml"
testTomlPath :: IO SettingsFile
testTomlPath = SettingsFile <$> getDataFileName "test-data/test_config.toml"
gargDBSchema :: IO FilePath
gargDBSchema = getDataFileName "devops/postgres/schema.sql"
......@@ -81,7 +81,7 @@ setup = do
Left err -> Prelude.fail $ show err
Right db -> do
let connInfo = tmpDBToConnInfo db
gargConfig <- fakeTomlPath >>= readConfig
gargConfig <- testTomlPath >>= readConfig
-- fix db since we're using tmp-postgres
<&> (gc_database_config .~ connInfo)
-- <&> (gc_worker . wsDatabase .~ connInfo)
......@@ -98,8 +98,8 @@ setup = do
bootstrapDB db pool gargConfig
ugen <- emptyCounter
test_nodeStory <- fromDBNodeStoryEnv pool
withLoggerHoisted Mock $ \logger -> do
withLoggerIO Mock $ \logger -> do
let wPoolConfig = defaultPoolConfig (PG.connectPostgreSQL (Tmp.toConnectionString db))
PG.close
idleTime
......@@ -107,7 +107,7 @@ setup = do
wPool <- newPool (setNumStripes (Just 2) wPoolConfig)
wNodeStory <- fromDBNodeStoryEnv wPool
_w_env_job_state <- newTVarIO Nothing
withLoggerHoisted Mock $ \wioLogger -> do
withLoggerIO Mock $ \wioLogger -> do
let wEnv = WorkerEnv { _w_env_config = gargConfig
, _w_env_logger = wioLogger
, _w_env_pool = wPool
......
test/Test/Database/Types.hs
View file @ c8a05344
......@@ -144,7 +144,10 @@ instance HasLogger (GargM TestEnv BackendInternalError) where
pure $ GargTestLogger mode test_logger_set
destroyLogger GargTestLogger{..} = liftIO $ FL.rmLoggerSet test_logger_set
logMsg (GargTestLogger 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
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)
test/Test/Utils.hs
View file @ c8a05344
......@@ -35,19 +35,20 @@ import Control.Concurrent.STM.TSem (TSem, waitTSem)
import Control.Concurrent.STM.TVar (newTVarIO, writeTVar, readTVarIO)
import Control.Exception.Safe ()
import Control.Monad ()
import Data.Aeson qualified as JSON
import Data.Aeson.KeyMap qualified as KM
import Data.Aeson qualified as JSON
import Data.ByteString.Char8 qualified as B
import Data.ByteString.Lazy qualified as L
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Encoding qualified as TLE
import Data.Text.Lazy qualified as TL
import Data.Text qualified as T
import Data.TreeDiff
import Gargantext.API.Admin.Auth.Types (AuthRequest(..), AuthResponse, Token, authRes_token)
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Routes.Types (xGargErrorScheme)
import Gargantext.Core.Config (LogConfig)
import Gargantext.Core.Notifications.Dispatcher.Types qualified as DT
import Gargantext.Core.Types.Individu (Username, GargPassword)
import Gargantext.Core.Worker.Types (JobInfo(..))
......@@ -55,21 +56,21 @@ import Gargantext.Prelude
import Gargantext.System.Logging (withLogger, logMsg, LogLevel(..))
import Network.HTTP.Client (defaultManagerSettings, newManager)
import Network.HTTP.Client qualified as HTTP
import Network.HTTP.Types (Header, Method, status200)
import Network.HTTP.Types.Header (hAccept, hAuthorization, hContentType)
import Network.HTTP.Types (Header, Method, status200)
import Network.Wai.Handler.Warp (Port)
import Network.Wai.Test (SResponse(..))
import Network.WebSockets qualified as WS
import Prelude qualified
import Servant.Client.Streaming (ClientEnv, baseUrlPort, mkClientEnv, parseBaseUrl, runClientM, makeClientRequest, defaultMakeClientRequest)
import Servant.Client.Core (BaseUrl)
import Servant.Client.Core.Request qualified as Client
import Servant.Client.Streaming (ClientEnv, baseUrlPort, mkClientEnv, parseBaseUrl, runClientM, makeClientRequest, defaultMakeClientRequest)
import System.Environment (lookupEnv)
import System.Timeout qualified as Timeout
import Test.API.Routes (auth_api)
import Test.Hspec.Expectations
import Test.Hspec.Wai (MatchBody(..), WaiExpectation, WaiSession, request)
import Test.Hspec.Wai.JSON (FromValue(..))
import Test.Hspec.Wai (MatchBody(..), WaiExpectation, WaiSession, request)
import Test.Hspec.Wai.Matcher (MatchHeader(..), ResponseMatcher(..), bodyEquals, formatHeader, match)
import Test.Tasty.HUnit (Assertion, assertBool)
import Test.Utils.Notifications (withWSConnection, millisecond)
......@@ -252,10 +253,11 @@ gargMkRequest traceEnabled bu clientRq = do
pollUntilWorkFinished :: HasCallStack
=> Port
=> LogConfig
-> Port
-> JobInfo
-> WaiSession () JobInfo
pollUntilWorkFinished port ji = do
pollUntilWorkFinished log_cfg port ji = do
let waitSecs = 60
isFinishedTVar <- liftIO $ newTVarIO False
let wsConnect =
......@@ -271,24 +273,24 @@ pollUntilWorkFinished port ji = do
case dec of
Nothing -> pure ()
Just (DT.NUpdateWorkerProgress ji' jl) -> do
withLogger () $ \ioL ->
withLogger log_cfg $ \ioL ->
logMsg ioL DEBUG $ "[pollUntilWorkFinished] received " <> show ji' <> ", " <> show jl
if ji' == ji && isFinished jl
then do
withLogger () $ \ioL ->
withLogger log_cfg $ \ioL ->
logMsg ioL DEBUG $ "[pollUntilWorkFinished] FINISHED! " <> show ji'
atomically $ writeTVar isFinishedTVar True
else
pure ()
_ -> pure ()
liftIO $ withAsync wsConnect $ \_ -> do
mRet <- Timeout.timeout (waitSecs * 1000 * millisecond) $ do
let go = do
finished <- readTVarIO isFinishedTVar
if finished
then do
withLogger () $ \ioL ->
withLogger log_cfg $ \ioL ->
logMsg ioL DEBUG $ "[pollUntilWorkFinished] JOB FINISHED: " <> show ji
return True
else do
......@@ -298,7 +300,7 @@ pollUntilWorkFinished port ji = do
case mRet of
Nothing -> panicTrace $ "[pollUntilWorkFinished] timed out while waiting to finish job " <> show ji
Just _ -> return ji
where
isFinished (JobLog { .. }) = _scst_remaining == Just 0
......@@ -317,7 +319,7 @@ waitUntil pred' timeoutMs = do
-- shortcut for testing mTimeout
p <- pred'
unless p (expectationFailure "Predicate test failed")
where
performTest = do
p <- pred'
......
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