Add debugLog and defaultExceptionResponse

.github/workflows/haskell-ci.yml

@@ -8,9 +8,9 @@
 #
 # For more information, see https://github.com/haskell-CI/haskell-ci
 #
-# version: 0.15.20230115
+# version: 0.16.3
 #
-# REGENDATA ("0.15.20230115",["github","cabal.project"])
+# REGENDATA ("0.16.3",["github","cabal.project"])
 #
 name: Haskell-CI
 on:
@@ -32,14 +32,19 @@ jobs:
  strategy:
  matrix:
  include:
- - compiler: ghc-9.4.4
+ - compiler: ghc-9.6.2
  compilerKind: ghc
- compilerVersion: 9.4.4
+ compilerVersion: 9.6.2
  setup-method: ghcup
  allow-failure: true
- - compiler: ghc-9.2.5
+ - compiler: ghc-9.4.5
  compilerKind: ghc
- compilerVersion: 9.2.5
+ compilerVersion: 9.4.5
+ setup-method: ghcup
+ allow-failure: true
+ - compiler: ghc-9.2.7
+ compilerKind: ghc
+ compilerVersion: 9.2.7
  setup-method: ghcup
  allow-failure: true
  - compiler: ghc-9.0.2
@@ -59,10 +64,10 @@ jobs:
  apt-get update
  apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
  mkdir -p "$HOME/.ghcup/bin"
- curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup"
+ curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup"
  chmod a+x "$HOME/.ghcup/bin/ghcup"
  "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
- "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
+ "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
  env:
  HCKIND: ${{ matrix.compilerKind }}
  HCNAME: ${{ matrix.compiler }}
@@ -78,7 +83,7 @@ jobs:
  echo "HC=$HC" >> "$GITHUB_ENV"
  echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"
  echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"
- echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
  HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
  echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
  echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
@@ -128,8 +133,8 @@ jobs:
  - name: install cabal-plan
  run: |
  mkdir -p $HOME/.cabal/bin
- curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz
- echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c -
+ curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.7.3.0/cabal-plan-0.7.3.0-x86_64-linux.xz > cabal-plan.xz
+ echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c -
  xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan
  rm -f cabal-plan.xz
  chmod a+x $HOME/.cabal/bin/cabal-plan
@@ -162,6 +167,9 @@ jobs:
  echo "package web-template" >> cabal.project
  echo " ghc-options: -Werror=missing-methods" >> cabal.project
  cat >> cabal.project <<EOF
+ allow-newer: openid-connect:text
+ allow-newer: openid-connect:mtl
+
  source-repository-package
  type: git
  location: https://github.com/biocad/bcd-log
@@ -213,7 +221,7 @@ jobs:
  ${CABAL} -vnormal check
  - name: haddock
  run: |
- $CABAL v2-haddock --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
+ $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
  - name: unconstrained build
  run: |
  rm -f cabal.project.local

CHANGELOG.md

@@ -6,6 +6,10 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 
 ## [Unreleased]
 
+## [0.1.3.14] - 2023-06-14
+### Added
+- Debug log formatter `debugLogHandler`, customizable log middleware `logMiddlewareCustom`.
+
 ## [0.1.3.13] - 2023-01-23
 ### Changed
 - Add check for aeson 2, for GHC 9.2.5.

cabal.project

@@ -28,3 +28,5 @@ source-repository-package
  tag: 79432eaa084705d6ac3f5b877287a74815a8eb71
  subdir: generic-override-aeson
  --sha256: 1qqb39lw71q7637bh2xpdcxrkyh9r6r55z2xmkgcgbwvx0wi5l9l
+
+allow-newer: openid-connect:text, openid-connect:mtl

src/Web/Template/Log.hs

@@ -1,27 +1,39 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Web.Template.Log
  ( bcdlog
  , bcdlog400
+ , debugLog
+ , debugLogHandler
+
+ , logMiddlewareCustom
+ , AccessLogRecord(..)
+ , formatTimeIso
 
  , userIdVaultKey
  , tokenVaultKey
  , pTokenVaultKey
  ) where
 
+import Control.Monad (forM_, when)
 import Crypto.JWT (ClaimsSet)
 import Data.Aeson (fromEncoding, pairs, (.=))
 import Data.ByteString.Builder (hPutBuilder, toLazyByteString)
 import Data.IORef (IORef, newIORef, readIORef)
 import Data.Text as T (Text, pack, unwords)
 import Data.Text.Encoding (decodeUtf8)
 import qualified Data.Text.Encoding.Error as TE
