Blammo-wai (empty) → 0.0.0.0
raw patch · 6 files changed
+524/−0 lines, 6 filesdep +Blammodep +Blammo-waidep +aeson
Dependencies added: Blammo, Blammo-wai, aeson, base, bytestring, case-insensitive, clock, http-types, lens, markdown-unlit, text, unliftio-core, wai, warp, yesod-core
Files
- Blammo-wai.cabal +95/−0
- CHANGELOG.md +9/−0
- LICENSE +21/−0
- README.lhs +100/−0
- README.md +100/−0
- src/Network/Wai/Middleware/Logging.hs +199/−0
+ Blammo-wai.cabal view
@@ -0,0 +1,95 @@+cabal-version: 1.18+name: Blammo-wai+version: 0.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: Using Blammo with WAI+description: Please see README.md+category: Logging, Web+build-type: Simple+extra-doc-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/freckle/blammo++library+ exposed-modules: Network.Wai.Middleware.Logging+ hs-source-dirs: src+ other-modules: Paths_Blammo_wai+ default-language: Haskell2010+ default-extensions:+ DerivingStrategies GeneralizedNewtypeDeriving 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 >=2.0.0.0,+ aeson >=1.5.2.0,+ base >=4.13.0.0 && <5,+ bytestring >=0.10.10.1,+ case-insensitive >=1.2.1.0,+ clock >=0.8,+ http-types >=0.12.3,+ text >=1.2.4.0,+ unliftio-core >=0.1.2.0,+ wai >=3.2.2.1++ if impl(ghc >=9.8)+ ghc-options: -Wno-missing-role-annotations++ 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_wai+ default-language: Haskell2010+ default-extensions:+ DerivingStrategies GeneralizedNewtypeDeriving 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 >=2.0.0.0,+ Blammo-wai,+ aeson >=1.5.2.0,+ base >=4.13.0.0 && <5,+ lens >=4.18.1,+ markdown-unlit >=0.5.1,+ text >=1.2.4.0,+ wai >=3.2.2.1,+ warp >=3.3.13,+ yesod-core >=1.6.18.8++ if impl(ghc >=9.8)+ ghc-options: -Wno-missing-role-annotations++ 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,9 @@+## [_Unreleased_](https://github.com/freckle/blammo/compare/v0.0.0.1...main)++## [v0.0.0.1](https://github.com/freckle/blammo/compare/0.0.0.0...v0.0.0.1)++...++## [v0.0.0.0](https://github.com/freckle/blammo/tree/v0.0.0.0)++First release
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++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+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,100 @@+# Blammo-wai++Integration of [Blammo](https://hackage.haskell.org/package/Blammo)+with [wai](https://hackage.haskell.org/package/wai).++<!--+```haskell+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE EmptyDataDeriving #-}+{-# LANGUAGE TypeFamilies #-}++module Main (module Main) where++import Prelude++import Control.Exception (displayException)+import Control.Monad (when)+import Data.Aeson+import Data.Text (Text)+import Text.Markdown.Unlit ()+import Control.Lens (lens)+```+-->++```haskell+-- Blammo+import Blammo.Logging++-- wai+import Network.Wai (Middleware)++-- Blammo-wai+import Network.Wai.Middleware.Logging++-- warp+import qualified Network.Wai.Handler.Warp as Warp++-- yesod+import Yesod.Core (Yesod)+import qualified Yesod.Core as Yesod+```++<!--+```haskell+main :: IO ()+main = pure ()+```+-->++```haskell+data App = App+ { appLogger :: Logger+ -- etc.+ }++instance HasLogger App where+ loggerL = lens appLogger $ \x y -> x {appLogger = y}+```++## Integration with WAI++```haskell+waiMiddleware :: App -> Middleware+waiMiddleware app =+ addThreadContext ["app" .= ("my-app" :: Text)]+ . requestLogger app+ . Yesod.defaultMiddlewaresNoLogging+```++## Integration with Warp++```haskell+warpSettings :: App -> Warp.Settings+warpSettings app = Warp.setOnException onEx $ Warp.defaultSettings+ where+ onEx _req ex =+ when (Warp.defaultShouldDisplayException ex)+ $ runWithLogger app+ $ logError+ $ "Warp exception" :# ["exception" .= displayException ex]+```++## Integration with Yesod++<!--+```haskell+instance Yesod.RenderRoute App where+ data Route App deriving stock Eq+ renderRoute = \case{}+```+-->++```haskell+instance Yesod App where+ messageLoggerSource app _logger loc source level msg =+ runWithLogger app $ monadLoggerLog loc source level msg+```
+ README.md view
@@ -0,0 +1,100 @@+# Blammo-wai++Integration of [Blammo](https://hackage.haskell.org/package/Blammo)+with [wai](https://hackage.haskell.org/package/wai).++<!--+```haskell+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE EmptyDataDeriving #-}+{-# LANGUAGE TypeFamilies #-}++module Main (module Main) where++import Prelude++import Control.Exception (displayException)+import Control.Monad (when)+import Data.Aeson+import Data.Text (Text)+import Text.Markdown.Unlit ()+import Control.Lens (lens)+```+-->++```haskell+-- Blammo+import Blammo.Logging++-- wai+import Network.Wai (Middleware)++-- Blammo-wai+import Network.Wai.Middleware.Logging++-- warp+import qualified Network.Wai.Handler.Warp as Warp++-- yesod+import Yesod.Core (Yesod)+import qualified Yesod.Core as Yesod+```++<!--+```haskell+main :: IO ()+main = pure ()+```+-->++```haskell+data App = App+ { appLogger :: Logger+ -- etc.+ }++instance HasLogger App where+ loggerL = lens appLogger $ \x y -> x {appLogger = y}+```++## Integration with WAI++```haskell+waiMiddleware :: App -> Middleware+waiMiddleware app =+ addThreadContext ["app" .= ("my-app" :: Text)]+ . requestLogger app+ . Yesod.defaultMiddlewaresNoLogging+```++## Integration with Warp++```haskell+warpSettings :: App -> Warp.Settings+warpSettings app = Warp.setOnException onEx $ Warp.defaultSettings+ where+ onEx _req ex =+ when (Warp.defaultShouldDisplayException ex)+ $ runWithLogger app+ $ logError+ $ "Warp exception" :# ["exception" .= displayException ex]+```++## Integration with Yesod++<!--+```haskell+instance Yesod.RenderRoute App where+ data Route App deriving stock Eq+ renderRoute = \case{}+```+-->++```haskell+instance Yesod App where+ messageLoggerSource app _logger loc source level msg =+ runWithLogger app $ monadLoggerLog loc source level msg+```
+ src/Network/Wai/Middleware/Logging.hs view
@@ -0,0 +1,199 @@+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