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.2.1 +version: 1.1.2.2 license: MIT license-file: LICENSE maintainer: Freckle Education @@ -49,28 +49,31 @@ -Wno-safe -Wno-unsafe build-depends: - aeson, + aeson >=1.5.2.0, base >=4.11.1.0 && <5, - bytestring, - case-insensitive, - clock, - containers, - dlist, - envparse, - exceptions, - fast-logger, - http-types, - lens, - monad-logger-aeson, - mtl, - text, - time, - unliftio, - unliftio-core, - unordered-containers, - vector, - wai + 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, + envparse >=0.5.0, + exceptions >=0.10.0, + fast-logger >=2.4.11, + http-types >=0.12.2, + lens >=4.16.1, + monad-logger-aeson >=0.3.0.2, + mtl >=2.2.2, + text >=1.2.3.1, + time >=1.8.0.2, + unliftio >=0.2.9.0, + unliftio-core >=0.1.2.0, + unordered-containers >=0.2.10.0, + vector >=0.12.0.2, + wai >=3.2.1.2 + if impl(ghc >=9.8) + ghc-options: -Wno-missing-role-annotations + if impl(ghc >=9.2) ghc-options: -Wno-missing-kind-signatures @@ -95,11 +98,16 @@ build-depends: Blammo, - aeson, + aeson >=1.5.2.0, base >=4.11.1.0 && <5, - markdown-unlit, - text + markdown-unlit >=0.5.0, + monad-logger >=0.3.30, + mtl >=2.2.2, + text >=1.2.3.1 + if impl(ghc >=9.8) + ghc-options: -Wno-missing-role-annotations + if impl(ghc >=9.2) ghc-options: -Wno-missing-kind-signatures @@ -113,6 +121,7 @@ hs-source-dirs: tests other-modules: Blammo.Logging.LoggerSpec + Blammo.Logging.LogSettings.EnvSpec Blammo.Logging.LogSettings.LogLevelsSpec Blammo.Logging.TerminalSpec Paths_Blammo @@ -130,13 +139,17 @@ build-depends: Blammo, - aeson, + aeson >=1.5.2.0, base >=4.11.1.0 && <5, - bytestring, - hspec, - mtl, - text, - time + bytestring >=0.10.8.2, + envparse >=0.5.0, + hspec >=2.7.9, + mtl >=2.2.2, + text >=1.2.3.1, + time >=1.8.0.2 + + if impl(ghc >=9.8) + ghc-options: -Wno-missing-role-annotations if impl(ghc >=9.2) ghc-options: -Wno-missing-kind-signatures diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,13 @@ -## [_Unreleased_](https://github.com/freckle/blammo/compare/v1.1.2.1...main) +## [_Unreleased_](https://github.com/freckle/blammo/compare/v1.1.2.2...main) + +## [v1.1.2.2](https://github.com/freckle/blammo/compare/v1.1.2.1...v1.1.2.2) + +- Don't automatically colorize if `TERM=dumb` is found in ENV +- Respect [`NO_COLOR`](http://no-color.org/) +- Automatically adjust log concurrency based on `LOG_FORMAT`: + + Disable concurrency for `tty` (making that the new default) and enable it for + `json`. Setting `LOG_CONCURRENCY` will still be respected. ## [v1.1.2.1](https://github.com/freckle/blammo/compare/v1.1.2.0...v1.1.2.1) diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -1,6 +1,5 @@ # Blammo - [![Hackage](https://img.shields.io/hackage/v/Blammo.svg?style=flat)](https://hackage.haskell.org/package/Blammo) [![Stackage Nightly](http://stackage.org/package/Blammo/badge/nightly)](http://stackage.org/nightly/package/Blammo) [![Stackage LTS](http://stackage.org/package/Blammo/badge/lts)](http://stackage.org/lts/package/Blammo) @@ -28,6 +27,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Main (module Main) where @@ -37,6 +37,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)) ``` --> @@ -123,14 +126,16 @@ ## Out of Order Messages Blammo is built on [fast-logger], which offers concurrent logging through -multiple buffers. By default, it uses {number-of-processors} buffers. This -concurrent logging is fast, but may deliver messages out of order. You want this -on production: your aggregator should be inspecting the message's time-stamp to -re-order as necessary on the other side. However, this can be problematic in a -CLI, where there is both little need for such high performance and a lower -tolerance for the confusion of out of order messages. +multiple buffers. This concurrent logging is fast, but may deliver messages out +of order. You want this on production: your aggregator should be inspecting the +message's time-stamp to re-order as necessary on the other side. However, this +can be problematic in a CLI, where there is both little need for such high +performance and a lower tolerance for the confusion of out of order messages. -For such cases, you can set `LOG_CONCURRENCY=1` to use a single buffer. +For this reason, the default behavior is to _not_ use concurrent logging, but +setting the format to `json` will automatically enable it (with +{number-of-cores} as the value). To handle this explicitly, set +`LOG_CONCURRENCY`. [fast-logger]: https://hackage.haskell.org/package/fast-logger @@ -138,6 +143,7 @@ | Setting | Setter | Environment variable and format | | --- | --- | --- | +| Format | `setLogSettingsFormat` | `LOG_FORMAT=tty\|json` | | Level(s) | `setLogSettingsLevels` | `LOG_LEVEL=[,,...]` | | Destination | `setLogSettingsDestination` | `LOG_DESTINATION=stdout\|stderr\|@` | | Color | `setLogSettingsColor ` | `LOG_COLOR=auto\|always\|never` | @@ -187,6 +193,64 @@ ```hs runAppT :: App -> ReaderT App (LoggingT IO) a -> IO a runAppT app f = runLoggerLoggingT app $ runReaderT f app +``` + +## Use without `LoggingT` + +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`: + +```haskell +data AppEnv = AppEnv + { appLogFunc :: Loc -> LogSource -> LogLevel -> LogStr -> IO () + -- ... + } + +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 +``` + +In your app you can use code written against the `MonadLogger` interface, like +the actions defined earlier: + +```haskell +app :: App () +app = do + action1 + 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: + +```haskell +main2 :: IO () +main2 = do + logFunc <- runSimpleLoggingT askLoggerIO + let appEnv = + AppEnv + { appLogFunc = logFunc + -- ... + } + runApp appEnv app ``` ## Integration with RIO diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,5 @@ # Blammo - [![Hackage](https://img.shields.io/hackage/v/Blammo.svg?style=flat)](https://hackage.haskell.org/package/Blammo) [![Stackage Nightly](http://stackage.org/package/Blammo/badge/nightly)](http://stackage.org/nightly/package/Blammo) [![Stackage LTS](http://stackage.org/package/Blammo/badge/lts)](http://stackage.org/lts/package/Blammo) @@ -28,6 +27,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Main (module Main) where @@ -37,6 +37,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)) ``` --> @@ -123,14 +126,16 @@ ## Out of Order Messages Blammo is built on [fast-logger], which offers concurrent logging through -multiple buffers. By default, it uses {number-of-processors} buffers. This -concurrent logging is fast, but may deliver messages out of order. You want this -on production: your aggregator should be inspecting the message's time-stamp to -re-order as necessary on the other side. However, this can be problematic in a -CLI, where there is both little need for such high performance and a lower -tolerance for the confusion of out of order messages. +multiple buffers. This concurrent logging is fast, but may deliver messages out +of order. You want this on production: your aggregator should be inspecting the +message's time-stamp to re-order as necessary on the other side. However, this +can be problematic in a CLI, where there is both little need for such high +performance and a lower tolerance for the confusion of out of order messages. -For such cases, you can set `LOG_CONCURRENCY=1` to use a single buffer. +For this reason, the default behavior is to _not_ use concurrent logging, but +setting the format to `json` will automatically enable it (with +{number-of-cores} as the value). To handle this explicitly, set +`LOG_CONCURRENCY`. [fast-logger]: https://hackage.haskell.org/package/fast-logger @@ -138,6 +143,7 @@ | Setting | Setter | Environment variable and format | | --- | --- | --- | +| Format | `setLogSettingsFormat` | `LOG_FORMAT=tty\|json` | | Level(s) | `setLogSettingsLevels` | `LOG_LEVEL=[,,...]` | | Destination | `setLogSettingsDestination` | `LOG_DESTINATION=stdout\|stderr\|@` | | Color | `setLogSettingsColor ` | `LOG_COLOR=auto\|always\|never` | @@ -187,6 +193,64 @@ ```hs runAppT :: App -> ReaderT App (LoggingT IO) a -> IO a runAppT app f = runLoggerLoggingT app $ runReaderT f app +``` + +## Use without `LoggingT` + +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`: + +```haskell +data AppEnv = AppEnv + { appLogFunc :: Loc -> LogSource -> LogLevel -> LogStr -> IO () + -- ... + } + +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 +``` + +In your app you can use code written against the `MonadLogger` interface, like +the actions defined earlier: + +```haskell +app :: App () +app = do + action1 + 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: + +```haskell +main2 :: IO () +main2 = do + logFunc <- runSimpleLoggingT askLoggerIO + let appEnv = + AppEnv + { appLogFunc = logFunc + -- ... + } + runApp appEnv app ``` ## Integration with RIO diff --git a/src/Blammo/Logging/LogSettings.hs b/src/Blammo/Logging/LogSettings.hs --- a/src/Blammo/Logging/LogSettings.hs +++ b/src/Blammo/Logging/LogSettings.hs @@ -86,6 +86,7 @@ = LogColorAuto | LogColorAlways | LogColorNever + deriving stock (Eq, Show) readLogColor :: String -> Either String LogColor readLogColor x @@ -115,7 +116,7 @@ , lsFormat = LogFormatTerminal , lsColor = LogColorAuto , lsBreakpoint = 120 - , lsConcurrency = Nothing + , lsConcurrency = Just 1 } setLogSettingsLevels :: LogLevels -> LogSettings -> LogSettings @@ -125,7 +126,17 @@ setLogSettingsDestination x ls = ls {lsDestination = x} setLogSettingsFormat :: LogFormat -> LogSettings -> LogSettings -setLogSettingsFormat x ls = ls {lsFormat = x} +setLogSettingsFormat x ls = case x of + LogFormatTerminal -> + ls + { lsFormat = x + , lsConcurrency = Just 1 + } + _ -> + ls + { lsFormat = x + , lsConcurrency = Nothing + } setLogSettingsColor :: LogColor -> LogSettings -> LogSettings setLogSettingsColor x ls = ls {lsColor = x} @@ -135,9 +146,9 @@ -- | Set the number of 'LoggerSet' Buffers used by @fast-logger@ -- --- By default this matches 'getNumCapabilities', which is more performant but --- does not guarantee message order. If this matters, such as in a CLI, set this --- value to @1@. +-- A value of 'Nothing' means to use 'getNumCapabilities'. Higher is more +-- performant, but may deliver messages out of order. The defualt is set for TTY +-- usage (so, @1@), but is also changed through 'setLogSettingsFormat' is used. -- -- Support for this option depends on your version of @fast-logger@: -- diff --git a/src/Blammo/Logging/LogSettings/Env.hs b/src/Blammo/Logging/LogSettings/Env.hs --- a/src/Blammo/Logging/LogSettings/Env.hs +++ b/src/Blammo/Logging/LogSettings/Env.hs @@ -14,6 +14,17 @@ -- recognized (e.g. @yes@ or @no@) but should not be relied on. Unrecognized -- values will produce an error -- +-- - @LOG_BREAKPOINT@: a number representing the column-width at which to break +-- into multi-line format. +-- +-- - @LOG_CONCURRENCY@: number of log buffers to use. More will perform faster +-- but result in out-of-order delivery. This is automatically disabled for +-- @LOG_FORMAT=tty@ and set to /number-of-cores/ for @LOG_FORMAT=json@. +-- +-- - @NO_COLOR@: if present and non-empty, behave as if @LOG_COLOR=never@ +-- +-- - @TERM@: if present and the value @dumb@, behave as if @LOG_COLOR=never@. +-- -- This module is meant to be imported @qualified@. -- -- @ @@ -45,7 +56,9 @@ import Blammo.Logging.LogSettings import Data.Bifunctor (first) +import Data.Bool (bool) import Data.Semigroup (Endo (..)) +import Data.Text (Text) import Env hiding (parse) import qualified Env import Text.Read (readEither) @@ -59,20 +72,30 @@ parseWith :: LogSettings -> IO LogSettings parseWith = Env.parse id . parserWith --- brittany-next-binding --columns 100 - parserWith :: LogSettings -> Parser Error LogSettings parserWith defaults = ($ defaults) . appEndo . mconcat <$> sequenceA - [ var (endo readLogLevels setLogSettingsLevels) "LOG_LEVEL" (def mempty) - , var (endo readLogDestination setLogSettingsDestination) "LOG_DESTINATION" (def mempty) - , var (endo readLogFormat setLogSettingsFormat) "LOG_FORMAT" (def mempty) - , var (endo readLogColor setLogSettingsColor) "LOG_COLOR" (def mempty) - , var (endo readEither setLogSettingsBreakpoint) "LOG_BREAKPOINT" (def mempty) - , var (endo readEither (setLogSettingsConcurrency . Just)) "LOG_CONCURRENCY" (def mempty) + [ endoVar readLogLevels setLogSettingsLevels "LOG_LEVEL" + , endoVar readLogDestination setLogSettingsDestination "LOG_DESTINATION" + , endoVar readLogColor setLogSettingsColor "LOG_COLOR" + , endoVar readEither setLogSettingsBreakpoint "LOG_BREAKPOINT" + , endoVar readEither (setLogSettingsConcurrency . Just) "LOG_CONCURRENCY" + , endoVar readLogFormat setLogSettingsFormat "LOG_FORMAT" + , endoSwitch (setLogSettingsColor LogColorNever) "NO_COLOR" + , endoOn "dumb" (setLogSettingsColor LogColorNever) "TERM" ] +endoVar + :: (AsUnset e, AsUnread e) + => (String -> Either String a) + -- ^ How to parse the value + -> (a -> b -> b) + -- ^ How to turn the parsed value into a setter + -> String + -> Parser e (Endo b) +endoVar reader setter x = var (endo reader setter) x $ def mempty + endo :: AsUnread e => (String -> Either String a) @@ -81,3 +104,15 @@ -- ^ How to turn the parsed value into a setter -> Reader e (Endo b) endo reader setter x = first unread $ Endo . setter <$> reader x + +endoSwitch :: (a -> a) -> String -> Parser e (Endo a) +endoSwitch f x = endoWhen f <$> switch x mempty + +endoOn :: AsUnset e => Text -> (a -> a) -> String -> Parser e (Endo a) +endoOn val f x = endoWhen f . (== Just val) <$> optional (var str x mempty) + +endoWhen + :: (a -> a) + -> Bool + -> Endo a +endoWhen f = bool mempty (Endo f) diff --git a/tests/Blammo/Logging/LogSettings/EnvSpec.hs b/tests/Blammo/Logging/LogSettings/EnvSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Blammo/Logging/LogSettings/EnvSpec.hs @@ -0,0 +1,102 @@ +module Blammo.Logging.LogSettings.EnvSpec + ( spec + ) where + +import Prelude + +import Blammo.Logging.LogSettings +import qualified Blammo.Logging.LogSettings.Env as LogSettingsEnv +import Blammo.Logging.LogSettings.LogLevels +import Data.List (intercalate) +import qualified Env +import Test.Hspec + +spec :: Spec +spec = do + context "LOG_LEVEL" $ do + it "reads a simple log-level" $ do + let env = [("LOG_LEVEL", "debug")] + + settings <- parseLogSettings env + getLogSettingsLevels settings `shouldBe` newLogLevels LevelDebug [] + + context "LOG_FORMAT and LOG_CONCURRENCY" $ do + it "Sets LOG_CONCURRENCY if format is tty" $ do + settings <- parseLogSettings [] + settingsTTY <- parseLogSettings [("LOG_FORMAT", "tty")] + + getLogSettingsConcurrency settings `shouldBe` Just 1 + getLogSettingsConcurrency settingsTTY `shouldBe` Just 1 + + it "Unsets LOG_CONCURRENCY if format is not tty" $ do + settings <- parseLogSettings [("LOG_FORMAT", "json")] + + getLogSettingsConcurrency settings `shouldBe` Nothing + + it "Respects explicit LOG_CONCURRENCY" $ do + settingsTTY1 <- + parseLogSettings [("LOG_CONCURRENCY", "2"), ("LOG_FORMAT", "tty")] + settingsTTY2 <- + parseLogSettings [("LOG_FORMAT", "tty"), ("LOG_CONCURRENCY", "3")] + settingsJSON1 <- + parseLogSettings [("LOG_FORMAT", "json"), ("LOG_CONCURRENCY", "4")] + settingsJSON2 <- + parseLogSettings [("LOG_CONCURRENCY", "5"), ("LOG_FORMAT", "json")] + + getLogSettingsConcurrency settingsTTY1 `shouldBe` Just 2 + getLogSettingsConcurrency settingsTTY2 `shouldBe` Just 3 + getLogSettingsConcurrency settingsJSON1 `shouldBe` Just 4 + getLogSettingsConcurrency settingsJSON2 `shouldBe` Just 5 + + context "NO_COLOR" $ do + it "changes LOG_COLOR to never" $ do + settings <- parseLogSettings [] + settingsC <- parseLogSettings [("NO_COLOR", "")] + settingsNC <- parseLogSettings [("NO_COLOR", "x")] + + getLogSettingsColor settings `shouldBe` LogColorAuto + getLogSettingsColor settingsC `shouldBe` LogColorAuto + getLogSettingsColor settingsNC `shouldBe` LogColorNever + + it "respects explicit LOG_COLOR after" $ do + settings1 <- parseLogSettings [("LOG_COLOR", "always"), ("NO_COLOR", "x")] + settings2 <- parseLogSettings [("NO_COLOR", "x"), ("LOG_COLOR", "always")] + + getLogSettingsColor settings1 `shouldBe` LogColorAlways + getLogSettingsColor settings2 `shouldBe` LogColorAlways + + context "TERM=dumb" $ do + it "changes LOG_COLOR to never" $ do + settings <- parseLogSettings [] + settingsC <- parseLogSettings [("TERM", "xterm")] + settingsNC <- parseLogSettings [("TERM", "dumb")] + + getLogSettingsColor settings `shouldBe` LogColorAuto + getLogSettingsColor settingsC `shouldBe` LogColorAuto + getLogSettingsColor settingsNC `shouldBe` LogColorNever + + it "respects explicit LOG_COLOR after" $ do + settings1 <- parseLogSettings [("LOG_COLOR", "always"), ("TERM", "dumb")] + settings2 <- parseLogSettings [("TERM", "dumb"), ("LOG_COLOR", "always")] + + getLogSettingsColor settings1 `shouldBe` LogColorAlways + getLogSettingsColor settings2 `shouldBe` LogColorAlways + +parseLogSettings :: [(String, String)] -> IO LogSettings +parseLogSettings env = do + case Env.parsePure LogSettingsEnv.parser env of + Left es -> expectationFailure (failureMessage es) *> error "Unreachable" + Right s -> pure s + where + failureMessage :: [(String, Env.Error)] -> String + failureMessage = + ("Expected parse to succeed, but there were errors:\n" <>) + . intercalate "\n " + . map showEnvError + + showEnvError :: (String, Env.Error) -> String + showEnvError (name, e) = + name <> " :" <> case e of + Env.UnsetError -> "expected, but not set" + Env.EmptyError -> "expected, but was empty" + Env.UnreadError x -> "invalid: " <> show x