Skip to content

Commit 510978d

Browse files
maksbotanmaksbotan
authored
version 0.1.3.1: optimize logging middleware (#18)
1 parent 249ff8a commit 510978d

File tree

3 files changed

+61
-56
lines changed

3 files changed

+61
-56
lines changed

‎CHANGELOG.md‎

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

77
## [Unreleased]
88

9+
## [0.1.3.1] - 2020-11-19
10+
### Changed
11+
- Rewrite logging middleware: do not force reading the whole request before passing it to the
12+
application.
13+
914
## [0.1.3.0] - 2020-10-14
1015
### Added
1116
- `servant` support.

‎src/Web/Template/Log.hs‎

Lines changed: 55 additions & 55 deletions
Original file line numberDiff line numberDiff line change
@@ -1,74 +1,74 @@
1+
{-# LANGUAGE BangPatterns #-}
12
{-# LANGUAGE OverloadedStrings #-}
23

34
module Web.Template.Log
45
( bcdlog
56
, bcdlog400
67
) where
78

8-
import Data.Aeson (pairs, (.=))
9-
import Data.Aeson.Encoding (encodingToLazyByteString)
10-
import Data.ByteString.Builder (toLazyByteString)
11-
import Data.Default (Default (..))
12-
import Data.Text as T (Text, pack, unpack, unwords)
13-
import Data.Text.Encoding (decodeUtf8)
14-
import qualified Data.Text.Lazy.Encoding as TLE (decodeUtf8)
15-
import Data.Time (ZonedTime, defaultTimeLocale, formatTime,
16-
nominalDiffTimeToSeconds, parseTimeM,
17-
zonedTimeToUTC)
18-
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
19-
import Network.HTTP.Types.Status (Status (..))
20-
import Network.Wai (Middleware, rawPathInfo, requestMethod)
21-
import Network.Wai.Logger (ZonedDate)
22-
import Network.Wai.Middleware.RequestLogger (OutputFormat (..),
23-
OutputFormatterWithDetails, mkRequestLogger,
24-
outputFormat)
25-
import System.BCD.Log (Level (..))
26-
import System.IO.Unsafe (unsafePerformIO)
27-
import System.Log.FastLogger (toLogStr)
9+
import Data.Aeson (fromEncoding, pairs, (.=))
10+
import Data.ByteString.Builder (hPutBuilder, toLazyByteString)
11+
import Data.Text as T (Text, pack, unwords)
12+
import Data.Text.Encoding (decodeUtf8)
13+
import qualified Data.Text.Encoding.Error as TE
14+
import qualified Data.Text.Lazy.Encoding as TLE (decodeUtf8With)
15+
import Data.Time (ZonedTime, defaultTimeLocale, formatTime,
16+
nominalDiffTimeToSeconds, utcToLocalZonedTime)
17+
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)
18+
import Network.HTTP.Types.Status (Status (..))
19+
import Network.Wai (Middleware, rawPathInfo, requestMethod, responseStatus)
20+
import Network.Wai.Internal (Response (..))
21+
import System.BCD.Log (Level (..))
22+
import System.IO (stdout)
2823

29-
{-# NOINLINE bcdlog #-}
3024
bcdlog :: Middleware
31-
bcdlog = unsafePerformIO $ mkRequestLogger def
32-
{ outputFormat = CustomOutputFormatWithDetails $ formatter False
33-
}
25+
bcdlog = logMiddleware False
3426

35-
{-# NOINLINE bcdlog400 #-}
3627
bcdlog400 :: Middleware
37-
bcdlog400 = unsafePerformIO $ mkRequestLogger def
38-
{ outputFormat = CustomOutputFormatWithDetails $ formatter True
39-
}
28+
bcdlog400 = logMiddleware True
4029

41-
formatter :: Bool -> OutputFormatterWithDetails
42-
formatter log400 zonedDate request status _ _ _ respBody = do
43-
let
44-
zonedTime = parseZonedDate zonedDate
45-
statusC = statusCode status
46-
method = decodeUtf8 $ requestMethod request
47-
url = decodeUtf8 $ rawPathInfo request
48-
msg' = T.unwords [method, url, pack (show statusC)]
30+
logMiddleware :: Bool -> Middleware
31+
logMiddleware log400 app request respond = do
32+
let
33+
url = decodeUtf8 $ rawPathInfo request
34+
method = decodeUtf8 $ requestMethod request
35+
start <- getPOSIXTime
36+
startZoned <- utcToLocalZonedTime $ posixSecondsToUTCTime start
4937

50-
-- Construct extended log record effectively by rendering directly to JSON, without
51-
-- intermediate Value step.
52-
res = pairs
53-
( "datetime" .= toIso zonedTime
54-
<> "timestamp" .= toMs zonedTime
55-
<> "level" .= INFO
56-
<> "app" .= ("scotty" :: Text)
57-
<> "msg" .= msg'
58-
<> "status" .= statusC
59-
<> "url" .= url
38+
app request $ \response -> do
39+
finishApp <- getPOSIXTime
40+
!rcv <- respond response
41+
finishNetwork <- getPOSIXTime
42+
let
43+
statusC = statusCode $ responseStatus response
44+
msg' = T.unwords [method, url, pack (show statusC)]
45+
responseBody =
46+
case response of
47+
-- Logger from wai-extra also reads streaming responses,
48+
-- but those may be big.
49+
ResponseBuilder _ _ b -> Just b
50+
_ -> Nothing
51+
logLine = pairs
52+
( "datetime" .= toIso startZoned
53+
<> "timestamp" .= floor @_ @Int (toMs start)
54+
<> "duration" .= toMs (finishApp - start)
55+
<> "send_duration" .= toMs (finishNetwork - finishApp)
56+
<> "level" .= INFO
57+
<> "app" .= ("scotty" :: Text)
58+
<> "msg" .= msg'
59+
<> "status" .= statusC
60+
<> "url" .= url
6061
<> if log400 && statusC >= 400
61-
then "response" .= (TLE.decodeUtf8 $ toLazyByteString respBody)
62+
then maybe mempty (\b -> "response" .= TLE.decodeUtf8With TE.lenientDecode (toLazyByteString b)) responseBody
6263
else mempty
6364
)
6465

65-
toLogStr (encodingToLazyByteString res) <> "\n"
66-
where
67-
toIso :: Maybe ZonedTime -> Text
68-
toIso = pack . maybe "1970-01-01T00:00:00+0000" (formatTime defaultTimeLocale "%FT%T%z")
66+
hPutBuilder stdout (fromEncoding logLine <> "\n")
6967

70-
toMs :: Maybe ZonedTime -> Int
71-
toMs = maybe 0 (floor . (1000 *) . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds . zonedTimeToUTC)
68+
return rcv
69+
where
70+
toIso :: ZonedTime -> Text
71+
toIso = pack . formatTime defaultTimeLocale "%FT%T%z"
7272

73-
parseZonedDate :: ZonedDate -> Maybe ZonedTime
74-
parseZonedDate = parseTimeM True defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z" . unpack . decodeUtf8
73+
toMs :: POSIXTime -> Double
74+
toMs = realToFrac . (1000 *) . nominalDiffTimeToSeconds

‎web-template.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
name: web-template
2-
version: 0.1.3.0
2+
version: 0.1.3.1
33
synopsis: Web template
44
description:
55
Web template includes:

0 commit comments

Comments
 (0)