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.2.1.0 +version: 2.0.0.0 license: MIT license-file: LICENSE maintainer: Freckle Education @@ -8,7 +8,7 @@ bug-reports: https://github.com/freckle/blammo/issues synopsis: Batteries-included Structured Logging library description: Please see README.md -category: Utils +category: Logging build-type: Simple extra-doc-files: README.md @@ -33,7 +33,6 @@ Blammo.Logging.Test Blammo.Logging.WithLogger Data.Aeson.Compat - Network.Wai.Middleware.Logging System.Log.FastLogger.Compat hs-source-dirs: src @@ -52,26 +51,22 @@ build-depends: aeson >=1.5.2.0, - base >=4.12.0.0 && <5, - bytestring >=0.10.8.2, - case-insensitive >=1.2.0.11, - clock >=0.8, - containers >=0.6.0.1, - dlist >=0.8.0.7, - envparse >=0.5.0, + base >=4.13.0.0 && <5, + bytestring >=0.10.10.1, + containers >=0.6.2.1, + dlist >=0.8.0.8, + envparse >=0.4.1, exceptions >=0.10.4, fast-logger >=3.2.3, - http-types >=0.12.3, - lens >=4.17.1, + lens >=4.18.1, monad-logger-aeson >=0.4.0.3, mtl >=2.2.2, - text >=1.2.3.1, - time >=1.8.0.2, - unliftio >=0.2.12, + text >=1.2.4.0, + time >=1.9.3, + unliftio >=0.2.13.1, unliftio-core >=0.1.2.0, unordered-containers >=0.2.10.0, - vector >=0.12.1.2, - wai >=3.2.2.1 + vector >=0.12.1.2 if impl(ghc >=9.8) ghc-options: -Wno-missing-role-annotations @@ -102,11 +97,11 @@ build-depends: Blammo, aeson >=1.5.2.0, - base >=4.12.0.0 && <5, - lens >=4.17.1, - markdown-unlit >=0.5.0, + base >=4.13.0.0 && <5, + lens >=4.18.1, + markdown-unlit >=0.5.1, mtl >=2.2.2, - text >=1.2.3.1 + text >=1.2.4.0 if impl(ghc >=9.8) ghc-options: -Wno-missing-role-annotations @@ -144,13 +139,13 @@ build-depends: Blammo, aeson >=1.5.2.0, - base >=4.12.0.0 && <5, - bytestring >=0.10.8.2, - envparse >=0.5.0, - hspec >=2.7.9, + base >=4.13.0.0 && <5, + bytestring >=0.10.10.1, + envparse >=0.4.1, + hspec >=2.7.6, mtl >=2.2.2, - text >=1.2.3.1, - time >=1.8.0.2 + text >=1.2.4.0, + time >=1.9.3 if impl(ghc >=9.8) ghc-options: -Wno-missing-role-annotations diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ ## [_Unreleased_](https://github.com/freckle/blammo/compare/v1.2.1.0...main) +## [v2.0.0.0](https://github.com/freckle/blammo/compare/v1.2.1.0...v2.0.0.0) + +- Remove module `Network.Wai.Middleware.Logging`. It is moved to a new + package, `Blammo-wai`. + ## [v1.2.1.0](https://github.com/freckle/blammo/compare/1.2.0.0...v1.2.1.0) - Add `Blammo.Logging.Simple.withLoggerEnv` diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ The MIT License (MIT) -Copyright (c) 2022 Renaissance Learning Inc +Copyright (c) 2022-2024 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 diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -321,52 +321,6 @@ } ``` -## 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 -import qualified Network.Wai.Handler.Warp as Warp - -instance HasLogger App where - -- ... - -warpSettings :: App -> Settings -warpSettings app = setOnException onEx $ defaultSettings - where - onEx _req ex = - when (Warp.defaultShouldDisplayException ex) - $ runWithLogger app - $ logError - $ "Warp exception" :# ["exception" .= displayException ex] -``` - -## Integration with Yesod - -```hs -instance HasLogger App where - -- ... - -instance Yesod App where - -- ... - - messageLoggerSource app _logger loc source level msg = - runWithLogger app $ monadLoggerLog loc source level msg -``` - --- [LICENSE](./LICENSE) | [CHANGELOG](./CHANGELOG.md) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -321,52 +321,6 @@ } ``` -## 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 -import qualified Network.Wai.Handler.Warp as Warp - -instance HasLogger App where - -- ... - -warpSettings :: App -> Settings -warpSettings app = setOnException onEx $ defaultSettings - where - onEx _req ex = - when (Warp.defaultShouldDisplayException ex) - $ runWithLogger app - $ logError - $ "Warp exception" :# ["exception" .= displayException ex] -``` - -## Integration with Yesod - -```hs -instance HasLogger App where - -- ... - -instance Yesod App where - -- ... - - messageLoggerSource app _logger loc source level msg = - runWithLogger app $ monadLoggerLog loc source level msg -``` - --- [LICENSE](./LICENSE) | [CHANGELOG](./CHANGELOG.md) diff --git a/src/Blammo/Logging/Test.hs b/src/Blammo/Logging/Test.hs --- a/src/Blammo/Logging/Test.hs +++ b/src/Blammo/Logging/Test.hs @@ -33,6 +33,7 @@ appendLogStrLn :: MonadIO m => LoggedMessages -> LogStr -> m () appendLogStrLn lm = appendLogStr lm . (<> "\n") -getLoggedMessages :: MonadIO m => LoggedMessages -> m [Either String LoggedMessage] +getLoggedMessages + :: MonadIO m => LoggedMessages -> m [Either String LoggedMessage] getLoggedMessages (LoggedMessages ref) = map (eitherDecodeStrict . fromLogStr) . DList.toList <$> readIORef ref diff --git a/src/Network/Wai/Middleware/Logging.hs b/src/Network/Wai/Middleware/Logging.hs deleted file mode 100644 --- a/src/Network/Wai/Middleware/Logging.hs +++ /dev/null @@ -1,199 +0,0 @@ -module Network.Wai.Middleware.Logging - ( addThreadContext - , addThreadContextFromRequest - , requestLogger - , requestLoggerWith - - -- * Configuration - , Config - , defaultConfig - , setConfigLogSource - , setConfigGetClientIp - , setConfigGetDestinationIp - ) where - -import Prelude - -import Blammo.Logging -import Control.Applicative ((<|>)) -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 Data.ByteString (ByteString) -import qualified Data.CaseInsensitive as CI -import Data.List (find) -import Data.Maybe (fromMaybe) -import Data.Text (Text, pack) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import Network.HTTP.Types.Header (Header, HeaderName) -import Network.HTTP.Types.Status (Status (..)) -import Network.Wai - ( Middleware - , Request - , Response - , rawPathInfo - , rawQueryString - , remoteHost - , 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 = addThreadContextFromRequest . const - --- | 'addThreadContext', but have the 'Request' available -addThreadContextFromRequest :: (Request -> [Pair]) -> Middleware -addThreadContextFromRequest toContext app request respond = do - withThreadContext (toContext request) $ 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 = requestLoggerWith defaultConfig - -data Config = Config - { cLogSource :: LogSource - , cGetClientIp :: Request -> Text - , cGetDestinationIp :: Request -> Maybe Text - } - -defaultConfig :: Config -defaultConfig = - Config - { cLogSource = "requestLogger" - , cGetClientIp = \req -> - fromMaybe (pack $ show $ remoteHost req) $ - (firstValue =<< lookupRequestHeader "x-forwarded-for" req) - <|> lookupRequestHeader "x-real-ip" req - , cGetDestinationIp = lookupRequestHeader "x-real-ip" - } - where - firstValue = find (not . T.null) . map T.strip . T.splitOn "," - -lookupRequestHeader :: HeaderName -> Request -> Maybe Text -lookupRequestHeader h = fmap decodeUtf8 . lookup h . requestHeaders - --- | Change the source used for log messages --- --- Default is @requestLogger@. -setConfigLogSource :: LogSource -> Config -> Config -setConfigLogSource x c = c {cLogSource = x} - --- | Change how the @clientIp@ field is determined --- --- Default is looking up the first value in @x-forwarded-for@, then the --- @x-real-ip@ header, then finally falling back to 'Network.Wai.remoteHost'. -setConfigGetClientIp :: (Request -> Text) -> Config -> Config -setConfigGetClientIp x c = c {cGetClientIp = x} - --- | Change how the @destinationIp@ field is determined --- --- Default is looking up the @x-real-ip@ header. --- --- __NOTE__: Our default uses a somewhat loose definition of /destination/. It --- would be more accurate to report the resolved IP address of the @Host@ --- header, but we don't have that available. Our default of @x-real-ip@ favors --- containerized Warp on AWS/ECS, where this value holds the ECS target --- container's IP address. This is valuable debugging information and could, if --- you squint, be considered a /destination/. -setConfigGetDestinationIp :: (Request -> Maybe Text) -> Config -> Config -setConfigGetDestinationIp x c = c {cGetDestinationIp = x} - -requestLoggerWith :: HasLogger env => Config -> env -> Middleware -requestLoggerWith config env app req respond = - withRunInIO $ \runInIO -> do - begin <- getTime - app req $ \resp -> do - recvd <- respond resp - duration <- toMillis . subtract begin <$> getTime - recvd <$ runInIO (runWithLogger env $ logResponse config duration req resp) - where - getTime = Clock.getTime Clock.Monotonic - toMillis x = fromIntegral (Clock.toNanoSecs x) / nsPerMs - -logResponse :: MonadLogger m => Config -> Double -> Request -> Response -> m () -logResponse Config {..} duration req resp - | statusCode status >= 500 = logErrorNS cLogSource $ message :# details - | statusCode status == 404 = logDebugNS cLogSource $ message :# details - | statusCode status >= 400 = logWarnNS cLogSource $ message :# details - | otherwise = logDebugNS cLogSource $ 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) - ] - , "clientIp" .= cGetClientIp req - , "destinationIp" .= cGetDestinationIp req - , "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 - -decodeUtf8 :: ByteString -> Text -decodeUtf8 = decodeUtf8With lenientDecode