packages feed

Blammo (empty) → 1.0.0.0

raw patch · 17 files changed

+1590/−0 lines, 17 filesdep +Blammodep +aesondep +base

Dependencies added: Blammo, aeson, base, bytestring, case-insensitive, clock, containers, envparse, exceptions, fast-logger, hspec, http-types, lens, markdown-unlit, monad-logger-aeson, text, time, unliftio-core, unordered-containers, vector, wai

Files

+ Blammo.cabal view
@@ -0,0 +1,132 @@+cabal-version:   1.18+name:            Blammo+version:         1.0.0.0+license:         MIT+license-file:    LICENSE+maintainer:      Freckle Education+homepage:        https://github.com/freckle/blammo#readme+bug-reports:     https://github.com/freckle/blammo/issues+synopsis:        Batteries-included Structured Logging library+description:     Please see README.md+category:        Utils+build-type:      Simple+extra-doc-files:+    README.md+    CHANGELOG.md++source-repository head+    type:     git+    location: https://github.com/freckle/blammo++library+    exposed-modules:+        Blammo.Logging+        Blammo.Logging.Colors+        Blammo.Logging.Logger+        Blammo.Logging.LogSettings+        Blammo.Logging.LogSettings.Env+        Blammo.Logging.LogSettings.LogLevels+        Blammo.Logging.Simple+        Blammo.Logging.Terminal+        Data.Aeson.Compat+        Network.Wai.Middleware.Logging++    hs-source-dirs:     src+    other-modules:      Paths_Blammo+    default-language:   Haskell2010+    default-extensions:+        DerivingStrategies LambdaCase NoImplicitPrelude OverloadedStrings+        RecordWildCards TypeApplications++    ghc-options:+        -Weverything -Wno-all-missed-specialisations+        -Wno-missing-exported-signatures -Wno-missing-import-lists+        -Wno-missing-local-signatures -Wno-monomorphism-restriction+        -Wno-safe -Wno-unsafe++    build-depends:+        aeson >=1.5.6.0,+        base >=4.14.3.0 && <5,+        bytestring >=0.10.12.0,+        case-insensitive >=1.2.1.0,+        clock >=0.8.3,+        containers >=0.6.5.1,+        envparse >=0.4.1,+        exceptions >=0.10.4,+        fast-logger >=3.0.5,+        http-types >=0.12.3,+        lens >=4.19.2,+        monad-logger-aeson >=0.2.0.0,+        text >=1.2.4.1,+        time >=1.9.3,+        unliftio-core >=0.2.0.1,+        unordered-containers >=0.2.16.0,+        vector >=0.12.3.1,+        wai >=3.2.3++    if impl(ghc >=9.2)+        ghc-options: -Wno-missing-kind-signatures++    if impl(ghc >=8.10)+        ghc-options:+            -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module++test-suite readme+    type:               exitcode-stdio-1.0+    main-is:            README.lhs+    other-modules:      Paths_Blammo+    default-language:   Haskell2010+    default-extensions:+        DerivingStrategies LambdaCase NoImplicitPrelude OverloadedStrings+        RecordWildCards TypeApplications++    ghc-options:+        -Weverything -Wno-all-missed-specialisations+        -Wno-missing-exported-signatures -Wno-missing-import-lists+        -Wno-missing-local-signatures -Wno-monomorphism-restriction+        -Wno-safe -Wno-unsafe -pgmL markdown-unlit++    build-depends:+        Blammo -any,+        aeson >=1.5.6.0,+        base >=4.14.3.0 && <5,+        markdown-unlit >=0.5.1,+        text >=1.2.4.1++    if impl(ghc >=9.2)+        ghc-options: -Wno-missing-kind-signatures++    if impl(ghc >=8.10)+        ghc-options:+            -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module++test-suite spec+    type:               exitcode-stdio-1.0+    main-is:            Spec.hs+    hs-source-dirs:     tests+    other-modules:+        Blammo.Logging.LogSettings.LogLevelsSpec+        Paths_Blammo++    default-language:   Haskell2010+    default-extensions:+        DerivingStrategies LambdaCase NoImplicitPrelude OverloadedStrings+        RecordWildCards TypeApplications++    ghc-options:+        -Weverything -Wno-all-missed-specialisations+        -Wno-missing-exported-signatures -Wno-missing-import-lists+        -Wno-missing-local-signatures -Wno-monomorphism-restriction+        -Wno-safe -Wno-unsafe++    build-depends:+        Blammo -any,+        base >=4.14.3.0 && <5,+        hspec >=2.7.10++    if impl(ghc >=9.2)+        ghc-options: -Wno-missing-kind-signatures++    if impl(ghc >=8.10)+        ghc-options:+            -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+## [_Unreleased_](https://github.com/freckle/blammo/compare/v1.0.0.0...main)++## [v1.0.0.0](https://github.com/freckle/blammo/tree/v1.0.0.0)++First tagged release.
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2022 Renaissance Learning Inc++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.lhs view
@@ -0,0 +1,280 @@+# Blammo++![](files/blammo.png)++Blammo is a Structured Logging library that's++- Easy to use: one import and go!+- Easy to configure: environment variable parsing out of the box!+- Easy to integrate: see below for Amazonka, Yesod, and more!+- Produces beautiful, colorful output in development+- Produces fast-fast JSON in production++All built on the well-known `MonadLogger` interface and using an efficient+`fast-logger` implementation.++> It's better than bad, it's good!++## Simple Usage++<!--+```haskell+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++module Main (module Main) where++import Prelude++import Data.Aeson+import Data.Text (Text)+import GHC.Generics (Generic)+import Text.Markdown.Unlit ()+```+-->++```haskell+import Blammo.Logging.Simple+```++Throughout your application, you should write against the ubiquitous+`MonadLogger` interface:++```haskell+action1 :: MonadLogger m => m ()+action1 = do+  logInfo "This is a message sans details"+```++And make use of [`monad-logger-aeson`][monad-logger-aeson] for structured+details:++[monad-logger-aeson]: https://jship.github.io/posts/2022-05-17-announcing-monad-logger-aeson/++```haskell+data MyError = MyError+  { code :: Int+  , messages :: [Text]+  }+  deriving stock Generic+  deriving anyclass ToJSON++action2 :: MonadLogger m => m ()+action2 = do+  logError $ "Something went wrong" :# ["error" .= MyError 100 ["x", "y"]]+  logDebug "This won't be seen in default settings"+```++When you run your transformer stack, wrap it in `runLoggerLoggingT` providing+any value with a `HasLogger` instance (such as your main `App`). The `Logger`+type itself has such an instance, and we provide `runSimpleLoggingT` for the+simplest case: it creates one configured via environment variables and then+calls `runLoggerLoggingT` with it.++You can use `withThreadContext` (from `monad-logger-aeson`) to add details that+will appear in all the logged messages within that scope. Placing one of these+at the very top-level adds details to all logged messages.++```haskell+runner :: LoggingT IO a -> IO a+runner = runSimpleLoggingT . withThreadContext ["app" .= ("example" :: Text)]++main :: IO ()+main = runner $ do+  action1+  action2+```++The defaults are good for CLI applications, producing colorful output (if+connected to a terminal device) suitable for a human:++![](files/readme-terminal.png)++Under the hood, `Logging.Settings.Env` is using [`envparse`][envparse] to+configure logging through environment variables. See that module for full+details. One thing we can adjust is `LOG_LEVEL`:++[envparse]: https://hackage.haskell.org/package/envparse++![](files/readme-terminal-debug.png)++In production, you will probably want to set `LOG_FORMAT=json` and ship logs to+some aggregator like Datadog or Mezmo (formerly LogDNA):++![](files/readme-json.png)++## Configuration++| Setting     | Setter                      | Environment variable and format          |+| ---         | ---                         | ---                                      |+| Level(s)    | `setLogSettingsLevels`      | `LOG_LEVEL=<level>[,<source:level>,...]` |+| Destination | `setLogSettingsDestination` | `LOG_DESTINATION=stdout\|stderr\|@<path>`  |+| Format      | `setLogSettingsFormat`      | `LOG_FORMAT=tty\|json`                    |++## Advanced Usage++Add our environment variable parser to your own,++```hs+data AppSettings = AppSettings+  { appDryRun :: Bool+  , appLogSettings :: LogSettings+  , -- ...+  }++loadAppSettings :: IO AppSettings+loadAppSettings = Env.parse id $ AppSettings+  <$> var switch "DRY_RUN" mempty+  <*> LogSettingsEnv.parser+  <*> -- ...+```++Load a `Logger` into your `App` type and define `HasLogger`,++```hs+data App = App+  { appSettings :: AppSettings+  , appLogger :: Logger+  , -- ...+  }++instance HasLogger App where+  loggerL = lens appLogger $ \x y -> x { appLogger = y }++loadApp :: IO App+loadApp = do+  appSettings <- loadAppSettings+  appLogger <- newLogger $ appLogSettings appSettings+  -- ...+  pure App {..}+```++Use `runLoggerLoggingT`,++```hs+runAppT :: App -> ReaderT App (LoggingT IO) a -> IO a+runAppT app f = runLoggerLoggingT app $ runReaderT f app+```++## Integration with RIO++```hs+data App = App+  { appLogFunc :: LogFunc+  , -- ...+  }++instance HasLogFuncApp where+  logFuncL = lens appLogFunc $ \x y -> x { logFunc = y }++runApp :: MonadIO m => RIO App a -> m a+runApp f = runSimpleLoggingT $ do+  loggerIO <- askLoggerIO++  let+    logFunc = mkLogFunc $ \cs source level msg -> loggerIO+      (callStackLoc cs)+      source+      (fromRIOLevel level)+      (getUtf8Builder msg)++  app <- App logFunc+    <$> -- ...+    <*> -- ...++  runRIO app $ f++callStackLoc :: CallStack -> Loc+callStackLoc = undefined++fromRIOLevel :: RIO.LogLevel -> LogLevel+fromRIOLevel = undefined+```++## Integration with Amazonka++```hs+data App = App+  { appLogger :: Logger+  , appAWS :: AWS.Env+  }++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++awsDiscover :: (MonadIO m, MonadLoggerIO m) => m AWS.Env+awsDiscover = do+  loggerIO <- askLoggerIO+  env <- liftIO $ AWS.newEnv AWS.discover+  pure $ env+    { AWS.envLogger = \level msg -> do+      loggerIO+        defaultLoc -- TODO: there may be a way to get a CallStack/Loc+        "Amazonka"+        (\case+          AWS.Info -> LevelInfo+          AWS.Error -> LevelError+          AWS.Debug -> LevelDebug+          AWS.Trace -> LevelOther "trace"+        )+        (toLogStr msg)+    }+```++## Integration with WAI++```hs+import Network.Wai.Middleware.Logging++instance HasLogger App where+  -- ...++waiMiddleware :: App -> Middleware+waiMiddleware app =+  addThreadContext ["app" .= ("my-app" :: Text)]+    $ requestLogger app+    $ defaultMiddlewaresNoLogging+```++## Integration with Warp++```hs+instance HasLogger App where+  -- ...++warpSettings :: App -> Settings+warpSettings app = setOnException onEx $ defaultSettings+ where+  onEx _req ex =+    when (defaultShouldDisplayException ex)+      $ runLoggerLoggingT app+      $ logError+      $ "Warp exception"+      :# ["exception" .= displayException ex]+```++## Integration with Yesod++```hs+import Blammo.Logging.Logger (getLoggerLoggerSet)++instance HasLogger App where+  -- ...++instance Yesod App where+  -- ...++  messageLoggerSource app _logger loc source level msg =+    runLoggerLoggingT app $ monadLoggerLog loc source level msg+```++---++[LICENSE](./LICENSE) | [CHANGELOG](./CHANGELOG.md)
+ README.md view
@@ -0,0 +1,280 @@+# Blammo++![](files/blammo.png)++Blammo is a Structured Logging library that's++- Easy to use: one import and go!+- Easy to configure: environment variable parsing out of the box!+- Easy to integrate: see below for Amazonka, Yesod, and more!+- Produces beautiful, colorful output in development+- Produces fast-fast JSON in production++All built on the well-known `MonadLogger` interface and using an efficient+`fast-logger` implementation.++> It's better than bad, it's good!++## Simple Usage++<!--+```haskell+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++module Main (module Main) where++import Prelude++import Data.Aeson+import Data.Text (Text)+import GHC.Generics (Generic)+import Text.Markdown.Unlit ()+```+-->++```haskell+import Blammo.Logging.Simple+```++Throughout your application, you should write against the ubiquitous+`MonadLogger` interface:++```haskell+action1 :: MonadLogger m => m ()+action1 = do+  logInfo "This is a message sans details"+```++And make use of [`monad-logger-aeson`][monad-logger-aeson] for structured+details:++[monad-logger-aeson]: https://jship.github.io/posts/2022-05-17-announcing-monad-logger-aeson/++```haskell+data MyError = MyError+  { code :: Int+  , messages :: [Text]+  }+  deriving stock Generic+  deriving anyclass ToJSON++action2 :: MonadLogger m => m ()+action2 = do+  logError $ "Something went wrong" :# ["error" .= MyError 100 ["x", "y"]]+  logDebug "This won't be seen in default settings"+```++When you run your transformer stack, wrap it in `runLoggerLoggingT` providing+any value with a `HasLogger` instance (such as your main `App`). The `Logger`+type itself has such an instance, and we provide `runSimpleLoggingT` for the+simplest case: it creates one configured via environment variables and then+calls `runLoggerLoggingT` with it.++You can use `withThreadContext` (from `monad-logger-aeson`) to add details that+will appear in all the logged messages within that scope. Placing one of these+at the very top-level adds details to all logged messages.++```haskell+runner :: LoggingT IO a -> IO a+runner = runSimpleLoggingT . withThreadContext ["app" .= ("example" :: Text)]++main :: IO ()+main = runner $ do+  action1+  action2+```++The defaults are good for CLI applications, producing colorful output (if+connected to a terminal device) suitable for a human:++![](files/readme-terminal.png)++Under the hood, `Logging.Settings.Env` is using [`envparse`][envparse] to+configure logging through environment variables. See that module for full+details. One thing we can adjust is `LOG_LEVEL`:++[envparse]: https://hackage.haskell.org/package/envparse++![](files/readme-terminal-debug.png)++In production, you will probably want to set `LOG_FORMAT=json` and ship logs to+some aggregator like Datadog or Mezmo (formerly LogDNA):++![](files/readme-json.png)++## Configuration++| Setting     | Setter                      | Environment variable and format          |+| ---         | ---                         | ---                                      |+| Level(s)    | `setLogSettingsLevels`      | `LOG_LEVEL=<level>[,<source:level>,...]` |+| Destination | `setLogSettingsDestination` | `LOG_DESTINATION=stdout\|stderr\|@<path>`  |+| Format      | `setLogSettingsFormat`      | `LOG_FORMAT=tty\|json`                    |++## Advanced Usage++Add our environment variable parser to your own,++```hs+data AppSettings = AppSettings+  { appDryRun :: Bool+  , appLogSettings :: LogSettings+  , -- ...+  }++loadAppSettings :: IO AppSettings+loadAppSettings = Env.parse id $ AppSettings+  <$> var switch "DRY_RUN" mempty+  <*> LogSettingsEnv.parser+  <*> -- ...+```++Load a `Logger` into your `App` type and define `HasLogger`,++```hs+data App = App+  { appSettings :: AppSettings+  , appLogger :: Logger+  , -- ...+  }++instance HasLogger App where+  loggerL = lens appLogger $ \x y -> x { appLogger = y }++loadApp :: IO App+loadApp = do+  appSettings <- loadAppSettings+  appLogger <- newLogger $ appLogSettings appSettings+  -- ...+  pure App {..}+```++Use `runLoggerLoggingT`,++```hs+runAppT :: App -> ReaderT App (LoggingT IO) a -> IO a+runAppT app f = runLoggerLoggingT app $ runReaderT f app+```++## Integration with RIO++```hs+data App = App+  { appLogFunc :: LogFunc+  , -- ...+  }++instance HasLogFuncApp where+  logFuncL = lens appLogFunc $ \x y -> x { logFunc = y }++runApp :: MonadIO m => RIO App a -> m a+runApp f = runSimpleLoggingT $ do+  loggerIO <- askLoggerIO++  let+    logFunc = mkLogFunc $ \cs source level msg -> loggerIO+      (callStackLoc cs)+      source+      (fromRIOLevel level)+      (getUtf8Builder msg)++  app <- App logFunc+    <$> -- ...+    <*> -- ...++  runRIO app $ f++callStackLoc :: CallStack -> Loc+callStackLoc = undefined++fromRIOLevel :: RIO.LogLevel -> LogLevel+fromRIOLevel = undefined+```++## Integration with Amazonka++```hs+data App = App+  { appLogger :: Logger+  , appAWS :: AWS.Env+  }++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++awsDiscover :: (MonadIO m, MonadLoggerIO m) => m AWS.Env+awsDiscover = do+  loggerIO <- askLoggerIO+  env <- liftIO $ AWS.newEnv AWS.discover+  pure $ env+    { AWS.envLogger = \level msg -> do+      loggerIO+        defaultLoc -- TODO: there may be a way to get a CallStack/Loc+        "Amazonka"+        (\case+          AWS.Info -> LevelInfo+          AWS.Error -> LevelError+          AWS.Debug -> LevelDebug+          AWS.Trace -> LevelOther "trace"+        )+        (toLogStr msg)+    }+```++## Integration with WAI++```hs+import Network.Wai.Middleware.Logging++instance HasLogger App where+  -- ...++waiMiddleware :: App -> Middleware+waiMiddleware app =+  addThreadContext ["app" .= ("my-app" :: Text)]+    $ requestLogger app+    $ defaultMiddlewaresNoLogging+```++## Integration with Warp++```hs+instance HasLogger App where+  -- ...++warpSettings :: App -> Settings+warpSettings app = setOnException onEx $ defaultSettings+ where+  onEx _req ex =+    when (defaultShouldDisplayException ex)+      $ runLoggerLoggingT app+      $ logError+      $ "Warp exception"+      :# ["exception" .= displayException ex]+```++## Integration with Yesod++```hs+import Blammo.Logging.Logger (getLoggerLoggerSet)++instance HasLogger App where+  -- ...++instance Yesod App where+  -- ...++  messageLoggerSource app _logger loc source level msg =+    runLoggerLoggingT app $ monadLoggerLog loc source level msg+```++---++[LICENSE](./LICENSE) | [CHANGELOG](./CHANGELOG.md)
+ src/Blammo/Logging.hs view
@@ -0,0 +1,85 @@+module Blammo.Logging+  ( LogSettings+  , LogLevel(..)+  , LogDestination(..)+  , LogFormat(..)+  , LogColor(..)+  , defaultLogSettings+  , setLogSettingsLevels+  , setLogSettingsDestination+  , setLogSettingsFormat+  , setLogSettingsColor+  , Logger+  , HasLogger(..)+  , newLogger+  , runLoggerLoggingT++  -- * Re-exports from "Control.Monad.Logger.Aeson"+  -- ** Messages+  , Message(..)+  , (.=)+  , Series++  -- ** Thread Context+  , MonadMask+  , withThreadContext+  , myThreadContext+  , Pair++  -- ** Transformer+  , MonadLogger(..)+  , MonadLoggerIO(..)+  , LoggingT++  -- ** Common logging functions+  -- | Import "Control.Monad.Logger.Aeson" if you want more++  -- *** Implicit call stack, no 'LogSource'+  , logDebug+  , logInfo+  , logWarn+  , logError+  , logOther++  -- *** Implicit call stack, with 'LogSource'+  , logDebugNS+  , logInfoNS+  , logWarnNS+  , logErrorNS+  , logOtherNS+  ) where++import Prelude++import Blammo.Logging.LogSettings+import Blammo.Logging.Logger+import Control.Lens ((^.))+import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Logger.Aeson+import Data.Aeson (Series)+import Data.Aeson.Types (Pair)+import Data.ByteString (ByteString)+import System.Log.FastLogger (LoggerSet, flushLogStr, pushLogStrLn)++runLoggerLoggingT :: (MonadIO m, HasLogger env) => env -> LoggingT m a -> m a+runLoggerLoggingT env f = do+  a <- runLoggingT+    (filterLogger (getLoggerShouldLog logger) f)+    (loggerOutput loggerSet $ getLoggerReformat logger)+  a <$ liftIO (flushLogStr loggerSet)+ where+  logger = env ^. loggerL+  loggerSet = getLoggerLoggerSet logger++loggerOutput+  :: LoggerSet+  -> (LogLevel -> ByteString -> ByteString)+  -> Loc+  -> LogSource+  -> LogLevel+  -> LogStr+  -> IO ()+loggerOutput loggerSet reformat =+  defaultOutputWith $ defaultOutputOptions $ \logLevel bytes -> do+    pushLogStrLn loggerSet $ toLogStr $ reformat logLevel bytes
+ src/Blammo/Logging/Colors.hs view
@@ -0,0 +1,57 @@+module Blammo.Logging.Colors+  ( Colors(..)+  , getColors+  ) where++import Prelude++import Data.Text (Text)++data Colors = Colors+  { gray :: Text -> Text+  , black :: Text -> Text+  , cyan :: Text -> Text+  , magenta :: Text -> Text+  , blue :: Text -> Text+  , yellow :: Text -> Text+  , green :: Text -> Text+  , red :: Text -> Text+  , bold :: Text -> Text+  , dim :: Text -> Text+  }++colors :: Colors+colors = Colors+  { gray = esc "0;37"+  , cyan = esc "0;36"+  , magenta = esc "0;35"+  , blue = esc "0;34"+  , yellow = esc "0;33"+  , green = esc "0;32"+  , red = esc "0;31"+  , black = esc "0;30"+  , bold = esc "1"+  , dim = esc "2"+  }+ where+  esc :: Text -> Text -> Text+  esc code x = "\ESC[" <> code <> "m" <> x <> "\ESC[0m"++noColors :: Colors+noColors = Colors+  { gray = id+  , black = id+  , cyan = id+  , magenta = id+  , blue = id+  , yellow = id+  , green = id+  , red = id+  , bold = id+  , dim = id+  }++getColors :: Bool -> Colors+getColors = \case+  True -> colors+  False -> noColors
+ src/Blammo/Logging/LogSettings.hs view
@@ -0,0 +1,147 @@+module Blammo.Logging.LogSettings+  ( LogSettings+  , LogLevels+  , LogDestination(..)+  , LogFormat(..)+  , LogColor(..)++  -- * Reading settings, e.g. from @ENV@+  , readLogLevels+  , readLogDestination+  , readLogFormat+  , readLogColor++  -- * Construction+  , defaultLogSettings++  -- * Modify+  , setLogSettingsLevels+  , setLogSettingsDestination+  , setLogSettingsFormat+  , setLogSettingsColor++  -- * Access+  , getLogSettingsLevels+  , getLogSettingsDestination+  , getLogSettingsFormat+  , getLogSettingsColor++  -- * Logic+  , shouldLogLevel+  , shouldColorAuto+  , shouldColorHandle+  ) where++import Prelude++import Blammo.Logging.LogSettings.LogLevels (LogLevels)+import qualified Blammo.Logging.LogSettings.LogLevels as LogLevels+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Logger.Aeson+import System.IO (Handle, hIsTerminalDevice)++data LogSettings = LogSettings+  { lsLevels :: LogLevels+  , lsDestination :: LogDestination+  , lsFormat :: LogFormat+  , lsColor :: LogColor+  }++readLogLevels :: String -> Either String LogLevels+readLogLevels = LogLevels.readLogLevels++data LogDestination+    = LogDestinationStdout+    | LogDestinationStderr+    | LogDestinationFile FilePath++readLogDestination :: String -> Either String LogDestination+readLogDestination = \case+  "stdout" -> Right LogDestinationStdout+  "stderr" -> Right LogDestinationStderr+  ('@' : path) -> Right $ LogDestinationFile path+  x ->+    Left+      $ "Invalid log destination "+      <> x+      <> ", must be stdout, stderr, or @{path}"++data LogFormat+    = LogFormatJSON+    | LogFormatTerminal++readLogFormat :: String -> Either String LogFormat+readLogFormat = \case+  "tty" -> Right LogFormatTerminal+  "json" -> Right LogFormatJSON+  x -> Left $ "Invalid log format " <> x <> ", must be tty or json"++data LogColor+    = LogColorAuto+    | LogColorAlways+    | LogColorNever++readLogColor :: String -> Either String LogColor+readLogColor x+  | x `elem` autoValues+  = Right LogColorAuto+  | x `elem` alwaysValues+  = Right LogColorAlways+  | x `elem` neverValues+  = Right LogColorNever+  | otherwise+  = Left $ "Invalid log color " <> x <> ", must be auto, always, or never"+ where+  autoValues :: [String]+  autoValues = ["auto"]++  alwaysValues :: [String]+  alwaysValues = ["always", "on", "yes", "true"]++  neverValues :: [String]+  neverValues = ["never", "off", "no", "false"]++defaultLogSettings :: LogSettings+defaultLogSettings = LogSettings+  { lsLevels = LogLevels.defaultLogLevels+  , lsDestination = LogDestinationStdout+  , lsFormat = LogFormatTerminal+  , lsColor = LogColorAuto+  }++setLogSettingsLevels :: LogLevels -> LogSettings -> LogSettings+setLogSettingsLevels x ls = ls { lsLevels = x }++setLogSettingsDestination :: LogDestination -> LogSettings -> LogSettings+setLogSettingsDestination x ls = ls { lsDestination = x }++setLogSettingsFormat :: LogFormat -> LogSettings -> LogSettings+setLogSettingsFormat x ls = ls { lsFormat = x }++setLogSettingsColor :: LogColor -> LogSettings -> LogSettings+setLogSettingsColor x ls = ls { lsColor = x }++getLogSettingsLevels :: LogSettings -> LogLevels+getLogSettingsLevels = lsLevels++getLogSettingsDestination :: LogSettings -> LogDestination+getLogSettingsDestination = lsDestination++getLogSettingsFormat :: LogSettings -> LogFormat+getLogSettingsFormat = lsFormat++getLogSettingsColor :: LogSettings -> LogColor+getLogSettingsColor = lsColor++shouldLogLevel :: LogSettings -> LogSource -> LogLevel -> Bool+shouldLogLevel = LogLevels.shouldLogLevel . getLogSettingsLevels++shouldColorAuto :: Applicative m => LogSettings -> m Bool -> m Bool+shouldColorAuto LogSettings {..} f = case lsColor of+  LogColorAuto -> f+  LogColorAlways -> pure True+  LogColorNever -> pure False++shouldColorHandle :: MonadIO m => LogSettings -> Handle -> m Bool+shouldColorHandle settings h =+  shouldColorAuto settings $ liftIO $ hIsTerminalDevice h
+ src/Blammo/Logging/LogSettings/Env.hs view
@@ -0,0 +1,62 @@+-- | Produce a 'LogSettings' by reading environment variables+--+-- - @LOG_LEVEL@: a known log level (case insensitive) and optional levels by+--   source. See "Logging.LogSettings.LogLevels".+--+-- - @LOG_DESTINATION@: the string @stderr@ or @stdout@ (case sensitive), or+--   @\@{path}@ to log to the file at @path@. Unrecognized values will produce+--   and error.+--+-- - @LOG_FORMAT@: the string @tty@ or @json@. Unrecognized values will produce+--   an error.+--+-- - @LOG_COLOR@: the string @auto@, @always@, or @never@. Other values may be+--   recognized (e.g. @yes@ or @no@) but should not be relied on. Unrecognized+--   values will produce an error+--+-- This module is meant to be imported @qualified@.+--+-- @+-- import Blammo.Logging+-- import qualified Logging.LogSettings.Env as Env+--+-- main :: IO ()+-- main = do+--   logger <- 'newLogger' =<< Env.'parse'+--   'runLoggerLoggingT' logger $ -- ...+-- @+--+module Blammo.Logging.LogSettings.Env+  ( parse+  , parser+  ) where++import Prelude++import Blammo.Logging.LogSettings+import Data.Bifunctor (first)+import Data.Semigroup (Endo(..))+import Env hiding (parse)+import qualified Env++parse :: IO LogSettings+parse = Env.parse id parser++-- brittany-next-binding --columns 100++parser :: Parser Error LogSettings+parser = ($ defaultLogSettings) . 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)+  ]++endo+  :: AsUnread e+  => (String -> Either String a)+  -- ^ How to parse the value+  -> (a -> b -> b)+  -- ^ How to turn the parsed value into a setter+  -> Reader e (Endo b)+endo reader setter x = first unread $ Endo . setter <$> reader x
+ src/Blammo/Logging/LogSettings/LogLevels.hs view
@@ -0,0 +1,124 @@+-- | Backwards-compatible extension to a simple 'LogLevel' parser/filter+--+-- Assume you are using this library/module to parse a @LOG_LEVEL@ environment+-- variable, which is used to filter your logs.+--+-- Running,+--+-- @+-- LOG_LEVEL=warn ./my-program+-- @+--+-- Will do what you expect: filter all logging to only those messages+-- at-or-above @warn@ level.+--+-- While,+--+-- @+-- LOG_LEVEL=debug ./my-program+-- @+--+-- Will enable debug logging throughout.+--+-- This is all un-surprising and this module does not change behavior in this+-- case whatsoever. But let's say that is entirely too noisy. Because you're+-- using Amazonka and persistent, and have correctly integrated your main+-- logging with them, you are now getting /tons/ of spam from their very-chatty+-- debug logs, and its drowning out the application debug logs you were hoping+-- to see.+--+-- Well, now can do this:+--+-- @+-- LOG_LEVEL="debug,Amazonka:info,SQL:warn" ./my-program+-- @+--+-- And suddenly your application's debug logs are standing out again, because+-- everything from the Amazonka source is filtered to info and the SQL source is+-- filtered to warn.+--+-- The format parsed by 'readLogLevels' is:+--+-- @+-- [<source:level>, ...,]<level>[, <source:level>, ...]+-- @+--+-- Where @<level>@ defines the minimum level for anything not overridden by+-- source. If you go on to add any @<source:level>@ pairs, that will change the+-- minimum level for messages from that source.+--+module Blammo.Logging.LogSettings.LogLevels+  ( LogLevels+  , LogLevel(..)+  , newLogLevels+  , readLogLevels+  , shouldLogLevel+  , defaultLogLevels+  ) where++import Prelude++import Control.Monad.Logger.Aeson+import Data.Either (partitionEithers)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Text (Text, pack, unpack)+import qualified Data.Text as T++data LogLevels = LogLevels+  { llDefaultLevel :: LogLevel+  , llSourceLevels :: Map LogSource LogLevel+  }+  deriving stock (Eq, Show)++newLogLevels :: LogLevel -> [(LogSource, LogLevel)] -> LogLevels+newLogLevels level sourceLevels = LogLevels+  { llDefaultLevel = level+  , llSourceLevels = Map.fromList sourceLevels+  }++readLogLevels :: String -> Either String LogLevels+readLogLevels s = toLogLevels . partitionEithers =<< traverse readPiece pieces+ where+  toLogLevels = \case+    ([], _) -> invalid "no level present"+    (_ : _ : _, _) -> invalid "more than one level present"+    ([level], sourceLevels) -> pure $ newLogLevels level sourceLevels++  readPiece t = case T.breakOn ":" t of+    (a, ":") -> invalid $ "no level for source " <> unpack a+    (a, b) | T.null a -> invalid $ "no source for level" <> unpack b+    (a, b) | T.null b -> pure $ Left $ readLogLevel a+    (a, b) -> pure $ Right (a, readLogLevel $ T.drop 1 b)++  pieces = filter (not . T.null) $ map T.strip $ T.splitOn "," $ pack s++  invalid reason = Left $ "Invalid log level " <> s <> ", " <> reason++readLogLevel :: Text -> LogLevel+readLogLevel t = case T.toLower t of+  "debug" -> LevelDebug+  "info" -> LevelInfo+  "warn" -> LevelWarn+  "error" -> LevelError+  _ -> LevelOther t++shouldLogLevel :: LogLevels -> LogSource -> LogLevel -> Bool+shouldLogLevel LogLevels {..} source = (`lgte` minLevel)+  where minLevel = fromMaybe llDefaultLevel $ Map.lookup source llSourceLevels++defaultLogLevels :: LogLevels+defaultLogLevels =+  LogLevels { llDefaultLevel = LevelInfo, llSourceLevels = Map.empty }++-- | Like '(>=)', but treats @'LevelOther' "trace"@ as below 'LevelDebug'+--+-- Normally, 'LevelOther' is the highest level, but it's common to use the+-- @trace@ level as more verbose than @debug@. With this comparison in use, we+-- can safely use @'LevelOther' "trace"@ for that.+--+lgte :: LogLevel -> LogLevel -> Bool+lgte _ (LevelOther x) | T.toLower x == "trace" = True+lgte (LevelOther x) _ | T.toLower x == "trace" = False+lgte a b = a >= b
+ src/Blammo/Logging/Logger.hs view
@@ -0,0 +1,71 @@+module Blammo.Logging.Logger+  ( Logger+  , HasLogger(..)+  , newLogger+  , getLoggerLoggerSet+  , getLoggerReformat+  , getLoggerShouldLog+  ) where++import Prelude++import Blammo.Logging.LogSettings+import Blammo.Logging.Terminal+import Control.Lens (Lens')+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Logger.Aeson+import Data.ByteString (ByteString)+import System.IO (stderr, stdout)+import System.Log.FastLogger+  ( LoggerSet+  , defaultBufSize+  , newFileLoggerSet+  , newStderrLoggerSet+  , newStdoutLoggerSet+  )++data Logger = Logger+  { lLoggerSet :: LoggerSet+  , lReformat :: LogLevel -> ByteString -> ByteString+  , lShouldLog :: LogSource -> LogLevel -> Bool+  }++getLoggerLoggerSet :: Logger -> LoggerSet+getLoggerLoggerSet = lLoggerSet++getLoggerReformat :: Logger -> LogLevel -> ByteString -> ByteString+getLoggerReformat = lReformat++getLoggerShouldLog :: Logger -> LogSource -> LogLevel -> Bool+getLoggerShouldLog = lShouldLog++class HasLogger env where+    loggerL :: Lens' env Logger++instance HasLogger Logger where+  loggerL = id++newLogger :: MonadIO m => LogSettings -> m Logger+newLogger settings = do+  (lLoggerSet, useColor) <- liftIO $ case getLogSettingsDestination settings of+    LogDestinationStdout ->+      (,)+        <$> newStdoutLoggerSet defaultBufSize+        <*> shouldColorHandle settings stdout+    LogDestinationStderr ->+      (,)+        <$> newStderrLoggerSet defaultBufSize+        <*> shouldColorHandle settings stderr+    LogDestinationFile path ->+      (,) <$> newFileLoggerSet defaultBufSize path <*> shouldColorAuto+        settings+        (pure False)++  let+    lReformat = case getLogSettingsFormat settings of+      LogFormatJSON -> const id -- Color is ignored+      LogFormatTerminal -> reformatTerminal useColor++    lShouldLog = shouldLogLevel settings++  pure $ Logger { .. }
+ src/Blammo/Logging/Simple.hs view
@@ -0,0 +1,22 @@+-- | Simplified out-of-the-box logging+module Blammo.Logging.Simple+  ( newLoggerEnv+  , runSimpleLoggingT+  , module Blammo.Logging+  ) where++import Prelude++import Blammo.Logging+import qualified Blammo.Logging.LogSettings.Env as Env+import Control.Monad.IO.Class (MonadIO(..))++-- | Construct a 'Logger' configured via environment variables+newLoggerEnv :: MonadIO m => m Logger+newLoggerEnv = liftIO $ newLogger =<< Env.parse++-- | Construct a 'Logger' configured via environment variables and use it+runSimpleLoggingT :: MonadIO m => LoggingT m a -> m a+runSimpleLoggingT f = do+  logger <- newLoggerEnv+  runLoggerLoggingT logger f
+ src/Blammo/Logging/Terminal.hs view
@@ -0,0 +1,94 @@+-- | Colorful logging for humans+--+-- Lines are formatted as+--+-- @+-- {timestamp} [{level}] {message} {details}+-- @+--+-- @level@ is padded to 9 characters and @message@ is padded to 31. This means+-- things will align as long as values are shorter than that. Longer values will+-- overflow (not be truncated).+--+-- This format was designed to match Python's+-- [structlog](https://www.structlog.org/en/stable/) package in its default+-- configuration.+--+module Blammo.Logging.Terminal+  ( reformatTerminal+  ) where++import Prelude++import Blammo.Logging.Colors+import Control.Monad.Logger.Aeson+import Data.Aeson+import Data.Aeson.Compat (KeyMap)+import qualified Data.Aeson.Compat as Key+import qualified Data.Aeson.Compat as KeyMap+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BSL+import Data.Maybe (fromMaybe)+import Data.Text (Text, pack)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Data.Time (defaultTimeLocale, formatTime)+import qualified Data.Vector as V++reformatTerminal :: Bool -> LogLevel -> ByteString -> ByteString+reformatTerminal useColor logLevel bytes = fromMaybe bytes $ do+  LoggedMessage {..} <- decode $ BSL.fromStrict bytes++  let+    colors@Colors {..} = getColors useColor++    logTimestampText =+      dim $ pack $ formatTime defaultTimeLocale "%F %X" loggedMessageTimestamp++    logLevelText = case logLevel of+      LevelDebug -> gray $ padTo 9 "debug"+      LevelInfo -> green $ padTo 9 "info"+      LevelWarn -> yellow $ padTo 9 "warn"+      LevelError -> red $ padTo 9 "error"+      LevelOther x -> blue $ padTo 9 x++    loggedSourceAsMap =+      foldMap (KeyMap.singleton "source" . String) loggedMessageLogSource++  pure $ encodeUtf8 $ mconcat+    [ logTimestampText <> " "+    , "[" <> logLevelText <> "] "+    , bold $ padTo 31 loggedMessageText+    , colorizeKeyMap colors loggedSourceAsMap+    , colorizeKeyMap colors loggedMessageThreadContext+    , colorizeKeyMap colors loggedMessageMeta+    ]++colorizeKeyMap :: Colors -> KeyMap Value -> Text+colorizeKeyMap Colors {..} km+  | KeyMap.null km = ""+  | otherwise = " " <> T.intercalate " " keyValues+ where+  keyValues = map (uncurry renderPair) $ KeyMap.toList km++  renderPair k v = cyan (Key.toText k) <> "=" <> magenta (fromValue v)++  fromValue = \case+    Object m -> obj $ map (uncurry renderPairNested) $ KeyMap.toList m+    Array a -> list $ map fromValue $ V.toList a+    String x -> x+    Number n -> sci n+    Bool b -> pack $ show b+    Null -> "null"++  renderPairNested k v = Key.toText k <> ": " <> fromValue v++  obj xs = "{" <> T.intercalate ", " xs <> "}"+  list xs = "[" <> T.intercalate ", " xs <> "]"+  sci = dropSuffix ".0" . pack . show++dropSuffix :: Text -> Text -> Text+dropSuffix suffix t = fromMaybe t $ T.stripSuffix suffix t++padTo :: Int -> Text -> Text+padTo n t = t <> T.replicate pad " " where pad = max 0 $ n - T.length t
+ src/Data/Aeson/Compat.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE CPP #-}++module Data.Aeson.Compat+  ( Key+  , fromText+  , toText+  , KeyMap+  , empty+  , null+  , singleton+  , fromList+  , toList+  ) where++#if MIN_VERSION_aeson(2, 0, 0)+import Data.Aeson.Key (Key, fromText, toText)+import Data.Aeson.KeyMap (KeyMap, empty, fromList, null, singleton, toList)+-- Avoid unused-packages (unordered-containers) warning for this path+import Data.HashMap.Strict ()+#else+import Prelude (id)++import Data.HashMap.Strict (HashMap, empty, fromList, null, singleton, toList)+import Data.Text (Text)++type Key = Text+type KeyMap = HashMap Text++fromText :: Text -> Key+fromText = id++toText :: Key -> Text+toText = id+#endif
+ src/Network/Wai/Middleware/Logging.hs view
@@ -0,0 +1,124 @@+module Network.Wai.Middleware.Logging+  ( addThreadContext+  , requestLogger+  ) where++import Prelude++import Blammo.Logging+import Control.Arrow ((***))+import Control.Monad.IO.Unlift (withRunInIO)+import Data.Aeson+import qualified Data.Aeson.Compat as Key+import qualified Data.Aeson.Compat as KeyMap+import qualified Data.CaseInsensitive as CI+import Data.Text (pack)+import Data.Text.Encoding (decodeUtf8)+import Network.HTTP.Types.Header (Header, HeaderName)+import Network.HTTP.Types.Status (Status(..))+import Network.Wai+  ( Middleware+  , Request+  , Response+  , rawPathInfo+  , rawQueryString+  , requestHeaders+  , requestMethod+  , responseHeaders+  , responseStatus+  )+import qualified System.Clock as Clock++-- | Add context to any logging done from the request-handling thread+addThreadContext :: [Pair] -> Middleware+addThreadContext context app request respond = do+  withThreadContext context $ do+    app request respond++-- | Log requests (more accurately, responses) as they happen+--+-- In JSON format, logged messages look like:+--+-- @+-- {+--   ...+--   message: {+--     text: "GET /foo/bar => 200 OK",+--     meta: {+--       method: "GET",+--       path: "/foo/bar",+--       query: "?baz=bat&quix=quo",+--       status: {+--         code: 200,+--         message: "OK"+--       },+--       durationMs: 1322.2,+--       requestHeaders: {+--         Authorization: "***",+--         Accept: "text/html",+--         Cookie: "***"+--       },+--       responseHeaders: {+--         Set-Cookie: "***",+--         Expires: "never"+--       }+--     }+--   }+-- }+-- @+--+requestLogger :: HasLogger env => env -> Middleware+requestLogger env app req respond =+  runLoggerLoggingT env $ withRunInIO $ \runInIO -> do+    begin <- getTime+    app req $ \resp -> do+      recvd <- respond resp+      duration <- toMillis . subtract begin <$> getTime+      recvd <$ runInIO (logResponse duration req resp)+ where+  getTime = Clock.getTime Clock.Monotonic++  toMillis x = fromIntegral (Clock.toNanoSecs x) / nsPerMs++logResponse :: MonadLogger m => Double -> Request -> Response -> m ()+logResponse duration req resp+  | statusCode status >= 500 = logError $ message :# details+  | statusCode status == 404 = logDebug $ message :# details+  | statusCode status >= 400 = logWarn $ message :# details+  | otherwise = logDebug $ message :# details+ where+  message =+    decodeUtf8 (requestMethod req)+      <> " "+      <> decodeUtf8 (rawPathInfo req)+      <> " => "+      <> pack (show $ statusCode status)+      <> " "+      <> decodeUtf8 (statusMessage status)++  details =+    [ "method" .= decodeUtf8 (requestMethod req)+    , "path" .= decodeUtf8 (rawPathInfo req)+    , "query" .= decodeUtf8 (rawQueryString req)+    , "status" .= object+      [ "code" .= statusCode status+      , "message" .= decodeUtf8 (statusMessage status)+      ]+    , "durationMs" .= duration+    , "requestHeaders"+      .= headerObject ["authorization", "cookie"] (requestHeaders req)+    , "responseHeaders" .= headerObject ["set-cookie"] (responseHeaders resp)+    ]++  status = responseStatus resp++headerObject :: [HeaderName] -> [Header] -> Value+headerObject redact = Object . KeyMap.fromList . map (mung . hide)+ where+  mung = Key.fromText . decodeUtf8 . CI.foldedCase *** String . decodeUtf8+  hide (k, v)+    | k `elem` redact = (k, "***")+    | otherwise = (k, v)++nsPerMs :: Double+nsPerMs = 1000000
+ tests/Blammo/Logging/LogSettings/LogLevelsSpec.hs view
@@ -0,0 +1,51 @@+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Blammo.Logging.LogSettings.LogLevelsSpec+  ( spec+  ) where++import Prelude++import Blammo.Logging.LogSettings.LogLevels+import Data.Either (isLeft, isRight)+import Test.Hspec++spec :: Spec+spec = do+  describe "readLogLevels" $ do+    it "rejects omitting the default log level" $ do+      readLogLevels "foo:warn" `shouldSatisfy` isLeft++    it "rejects multiple default log levels" $ do+      readLogLevels "info,warn" `shouldSatisfy` isLeft++    it "rejects multiple default log levels with sources" $ do+      readLogLevels "info,foo:warn,info" `shouldSatisfy` isLeft++    it "rejects invalid sources" $ do+      readLogLevels "info,foo:" `shouldSatisfy` isLeft+      readLogLevels "info,:bar" `shouldSatisfy` isLeft++    it "accepts the default log level in any position" $ do+      readLogLevels "info,foo:warn" `shouldSatisfy` isRight+      readLogLevels "foo:warn,info" `shouldSatisfy` isRight+      readLogLevels "foo:warn,info,foo:warn" `shouldSatisfy` isRight++  describe "shouldLogLevel" $ do+    it "uses the default log level for unknown sources" $ do+      let+        Right ll1 = readLogLevels "warn"+        Right ll2 = readLogLevels "warn,foo:debug"++      shouldLogLevel ll1 "foo" LevelInfo `shouldBe` False+      shouldLogLevel ll1 "bar" LevelInfo `shouldBe` False++      shouldLogLevel ll2 "foo" LevelInfo `shouldBe` True+      shouldLogLevel ll2 "bar" LevelInfo `shouldBe` False++    it "can override multiple sources" $ do+      let Right ll = readLogLevels "debug,Amazonka:warn,SQL:info"++      shouldLogLevel ll "app" LevelDebug `shouldBe` True+      shouldLogLevel ll "Amazonka" LevelInfo `shouldBe` False+      shouldLogLevel ll "SQL" LevelDebug `shouldBe` False
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Main -Wno-missing-export-lists #-}