diff --git a/Blammo-wai.cabal b/Blammo-wai.cabal new file mode 100644 --- /dev/null +++ b/Blammo-wai.cabal @@ -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 diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 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-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. diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,100 @@ +# Blammo-wai + +Integration of [Blammo](https://hackage.haskell.org/package/Blammo) +with [wai](https://hackage.haskell.org/package/wai). + + + +```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 +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 App where + messageLoggerSource app _logger loc source level msg = + runWithLogger app $ monadLoggerLog loc source level msg +``` diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,100 @@ +# Blammo-wai + +Integration of [Blammo](https://hackage.haskell.org/package/Blammo) +with [wai](https://hackage.haskell.org/package/wai). + + + +```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 +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 App where + messageLoggerSource app _logger loc source level msg = + runWithLogger app $ monadLoggerLog loc source level msg +``` 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,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