.monadlogger-without-loggingt.md

Using MonadLogger without LoggingT in Haskell

monadlogger-without-loggingt.cabal

cabal-version: 3.0
name: monadlogger-without-loggingt
version: 1.0.0

common options
    build-depends:
        , Blammo
        , monad-logger
        , monad-logger-aeson
        , relude
    ghc-options:
        -Wall
        -Wcompat
        -Widentities
        -Wincomplete-uni-patterns
        -Wincomplete-record-updates
        -Wredundant-constraints
        -Wmissing-export-lists
        -Wpartial-fields
        -Wunused-packages
    default-language: GHC2021
    default-extensions:
        DeriveAnyClass
        DerivingStrategies
        DerivingVia
        DuplicateRecordFields
        NoImplicitPrelude
        OverloadedRecordDot
        OverloadedStrings
        StrictData

executable with-loggingt
    import: options
    main-is: WithLoggingT.hs
    hs-source-dirs: .

executable without-loggingt
    import: options
    main-is: WithoutLoggingT.hs
    hs-source-dirs: .

WithLoggingT.hs

module Main (main) where

import Relude

import Blammo.Logging.Simple qualified as Blammo (runSimpleLoggingT)
import Control.Monad.Logger (LoggingT, MonadLogger)
import Control.Monad.Logger.Aeson (Message ((:#)), (.=))
import Control.Monad.Logger.Aeson qualified as LoggerJson (
  logInfo,
  logWarn,
  runStdoutLoggingT,
 )
import Control.Monad.Logger.CallStack qualified as Logger (
  logInfo,
  logWarn,
  runStdoutLoggingT,
 )

data Item = Item
  { itemId :: Text
  , itemContents :: Text
  }

fetchItem :: Text -> IO Item
fetchItem _itemUrl =
  pure
    $ Item
      { itemId = "652412308"
      , itemContents = "<p>Hello world!</p>"
      }

isInvalidItem :: Item -> Bool
isInvalidItem _item = True

processItem :: (MonadIO m) => Item -> m ()
processItem _item = pure ()

data AppEnv = AppEnv
  { appName :: Text
  , appItemUrl :: Text
  }

newtype App a = App
  {unApp :: ReaderT AppEnv (LoggingT IO) a}
  deriving newtype
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadReader AppEnv
    , MonadLogger
    )

runApp :: AppEnv -> (LoggingT IO a -> IO a) -> App a -> IO a
runApp env runLogging action =
  runLogging $ runReaderT (unApp action) env

actionPlain :: (MonadReader AppEnv m, MonadLogger m, MonadIO m) => m ()
actionPlain = do
  itemUrl <- asks appItemUrl
  Logger.logInfo $ "Fetching item: " <> "itemUrl=" <> itemUrl
  item <- liftIO $ fetchItem itemUrl
  if isInvalidItem item
    then
      Logger.logWarn
        $ "Skipping invalid item: "
        <> "itemUrl="
        <> itemUrl
        <> " itemId="
        <> itemId item
    else processItem item

appPlain :: App ()
appPlain = do
  appName <- asks appName
  Logger.logInfo $ "App started: " <> "appName=" <> appName
  actionPlain

actionJson :: (MonadReader AppEnv m, MonadLogger m, MonadIO m) => m ()
actionJson = do
  itemUrl <- asks appItemUrl
  LoggerJson.logInfo $ "Fetching item" :# ["itemUrl" .= itemUrl]
  item <- liftIO $ fetchItem itemUrl
  if isInvalidItem item
    then
      LoggerJson.logWarn
        $ "Skipping invalid item"
        :# [ "itemUrl" .= itemUrl
           , "itemId" .= itemId item
           ]
    else processItem item

appJson :: App ()
appJson = do
  appName <- asks appName
  LoggerJson.logInfo $ "App started" :# ["appName" .= appName]
  actionJson

mainPlain :: IO ()
mainPlain = do
  let appEnv =
        AppEnv
          { appName = "example-1a"
          , appItemUrl = "https://www.example.com/item"
          }
  runApp appEnv Logger.runStdoutLoggingT appPlain

mainJson :: IO ()
mainJson = do
  let appEnv =
        AppEnv
          { appName = "example-1b"
          , appItemUrl = "https://www.example.com/item"
          }
  runApp appEnv LoggerJson.runStdoutLoggingT appJson

mainBlammo :: IO ()
mainBlammo = do
  let appEnv =
        AppEnv
          { appName = "example-1c"
          , appItemUrl = "https://www.example.com/item"
          }
  runApp appEnv Blammo.runSimpleLoggingT appJson

main :: IO ()
main = do
  mainPlain
  putStrLn ""
  mainJson
  putStrLn ""
  mainBlammo

WithoutLoggingT.hs

module Main (main) where

import Relude

import Blammo.Logging.Simple qualified as Blammo (runSimpleLoggingT)
import Control.Monad.Logger (
  Loc,
  LogLevel,
  LogSource,
  LogStr,
  MonadLogger (monadLoggerLog),
  MonadLoggerIO (askLoggerIO),
  ToLogStr (toLogStr),
 )
import Control.Monad.Logger.Aeson (Message ((:#)), (.=))
import Control.Monad.Logger.Aeson qualified as LoggerJson (
  defaultOutput,
  logInfo,
  logWarn,
 )
import Control.Monad.Logger.CallStack qualified as Logger (
  defaultOutput,
  logInfo,
  logWarn,
 )

type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()

data Item = Item
  { itemId :: Text
  , itemContents :: Text
  }

fetchItem :: Text -> IO Item
fetchItem _itemUrl =
  pure
    $ Item
      { itemId = "652412308"
      , itemContents = "<p>Hello world!</p>"
      }

isInvalidItem :: Item -> Bool
isInvalidItem _item = True

processItem :: (MonadIO m) => Item -> m ()
processItem _item = pure ()

data AppEnv = AppEnv
  { appName :: Text
  , appItemUrl :: Text
  , appLogFunc :: LogFunc
  }

newtype App a = App
  {unApp :: ReaderT AppEnv IO a}
  deriving newtype
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadReader AppEnv
    )

instance MonadLogger App where
  monadLoggerLog loc logSource logLevel msg = do
    logFunc <- asks appLogFunc
    liftIO $ logFunc loc logSource logLevel (toLogStr msg)

runApp :: AppEnv -> App a -> IO a
runApp env action =
  runReaderT (unApp action) env

actionPlain :: (MonadReader AppEnv m, MonadLogger m, MonadIO m) => m ()
actionPlain = do
  itemUrl <- asks appItemUrl
  Logger.logInfo $ "Fetching item: " <> "itemUrl=" <> itemUrl
  item <- liftIO $ fetchItem itemUrl
  if isInvalidItem item
    then
      Logger.logWarn
        $ "Skipping invalid item: "
        <> "itemUrl="
        <> itemUrl
        <> " itemId="
        <> itemId item
    else processItem item

appPlain :: App ()
appPlain = do
  appName <- asks appName
  Logger.logInfo $ "App started: " <> "appName=" <> appName
  actionPlain

actionJson :: (MonadReader AppEnv m, MonadLogger m, MonadIO m) => m ()
actionJson = do
  itemUrl <- asks appItemUrl
  LoggerJson.logInfo $ "Fetching item" :# ["itemUrl" .= itemUrl]
  item <- liftIO $ fetchItem itemUrl
  if isInvalidItem item
    then
      LoggerJson.logWarn
        $ "Skipping invalid item"
        :# [ "itemUrl" .= itemUrl
           , "itemId" .= itemId item
           ]
    else processItem item

appJson :: App ()
appJson = do
  appName <- asks appName
  LoggerJson.logInfo $ "App started" :# ["appName" .= appName]
  actionJson

mainPlain :: IO ()
mainPlain = do
  let logFunc = Logger.defaultOutput stdout
      appEnv =
        AppEnv
          { appName = "example-2a"
          , appItemUrl = "https://www.example.com/item"
          , appLogFunc = logFunc
          }
  runApp appEnv appPlain

mainJson :: IO ()
mainJson = do
  let logFunc = LoggerJson.defaultOutput stdout
      appEnv =
        AppEnv
          { appName = "example-2b"
          , appItemUrl = "https://www.example.com/item"
          , appLogFunc = logFunc
          }
  runApp appEnv appJson

getBlammoLogFunc :: IO LogFunc
getBlammoLogFunc =
  Blammo.runSimpleLoggingT askLoggerIO

mainBlammo :: IO ()
mainBlammo = do
  logFunc <- getBlammoLogFunc
  let appEnv =
        AppEnv
          { appName = "example-2c"
          , appItemUrl = "https://www.example.com/item"
          , appLogFunc = logFunc
          }
  runApp appEnv appJson

main :: IO ()
main = do
  mainPlain
  putStrLn ""
  mainJson
  putStrLn ""
  mainBlammo