1  {-# LANGUAGE TemplateHaskell #-}
  2  {-# LANGUAGE TypeFamilies    #-}
  3  {-# LANGUAGE TypeApplications #-}
  4  
  5  module Gargantext.System.Logging (
  6      LogLevel(..)
  7    , HasLogger(..)
  8    , MonadLogger(..)
  9    , logM
 10    , logLocM
 11    , logLoc
 12    , withLogger
 13    , withLoggerHoisted
 14    ) where
 15  
 16  import Language.Haskell.TH hiding (Type)
 17  import Control.Exception.Lifted (bracket)
 18  import Control.Monad.IO.Class
 19  import Control.Monad.Trans.Control
 20  import Data.Kind (Type)
 21  import Prelude
 22  import qualified Data.Text as T
 23  import qualified Language.Haskell.TH.Syntax        as TH
 24  
 25  data LogLevel =
 26    -- | Debug messages
 27    DEBUG
 28    -- | Information
 29    | INFO
 30    -- | Normal runtime conditions
 31    | NOTICE
 32    -- | General Warnings
 33    | WARNING
 34    -- | General Errors
 35    | ERROR
 36    -- | Severe situations
 37    | CRITICAL
 38    -- | Take immediate action
 39    | ALERT
 40    -- | System is unusable
 41    | EMERGENCY
 42    deriving (Show, Eq, Ord, Enum, Bounded)
 43  
 44  -- | This is a barebore logging interface which we
 45  -- can extend to plug a proper logging library, without
 46  -- the details of the logger cropping up everywhere in
 47  -- the rest of the codebase.
 48  class HasLogger m where
 49    data family Logger m        :: Type
 50    type family LogInitParams m :: Type
 51    type family LogPayload m    :: Type
 52    initLogger    :: LogInitParams m -> (forall m1. MonadIO m1 => m1 (Logger m))
 53    destroyLogger :: Logger m        -> (forall m1. MonadIO m1 => m1 ())
 54    logMsg        :: Logger m        -> LogLevel -> LogPayload m -> m ()
 55    logTxt        :: Logger m        -> LogLevel -> T.Text -> m ()
 56  
 57  -- | Separate typeclass to get hold of a 'Logger' from within a monad.
 58  -- We keey 'HasLogger' and 'MonadLogger' separate to enforce compositionality,
 59  -- i.e. we can still give instances to 'HasLogger' for things like 'IO' without
 60  -- having to force actually acquiring a logger for those monads.
 61  class HasLogger m => MonadLogger m where
 62    getLogger :: m (Logger m)
 63  
 64  -- | A variant of 'logTxt' that doesn't require passing an explicit 'Logger'.
 65  logM :: (Monad m, MonadLogger m) => LogLevel -> T.Text -> m ()
 66  logM level msg = do
 67    logger <- getLogger
 68    logTxt logger level msg
 69  
 70  -- | Like 'logM', but it automatically adds the file and line number to
 71  -- the output log.
 72  logLocM :: ExpQ
 73  logLocM = [| \level msg ->
 74    let loc = $(getLocTH)
 75    in logM level (formatWithLoc loc msg)
 76    |]
 77  
 78  logLoc :: ExpQ
 79  logLoc = [| \logger level msg ->
 80    let loc = $(getLocTH)
 81    in logTxt logger level (formatWithLoc loc msg)
 82    |]
 83  
 84  formatWithLoc :: Loc -> T.Text -> T.Text
 85  formatWithLoc loc msg = "[" <> locationToText <> "] " <> msg
 86    where
 87      locationToText :: T.Text
 88      locationToText = T.pack $ (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)
 89        where
 90          line = show . fst . loc_start
 91          char = show . snd . loc_start
 92  
 93  getLocTH :: ExpQ
 94  getLocTH = [| $(location >>= liftLoc) |]
 95  
 96  liftLoc :: Loc -> Q Exp
 97  liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc
 98      $(TH.lift a)
 99      $(TH.lift b)
100      $(TH.lift c)
101      ($(TH.lift d1), $(TH.lift d2))
102      ($(TH.lift e1), $(TH.lift e2))
103      |]
104  
105  -- | exception-safe combinator that creates and destroys a logger.
106  -- Think about it like a 'bracket' function from 'Control.Exception'.
107  withLogger :: (MonadBaseControl IO m, MonadIO m, HasLogger m)
108             => LogInitParams m
109             -> (Logger m -> m a)
110             -> m a
111  withLogger params = bracket (initLogger params) destroyLogger
112  
113  -- | Like 'withLogger', but it allows creating a 'Logger' that can run in
114  -- a different monad from within an 'IO' action.
115  withLoggerHoisted :: (MonadBaseControl IO m, HasLogger m)
116                    => LogInitParams m
117                    -> (Logger m -> IO a)
118                    -> IO a
119  withLoggerHoisted params act = bracket (initLogger params) destroyLogger act
120  
121  -- | A plain logger in the IO monad, waiting for more serious logging solutions like
122  -- the one described in https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/229
123  instance HasLogger IO where
124    data instance Logger IO        = IOLogger
125    type instance LogInitParams IO = ()
126    type instance LogPayload IO    = String
127    initLogger                     = \() -> pure IOLogger
128    destroyLogger                  = \_  -> pure ()
129    logMsg = \IOLogger lvl msg ->
130      let pfx = "[" <> show lvl <> "] "
131      in putStrLn $ pfx <> msg
132    logTxt lgr lvl msg = logMsg lgr lvl (T.unpack msg)