version 0.1.3.1: optimize logging middleware (#18)

CHANGELOG.md

@@ -6,6 +6,11 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 
 ## [Unreleased]
 
+## [0.1.3.1] - 2020-11-19
+### Changed
+- Rewrite logging middleware: do not force reading the whole request before passing it to the
+  application.
+
 ## [0.1.3.0] - 2020-10-14
 ### Added
 - `servant` support.

src/Web/Template/Log.hs

@@ -1,74 +1,74 @@
+{-# LANGUAGE BangPatterns      #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Web.Template.Log
   ( bcdlog
   , bcdlog400
   ) where
 
-import           Data.Aeson                           (pairs, (.=))
-import           Data.Aeson.Encoding                  (encodingToLazyByteString)
-import           Data.ByteString.Builder              (toLazyByteString)
-import           Data.Default                         (Default (..))
-import           Data.Text                            as T (Text, pack, unpack, unwords)
-import           Data.Text.Encoding                   (decodeUtf8)
-import qualified Data.Text.Lazy.Encoding              as TLE (decodeUtf8)
-import           Data.Time                            (ZonedTime, defaultTimeLocale, formatTime,
-                                                       nominalDiffTimeToSeconds, parseTimeM,
-                                                       zonedTimeToUTC)
-import           Data.Time.Clock.POSIX                (utcTimeToPOSIXSeconds)
-import           Network.HTTP.Types.Status            (Status (..))
-import           Network.Wai                          (Middleware, rawPathInfo, requestMethod)
-import           Network.Wai.Logger                   (ZonedDate)
-import           Network.Wai.Middleware.RequestLogger (OutputFormat (..),
-                                                       OutputFormatterWithDetails, mkRequestLogger,
-                                                       outputFormat)
-import           System.BCD.Log                       (Level (..))
-import           System.IO.Unsafe                     (unsafePerformIO)
-import           System.Log.FastLogger                (toLogStr)
+import           Data.Aeson                (fromEncoding, pairs, (.=))
+import           Data.ByteString.Builder   (hPutBuilder, toLazyByteString)
+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.Lazy.Encoding   as TLE (decodeUtf8With)
+import           Data.Time                 (ZonedTime, defaultTimeLocale, formatTime,
+                                            nominalDiffTimeToSeconds, utcToLocalZonedTime)
+import           Data.Time.Clock.POSIX     (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)
+import           Network.HTTP.Types.Status (Status (..))
+import           Network.Wai               (Middleware, rawPathInfo, requestMethod, responseStatus)
+import           Network.Wai.Internal      (Response (..))
+import           System.BCD.Log            (Level (..))
+import           System.IO                 (stdout)
 
-{-# NOINLINE bcdlog #-}
 bcdlog :: Middleware
-bcdlog = unsafePerformIO $ mkRequestLogger def
-  { outputFormat = CustomOutputFormatWithDetails $ formatter False
-  }
+bcdlog = logMiddleware False
 
-{-# NOINLINE bcdlog400 #-}
 bcdlog400 :: Middleware
-bcdlog400 = unsafePerformIO $ mkRequestLogger def
-  { outputFormat = CustomOutputFormatWithDetails $ formatter True
-  }
+bcdlog400 = logMiddleware True
 
-formatter :: Bool -> OutputFormatterWithDetails
-formatter log400 zonedDate request status _ _ _ respBody = do
-    let
-      zonedTime = parseZonedDate zonedDate
-      statusC   = statusCode status
-      method    = decodeUtf8 $ requestMethod request
-      url       = decodeUtf8 $ rawPathInfo request
-      msg'      = T.unwords [method, url, pack (show statusC)]
+logMiddleware :: Bool -> Middleware
+logMiddleware log400 app request respond = do
+  let
+    url = decodeUtf8 $ rawPathInfo request
+    method = decodeUtf8 $ requestMethod request
+  start <- getPOSIXTime
+  startZoned <- utcToLocalZonedTime $ posixSecondsToUTCTime start
 
-      -- Construct extended log record effectively by rendering directly to JSON, without
-      -- intermediate Value step.
-      res = pairs
-        (  "datetime"  .= toIso zonedTime
-        <> "timestamp" .= toMs zonedTime
-        <> "level"     .= INFO
-        <> "app"       .= ("scotty" :: Text)
-        <> "msg"       .= msg'
-        <> "status"    .= statusC
-        <> "url"       .= url
+  app request $ \response -> do
+    finishApp <- getPOSIXTime
+    !rcv <- respond response
+    finishNetwork <- getPOSIXTime
+    let
+      statusC = statusCode $ responseStatus response
+      msg'    = T.unwords [method, url, pack (show statusC)]
+      responseBody =
+        case response of
+          -- Logger from wai-extra also reads streaming responses,
+          -- 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
         <> if log400 && statusC >= 400
-              then "response" .= (TLE.decodeUtf8 $ toLazyByteString respBody)
+              then maybe mempty (\b -> "response" .= TLE.decodeUtf8With TE.lenientDecode (toLazyByteString b)) responseBody
               else mempty
         )
 
-    toLogStr (encodingToLazyByteString res) <> "\n"
-  where
-    toIso :: Maybe ZonedTime -> Text
-    toIso = pack . maybe "1970-01-01T00:00:00+0000" (formatTime defaultTimeLocale "%FT%T%z")
+    hPutBuilder stdout (fromEncoding logLine <> "\n")
 
-    toMs :: Maybe ZonedTime -> Int
-    toMs = maybe 0 (floor . (1000 *) . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds . zonedTimeToUTC)
+    return rcv
+  where
+    toIso :: ZonedTime -> Text
+    toIso = pack . formatTime defaultTimeLocale "%FT%T%z"
 
-    parseZonedDate :: ZonedDate -> Maybe ZonedTime
-    parseZonedDate = parseTimeM True defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z" . unpack . decodeUtf8
+    toMs :: POSIXTime -> Double
+    toMs = realToFrac . (1000 *) . nominalDiffTimeToSeconds

web-template.cabal

@@ -1,5 +1,5 @@
 name:                web-template
-version:             0.1.3.0
+version:             0.1.3.1
 synopsis:            Web template
 description:
             Web template includes: