Commit 93f605d5 authored by Alfredo Di Napoli's avatar Alfredo Di Napoli

refactoring(logging): add log_file and log_config to Toml config

Furthermore, the env var we used to override (in some parts) the logging
level from `LOG_LEVEL`  to `GGTX_LOG_LEVEL`, to avoid the env var
`LOG_LEVEL` clashing with some other service.

This will eventually allow us to properly override the logging level in
the tests, silencing non interesting stuff.
parent 89d97fd0
...@@ -19,17 +19,17 @@ Import a corpus binary. ...@@ -19,17 +19,17 @@ Import a corpus binary.
module CLI.Ini where module CLI.Ini where
import CLI.Types import CLI.Types
import Control.Monad.Logger (LogLevel(LevelDebug))
import Data.Text qualified as T
import Data.Text.IO qualified as T (writeFile)
import Database.PostgreSQL.Simple qualified as PGS 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.Ini qualified as Ini
import Gargantext.Core.Config.Ini.Mail qualified as IniMail import Gargantext.Core.Config.Ini.Mail qualified as IniMail
import Gargantext.Core.Config.Ini.NLP qualified as IniNLP 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.Types qualified as CTypes
import Gargantext.Core.Config.Worker (WorkerSettings(..), WorkerDefinition(..)) import Gargantext.Core.Config.Worker (WorkerSettings(..), WorkerDefinition(..))
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.System.Logging (LogLevel(..))
import Options.Applicative import Options.Applicative
import Servant.Client.Core (parseBaseUrl) import Servant.Client.Core (parseBaseUrl)
import Toml qualified import Toml qualified
...@@ -87,7 +87,10 @@ convertConfigs ini@(Ini.GargConfig { .. }) iniMail nlpConfig connInfo = ...@@ -87,7 +87,10 @@ convertConfigs ini@(Ini.GargConfig { .. }) iniMail nlpConfig connInfo =
, _wsDefaultVisibilityTimeout = 1 , _wsDefaultVisibilityTimeout = 1
, _wsDefaultDelay = 0 , _wsDefaultDelay = 0
, _wsDatabase = connInfo { PGS.connectDatabase = "pgmq"} } , _wsDatabase = connInfo { PGS.connectDatabase = "pgmq"} }
, _gc_log_level = LevelDebug , _gc_logging = Config.LogConfig {
_lc_log_level = INFO
, _lc_log_file = Nothing
}
} }
where where
_ac_scrapyd_url = _ac_scrapyd_url =
......
...@@ -102,7 +102,7 @@ pass = PASSWORD_TO_CHANGE ...@@ -102,7 +102,7 @@ pass = PASSWORD_TO_CHANGE
[logs] [logs]
log_file = "/var/log/gargantext/backend.log" log_file = "/var/log/gargantext/backend.log"
log_level = "LevelDebug" log_level = "info"
log_formatter = "verbose" log_formatter = "verbose"
......
...@@ -694,7 +694,6 @@ executable gargantext ...@@ -694,7 +694,6 @@ executable gargantext
, gargantext-prelude , gargantext-prelude
, haskell-bee , haskell-bee
, MonadRandom ^>= 0.6 , MonadRandom ^>= 0.6
, monad-logger ^>= 0.3.36
, optparse-applicative , optparse-applicative
, postgresql-simple >= 0.6.4 && <= 0.7.0.0 , postgresql-simple >= 0.6.4 && <= 0.7.0.0
, servant >= 0.20.1 && < 0.21 , servant >= 0.20.1 && < 0.21
......
...@@ -4,61 +4,61 @@ cradle: ...@@ -4,61 +4,61 @@ cradle:
component: "lib:gargantext" component: "lib:gargantext"
- path: "./bin/gargantext-cli/Main.hs" - path: "./bin/gargantext-cli/Main.hs"
component: "gargantext:exe:gargantext-cli" component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Admin.hs" - path: "./bin/gargantext-cli/CLI/Admin.hs"
component: "gargantext:exe:gargantext-cli" component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/FileDiff.hs" - path: "./bin/gargantext-cli/CLI/FileDiff.hs"
component: "gargantext:exe:gargantext-cli" component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/FilterTermsAndCooc.hs" - path: "./bin/gargantext-cli/CLI/FilterTermsAndCooc.hs"
component: "gargantext:exe:gargantext-cli" component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Import.hs" - path: "./bin/gargantext-cli/CLI/Import.hs"
component: "gargantext:exe:gargantext-cli" component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Ini.hs" - path: "./bin/gargantext-cli/CLI/Ini.hs"
component: "gargantext:exe:gargantext-cli" component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Init.hs" - path: "./bin/gargantext-cli/CLI/Init.hs"
component: "gargantext:exe:gargantext-cli" component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Invitations.hs" - path: "./bin/gargantext-cli/CLI/Invitations.hs"
component: "gargantext:exe:gargantext-cli" component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/ObfuscateDB.hs" - path: "./bin/gargantext-cli/CLI/ObfuscateDB.hs"
component: "gargantext:exe:gargantext-cli" component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Parsers.hs" - path: "./bin/gargantext-cli/CLI/Parsers.hs"
component: "gargantext:exe:gargantext-cli" component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Phylo.hs" - path: "./bin/gargantext-cli/CLI/Phylo.hs"
component: "gargantext:exe:gargantext-cli" component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Phylo/Common.hs" - 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" - 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" - path: "./bin/gargantext-cli/CLI/Server/Routes.hs"
component: "gargantext:exe:gargantext-cli" component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Types.hs" - path: "./bin/gargantext-cli/CLI/Types.hs"
component: "gargantext:exe:gargantext-cli" component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/CLI/Upgrade.hs" - path: "./bin/gargantext-cli/CLI/Upgrade.hs"
component: "gargantext:exe:gargantext-cli" component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-cli/Paths_gargantext.hs" - path: "./bin/gargantext-cli/Paths_gargantext.hs"
component: "gargantext:exe:gargantext-cli" component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-server/Main.hs" - path: "./bin/gargantext-server/Main.hs"
component: "gargantext:exe:gargantext-server" component: "gargantext:exe:gargantext"
- path: "./bin/gargantext-server/Paths_gargantext.hs" - path: "./bin/gargantext-server/Paths_gargantext.hs"
component: "gargantext:exe:gargantext-server" component: "gargantext:exe:gargantext"
- path: "./test" - path: "./test"
component: "gargantext:test:garg-test-tasty" component: "gargantext:test:garg-test-tasty"
......
...@@ -48,14 +48,14 @@ import Gargantext.API.Middleware (logStdoutDevSanitised) ...@@ -48,14 +48,14 @@ import Gargantext.API.Middleware (logStdoutDevSanitised)
import Gargantext.API.Routes.Named (API) import Gargantext.API.Routes.Named (API)
import Gargantext.API.Routes.Named.EKG (EkgAPI) import Gargantext.API.Routes.Named.EKG (EkgAPI)
import Gargantext.API.Server.Named (server) 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.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.Config.Utils (readConfig)
import Gargantext.Core.Notifications (withNotifications) import Gargantext.Core.Notifications (withNotifications)
import Gargantext.Database.Prelude qualified as DB import Gargantext.Database.Prelude qualified as DB
import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp) import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp)
import Gargantext.Prelude hiding (putStrLn, to) import Gargantext.Prelude hiding (putStrLn, to)
import Gargantext.System.Logging (withLoggerIO) import Gargantext.System.Logging (withLoggerIO, renderLogLevel)
import Network.HTTP.Types hiding (Query) import Network.HTTP.Types hiding (Query)
import Network.Wai (Middleware, Request, requestHeaders) import Network.Wai (Middleware, Request, requestHeaders)
import Network.Wai.Handler.Warp hiding (defaultSettings) import Network.Wai.Handler.Warp hiding (defaultSettings)
...@@ -80,11 +80,11 @@ startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerIO mode $ \ ...@@ -80,11 +80,11 @@ startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerIO mode $ \
let fc = env ^. env_config . gc_frontend_config let fc = env ^. env_config . gc_frontend_config
let proxyStatus = microServicesProxyStatus fc let proxyStatus = microServicesProxyStatus fc
runDbCheck env runDbCheck env
portRouteInfo nc port proxyStatus startupInfo config port proxyStatus
app <- makeApp env app <- makeApp env
mid <- makeGargMiddleware (fc ^. fc_cors) mode mid <- makeGargMiddleware (fc ^. fc_cors) mode
periodicActions <- schedulePeriodicActions env periodicActions <- schedulePeriodicActions env
let runServer = run port (mid app) `finally` stopGargantext periodicActions let runServer = run port (mid app) `finally` stopGargantext periodicActions
case proxyStatus of case proxyStatus of
PXY_disabled PXY_disabled
...@@ -94,7 +94,7 @@ startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerIO mode $ \ ...@@ -94,7 +94,7 @@ startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerIO mode $ \
proxyCache <- InMemory.newCache (Just oneHour) proxyCache <- InMemory.newCache (Just oneHour)
let runProxy = run proxyPort (mid (microServicesProxyApp proxyCache env)) let runProxy = run proxyPort (mid (microServicesProxyApp proxyCache env))
Async.race_ runServer runProxy 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`
(\(err :: SomeException) -> pure $ Left err) (\(err :: SomeException) -> pure $ Left err)
...@@ -106,11 +106,12 @@ startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerIO mode $ \ ...@@ -106,11 +106,12 @@ startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerIO mode $ \
Left err -> panicTrace $ "Unexpected exception:" <> show err Left err -> panicTrace $ "Unexpected exception:" <> show err
oneHour = Clock.fromNanoSecs 3600_000_000_000 oneHour = Clock.fromNanoSecs 3600_000_000_000
portRouteInfo :: NotificationsConfig -> PortNumber -> MicroServicesProxyStatus -> IO () startupInfo :: GargConfig -> PortNumber -> MicroServicesProxyStatus -> IO ()
portRouteInfo nc mainPort proxyStatus = do startupInfo config mainPort proxyStatus = do
putStrLn "==========================================================================================================" putStrLn "=========================================================================================================="
putStrLn " GarganText Main Routes" putStrLn " GarganText Server"
putStrLn "==========================================================================================================" putStrLn "=========================================================================================================="
putStrLn $ " - Log Level ...............................: " <> renderLogLevel ll
putStrLn $ " - Web GarganText Frontend..................: " <> "http://localhost:" <> toUrlPiece mainPort <> "/index.html" putStrLn $ " - Web GarganText Frontend..................: " <> "http://localhost:" <> toUrlPiece mainPort <> "/index.html"
putStrLn $ " - Swagger UI (API documentation)...........: " <> "http://localhost:" <> toUrlPiece mainPort <> "/swagger-ui" putStrLn $ " - Swagger UI (API documentation)...........: " <> "http://localhost:" <> toUrlPiece mainPort <> "/swagger-ui"
putStrLn $ " - Playground GraphQL (API documentation)...: " <> "http://localhost:" <> toUrlPiece mainPort <> "/gql" putStrLn $ " - Playground GraphQL (API documentation)...: " <> "http://localhost:" <> toUrlPiece mainPort <> "/gql"
...@@ -121,6 +122,8 @@ portRouteInfo nc mainPort proxyStatus = do ...@@ -121,6 +122,8 @@ portRouteInfo nc mainPort proxyStatus = do
putStrLn $ " - WebSocket address........................: " <> "ws://localhost:" <> toUrlPiece mainPort <> "/ws" putStrLn $ " - WebSocket address........................: " <> "ws://localhost:" <> toUrlPiece mainPort <> "/ws"
putStrLn "==========================================================================================================" putStrLn "=========================================================================================================="
where where
nc = config ^. gc_notifications_config
ll = config ^. gc_logging . lc_log_level
renderProxyStatus = case proxyStatus of renderProxyStatus = case proxyStatus of
PXY_disabled -> PXY_disabled ->
" - Microservices proxy .....................: DISABLED (enable in gargantext-settings.toml)" " - Microservices proxy .....................: DISABLED (enable in gargantext-settings.toml)"
......
...@@ -62,7 +62,7 @@ settingsFromEnvironment = ...@@ -62,7 +62,7 @@ settingsFromEnvironment =
Settings <$> (encodeUtf8 <$> reqSetting "ALLOWED_ORIGIN") Settings <$> (encodeUtf8 <$> reqSetting "ALLOWED_ORIGIN")
<*> (encodeUtf8 <$> reqSetting "ALLOWED_HOST") <*> (encodeUtf8 <$> reqSetting "ALLOWED_HOST")
<*> optSetting "PORT" 3000 <*> optSetting "PORT" 3000
<*> (parseLogLevel <$> optSetting "LOG_LEVEL" "warn") <*> (parseLogLevel <$> optSetting "GGTX_LOG_LEVEL" "warn")
<*> reqSetting "DB_SERVER" <*> reqSetting "DB_SERVER"
<*> (parseJwk <$> reqSetting "JWT_SECRET") <*> (parseJwk <$> reqSetting "JWT_SECRET")
<*> optSetting "SEND_EMAIL" SendEmailViaAws <*> optSetting "SEND_EMAIL" SendEmailViaAws
......
...@@ -36,7 +36,7 @@ serveWorkerAPI f = WorkerAPI { workerAPIPost } ...@@ -36,7 +36,7 @@ serveWorkerAPI f = WorkerAPI { workerAPIPost }
where where
workerAPIPost i = do workerAPIPost i = do
let job = f i let job = f i
logM DDEBUG $ "[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
, _ji_mNode_id = getWorkerMNodeId job } , _ji_mNode_id = getWorkerMNodeId job }
...@@ -54,4 +54,4 @@ serveWorkerAPIEJob f = WorkerAPI { workerAPIPost } ...@@ -54,4 +54,4 @@ serveWorkerAPIEJob f = WorkerAPI { workerAPIPost }
mId <- sendJob job mId <- sendJob job
pure $ JobInfo { _ji_message_id = mId pure $ JobInfo { _ji_message_id = mId
, _ji_mNode_id = getWorkerMNodeId job } , _ji_mNode_id = getWorkerMNodeId job }
...@@ -12,10 +12,12 @@ Configuration for the gargantext server ...@@ -12,10 +12,12 @@ Configuration for the gargantext server
-} -}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE LambdaCase #-}
module Gargantext.Core.Config ( module Gargantext.Core.Config (
-- * Types -- * Types
GargConfig(..) GargConfig(..)
, LogConfig(..)
-- * Lenses -- * Lenses
, gc_datafilepath , gc_datafilepath
...@@ -29,7 +31,9 @@ module Gargantext.Core.Config ( ...@@ -29,7 +31,9 @@ module Gargantext.Core.Config (
, gc_secrets , gc_secrets
, gc_apis , gc_apis
, gc_worker , gc_worker
, gc_log_level , gc_logging
, lc_log_level
, lc_log_file
, mkProxyUrl , mkProxyUrl
...@@ -39,24 +43,43 @@ module Gargantext.Core.Config ( ...@@ -39,24 +43,43 @@ module Gargantext.Core.Config (
) where ) where
import Control.Lens (Getter) import Control.Lens (Getter)
import Control.Monad.Logger (LogLevel(LevelDebug)) import Gargantext.System.Logging (LogLevel, parseLogLevel)
import Data.Text as T
import Database.PostgreSQL.Simple qualified as PSQL import Database.PostgreSQL.Simple qualified as PSQL
import Data.Text as T
import Gargantext.Core.Config.Mail (MailConfig) import Gargantext.Core.Config.Mail (MailConfig)
import Gargantext.Core.Config.NLP (NLPConfig) import Gargantext.Core.Config.NLP (NLPConfig)
import Gargantext.Core.Config.Worker (WorkerSettings)
import Gargantext.Core.Config.Types import Gargantext.Core.Config.Types
import Gargantext.Core.Config.Worker (WorkerSettings)
import Gargantext.Prelude import Gargantext.Prelude
import Network.HTTP.Client qualified as HTTP import Network.HTTP.Client qualified as HTTP
import Servant.Auth.Server (JWTSettings) import Servant.Auth.Server (JWTSettings)
import Servant.Client (BaseUrl(..), Scheme(Http), parseBaseUrl) import Servant.Client (BaseUrl(..), Scheme(Http), parseBaseUrl)
import Toml.Schema import Toml.Schema
import Toml.Schema.FromValue (typeError)
-- | strip a given character from end of string -- | strip a given character from end of string
-- stripRight :: Char -> T.Text -> T.Text -- stripRight :: Char -> T.Text -> T.Text
-- stripRight c s = if T.last s == c then stripRight c (T.take (T.length s - 1) s) else s -- 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 -- Non-strict data so that we can use it in tests
data GargConfig = GargConfig { _gc_datafilepath :: ~FilePath data GargConfig = GargConfig { _gc_datafilepath :: ~FilePath
-- , _gc_repofilepath :: ~FilePath -- , _gc_repofilepath :: ~FilePath
...@@ -70,12 +93,10 @@ data GargConfig = GargConfig { _gc_datafilepath :: ~FilePath ...@@ -70,12 +93,10 @@ data GargConfig = GargConfig { _gc_datafilepath :: ~FilePath
, _gc_secrets :: ~SecretsConfig , _gc_secrets :: ~SecretsConfig
, _gc_apis :: ~APIsConfig , _gc_apis :: ~APIsConfig
, _gc_worker :: ~WorkerSettings , _gc_worker :: ~WorkerSettings
, _gc_log_level :: ~LogLevel , _gc_logging :: ~LogConfig
} }
deriving (Generic, Show) deriving (Generic, Show)
makeLenses ''GargConfig
instance FromValue GargConfig where instance FromValue GargConfig where
fromValue = parseTableFromValue $ do fromValue = parseTableFromValue $ do
_gc_frontend_config <- reqKey "frontend" _gc_frontend_config <- reqKey "frontend"
...@@ -89,7 +110,7 @@ instance FromValue GargConfig where ...@@ -89,7 +110,7 @@ instance FromValue GargConfig where
_gc_apis <- reqKey "apis" _gc_apis <- reqKey "apis"
_gc_notifications_config <- reqKey "notifications" _gc_notifications_config <- reqKey "notifications"
_gc_worker <- reqKey "worker" _gc_worker <- reqKey "worker"
let _gc_log_level = LevelDebug _gc_logging <- reqKey "logs"
return $ GargConfig { _gc_datafilepath return $ GargConfig { _gc_datafilepath
, _gc_jobs , _gc_jobs
, _gc_apis , _gc_apis
...@@ -101,7 +122,7 @@ instance FromValue GargConfig where ...@@ -101,7 +122,7 @@ instance FromValue GargConfig where
, _gc_frames , _gc_frames
, _gc_secrets , _gc_secrets
, _gc_worker , _gc_worker
, _gc_log_level } , _gc_logging }
instance ToValue GargConfig where instance ToValue GargConfig where
toValue = defaultTableToValue toValue = defaultTableToValue
instance ToTable GargConfig where instance ToTable GargConfig where
...@@ -139,3 +160,11 @@ class HasJWTSettings env where ...@@ -139,3 +160,11 @@ class HasJWTSettings env where
class HasManager env where class HasManager env where
gargHttpManager :: Getter env HTTP.Manager gargHttpManager :: Getter env HTTP.Manager
--
-- Lenses
--
makeLenses ''LogConfig
makeLenses ''GargConfig
...@@ -11,7 +11,7 @@ https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341 ...@@ -11,7 +11,7 @@ https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
Docs: Docs:
https://dev.sub.gargantext.org/#/share/Notes/187918 https://dev.sub.gargantext.org/#/share/Notes/187918
-} -}
module Gargantext.Core.Notifications.CentralExchange ( module Gargantext.Core.Notifications.CentralExchange (
...@@ -31,7 +31,7 @@ import Gargantext.Prelude ...@@ -31,7 +31,7 @@ import Gargantext.Prelude
import Gargantext.System.Logging (LogLevel(..), withLogger, logMsg) import Gargantext.System.Logging (LogLevel(..), withLogger, logMsg)
import Nanomsg (Pull(..), Push(..), bind, connect, recv, send, withSocket) import Nanomsg (Pull(..), Push(..), bind, connect, recv, send, withSocket)
import System.Timeout (timeout) import System.Timeout (timeout)
{- {-
Central exchange is a service, which gathers messages from various Central exchange is a service, which gathers messages from various
...@@ -42,7 +42,7 @@ The primary goal is to be able to read as many messages as possible ...@@ -42,7 +42,7 @@ 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 and then send them to the Dispatcher. Although nanomsg does some
message buffering, we don't want these messages to pile up, especially message buffering, we don't want these messages to pile up, especially
with many users having updates. with many users having updates.
-} -}
gServer :: NotificationsConfig -> IO () gServer :: NotificationsConfig -> IO ()
...@@ -50,10 +50,10 @@ gServer (NotificationsConfig { .. }) = do ...@@ -50,10 +50,10 @@ gServer (NotificationsConfig { .. }) = do
withSocket Pull $ \s -> do withSocket Pull $ \s -> do
withSocket Push $ \s_dispatcher -> do withSocket Push $ \s_dispatcher -> do
withLogger () $ \ioLogger -> do withLogger () $ \ioLogger -> do
logMsg ioLogger DDEBUG $ "[central_exchange] binding to " <> T.unpack _nc_central_exchange_bind logMsg ioLogger DEBUG $ "[central_exchange] binding to " <> T.unpack _nc_central_exchange_bind
_ <- bind s $ T.unpack _nc_central_exchange_bind _ <- bind s $ T.unpack _nc_central_exchange_bind
withLogger () $ \ioLogger -> do withLogger () $ \ioLogger -> do
logMsg ioLogger DDEBUG $ "[central_exchange] connecting to " <> T.unpack _nc_dispatcher_bind logMsg ioLogger DEBUG $ "[central_exchange] connecting to " <> T.unpack _nc_dispatcher_bind
_ <- connect s_dispatcher $ T.unpack _nc_dispatcher_connect _ <- connect s_dispatcher $ T.unpack _nc_dispatcher_connect
tChan <- TChan.newTChanIO tChan <- TChan.newTChanIO
...@@ -67,7 +67,7 @@ gServer (NotificationsConfig { .. }) = do ...@@ -67,7 +67,7 @@ gServer (NotificationsConfig { .. }) = do
forever $ do forever $ do
-- putText "[central_exchange] receiving" -- putText "[central_exchange] receiving"
r <- recv s r <- recv s
logMsg ioLogger DDEBUG $ "[central_exchange] received: " <> show r logMsg ioLogger DEBUG $ "[central_exchange] received: " <> show r
-- C.putStrLn $ "[central_exchange] " <> r -- C.putStrLn $ "[central_exchange] " <> r
atomically $ TChan.writeTChan tChan r atomically $ TChan.writeTChan tChan r
where where
...@@ -81,10 +81,10 @@ gServer (NotificationsConfig { .. }) = do ...@@ -81,10 +81,10 @@ gServer (NotificationsConfig { .. }) = do
-- putText $ "[central_exchange] sending that to the dispatcher: " <> show node_id -- putText $ "[central_exchange] sending that to the dispatcher: " <> show node_id
-- To make this more robust, use withAsync so we don't -- To make this more robust, use withAsync so we don't
-- block the main thread (send is blocking) -- block the main thread (send is blocking)
-- NOTE: If we're flooded with messages, and send is -- NOTE: If we're flooded with messages, and send is
-- slow, we might be spawning many threads... -- slow, we might be spawning many threads...
-- NOTE: Currently we just forward the message that we -- NOTE: Currently we just forward the message that we
-- got. So in theory central exchange isn't needed (we -- got. So in theory central exchange isn't needed (we
-- could ping dispatcher directly). However, I think -- could ping dispatcher directly). However, I think
...@@ -102,7 +102,7 @@ gServer (NotificationsConfig { .. }) = do ...@@ -102,7 +102,7 @@ gServer (NotificationsConfig { .. }) = do
void $ timeout 100_000 $ send s_dispatcher r void $ timeout 100_000 $ send s_dispatcher r
Nothing -> Nothing ->
logMsg ioLogger ERROR $ "[central_exchange] cannot decode message: " <> show r logMsg ioLogger ERROR $ "[central_exchange] cannot decode message: " <> show r
notify :: NotificationsConfig -> CEMessage -> IO () notify :: NotificationsConfig -> CEMessage -> IO ()
notify (NotificationsConfig { _nc_central_exchange_connect }) ceMessage = do notify (NotificationsConfig { _nc_central_exchange_connect }) ceMessage = do
...@@ -111,7 +111,7 @@ notify (NotificationsConfig { _nc_central_exchange_connect }) ceMessage = do ...@@ -111,7 +111,7 @@ notify (NotificationsConfig { _nc_central_exchange_connect }) ceMessage = do
_ <- connect s $ T.unpack _nc_central_exchange_connect _ <- connect s $ T.unpack _nc_central_exchange_connect
let str = Aeson.encode ceMessage let str = Aeson.encode ceMessage
withLogger () $ \ioLogger -> withLogger () $ \ioLogger ->
logMsg ioLogger DDEBUG $ "[central_exchange] sending: " <> (T.unpack $ TE.decodeUtf8 $ BSL.toStrict str) logMsg ioLogger DEBUG $ "[central_exchange] sending: " <> (T.unpack $ TE.decodeUtf8 $ BSL.toStrict str)
-- err <- sendNonblocking s $ BSL.toStrict str -- err <- sendNonblocking s $ BSL.toStrict str
-- putText $ "[notify] err: " <> show err -- putText $ "[notify] err: " <> show err
void $ timeout 100_000 $ send s $ BSL.toStrict str void $ timeout 100_000 $ send s $ BSL.toStrict str
...@@ -11,7 +11,7 @@ https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341 ...@@ -11,7 +11,7 @@ https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
Docs: Docs:
https://dev.sub.gargantext.org/#/share/Notes/187918 https://dev.sub.gargantext.org/#/share/Notes/187918
-} -}
module Gargantext.Core.Notifications.Dispatcher ( module Gargantext.Core.Notifications.Dispatcher (
...@@ -45,7 +45,7 @@ Dispatcher is a service, which provides couple of functionalities: ...@@ -45,7 +45,7 @@ Dispatcher is a service, which provides couple of functionalities:
- handles WebSocket connections and manages them - handles WebSocket connections and manages them
- accepts messages from central exchange - accepts messages from central exchange
- dispatches these messages to connected users - dispatches these messages to connected users
-} -}
data Dispatcher = data Dispatcher =
...@@ -63,7 +63,7 @@ withDispatcher nc cb = do ...@@ -63,7 +63,7 @@ withDispatcher nc cb = do
let dispatcher = Dispatcher { d_subscriptions = subscriptions } let dispatcher = Dispatcher { d_subscriptions = subscriptions }
cb dispatcher cb dispatcher
-- | This is a nanomsg socket listener. We want to read the messages -- | This is a nanomsg socket listener. We want to read the messages
-- | as fast as possible and then process them gradually in a separate -- | as fast as possible and then process them gradually in a separate
-- | thread. -- | thread.
...@@ -71,7 +71,7 @@ dispatcherListener :: NotificationsConfig -> SSet.Set Subscription -> IO () ...@@ -71,7 +71,7 @@ dispatcherListener :: NotificationsConfig -> SSet.Set Subscription -> IO ()
dispatcherListener (NotificationsConfig { _nc_dispatcher_bind }) subscriptions = do dispatcherListener (NotificationsConfig { _nc_dispatcher_bind }) subscriptions = do
withSocket Pull $ \s -> do withSocket Pull $ \s -> do
withLogger () $ \ioLogger -> do withLogger () $ \ioLogger -> do
logMsg ioLogger DDEBUG $ "[dispatcherListener] binding to " <> T.unpack _nc_dispatcher_bind logMsg ioLogger DEBUG $ "[dispatcherListener] binding to " <> T.unpack _nc_dispatcher_bind
_ <- bind s $ T.unpack _nc_dispatcher_bind _ <- bind s $ T.unpack _nc_dispatcher_bind
tChan <- TChan.newTChanIO tChan <- TChan.newTChanIO
...@@ -91,18 +91,18 @@ dispatcherListener (NotificationsConfig { _nc_dispatcher_bind }) subscriptions = ...@@ -91,18 +91,18 @@ dispatcherListener (NotificationsConfig { _nc_dispatcher_bind }) subscriptions =
where where
worker tChan throttleTChan = do worker tChan throttleTChan = do
-- tId <- myThreadId -- tId <- myThreadId
forever $ do forever $ do
r <- atomically $ TChan.readTChan tChan r <- atomically $ TChan.readTChan tChan
-- putText $ "[" <> show tId <> "] received a message: " <> decodeUtf8 r -- putText $ "[" <> show tId <> "] received a message: " <> decodeUtf8 r
case Aeson.decode (BSL.fromStrict r) of case Aeson.decode (BSL.fromStrict r) of
Nothing -> Nothing ->
withLogger () $ \ioL -> withLogger () $ \ioL ->
logMsg ioL DEBUG "[dispatcher_listener] unknown message from central exchange" logMsg ioL DEBUG "[dispatcher_listener] unknown message from central exchange"
Just ceMessage -> do Just ceMessage -> do
withLogger () $ \ioL -> withLogger () $ \ioL ->
logMsg ioL DDEBUG $ "[dispatcher_listener] received " <> show ceMessage logMsg ioL DEBUG $ "[dispatcher_listener] received " <> show ceMessage
-- subs <- atomically $ readTVar subscriptions -- subs <- atomically $ readTVar subscriptions
filteredSubs <- atomically $ do filteredSubs <- atomically $ do
let subs' = UnfoldlM.filter (pure . ceMessageSubPred ceMessage) $ SSet.unfoldlM subscriptions let subs' = UnfoldlM.filter (pure . ceMessageSubPred ceMessage) $ SSet.unfoldlM subscriptions
...@@ -164,7 +164,7 @@ sendNotification throttleTChan ceMessage sub = do ...@@ -164,7 +164,7 @@ sendNotification throttleTChan ceMessage sub = do
sendDataMessageThrottled :: (WS.Connection, WS.DataMessage) -> IO () sendDataMessageThrottled :: (WS.Connection, WS.DataMessage) -> IO ()
sendDataMessageThrottled (conn, msg) = do sendDataMessageThrottled (conn, msg) = do
withLogger () $ \ioL -> withLogger () $ \ioL ->
logMsg ioL DDEBUG $ "[sendDataMessageThrottled] dispatching notification: " <> show msg logMsg ioL DEBUG $ "[sendDataMessageThrottled] dispatching notification: " <> show msg
WS.sendDataMessage conn msg WS.sendDataMessage conn msg
......
...@@ -138,7 +138,7 @@ instance CET.HasCentralExchangeNotification WorkerEnv where ...@@ -138,7 +138,7 @@ instance CET.HasCentralExchangeNotification WorkerEnv where
c <- asks (view $ to _w_env_config) c <- asks (view $ to _w_env_config)
liftBase $ do liftBase $ do
withLogger () $ \ioL -> withLogger () $ \ioL ->
logMsg ioL DDEBUG $ "[ce_notify]: " <> show (_gc_notifications_config c) <> " :: " <> show m logMsg ioL DEBUG $ "[ce_notify]: " <> show (_gc_notifications_config c) <> " :: " <> show m
CE.notify (_gc_notifications_config c) m CE.notify (_gc_notifications_config c) m
--------- ---------
...@@ -236,7 +236,7 @@ instance MonadJobStatus WorkerMonad where ...@@ -236,7 +236,7 @@ instance MonadJobStatus WorkerMonad where
Nothing -> jobLogFailures steps latest Nothing -> jobLogFailures steps latest
Just msg -> addErrorEvent msg (jobLogFailures steps latest)) Just msg -> addErrorEvent msg (jobLogFailures steps latest))
markComplete jh = updateJobProgress jh jobLogComplete markComplete jh = updateJobProgress jh jobLogComplete
markFailed mb_msg jh = markFailed mb_msg jh =
updateJobProgress jh (\latest -> case mb_msg of updateJobProgress jh (\latest -> case mb_msg of
Nothing -> jobLogFailTotal latest Nothing -> jobLogFailTotal latest
Just msg -> jobLogFailTotalWithMessage msg latest) Just msg -> jobLogFailTotalWithMessage msg latest)
...@@ -264,4 +264,4 @@ updateJobProgress (WorkerJobHandle (ji@JobInfo { _ji_message_id })) f = do ...@@ -264,4 +264,4 @@ updateJobProgress (WorkerJobHandle (ji@JobInfo { _ji_message_id })) f = do
in in
Just (WorkerJobState { _wjs_job_info = ji Just (WorkerJobState { _wjs_job_info = ji
, _wjs_job_log = f initJobLog }) , _wjs_job_log = f initJobLog })
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE LambdaCase #-}
module Gargantext.System.Logging ( module Gargantext.System.Logging (
LogLevel(..) LogLevel(..)
, HasLogger(..) , HasLogger(..)
, MonadLogger(..) , MonadLogger(..)
, parseLogLevel
, renderLogLevel
, prop_loglevel_roundtrip
, logM , logM
, logLocM , logLocM
, logLoc , logLoc
...@@ -28,26 +32,35 @@ import Text.Read (readMaybe) ...@@ -28,26 +32,35 @@ import Text.Read (readMaybe)
data LogLevel = data LogLevel =
-- | Detailed debug messages
DDEBUG
-- | Debug messages -- | Debug messages
| DEBUG DEBUG
-- | Information -- | Information
| INFO | INFO
-- | Normal runtime conditions -- | Normal runtime conditions
| NOTICE
-- | General Warnings
| WARNING | WARNING
-- | General Errors -- | General Errors
| ERROR | ERROR
-- | Severe situations
| CRITICAL
-- | Take immediate action
| ALERT
-- | System is unusable
| EMERGENCY
deriving (Show, Eq, Ord, Enum, Bounded, Read) 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 -- | This is a barebore logging interface which we
-- can extend to plug a proper logging library, without -- can extend to plug a proper logging library, without
-- the details of the logger cropping up everywhere in -- the details of the logger cropping up everywhere in
...@@ -132,7 +145,7 @@ instance HasLogger IO where ...@@ -132,7 +145,7 @@ instance HasLogger IO where
type instance LogInitParams IO = () type instance LogInitParams IO = ()
type instance LogPayload IO = String type instance LogPayload IO = String
initLogger () = do initLogger () = do
mLvl <- liftIO $ lookupEnv "LOG_LEVEL" mLvl <- liftIO $ lookupEnv "GGTX_LOG_LEVEL"
let lvl = case mLvl of let lvl = case mLvl of
Nothing -> INFO Nothing -> INFO
Just s -> Just s ->
......
...@@ -52,6 +52,10 @@ user = "gargantua" ...@@ -52,6 +52,10 @@ user = "gargantua"
pass = "gargantua_test" pass = "gargantua_test"
name = "gargandb_test" name = "gargandb_test"
[logs]
log_file = "/var/log/gargantext/backend.log"
log_level = "warn"
[mail] [mail]
port = 25 port = 25
host = "localhost" host = "localhost"
......
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