diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,32 @@ -## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.0.2.8...main) +## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.0.2.10...main) -- None. +- None + +## [v1.0.2.10](https://github.com/freckle/freckle-app/compare/v1.0.2.9...v1.0.2.10) + +- Support GHC 9.0 and 9.2 + +- Change `Wai` function arguments for producing `RouteName` and `TraceId` to + tags + + To maintain the same behavior, replace + + ```hs + makeLoggingMiddleware app getRouteName getTraceId ... + ``` + + With + + ```hs + makeLoggingMiddleware app getTags ... + where + getTags req = catMaybes + [ ("route", ) <$> getRouteName req + , ("trace_id", ) <$> getTraceId req + ] + ``` + + And similar for `makeRequestMetricsMiddleware`. ## [v1.0.2.9](https://github.com/freckle/freckle-app/compare/v1.0.2.8...v1.0.2.9) diff --git a/freckle-app.cabal b/freckle-app.cabal --- a/freckle-app.cabal +++ b/freckle-app.cabal @@ -1,6 +1,6 @@ -cabal-version: 1.12 +cabal-version: 1.18 name: freckle-app -version: 1.0.2.9 +version: 1.0.2.10 license: MIT license-file: LICENSE maintainer: Freckle Education @@ -10,10 +10,10 @@ description: Please see README.md category: Utils build-type: Simple -extra-source-files: +extra-source-files: package.yaml +extra-doc-files: README.md CHANGELOG.md - package.yaml source-repository head type: git @@ -64,7 +64,7 @@ build-depends: Glob >=0.9.3, MonadRandom >=0.5.1.1, - aeson >=1.3.1.1 && <2.0, + aeson >=1.3.1.1, ansi-terminal >=0.8.2, base >=4.11.1.0 && <5, bytestring >=0.10.8.2, @@ -113,7 +113,6 @@ transformers >=0.5.5.0, transformers-base >=0.4.5.2, unliftio >=0.2.9.0, - unliftio-core >=0.1.2.0, unordered-containers >=0.2.9.0, vector >=0.12.0.2, wai >=3.2.1.2, diff --git a/library/Freckle/App/Logging.hs b/library/Freckle/App/Logging.hs --- a/library/Freckle/App/Logging.hs +++ b/library/Freckle/App/Logging.hs @@ -172,8 +172,12 @@ where labelEnd = fromIntegral $ fromEnum ']' - (levelStr : logStr) = - BS.split labelEnd . fromLogStr $ defaultLogStr loc src level $ toLogStr str + (levelStr, logStr) = + let formatted = fromLogStr $ defaultLogStr loc src level $ toLogStr str + in + case BS.split labelEnd formatted of + [] -> ("", [formatted]) + (x : xs) -> (x, xs) esc x = if isANSI then BS8.pack $ setSGRCode [x] else "" diff --git a/library/Freckle/App/Wai.hs b/library/Freckle/App/Wai.hs --- a/library/Freckle/App/Wai.hs +++ b/library/Freckle/App/Wai.hs @@ -1,10 +1,6 @@ -{-# LANGUAGE TupleSections #-} - -- | Integration of "Freckle.App" tooling with "Network.Wai" module Freckle.App.Wai - ( RouteName(..) - , TraceId(..) - , makeLoggingMiddleware + ( makeLoggingMiddleware , makeRequestMetricsMiddleware , noCacheMiddleware , corsMiddleware @@ -24,6 +20,7 @@ import qualified Data.CaseInsensitive as CI import Data.Default (def) import Data.IP (fromHostAddress, fromHostAddress6) +import Data.String (fromString) import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Freckle.App.Datadog (HasDogStatsClient, HasDogStatsTags) @@ -44,29 +41,18 @@ ) import System.Log.FastLogger (LoggerSet, toLogStr) -newtype RouteName = RouteName - { unRouteName :: Text - } - deriving newtype ToJSON - -newtype TraceId = TraceId - { unTraceId :: Text - } - deriving newtype ToJSON - makeLoggingMiddleware :: HasLogging app => app - -> (Request -> Maybe RouteName) - -> (Request -> Maybe TraceId) + -> (Request -> [(Text, Text)]) -> LoggerSet -> IO Middleware -makeLoggingMiddleware app getRouteName getTraceId ls = case getLogFormat app of +makeLoggingMiddleware app getTags ls = case getLogFormat app of FormatJSON -> makeWith $ CustomOutputFormatWithDetails $ suppressByStatus (getLogLevel app) - $ jsonOutputFormatter getRouteName getTraceId + $ jsonOutputFormatter getTags FormatTerminal -> makeWith $ Detailed $ getLogDefaultANSI app where makeWith format = @@ -81,26 +67,25 @@ = "" jsonOutputFormatter - :: (Request -> Maybe RouteName) - -> (Request -> Maybe TraceId) - -> OutputFormatterWithDetails -jsonOutputFormatter getRouteName getTraceId date req status responseSize duration _reqBody response - = toLogStr $ formatJsonNoLoc (statusLevel status) $ object - [ "time" .= decodeUtf8 date - , "method" .= decodeUtf8 (requestMethod req) - , "route" .= getRouteName req - , "path" .= decodeUtf8 (rawPathInfo req) - , "query_string" .= map queryItemToJSON (queryString req) - , "status" .= statusCode status - , "duration_ms" .= (duration * 1000) - , "request_size" .= requestBodyLengthToJSON (requestBodyLength req) - , "response_size" .= responseSize - , "response_body" .= do - guard $ statusCode status >= 400 - Just $ maybeDecodeToValue $ toLazyByteString response - , "trace_id" .= getTraceId req - , "client_ip" .= (decodeUtf8 <$> clientIp) - ] + :: (Request -> [(Text, Text)]) -> OutputFormatterWithDetails +jsonOutputFormatter getTags date req status responseSize duration _reqBody response + = toLogStr + $ formatJsonNoLoc (statusLevel status) + $ object + $ [ "time" .= decodeUtf8 date + , "method" .= decodeUtf8 (requestMethod req) + , "path" .= decodeUtf8 (rawPathInfo req) + , "query_string" .= map queryItemToJSON (queryString req) + , "status" .= statusCode status + , "duration_ms" .= (duration * 1000) + , "request_size" .= requestBodyLengthToJSON (requestBodyLength req) + , "response_size" .= responseSize + , "response_body" .= do + guard $ statusCode status >= 400 + Just $ maybeDecodeToValue $ toLazyByteString response + , "client_ip" .= (decodeUtf8 <$> clientIp) + ] + <> map (uncurry (.=) . first (fromString . unpack)) (getTags req) where clientIp = requestRealIp req <|> Just (sockAddrToIp $ remoteHost req) statusLevel :: Status -> LogLevel @@ -163,9 +148,9 @@ makeRequestMetricsMiddleware :: (HasDogStatsClient env, HasDogStatsTags env) => env - -> (Request -> Maybe RouteName) + -> (Request -> [(Text, Text)]) -> Middleware -makeRequestMetricsMiddleware env getRouteName app req sendResponse' = do +makeRequestMetricsMiddleware env getTags app req sendResponse' = do start <- getCurrentTime app req $ \res -> do flip runReaderT env $ do @@ -174,7 +159,7 @@ sendResponse' res where tags res = - maybeToList (("route", ) . unRouteName <$> getRouteName req) + getTags req <> [ ("method", decodeUtf8 $ requestMethod req) , ("status", pack $ show $ statusCode $ responseStatus res) ] diff --git a/library/Freckle/App/Yesod/Routes.hs b/library/Freckle/App/Yesod/Routes.hs --- a/library/Freckle/App/Yesod/Routes.hs +++ b/library/Freckle/App/Yesod/Routes.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Freckle.App.Yesod.Routes ( mkRouteNameCaseExp ) where @@ -38,11 +40,18 @@ matches <- fold <$> traverse mkMatches children pure [ TH.Match - (TH.ConP constName paramVars) + (conP constName paramVars) (TH.NormalB $ TH.CaseE (TH.VarE caseVar) matches) [] ] where constName = TH.mkName name + +conP :: TH.Name -> [TH.Pat] -> TH.Pat +#if MIN_VERSION_template_haskell(2,18,0) +conP x = TH.ConP x [] +#else +conP = TH.ConP +#endif isDynamic :: Piece a -> Bool isDynamic = \case diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,15 +1,17 @@ --- name: freckle-app -version: 1.0.2.9 +version: 1.0.2.10 maintainer: Freckle Education category: Utils github: freckle/freckle-app synopsis: Haskell application toolkit used at Freckle description: Please see README.md -extra-source-files: +extra-doc-files: - README.md - CHANGELOG.md + +extra-source-files: - package.yaml flags: @@ -52,7 +54,7 @@ dependencies: - Glob - MonadRandom - - aeson < 2.0 + - aeson - ansi-terminal - bytestring - case-insensitive @@ -100,7 +102,6 @@ - transformers - transformers-base - unliftio - - unliftio-core - unordered-containers - vector - wai