+import qualified Data.Text.IO as TIO
+import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Encoding as TLE (decodeUtf8With)
+import qualified Data.Text.Lazy.IO as TLIO
 import Data.Time (ZonedTime, defaultTimeLocale, formatTime,
  nominalDiffTimeToSeconds, utcToLocalZonedTime)
 import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)
 import Data.Vault.Lazy (Key, insert, newKey)
+import GHC.Generics (Generic)
 import Network.HTTP.Types.Status (Status (..))
 import Network.Wai (Middleware, rawPathInfo, requestMethod, responseStatus,
  vault)
@@ -42,14 +54,33 @@ pTokenVaultKey :: Key (IORef (Maybe ClaimsSet))
 pTokenVaultKey = unsafePerformIO newKey
 {-# NOINLINE pTokenVaultKey #-}
 
+data AccessLogRecord
+ = AccessLogRecord
+ { alStart :: !POSIXTime
+ , alFinishApp :: !POSIXTime
+ , alFinishNetwork :: !POSIXTime
+ , alMsg :: !Text
+ , alStatus :: !Int
+ , alURL :: !Text
+ , alUserId :: !(Maybe Text)
+ , alResponseBody :: Maybe TL.Text
+ }
+ deriving (Show, Generic)
+
 bcdlog :: Middleware
 bcdlog = logMiddleware False
 
 bcdlog400 :: Middleware
 bcdlog400 = logMiddleware True
 
+debugLog :: Middleware
+debugLog = logMiddlewareCustom True $ Just debugLogHandler
+
 logMiddleware :: Bool -> Middleware
-logMiddleware log400 app request respond = do
+logMiddleware log400 = logMiddlewareCustom log400 Nothing
+
+logMiddlewareCustom :: Bool -> Maybe (AccessLogRecord -> IO ()) -> Middleware
+logMiddlewareCustom log400 mLogAction app request respond = do
  let
  url = decodeUtf8 $ rawPathInfo request
  method = decodeUtf8 $ requestMethod request
@@ -85,29 +116,63 @@ logMiddleware log400 app request respond = do
  -- but those may be big.
  ResponseBuilder _ _ b -> Just b
  _ -> Nothing
- logLine = pairs
- ( "datetime" .= toIso startZoned
- <> "timestamp" .= floor @_ @Int (toMs start)
- <> "duration" .= toMs (finishApp - start)
- <> "send_duration" .= toMs (finishNetwork - finishApp)
- <> "level" .= INFO
- <> "app" .= ("scotty" :: Text)
- <> "msg" .= msg'
- <> "status" .= statusC
- <> "url" .= url
- <> maybe mempty ("userId" .=) userId
- <> if log400 && statusC >= 400
- then maybe mempty (\b -> "response" .= TLE.decodeUtf8With TE.lenientDecode (toLazyByteString b)) responseBody
- else mempty
- )
-
- hPutBuilder stdout (fromEncoding logLine <> "\n")
- hFlush stdout
+ responseBodyText = TLE.decodeUtf8With TE.lenientDecode . toLazyByteString <$> responseBody
+
+ case mLogAction of
+ Nothing -> do
+ let
+ logLine = pairs
+ ( "datetime" .= formatTimeIso startZoned
+ <> "timestamp" .= floor @_ @Int (toMs start)
+ <> "duration" .= toMs (finishApp - start)
+ <> "send_duration" .= toMs (finishNetwork - finishApp)
+ <> "level" .= INFO
+ <> "app" .= ("scotty" :: Text)
+ <> "msg" .= msg'
+ <> "status" .= statusC
+ <> "url" .= url
+ <> maybe mempty ("userId" .=) userId
+ <> if log400 && statusC >= 400
+ then maybe mempty ("response" .=) responseBodyText
+ else mempty
+ )
+
+ hPutBuilder stdout (fromEncoding logLine <> "\n")
+ hFlush stdout
+ Just logAction -> do
+ logAction AccessLogRecord
+ { alStart = start
+ , alFinishApp = finishApp
+ , alFinishNetwork = finishNetwork
+ , alMsg = msg'
+ , alStatus = statusC
+ , alURL = url
+ , alUserId = userId
+ , alResponseBody = responseBodyText
+ }
 
  return rcv
- where
- toIso :: ZonedTime -> Text
- toIso = pack . formatTime defaultTimeLocale "%FT%T%z"
 
- toMs :: POSIXTime -> Double
- toMs = realToFrac . (1000 *) . nominalDiffTimeToSeconds
+formatTimeIso :: ZonedTime -> Text
+formatTimeIso = pack . formatTime defaultTimeLocale "%FT%T%z"
+
+toMs :: POSIXTime -> Double
+toMs = realToFrac . (1000 *) . nominalDiffTimeToSeconds
+
+debugLogHandler :: AccessLogRecord -> IO ()
+debugLogHandler AccessLogRecord{..} = do
+ let
+ duration = toMs (alFinishApp - alStart)
+ sendDuration = toMs (alFinishNetwork - alFinishApp)
+
+ startZoned <- utcToLocalZonedTime $ posixSecondsToUTCTime alStart
+ TIO.putStrLn $
+ formatTimeIso startZoned
+ <> " INFO "
+ <> alMsg
+ <> " " <> pack (show duration)
+ <> " " <> pack (show sendDuration)
+ when (alStatus >= 400) $
+ forM_ alResponseBody TLIO.putStrLn
+
+ hFlush stdout

src/Web/Template/Server.hs

@@ -12,6 +12,8 @@ module Web.Template.Server
  , defaultHandleLog400
  , defaultHeaderCORS
  , defaultOnException
+ , debugOnException
+ , debugLog
  , toApplication
  ) where
 

