Add WithLogger monad for deriving via (#44)

Library changes: * add withLogger, runLogAction * add WithLogger monad transformer, runWithLogger * remove runLoggerLoggingT from WAI middleware * major version bump Readme: * avoid bad use of withLoggerLoggingT in examples * recommend WithLogger in the "use without LoggingT" section Internal changes: * upgrade checkout action * automatically generate stack matrix * switch to new hlint-run action * drop LTS 12
freckle · Jun 3, 2024 · e4879ce · e4879ce
1 parent 9c349f6
commit e4879ce
Show file tree

Hide file tree

Showing 13 changed files with 143 additions and 259 deletions.
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
@@ -6,33 +6,36 @@ on:
     branches: main
 
 jobs:
+  generate:
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v4
+      - id: generate
+        uses: freckle/stack-action/generate-matrix@v5
+    outputs:
+      stack-yamls: ${{ steps.generate.outputs.stack-yamls }}
+
   test:
     runs-on: ubuntu-latest
+    needs: generate
 
     strategy:
       matrix:
-        stack-yaml:
-          - stack-nightly.yaml   # ghc-9.4
-          - stack.yaml           # ghc-9.2
-          - stack-lts-19.33.yaml # ghc-9.0
-          - stack-lts-18.28.yaml # ghc-8.10
-          - stack-lts-16.31.yaml # ghc-8.8
-          - stack-lts-14.27.yaml # ghc-8.6
-          - stack-lts-12.26.yaml # ghc-8.4
+        stack-yaml: ${{ fromJSON(needs.generate.outputs.stack-yamls) }}
       fail-fast: false
 
     steps:
-      - uses: actions/checkout@v3
+      - uses: actions/checkout@v4
       - uses: freckle/stack-action@v4
         with:
           stack-yaml: ${{ matrix.stack-yaml }}
 
   lint:
     runs-on: ubuntu-latest
     steps:
-      - uses: actions/checkout@v3
-      - uses: haskell/actions/hlint-setup@v2
-      - uses: haskell/actions/hlint-run@v2
+      - uses: actions/checkout@v4
+      - uses: haskell-actions/hlint-setup@v2
+      - uses: haskell-actions/hlint-run@v2
         with:
           fail-on: warning
           path: '["src/", "tests/"]'
diff --git a/Blammo.cabal b/Blammo.cabal
@@ -5,7 +5,7 @@ cabal-version: 1.18
 -- see: https://github.com/sol/hpack
 
 name:           Blammo
-version:        1.1.3.0
+version:        1.2.0.0
 synopsis:       Batteries-included Structured Logging library
 description:    Please see README.md
 category:       Utils
@@ -36,6 +36,7 @@ library
       Blammo.Logging.Terminal
       Blammo.Logging.Terminal.LogPiece
       Blammo.Logging.Test
+      Blammo.Logging.WithLogger
       Data.Aeson.Compat
       Network.Wai.Middleware.Logging
       System.Log.FastLogger.Compat
@@ -45,6 +46,7 @@ library
       src
   default-extensions:
       DerivingStrategies
+      GeneralizedNewtypeDeriving
       LambdaCase
       NoImplicitPrelude
       OverloadedStrings
@@ -88,6 +90,7 @@ test-suite readme
       Paths_Blammo
   default-extensions:
       DerivingStrategies
+      GeneralizedNewtypeDeriving
       LambdaCase
       NoImplicitPrelude
       OverloadedStrings
@@ -98,8 +101,8 @@ test-suite readme
       Blammo
     , aeson
     , base <5
+    , lens
     , markdown-unlit
-    , monad-logger
     , mtl
     , text
   default-language: Haskell2010
@@ -123,6 +126,7 @@ test-suite spec
       tests
   default-extensions:
       DerivingStrategies
+      GeneralizedNewtypeDeriving
       LambdaCase
       NoImplicitPrelude
       OverloadedStrings

diff --git 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
@@ -26,8 +26,7 @@ All built on the well-known `MonadLogger` interface and using an efficient
 ```haskell
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DerivingVia #-}
 
 module Main (module Main) where
 
@@ -37,9 +36,9 @@ import Data.Aeson
 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 @@ setting the format to `json` will automatically enable it (with
 ## Configuration
 
 | Setting     | Setter                      | Environment variable and format           |
-| ---         | ---                         | ---                                       |
+| ----------- | --------------------------- | ----------------------------------------- |
 | Format      | `setLogSettingsFormat`      | `LOG_FORMAT=tty\|json`                    |
 | Level(s)    | `setLogSettingsLevels`      | `LOG_LEVEL=<level>[,<source:level>,...]`  |
 | Destination | `setLogSettingsDestination` | `LOG_DESTINATION=stdout\|stderr\|@<path>` |
@@ -199,14 +198,17 @@ runAppT app f = runLoggerLoggingT app $ runReaderT f app
 
 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 @@ newtype App a = App
     , 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 @@ app = do
   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 @@ data App = App
 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,18 +339,19 @@ waiMiddleware app =
 ## Integration with Warp
 
 ```hs
+import qualified Network.Wai.Handler.Warp as Warp
+
 instance HasLogger App where
   -- ...
 
 warpSettings :: App -> Settings
 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 @@ instance Yesod App where
   -- ...
 
   messageLoggerSource app _logger loc source level msg =
-    runLoggerLoggingT app $ monadLoggerLog loc source level msg
+    runWithLogger app $ monadLoggerLog loc source level msg
 ```
 
 ---

diff --git a/package.yaml b/package.yaml
@@ -1,5 +1,5 @@
 name: Blammo
-version: 1.1.3.0
+version: 1.2.0.0
 maintainer: Freckle Education
 category: Utils
 github: freckle/blammo
@@ -37,6 +37,7 @@ dependencies:
 
 default-extensions:
   - DerivingStrategies
+  - GeneralizedNewtypeDeriving
   - LambdaCase
   - NoImplicitPrelude
   - OverloadedStrings
@@ -91,7 +92,7 @@ tests:
     dependencies:
       - Blammo
       - aeson
+      - lens
       - markdown-unlit
-      - monad-logger
       - mtl
       - text
diff --git a/src/Blammo/Logging.hs b/src/Blammo/Logging.hs
@@ -13,6 +13,7 @@ module Blammo.Logging
   , setLogSettingsConcurrency
   , Logger
   , HasLogger (..)
+  , withLogger
   , newLogger
   , runLoggerLoggingT
 
@@ -29,10 +30,12 @@ module Blammo.Logging
   , myThreadContext
   , Pair
 
-    -- ** Transformer
+    -- ** Transformers
   , MonadLogger (..)
   , MonadLoggerIO (..)
   , LoggingT
+  , WithLogger (..)
+  , runWithLogger
 
     -- ** Common logging functions
 
@@ -54,36 +57,23 @@ module Blammo.Logging
   , 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