diff --git a/Blammo.cabal b/Blammo.cabal new file mode 100644 --- /dev/null +++ b/Blammo.cabal @@ -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 diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -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 +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=[,,...]` | +| Destination | `setLogSettingsDestination` | `LOG_DESTINATION=stdout\|stderr\|@` | +| 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) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 +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=[,,...]` | +| Destination | `setLogSettingsDestination` | `LOG_DESTINATION=stdout\|stderr\|@` | +| 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) diff --git a/src/Blammo/Logging.hs b/src/Blammo/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Blammo/Logging.hs @@ -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 diff --git a/src/Blammo/Logging/Colors.hs b/src/Blammo/Logging/Colors.hs new file mode 100644 --- /dev/null +++ b/src/Blammo/Logging/Colors.hs @@ -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 diff --git a/src/Blammo/Logging/LogSettings.hs b/src/Blammo/Logging/LogSettings.hs new file mode 100644 --- /dev/null +++ b/src/Blammo/Logging/LogSettings.hs @@ -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 diff --git a/src/Blammo/Logging/LogSettings/Env.hs b/src/Blammo/Logging/LogSettings/Env.hs new file mode 100644 --- /dev/null +++ b/src/Blammo/Logging/LogSettings/Env.hs @@ -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 diff --git a/src/Blammo/Logging/LogSettings/LogLevels.hs b/src/Blammo/Logging/LogSettings/LogLevels.hs new file mode 100644 --- /dev/null +++ b/src/Blammo/Logging/LogSettings/LogLevels.hs @@ -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: +-- +-- @ +-- [, ...,][, , ...] +-- @ +-- +-- Where @@ defines the minimum level for anything not overridden by +-- source. If you go on to add any @@ 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 diff --git a/src/Blammo/Logging/Logger.hs b/src/Blammo/Logging/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Blammo/Logging/Logger.hs @@ -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 { .. } diff --git a/src/Blammo/Logging/Simple.hs b/src/Blammo/Logging/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Blammo/Logging/Simple.hs @@ -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 diff --git a/src/Blammo/Logging/Terminal.hs b/src/Blammo/Logging/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/Blammo/Logging/Terminal.hs @@ -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 diff --git a/src/Data/Aeson/Compat.hs b/src/Data/Aeson/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Compat.hs @@ -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 diff --git a/src/Network/Wai/Middleware/Logging.hs b/src/Network/Wai/Middleware/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Middleware/Logging.hs @@ -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 diff --git a/tests/Blammo/Logging/LogSettings/LogLevelsSpec.hs b/tests/Blammo/Logging/LogSettings/LogLevelsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Blammo/Logging/LogSettings/LogLevelsSpec.hs @@ -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 diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Main -Wno-missing-export-lists #-}