src/Web/Template/Wai.hs

@@ -1,17 +1,29 @@
 module Web.Template.Wai
- where
+ ( logMiddlewareCustom
+ , debugLogHandler
+ , debugLog
+ , formatTimeIso
+
+ , module Web.Template.Wai
+ ) where
 
-import Control.Exception (SomeException, fromException)
-import Data.Text (Text)
-import Network.HTTP.Types (Header)
-import Network.Wai (Middleware, Request, mapResponseHeaders, modifyResponse)
-import Network.Wai.Handler.Warp (InvalidRequest (..), Port, Settings, defaultSettings,
- exceptionResponseForDebug, setOnException, setOnExceptionResponse,
- setPort)
+import Control.Exception (SomeException, displayException, fromException)
+import Data.Aeson (fromEncoding, object, pairs, (.=))
+import Data.Text (Text, pack)
+import Data.Text.Encoding (decodeUtf8)
+import qualified Data.Text.IO as TIO
+import Data.Time (defaultTimeLocale, formatTime, utcToLocalZonedTime)
+import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime)
+import Network.HTTP.Types (Header, status500)
+import Network.Wai (Middleware, Request (..), Response, mapResponseHeaders,
+ modifyResponse, responseBuilder)
+import Network.Wai.Handler.Warp (InvalidRequest (..), Port, Settings, defaultSettings,
+ setOnException, setOnExceptionResponse, setPort)
+import System.IO (hFlush, stdout)
 
 import System.BCD.Log (error')
 
-import Web.Template.Log (bcdlog, bcdlog400)
+import Web.Template.Log (bcdlog, bcdlog400, debugLog, debugLogHandler, logMiddlewareCustom, formatTimeIso)
 
 defaultHandleLog :: Middleware
 defaultHandleLog = bcdlog
@@ -37,10 +49,38 @@ defaultOnException _ e =
  Just ConnectionClosedByPeer -> return ()
  _ -> error' ("scotty" :: Text) $ show e
 
+debugOnException :: Maybe Request -> SomeException -> IO ()
+debugOnException req e =
+ case fromException e of
+ Just ConnectionClosedByPeer -> return ()
+ _ -> do
+ time <- getPOSIXTime >>= utcToLocalZonedTime . posixSecondsToUTCTime
+ let
+ msg = pack (formatTime defaultTimeLocale "%FT%T%z" time) <> " ERROR"
+ exc = pack $ displayException e
+ reqMsg =
+ case req of
+ Nothing -> ""
+ Just request -> let
+ url = decodeUtf8 $ rawPathInfo request
+ method = decodeUtf8 $ requestMethod request
+ in " " <> method <> " " <> url
+
+ TIO.putStrLn $ msg <> reqMsg <> "\n" <> exc
+ hFlush stdout
+
+defaultExceptionResponse :: SomeException -> Response
+defaultExceptionResponse e = responseBuilder status500 [] $ fromEncoding $ pairs
+ ( "error" .= ("exception" :: Text)
+ <> ("params" .= object
+ [ "message" .= displayException e
+ ])
+ )
+
 warpSettings :: Port -> (Settings -> Settings) -> Settings
 warpSettings port userSettings =
- setOnException defaultOnException
- . setOnExceptionResponse exceptionResponseForDebug
+ userSettings
+ . setOnException defaultOnException
+ . setOnExceptionResponse defaultExceptionResponse
  . setPort port
- . userSettings
  $ defaultSettings

web-template.cabal

@@ -1,5 +1,5 @@
 name: web-template
-version: 0.1.3.13
+version: 0.1.3.14
 synopsis: Web template
 description:
  Web template includes:
@@ -22,8 +22,9 @@ cabal-version: >=1.10
 tested-with:
  GHC ==8.10.7
  || ==9.0.2
- || ==9.2.5
- || ==9.4.4
+ || ==9.2.7
+ || ==9.4.5
+ || ==9.6.2
 
 library
  hs-source-dirs: src