diff --git a/Blammo.cabal b/Blammo.cabal --- a/Blammo.cabal +++ b/Blammo.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: Blammo -version: 1.1.3.0 +version: 1.2.0.0 license: MIT license-file: LICENSE maintainer: Freckle Education @@ -31,6 +31,7 @@ Blammo.Logging.Terminal Blammo.Logging.Terminal.LogPiece Blammo.Logging.Test + Blammo.Logging.WithLogger Data.Aeson.Compat Network.Wai.Middleware.Logging System.Log.FastLogger.Compat @@ -39,8 +40,9 @@ other-modules: Paths_Blammo default-language: Haskell2010 default-extensions: - DerivingStrategies LambdaCase NoImplicitPrelude OverloadedStrings - RecordWildCards TypeApplications + DerivingStrategies GeneralizedNewtypeDeriving LambdaCase + NoImplicitPrelude OverloadedStrings RecordWildCards + TypeApplications ghc-options: -Weverything -Wno-all-missed-specialisations @@ -50,26 +52,26 @@ build-depends: aeson >=1.5.2.0, - base >=4.11.1.0 && <5, + base >=4.12.0.0 && <5, bytestring >=0.10.8.2, case-insensitive >=1.2.0.11, - clock >=0.7.2, - containers >=0.5.11.0, - dlist >=0.8.0.5, + clock >=0.8, + containers >=0.6.0.1, + dlist >=0.8.0.7, envparse >=0.5.0, - exceptions >=0.10.0, + exceptions >=0.10.4, fast-logger >=3.2.3, - http-types >=0.12.2, - lens >=4.16.1, + http-types >=0.12.3, + lens >=4.17.1, monad-logger-aeson >=0.4.0.3, mtl >=2.2.2, text >=1.2.3.1, time >=1.8.0.2, - unliftio >=0.2.9.0, + unliftio >=0.2.12, unliftio-core >=0.1.2.0, unordered-containers >=0.2.10.0, - vector >=0.12.0.2, - wai >=3.2.1.2 + vector >=0.12.1.2, + wai >=3.2.2.1 if impl(ghc >=9.8) ghc-options: -Wno-missing-role-annotations @@ -87,8 +89,9 @@ other-modules: Paths_Blammo default-language: Haskell2010 default-extensions: - DerivingStrategies LambdaCase NoImplicitPrelude OverloadedStrings - RecordWildCards TypeApplications + DerivingStrategies GeneralizedNewtypeDeriving LambdaCase + NoImplicitPrelude OverloadedStrings RecordWildCards + TypeApplications ghc-options: -Weverything -Wno-all-missed-specialisations @@ -99,9 +102,9 @@ build-depends: Blammo, aeson >=1.5.2.0, - base >=4.11.1.0 && <5, + base >=4.12.0.0 && <5, + lens >=4.17.1, markdown-unlit >=0.5.0, - monad-logger >=0.3.39, mtl >=2.2.2, text >=1.2.3.1 @@ -128,8 +131,9 @@ default-language: Haskell2010 default-extensions: - DerivingStrategies LambdaCase NoImplicitPrelude OverloadedStrings - RecordWildCards TypeApplications + DerivingStrategies GeneralizedNewtypeDeriving LambdaCase + NoImplicitPrelude OverloadedStrings RecordWildCards + TypeApplications ghc-options: -Weverything -Wno-all-missed-specialisations @@ -140,7 +144,7 @@ build-depends: Blammo, aeson >=1.5.2.0, - base >=4.11.1.0 && <5, + base >=4.12.0.0 && <5, bytestring >=0.10.8.2, envparse >=0.5.0, hspec >=2.7.9, diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,12 @@ -## [_Unreleased_](https://github.com/freckle/blammo/compare/v1.1.3.0...main) +## [_Unreleased_](https://github.com/freckle/blammo/compare/v1.2.0.0...main) + +## [v1.2.0.0](https://github.com/freckle/blammo/compare/v1.1.3.0...v1.2.0.0) + +- New in `Blammo.Logging`: `withLogger`, `WithLogger(..), runWithLogger` +- New in `Blammo.Logging.Logger`: `runLogAction` +- WAI middleware no longer performs a log flush. Wrap your entire application + in either `withLoggerLoggingT` or `withLogger` to ensure a log flush at + application shutdown. ## [v1.1.3.0](https://github.com/freckle/blammo/compare/v1.1.2.3...v1.1.3.0) diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -26,8 +26,7 @@ ```haskell {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DerivingVia #-} module Main (module Main) where @@ -37,9 +36,9 @@ import Data.Text (Text) import GHC.Generics (Generic) import Text.Markdown.Unlit () -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Logger (Loc, LogStr, ToLogStr (toLogStr)) -import Control.Monad.Reader (asks, MonadReader, ReaderT (runReaderT)) +import Control.Lens (lens) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (MonadReader, ReaderT (runReaderT)) ``` --> @@ -142,7 +141,7 @@ ## Configuration | Setting | Setter | Environment variable and format | -| --- | --- | --- | +| ----------- | --------------------------- | ----------------------------------------- | | Format | `setLogSettingsFormat` | `LOG_FORMAT=tty\|json` | | Level(s) | `setLogSettingsLevels` | `LOG_LEVEL=[,,...]` | | Destination | `setLogSettingsDestination` | `LOG_DESTINATION=stdout\|stderr\|@` | @@ -199,14 +198,17 @@ If your app monad is not a transformer stack containing `LoggingT` (ex: the [ReaderT pattern](https://www.fpcomplete.com/blog/readert-design-pattern/)), you -can implement a custom instance of `MonadLogger`: +can derive `MonadLogger` via `WithLogger`: ```haskell data AppEnv = AppEnv - { appLogFunc :: Loc -> LogSource -> LogLevel -> LogStr -> IO () + { appLogger :: Logger -- ... } +instance HasLogger AppEnv where + loggerL = lens appLogger $ \x y -> x {appLogger = y} + newtype App a = App { unApp :: ReaderT AppEnv IO a } deriving newtype @@ -216,11 +218,8 @@ , MonadIO , MonadReader AppEnv ) - -instance MonadLogger App where - monadLoggerLog loc logSource logLevel msg = do - logFunc <- asks appLogFunc - liftIO $ logFunc loc logSource logLevel (toLogStr msg) + deriving (MonadLogger, MonadLoggerIO) + via (WithLogger AppEnv IO) runApp :: AppEnv -> App a -> IO a runApp env action = @@ -237,20 +236,18 @@ action2 ``` -To retrieve the log function from Blammo, use `askLoggerIO` (from -`MonadLoggerIO`) with `runSimpleLoggingT` (or `runLoggerLoggingT` if you need -more customization options), when you initialize the app: +Initialize the app with `withLogger`. ```haskell main2 :: IO () -main2 = do - logFunc <- runSimpleLoggingT askLoggerIO - let appEnv = - AppEnv - { appLogFunc = logFunc - -- ... - } - runApp appEnv app +main2 = + withLogger defaultLogSettings $ \logger -> do + let appEnv = + AppEnv + { appLogger = logger + -- ... + } + runApp appEnv app ``` ## Integration with RIO @@ -299,11 +296,11 @@ instance HasLogger App where -- ... -runApp :: ReaderT App (LoggingT IO) a -> IO a -runApp f = do - logger <- newLogger defaultLogSettings - app <- App logger <$> runLoggerLoggingT logger awsDiscover - runLoggerLoggingT app $ runReaderT f app +runApp :: MonadUnliftIO m => ReaderT App m a -> m a +runApp f = + withLogger defaultLogSettings $ \logger -> do + aws <- runWithLogger logger awsDiscover + runReaderT f $ App logger aws awsDiscover :: (MonadIO m, MonadLoggerIO m) => m AWS.Env awsDiscover = do @@ -342,6 +339,8 @@ ## Integration with Warp ```hs +import qualified Network.Wai.Handler.Warp as Warp + instance HasLogger App where -- ... @@ -349,11 +348,10 @@ warpSettings app = setOnException onEx $ defaultSettings where onEx _req ex = - when (defaultShouldDisplayException ex) - $ runLoggerLoggingT app + when (Warp.defaultShouldDisplayException ex) + $ runWithLogger app $ logError - $ "Warp exception" - :# ["exception" .= displayException ex] + $ "Warp exception" :# ["exception" .= displayException ex] ``` ## Integration with Yesod @@ -366,7 +364,7 @@ -- ... messageLoggerSource app _logger loc source level msg = - runLoggerLoggingT app $ monadLoggerLog loc source level msg + runWithLogger app $ monadLoggerLog loc source level msg ``` --- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -26,8 +26,7 @@ ```haskell {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DerivingVia #-} module Main (module Main) where @@ -37,9 +36,9 @@ import Data.Text (Text) import GHC.Generics (Generic) import Text.Markdown.Unlit () -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Logger (Loc, LogStr, ToLogStr (toLogStr)) -import Control.Monad.Reader (asks, MonadReader, ReaderT (runReaderT)) +import Control.Lens (lens) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (MonadReader, ReaderT (runReaderT)) ``` --> @@ -142,7 +141,7 @@ ## Configuration | Setting | Setter | Environment variable and format | -| --- | --- | --- | +| ----------- | --------------------------- | ----------------------------------------- | | Format | `setLogSettingsFormat` | `LOG_FORMAT=tty\|json` | | Level(s) | `setLogSettingsLevels` | `LOG_LEVEL=[,,...]` | | Destination | `setLogSettingsDestination` | `LOG_DESTINATION=stdout\|stderr\|@` | @@ -199,14 +198,17 @@ If your app monad is not a transformer stack containing `LoggingT` (ex: the [ReaderT pattern](https://www.fpcomplete.com/blog/readert-design-pattern/)), you -can implement a custom instance of `MonadLogger`: +can derive `MonadLogger` via `WithLogger`: ```haskell data AppEnv = AppEnv - { appLogFunc :: Loc -> LogSource -> LogLevel -> LogStr -> IO () + { appLogger :: Logger -- ... } +instance HasLogger AppEnv where + loggerL = lens appLogger $ \x y -> x {appLogger = y} + newtype App a = App { unApp :: ReaderT AppEnv IO a } deriving newtype @@ -216,11 +218,8 @@ , MonadIO , MonadReader AppEnv ) - -instance MonadLogger App where - monadLoggerLog loc logSource logLevel msg = do - logFunc <- asks appLogFunc - liftIO $ logFunc loc logSource logLevel (toLogStr msg) + deriving (MonadLogger, MonadLoggerIO) + via (WithLogger AppEnv IO) runApp :: AppEnv -> App a -> IO a runApp env action = @@ -237,20 +236,18 @@ action2 ``` -To retrieve the log function from Blammo, use `askLoggerIO` (from -`MonadLoggerIO`) with `runSimpleLoggingT` (or `runLoggerLoggingT` if you need -more customization options), when you initialize the app: +Initialize the app with `withLogger`. ```haskell main2 :: IO () -main2 = do - logFunc <- runSimpleLoggingT askLoggerIO - let appEnv = - AppEnv - { appLogFunc = logFunc - -- ... - } - runApp appEnv app +main2 = + withLogger defaultLogSettings $ \logger -> do + let appEnv = + AppEnv + { appLogger = logger + -- ... + } + runApp appEnv app ``` ## Integration with RIO @@ -299,11 +296,11 @@ instance HasLogger App where -- ... -runApp :: ReaderT App (LoggingT IO) a -> IO a -runApp f = do - logger <- newLogger defaultLogSettings - app <- App logger <$> runLoggerLoggingT logger awsDiscover - runLoggerLoggingT app $ runReaderT f app +runApp :: MonadUnliftIO m => ReaderT App m a -> m a +runApp f = + withLogger defaultLogSettings $ \logger -> do + aws <- runWithLogger logger awsDiscover + runReaderT f $ App logger aws awsDiscover :: (MonadIO m, MonadLoggerIO m) => m AWS.Env awsDiscover = do @@ -342,6 +339,8 @@ ## Integration with Warp ```hs +import qualified Network.Wai.Handler.Warp as Warp + instance HasLogger App where -- ... @@ -349,11 +348,10 @@ warpSettings app = setOnException onEx $ defaultSettings where onEx _req ex = - when (defaultShouldDisplayException ex) - $ runLoggerLoggingT app + when (Warp.defaultShouldDisplayException ex) + $ runWithLogger app $ logError - $ "Warp exception" - :# ["exception" .= displayException ex] + $ "Warp exception" :# ["exception" .= displayException ex] ``` ## Integration with Yesod @@ -366,7 +364,7 @@ -- ... messageLoggerSource app _logger loc source level msg = - runLoggerLoggingT app $ monadLoggerLog loc source level msg + runWithLogger app $ monadLoggerLog loc source level msg ``` --- diff --git a/src/Blammo/Logging.hs b/src/Blammo/Logging.hs --- a/src/Blammo/Logging.hs +++ b/src/Blammo/Logging.hs @@ -13,6 +13,7 @@ , setLogSettingsConcurrency , Logger , HasLogger (..) + , withLogger , newLogger , runLoggerLoggingT @@ -29,10 +30,12 @@ , myThreadContext , Pair - -- ** Transformer + -- ** Transformers , MonadLogger (..) , MonadLoggerIO (..) , LoggingT + , WithLogger (..) + , runWithLogger -- ** Common logging functions @@ -54,36 +57,23 @@ , logOtherNS ) where -import Prelude - import Blammo.Logging.LogSettings import Blammo.Logging.Logger -import Control.Lens ((^.)) +import Blammo.Logging.WithLogger +import Control.Lens (view) import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Logger.Aeson import Data.Aeson (Series) import Data.Aeson.Types (Pair) -import Data.ByteString (ByteString) import UnliftIO.Exception (finally) +-- | Initialize logging, pass a 'Logger' to the callback, and clean up at the end. +-- +-- Applications should avoid calling this more than once in their lifecycle. runLoggerLoggingT :: (MonadUnliftIO m, HasLogger env) => env -> LoggingT m a -> m a -runLoggerLoggingT env f = (`finally` flushLogStr logger) $ do - runLoggingT - (filterLogger (getLoggerShouldLog logger) f) - (loggerOutput logger $ getLoggerReformat logger) +runLoggerLoggingT env f = + runLoggingT f (runLogAction logger) `finally` flushLogStr logger where - logger = env ^. loggerL - -loggerOutput - :: Logger - -> (LogLevel -> ByteString -> ByteString) - -> Loc - -> LogSource - -> LogLevel - -> LogStr - -> IO () -loggerOutput logger reformat = - defaultOutputWith $ defaultOutputOptions $ \logLevel bytes -> do - pushLogStrLn logger $ toLogStr $ reformat logLevel bytes + logger = view loggerL env diff --git a/src/Blammo/Logging/Logger.hs b/src/Blammo/Logging/Logger.hs --- a/src/Blammo/Logging/Logger.hs +++ b/src/Blammo/Logging/Logger.hs @@ -1,6 +1,7 @@ module Blammo.Logging.Logger ( Logger , HasLogger (..) + , withLogger , newLogger , flushLogger , pushLogger @@ -11,6 +12,7 @@ , getLoggerShouldColor , pushLogStrLn , flushLogStr + , runLogAction -- * Testing , newTestLogger @@ -28,7 +30,7 @@ import Blammo.Logging.Test hiding (getLoggedMessages) import qualified Blammo.Logging.Test as LoggedMessages import Control.Lens (view) -import Control.Monad (unless) +import Control.Monad (unless, when) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Logger.Aeson import Control.Monad.Reader (MonadReader) @@ -49,7 +51,34 @@ , newStderrLoggerSetN , newStdoutLoggerSetN ) -import UnliftIO.Exception (throwString) +import UnliftIO (MonadUnliftIO) +import UnliftIO.Exception (finally, throwString) + +-- | Initialize logging, pass a 'Logger' to the callback, and clean up at the end. +-- +-- Applications should avoid calling this more than once in their lifecycle. +withLogger :: MonadUnliftIO m => LogSettings -> (Logger -> m a) -> m a +withLogger settings f = do + logger <- newLogger settings + f logger `finally` flushLogStr logger + +-- | Write a message to the 'Logger', unless the logger's filter options +-- reject it based on its 'LogSource' and 'LogLevel' +runLogAction + :: (MonadIO m, ToLogStr msg) + => Logger + -> Loc + -> LogSource + -> LogLevel + -> msg + -> m () +runLogAction logger loc source level msg = + liftIO $ + when (lShouldLog logger source level) $ + defaultOutputWith options loc source level (toLogStr msg) + where + options = defaultOutputOptions $ \logLevel bytes -> + pushLogStrLn logger $ toLogStr $ getLoggerReformat logger logLevel bytes getLoggerLogSettings :: Logger -> LogSettings getLoggerLogSettings = lLogSettings diff --git a/src/Blammo/Logging/WithLogger.hs b/src/Blammo/Logging/WithLogger.hs new file mode 100644 --- /dev/null +++ b/src/Blammo/Logging/WithLogger.hs @@ -0,0 +1,28 @@ +module Blammo.Logging.WithLogger (WithLogger (..), runWithLogger) where + +import Prelude + +import Blammo.Logging.Logger (HasLogger (..), runLogAction) +import Control.Lens (view) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Logger.Aeson (MonadLogger (..), MonadLoggerIO (..)) +import Control.Monad.Reader (MonadReader, ReaderT (ReaderT), asks) + +-- | Useful with the @DerivingVia@ language extension to derive +-- 'MonadLogger' for your application monad +newtype WithLogger env m a = WithLogger (ReaderT env m a) + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader env) + +runWithLogger :: env -> WithLogger env m a -> m a +runWithLogger env (WithLogger (ReaderT f)) = f env + +instance (MonadIO m, HasLogger env) => MonadLogger (WithLogger env m) where + monadLoggerLog loc source level msg = do + logger <- asks (view loggerL) + runLogAction logger loc source level msg + +instance (MonadIO m, HasLogger env) => MonadLoggerIO (WithLogger env m) where + askLoggerIO = do + logger <- asks (view loggerL) + pure $ \loc source level msg -> + liftIO $ runLogAction logger loc source level msg diff --git a/src/Network/Wai/Middleware/Logging.hs b/src/Network/Wai/Middleware/Logging.hs --- a/src/Network/Wai/Middleware/Logging.hs +++ b/src/Network/Wai/Middleware/Logging.hs @@ -139,15 +139,14 @@ requestLoggerWith :: HasLogger env => Config -> env -> Middleware requestLoggerWith config env app req respond = - runLoggerLoggingT env $ withRunInIO $ \runInIO -> do + withRunInIO $ \runInIO -> do begin <- getTime app req $ \resp -> do recvd <- respond resp duration <- toMillis . subtract begin <$> getTime - recvd <$ runInIO (logResponse config duration req resp) + recvd <$ runInIO (runWithLogger env $ logResponse config duration req resp) where getTime = Clock.getTime Clock.Monotonic - toMillis x = fromIntegral (Clock.toNanoSecs x) / nsPerMs logResponse :: MonadLogger m => Config -> Double -> Request -> Response -> m ()