Use existing FastLogger for GargM

bin/gargantext-server/Main.hs

@@ -25,7 +25,8 @@ module Main where
 import Data.String (String)
 import Data.Text (unpack)
 import Data.Version (showVersion)
-import Gargantext.API (startGargantext, Mode(..)) -- , startGargantextMock)
+import Gargantext.API (startGargantext) -- , startGargantextMock)
+import Gargantext.API.Admin.EnvTypes
 import Gargantext.Prelude
 import Gargantext.System.Logging
 import Options.Generic

src/Gargantext/API.hs

@@ -29,13 +29,14 @@ Pouillard (who mainly made it).
 {-# LANGUAGE BangPatterns         #-}
 {-# LANGUAGE NumericUnderscores   #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
 module Gargantext.API
       where
 
 import Control.Concurrent
 import Control.Exception (catch, finally, SomeException{-, displayException, IOException-})
-import Control.Lens
+import Control.Lens hiding (Level)
 import Control.Monad.Except
 import Control.Monad.Reader (runReaderT)
 import Data.Either
@@ -46,9 +47,8 @@ import Data.Text.Encoding (encodeUtf8)
 import Data.Text.IO (putStrLn)
 import Data.Validity
 import GHC.Base (Applicative)
-import GHC.Generics (Generic)
 import Gargantext.API.Admin.Auth.Types (AuthContext)
-import Gargantext.API.Admin.EnvTypes (Env)
+import Gargantext.API.Admin.EnvTypes (Env, Mode(..))
 import Gargantext.API.Admin.Settings (newEnv)
 import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings)
 import Gargantext.API.EKG
@@ -69,14 +69,12 @@ import Servant
 import System.FilePath
 import qualified Gargantext.Database.Prelude as DB
 import qualified System.Cron.Schedule as Cron
-
-data Mode = Dev | Mock | Prod
-  deriving (Show, Read, Generic)
+import Gargantext.System.Logging
 
 -- | startGargantext takes as parameters port number and Ini file.
 startGargantext :: Mode -> PortNumber -> FilePath -> IO ()
-startGargantext mode port file = do
-  env <- newEnv port file
+startGargantext mode port file = withLoggerHoisted mode $ \logger -> do
+  env <- newEnv logger port file
   runDbCheck env
   portRouteInfo port
   app <- makeApp env

src/Gargantext/API/Admin/EnvTypes.hs

@@ -2,10 +2,12 @@
 
 {-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Gargantext.API.Admin.EnvTypes (
     GargJob(..)
   , Env(..)
+  , Mode(..)
   , mkJobHandle
   , env_logger
   , env_manager
@@ -18,7 +20,7 @@ module Gargantext.API.Admin.EnvTypes (
   , ConcreteJobHandle -- opaque
   ) where
 
-import Control.Lens hiding ((:<))
+import Control.Lens hiding (Level, (:<))
 import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Pool (Pool)
@@ -29,24 +31,57 @@ import Network.HTTP.Client (Manager)
 import Servant.Client (BaseUrl)
 import Servant.Job.Async (HasJobEnv(..), Job)
 import qualified Servant.Job.Async as SJ
-import System.Log.FastLogger
 import qualified Servant.Job.Core
 
-import Gargantext.API.Admin.Types
+import Data.List ((\\))
 import Gargantext.API.Admin.Orchestrator.Types
+import Gargantext.API.Admin.Types
 import Gargantext.API.Job
-import Gargantext.API.Prelude (GargM)
-import Gargantext.Core.NodeStory
+import Gargantext.API.Prelude (GargM, GargError)
 import Gargantext.Core.Mail.Types (HasMail, mailSettings)
 import Gargantext.Core.NLP (NLPServerMap, HasNLPServer(..))
+import Gargantext.Core.NodeStory
 import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig(..))
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (GargConfig(..))
 import Gargantext.Prelude.Mail.Types (MailConfig)
+import Gargantext.System.Logging
+import qualified System.Log.FastLogger as FL
 
 import qualified Gargantext.Utils.Jobs.Monad as Jobs
 import Gargantext.Utils.Jobs.Map (LoggerM, J(..), jTask, rjGetLog)
 
+data Mode = Dev | Mock | Prod
+  deriving (Show, Read, Generic)
+
+-- | Given the 'Mode' the server is running in, it returns the list of
+-- allowed levels. For example for production we ignore everything which
+-- has priority lower than "warning".
+modeToLoggingLevels :: Mode -> [Level]
+modeToLoggingLevels = \case
+   Dev  -> [minBound .. maxBound]
+   Mock -> [minBound .. maxBound]
+   -- For production, accepts everything but DEBUG.
+   Prod -> [minBound .. maxBound] \\ [DEBUG]
+
+instance HasLogger (GargM Env GargError) where
+  data instance Logger (GargM Env GargError)  =
+    GargLogger {
+        logger_mode    :: Mode
+      , logger_set     :: FL.LoggerSet
+      }
+  type instance InitParams (GargM Env GargError) = Mode
+  type instance Payload (GargM Env GargError) = 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 <> "] "
+    when (lvl `elem` (modeToLoggingLevels mode)) $
+      liftIO $ FL.pushLogStrLn logger_set $ FL.toLogStr pfx <> msg
+
+
 data GargJob
   = TableNgramsJob
   | ForgotPasswordJob
@@ -72,7 +107,7 @@ data GargJob
 -- we need to remember to force the fields to WHNF at that point.
 data Env = Env
   { _env_settings  :: ~Settings
-  , _env_logger    :: ~LoggerSet
+  , _env_logger    :: ~(Logger (GargM Env GargError))
   , _env_pool      :: ~(Pool Connection)
   , _env_nodeStory :: ~NodeStoryEnv
   , _env_manager   :: ~Manager

src/Gargantext/API/Admin/Settings.hs

@@ -37,12 +37,12 @@ import System.Directory
 -- import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
 import System.IO (FilePath, hClose)
 import System.IO.Temp (withTempFile)
-import System.Log.FastLogger
 import qualified Data.ByteString.Lazy as L
 
 
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.Types
+import Gargantext.API.Prelude
 -- import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
 import Gargantext.Core.NLP (nlpServerMap)
 import Gargantext.Database.Prelude (databaseParameters, hasConfig)
@@ -54,6 +54,7 @@ import qualified Gargantext.Utils.Jobs       as Jobs
 import qualified Gargantext.Utils.Jobs.Monad as Jobs
 import qualified Gargantext.Utils.Jobs.Queue as Jobs
 import qualified Gargantext.Utils.Jobs.Settings as Jobs
+import Gargantext.System.Logging
 
 devSettings :: FilePath -> IO Settings
 devSettings jwkFile = do
@@ -176,8 +177,8 @@ readRepoEnv repoDir = do
 devJwkFile :: FilePath
 devJwkFile = "dev.jwk"
 
-newEnv :: PortNumber -> FilePath -> IO Env
-newEnv port file = do
+newEnv :: Logger (GargM Env GargError) -> PortNumber -> FilePath -> IO Env
+newEnv logger port file = do
   !manager_env  <- newTlsManager
   !settings'    <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
   when (port /= settings' ^. appPort) $
@@ -200,7 +201,6 @@ newEnv port file = do
                         & Jobs.l_jsJobTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_job_timeout)
                         & Jobs.l_jsIDTimeout  .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_id_timeout)
   !jobs_env     <- Jobs.newJobEnv jobs_settings prios' manager_env
-  !logger        <- newStderrLoggerSet defaultBufSize
   !config_mail  <- Mail.readConfig file
   !nlp_env      <- nlpServerMap <$> NLP.readConfig file
 

src/Gargantext/API/Prelude.hs

@@ -49,6 +49,7 @@ import Servant
 import Servant.Job.Async
 import Servant.Job.Core (HasServerError(..), serverError)
 import qualified Servant.Job.Types as SJ
+import Gargantext.System.Logging
 
 class HasJoseError e where
   _JoseError :: Prism' e Jose.Error
@@ -88,7 +89,7 @@ type GargServerC env err m =
 
 type GargServerT env err m api = GargServerC env err m => ServerT api m
 
-type GargServer api = forall env err m. GargServerT env err m api
+type GargServer api = forall env err m. HasLogger m => GargServerT env err m api
 
 -- This is the concrete monad. It needs to be used as little as possible.
 type GargM env err = ReaderT env (ExceptT err IO)

src/Gargantext/Database/Action/Flow/Types.hs

@@ -30,6 +30,7 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Prelude (CmdM)
 import Gargantext.Database.Query.Table.Node.Document.Insert
 import Gargantext.Database.Query.Tree.Error (HasTreeError)
+import Gargantext.System.Logging
 
 type FlowCmdM env err m =
   ( CmdM     env err m
@@ -37,6 +38,7 @@ type FlowCmdM env err m =
   , HasNodeError err
   , HasInvalidError err
   , HasTreeError err
+  , HasLogger m
   )
 
 type FlowCorpus a = ( AddUniqId      a

src/Gargantext/System/Logging.hs

@@ -6,6 +6,7 @@ import Prelude
 import Data.Kind (Type)
 import Control.Monad.Trans.Control
 import Control.Exception.Lifted (bracket)
+import Control.Monad.IO.Class
 
 data Level =
   -- | Debug messages
@@ -34,14 +35,20 @@ class HasLogger m where
   data family Logger m     :: Type
   type family InitParams m :: Type
   type family Payload m    :: Type
-  initLogger    :: InitParams m -> m (Logger m)
-  destroyLogger :: Logger m -> m ()
+  initLogger    :: InitParams m -> (forall m1. MonadIO m1 => m1 (Logger m))
+  destroyLogger :: Logger m     -> (forall m1. MonadIO m1 => m1 ())
   logMsg        :: Logger m     -> Level -> Payload m -> m ()
 
 -- | exception-safe combinator that creates and destroys a logger.
 -- Think about it like a 'bracket' function from 'Control.Exception'.
-withLogger :: (MonadBaseControl IO m, HasLogger m)
+withLogger :: (MonadBaseControl IO m, MonadIO m, HasLogger m)
            => InitParams m
            -> (Logger m -> m a)
            -> m a
 withLogger params = bracket (initLogger params) destroyLogger
+
+withLoggerHoisted :: (MonadBaseControl IO m, HasLogger m)
+                  => InitParams m
+                  -> (Logger m -> IO a)
+                  -> IO a
+withLoggerHoisted params act = bracket (initLogger params) destroyLogger act