Skip to content

Instantly share code, notes, and snippets.

@nicolashery
Last active September 26, 2023 19:11
Show Gist options
  • Save nicolashery/a5eceb7603262f79f08d8b29ed41aef6 to your computer and use it in GitHub Desktop.
Save nicolashery/a5eceb7603262f79f08d8b29ed41aef6 to your computer and use it in GitHub Desktop.

Using MonadLogger without LoggingT in Haskell

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: .
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
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment