Skip to content

Commit 185f592

Browse files
maksbotanmaksbotan
authored
Merge pull request #34 from biocad/maksbotan/debug-logs
Add debugLog and defaultExceptionResponse
2 parents 68b3332 + bb5a866 commit 185f592

File tree

7 files changed

+173
-51
lines changed

7 files changed

+173
-51
lines changed

‎.github/workflows/haskell-ci.yml‎

Lines changed: 20 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -8,9 +8,9 @@
88
#
99
# For more information, see https://github.com/haskell-CI/haskell-ci
1010
#
11-
# version: 0.15.20230115
11+
# version: 0.16.3
1212
#
13-
# REGENDATA ("0.15.20230115",["github","cabal.project"])
13+
# REGENDATA ("0.16.3",["github","cabal.project"])
1414
#
1515
name: Haskell-CI
1616
on:
@@ -32,14 +32,19 @@ jobs:
3232
strategy:
3333
matrix:
3434
include:
35-
- compiler: ghc-9.4.4
35+
- compiler: ghc-9.6.2
3636
compilerKind: ghc
37-
compilerVersion: 9.4.4
37+
compilerVersion: 9.6.2
3838
setup-method: ghcup
3939
allow-failure: true
40-
- compiler: ghc-9.2.5
40+
- compiler: ghc-9.4.5
4141
compilerKind: ghc
42-
compilerVersion: 9.2.5
42+
compilerVersion: 9.4.5
43+
setup-method: ghcup
44+
allow-failure: true
45+
- compiler: ghc-9.2.7
46+
compilerKind: ghc
47+
compilerVersion: 9.2.7
4348
setup-method: ghcup
4449
allow-failure: true
4550
- compiler: ghc-9.0.2
@@ -59,10 +64,10 @@ jobs:
5964
apt-get update
6065
apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
6166
mkdir -p "$HOME/.ghcup/bin"
62-
curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup"
67+
curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup"
6368
chmod a+x "$HOME/.ghcup/bin/ghcup"
6469
"$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
65-
"$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
70+
"$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
6671
env:
6772
HCKIND: ${{ matrix.compilerKind }}
6873
HCNAME: ${{ matrix.compiler }}
@@ -78,7 +83,7 @@ jobs:
7883
echo "HC=$HC" >> "$GITHUB_ENV"
7984
echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"
8085
echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"
81-
echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
86+
echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
8287
HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
8388
echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
8489
echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
@@ -128,8 +133,8 @@ jobs:
128133
- name: install cabal-plan
129134
run: |
130135
mkdir -p $HOME/.cabal/bin
131-
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
132-
echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c -
136+
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
137+
echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c -
133138
xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan
134139
rm -f cabal-plan.xz
135140
chmod a+x $HOME/.cabal/bin/cabal-plan
@@ -162,6 +167,9 @@ jobs:
162167
echo "package web-template" >> cabal.project
163168
echo " ghc-options: -Werror=missing-methods" >> cabal.project
164169
cat >> cabal.project <<EOF
170+
allow-newer: openid-connect:text
171+
allow-newer: openid-connect:mtl
172+
165173
source-repository-package
166174
type: git
167175
location: https://github.com/biocad/bcd-log
@@ -213,7 +221,7 @@ jobs:
213221
${CABAL} -vnormal check
214222
- name: haddock
215223
run: |
216-
$CABAL v2-haddock --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
224+
$CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
217225
- name: unconstrained build
218226
run: |
219227
rm -f cabal.project.local

‎CHANGELOG.md‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,10 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
66

77
## [Unreleased]
88

9+
## [0.1.3.14] - 2023-06-14
10+
### Added
11+
- Debug log formatter `debugLogHandler`, customizable log middleware `logMiddlewareCustom`.
12+
913
## [0.1.3.13] - 2023-01-23
1014
### Changed
1115
- Add check for aeson 2, for GHC 9.2.5.

‎cabal.project‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -28,3 +28,5 @@ source-repository-package
2828
tag: 79432eaa084705d6ac3f5b877287a74815a8eb71
2929
subdir: generic-override-aeson
3030
--sha256: 1qqb39lw71q7637bh2xpdcxrkyh9r6r55z2xmkgcgbwvx0wi5l9l
31+
32+
allow-newer: openid-connect:text, openid-connect:mtl

‎src/Web/Template/Log.hs‎

Lines changed: 89 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -1,27 +1,39 @@
11
{-# LANGUAGE BangPatterns #-}
22
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE RecordWildCards #-}
34

45
module Web.Template.Log
56
( bcdlog
67
, bcdlog400
8+
, debugLog
9+
, debugLogHandler
10+
11+
, logMiddlewareCustom
12+
, AccessLogRecord(..)
13+
, formatTimeIso
714

815
, userIdVaultKey
916
, tokenVaultKey
1017
, pTokenVaultKey
1118
) where
1219

20+
import Control.Monad (forM_, when)
1321
import Crypto.JWT (ClaimsSet)
1422
import Data.Aeson (fromEncoding, pairs, (.=))
1523
import Data.ByteString.Builder (hPutBuilder, toLazyByteString)
1624
import Data.IORef (IORef, newIORef, readIORef)
1725
import Data.Text as T (Text, pack, unwords)
1826
import Data.Text.Encoding (decodeUtf8)
1927
import qualified Data.Text.Encoding.Error as TE
28+
import qualified Data.Text.IO as TIO
29+
import qualified Data.Text.Lazy as TL
2030
import qualified Data.Text.Lazy.Encoding as TLE (decodeUtf8With)
31+
import qualified Data.Text.Lazy.IO as TLIO
2132
import Data.Time (ZonedTime, defaultTimeLocale, formatTime,
2233
nominalDiffTimeToSeconds, utcToLocalZonedTime)
2334
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)
2435
import Data.Vault.Lazy (Key, insert, newKey)
36+
import GHC.Generics (Generic)
2537
import Network.HTTP.Types.Status (Status (..))
2638
import Network.Wai (Middleware, rawPathInfo, requestMethod, responseStatus,
2739
vault)
@@ -42,14 +54,33 @@ pTokenVaultKey :: Key (IORef (Maybe ClaimsSet))
4254
pTokenVaultKey = unsafePerformIO newKey
4355
{-# NOINLINE pTokenVaultKey #-}
4456

57+
data AccessLogRecord
58+
= AccessLogRecord
59+
{ alStart :: !POSIXTime
60+
, alFinishApp :: !POSIXTime
61+
, alFinishNetwork :: !POSIXTime
62+
, alMsg :: !Text
63+
, alStatus :: !Int
64+
, alURL :: !Text
65+
, alUserId :: !(Maybe Text)
66+
, alResponseBody :: Maybe TL.Text
67+
}
68+
deriving (Show, Generic)
69+
4570
bcdlog :: Middleware
4671
bcdlog = logMiddleware False
4772

4873
bcdlog400 :: Middleware
4974
bcdlog400 = logMiddleware True
5075

76+
debugLog :: Middleware
77+
debugLog = logMiddlewareCustom True $ Just debugLogHandler
78+
5179
logMiddleware :: Bool -> Middleware
52-
logMiddleware log400 app request respond = do
80+
logMiddleware log400 = logMiddlewareCustom log400 Nothing
81+
82+
logMiddlewareCustom :: Bool -> Maybe (AccessLogRecord -> IO ()) -> Middleware
83+
logMiddlewareCustom log400 mLogAction app request respond = do
5384
let
5485
url = decodeUtf8 $ rawPathInfo request
5586
method = decodeUtf8 $ requestMethod request
@@ -85,29 +116,63 @@ logMiddleware log400 app request respond = do
85116
-- but those may be big.
86117
ResponseBuilder _ _ b -> Just b
87118
_ -> Nothing
88-
logLine = pairs
89-
( "datetime" .= toIso startZoned
90-
<> "timestamp" .= floor @_ @Int (toMs start)
91-
<> "duration" .= toMs (finishApp - start)
92-
<> "send_duration" .= toMs (finishNetwork - finishApp)
93-
<> "level" .= INFO
94-
<> "app" .= ("scotty" :: Text)
95-
<> "msg" .= msg'
96-
<> "status" .= statusC
97-
<> "url" .= url
98-
<> maybe mempty ("userId" .=) userId
99-
<> if log400 && statusC >= 400
100-
then maybe mempty (\b -> "response" .= TLE.decodeUtf8With TE.lenientDecode (toLazyByteString b)) responseBody
101-
else mempty
102-
)
103-
104-
hPutBuilder stdout (fromEncoding logLine <> "\n")
105-
hFlush stdout
119+
responseBodyText = TLE.decodeUtf8With TE.lenientDecode . toLazyByteString <$> responseBody
120+
121+
case mLogAction of
122+
Nothing -> do
123+
let
124+
logLine = pairs
125+
( "datetime" .= formatTimeIso startZoned
126+
<> "timestamp" .= floor @_ @Int (toMs start)
127+
<> "duration" .= toMs (finishApp - start)
128+
<> "send_duration" .= toMs (finishNetwork - finishApp)
129+
<> "level" .= INFO
130+
<> "app" .= ("scotty" :: Text)
131+
<> "msg" .= msg'
132+
<> "status" .= statusC
133+
<> "url" .= url
134+
<> maybe mempty ("userId" .=) userId
135+
<> if log400 && statusC >= 400
136+
then maybe mempty ("response" .=) responseBodyText
137+
else mempty
138+
)
139+
140+
hPutBuilder stdout (fromEncoding logLine <> "\n")
141+
hFlush stdout
142+
Just logAction -> do
143+
logAction AccessLogRecord
144+
{ alStart = start
145+
, alFinishApp = finishApp
146+
, alFinishNetwork = finishNetwork
147+
, alMsg = msg'
148+
, alStatus = statusC
149+
, alURL = url
150+
, alUserId = userId
151+
, alResponseBody = responseBodyText
152+
}
106153

107154
return rcv
108-
where
109-
toIso :: ZonedTime -> Text
110-
toIso = pack . formatTime defaultTimeLocale "%FT%T%z"
111155

112-
toMs :: POSIXTime -> Double
113-
toMs = realToFrac . (1000 *) . nominalDiffTimeToSeconds
156+
formatTimeIso :: ZonedTime -> Text
157+
formatTimeIso = pack . formatTime defaultTimeLocale "%FT%T%z"
158+
159+
toMs :: POSIXTime -> Double
160+
toMs = realToFrac . (1000 *) . nominalDiffTimeToSeconds
161+
162+
debugLogHandler :: AccessLogRecord -> IO ()
163+
debugLogHandler AccessLogRecord{..} = do
164+
let
165+
duration = toMs (alFinishApp - alStart)
166+
sendDuration = toMs (alFinishNetwork - alFinishApp)
167+
168+
startZoned <- utcToLocalZonedTime $ posixSecondsToUTCTime alStart
169+
TIO.putStrLn $
170+
formatTimeIso startZoned
171+
<> " INFO "
172+
<> alMsg
173+
<> " " <> pack (show duration)
174+
<> " " <> pack (show sendDuration)
175+
when (alStatus >= 400) $
176+
forM_ alResponseBody TLIO.putStrLn
177+
178+
hFlush stdout

‎src/Web/Template/Server.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,8 @@ module Web.Template.Server
1212
, defaultHandleLog400
1313
, defaultHeaderCORS
1414
, defaultOnException
15+
, debugOnException
16+
, debugLog
1517
, toApplication
1618
) where
1719

‎src/Web/Template/Wai.hs‎

Lines changed: 52 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -1,17 +1,29 @@
11
module Web.Template.Wai
2-
where
2+
( logMiddlewareCustom
3+
, debugLogHandler
4+
, debugLog
5+
, formatTimeIso
6+
7+
, module Web.Template.Wai
8+
) where
39

4-
import Control.Exception (SomeException, fromException)
5-
import Data.Text (Text)
6-
import Network.HTTP.Types (Header)
7-
import Network.Wai (Middleware, Request, mapResponseHeaders, modifyResponse)
8-
import Network.Wai.Handler.Warp (InvalidRequest (..), Port, Settings, defaultSettings,
9-
exceptionResponseForDebug, setOnException, setOnExceptionResponse,
10-
setPort)
10+
import Control.Exception (SomeException, displayException, fromException)
11+
import Data.Aeson (fromEncoding, object, pairs, (.=))
12+
import Data.Text (Text, pack)
13+
import Data.Text.Encoding (decodeUtf8)
14+
import qualified Data.Text.IO as TIO
15+
import Data.Time (defaultTimeLocale, formatTime, utcToLocalZonedTime)
16+
import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime)
17+
import Network.HTTP.Types (Header, status500)
18+
import Network.Wai (Middleware, Request (..), Response, mapResponseHeaders,
19+
modifyResponse, responseBuilder)
20+
import Network.Wai.Handler.Warp (InvalidRequest (..), Port, Settings, defaultSettings,
21+
setOnException, setOnExceptionResponse, setPort)
22+
import System.IO (hFlush, stdout)
1123

1224
import System.BCD.Log (error')
1325

14-
import Web.Template.Log (bcdlog, bcdlog400)
26+
import Web.Template.Log (bcdlog, bcdlog400, debugLog, debugLogHandler, logMiddlewareCustom, formatTimeIso)
1527

1628
defaultHandleLog :: Middleware
1729
defaultHandleLog = bcdlog
@@ -37,10 +49,38 @@ defaultOnException _ e =
3749
Just ConnectionClosedByPeer -> return ()
3850
_ -> error' ("scotty" :: Text) $ show e
3951

52+
debugOnException :: Maybe Request -> SomeException -> IO ()
53+
debugOnException req e =
54+
case fromException e of
55+
Just ConnectionClosedByPeer -> return ()
56+
_ -> do
57+
time <- getPOSIXTime >>= utcToLocalZonedTime . posixSecondsToUTCTime
58+
let
59+
msg = pack (formatTime defaultTimeLocale "%FT%T%z" time) <> " ERROR"
60+
exc = pack $ displayException e
61+
reqMsg =
62+
case req of
63+
Nothing -> ""
64+
Just request -> let
65+
url = decodeUtf8 $ rawPathInfo request
66+
method = decodeUtf8 $ requestMethod request
67+
in " " <> method <> " " <> url
68+
69+
TIO.putStrLn $ msg <> reqMsg <> "\n" <> exc
70+
hFlush stdout
71+
72+
defaultExceptionResponse :: SomeException -> Response
73+
defaultExceptionResponse e = responseBuilder status500 [] $ fromEncoding $ pairs
74+
( "error" .= ("exception" :: Text)
75+
<> ("params" .= object
76+
[ "message" .= displayException e
77+
])
78+
)
79+
4080
warpSettings :: Port -> (Settings -> Settings) -> Settings
4181
warpSettings port userSettings =
42-
setOnException defaultOnException
43-
. setOnExceptionResponse exceptionResponseForDebug
82+
userSettings
83+
. setOnException defaultOnException
84+
. setOnExceptionResponse defaultExceptionResponse
4485
. setPort port
45-
. userSettings
4686
$ defaultSettings

‎web-template.cabal‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
name: web-template
2-
version: 0.1.3.13
2+
version: 0.1.3.14
33
synopsis: Web template
44
description:
55
Web template includes:
@@ -22,8 +22,9 @@ cabal-version: >=1.10
2222
tested-with:
2323
GHC ==8.10.7
2424
|| ==9.0.2
25-
|| ==9.2.5
26-
|| ==9.4.4
25+
|| ==9.2.7
26+
|| ==9.4.5
27+
|| ==9.6.2
2728

2829
library
2930
hs-source-dirs: src

0 commit comments

Comments
 (0)