version 0.1.1.7: logging

CHANGELOG.md

@@ -6,6 +6,14 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 
 ## [Unreleased]
 
+## [0.1.1.7] - 2019-09-14
+### Added
+- `bcdLogFast` middleware for logging with `fast-logger`.
+- Instance `MonadBCDLog WebM`. 
+### Changed
+- Request logger now logs request method, url and result status code as separate fields in JSON.
+- Request logger now logs request duration in milliseconds.
+
 ## [0.1.1.6] - 2019-09-13
 ### Added
 - `MonadWebError` type class with `throwJson` function.

README.md

@@ -48,3 +48,9 @@ Authorised: 0000-0000-0000-000000000000.
 >>> curl localhost:5000/v1/throw
 ["error",42]
 ```
+
+* example of logging all exceptions
+```
+curl http://localhost:5000/v1/exception
+{"error":"error.exception"}
+```

app/Main.hs

@@ -2,49 +2,75 @@
 
 module Main where
 
-import           Control.Monad.RWS (ask, lift, tell)
-import           Data.Text         (Text, pack)
-import           Data.Text.Lazy    (fromStrict)
-import           Text.Printf       (printf)
-import           Web.Scotty.Trans  (get, text)
-import           Web.Template      (CustomWebServer (..), MonadWebError,
-                                    Process (..), ProcessRW, Route (..),
-                                    defaultHandleLog, restartOnError1,
-                                    runWebServer, throwJson500)
+import           Control.Monad.RWS     (asks, lift, tell)
+import           Data.Text             (Text, pack)
+import           Data.Text.Lazy        (fromStrict)
+import           System.BCD.Log        (Level (..), MonadBCDLog (..),
+                                        WithBCDLog)
+import           System.Log.FastLogger (LoggerSet, defaultBufSize,
+                                        newStderrLoggerSet)
+import           Text.Printf           (printf)
+import           Web.Scotty.Trans      (get, text)
+import           Web.Template          (CustomWebServer (..), MonadWebError,
+                                        Process (..), ProcessRW, Route (..),
+                                        bcdLogFast, logException,
+                                        restartOnError1, runWebServer,
+                                        throwJson500)
+
+type REnv = (Int, LoggerSet)
+
+appName :: Text
+appName = "web-template"
 
 main :: IO ()
-main = restartOnError1 $ runWebServer 5000 myWebServer
+main = do
+    ls <- newStderrLoggerSet defaultBufSize
+    logger <- bcdLogFast ls appName
+    let
+      rEnv = (0, ls)
+      myWebServer = CustomWebServer rEnv wEnv () [logger] [ Route get 1 "/ping" pingR
+                                                          , Route get 2 "/ping" pingR2
+                                                          , Route get 1 "/pong" pongR
+                                                          , Route get 1 "/throw" throwR
+                                                          , Route get 1 "/exception" exceptionR
+                                                          ]
+    restartOnError1 $ runWebServer 5000 myWebServer
   where
-    rEnv = 0
     wEnv = ["Start server"]
-    myWebServer = CustomWebServer rEnv wEnv () [defaultHandleLog] [ Route get 1 "/ping" pingR
-                                                                  , Route get 2 "/ping" pingR2
-                                                                  , Route get 1 "/pong" pongR
-                                                                  , Route get 1 "/throw" throwR
-                                                                  ]
 
-pingR :: ProcessRW Int [Text]
+pingR :: ProcessRW REnv [Text]
 pingR = Process $ do
-    env <- lift ask
+    env <- lift $ asks fst
     lift $ tell ["Got /ping request"]
+    -- This call will log "Main.logMsg:45" as location as there is no 'HasCallStack' in scope here.
+    logMsg appName INFO "pingR"
     text . fromStrict . pack $ printf "Pong!\nCurrent environment: %d." env
 
-pingR2 :: ProcessRW Int [Text]
+pingR2 :: ProcessRW REnv [Text]
 pingR2 = Process $ do
-    env <- lift ask
+    env <- lift $ asks fst
     lift $ tell ["Got /ping request (version 2)"]
     text . fromStrict . pack $ printf "Pong of version 2!\nCurrent environment: %d." env
 
-pongR :: ProcessRW Int [Text]
+pongR :: ProcessRW REnv [Text]
 pongR = AuthProcess $ \userId -> do
     lift $ tell ["Got /pong request"]
     text . fromStrict . pack $ printf "Ping!\nAuthorised: %s." userId
 
 -- Demonstration of MTL-style.
 -- Algorithm does not depend on ActionT, but can be called from it.
-algo :: MonadWebError m => m ()
-algo = throwJson500 ("error" :: String, 42 :: Int)
+--
+-- Observe that this computation is pure and therefore can be tested with mock instances.
+algo :: (Monad m, WithBCDLog m, MonadWebError m) => m ()
+algo = do
+    -- This call will log "Main.algo:66" as source location because of 'WithBCDLog' constraint.
+    logDebug appName "here"
+    throwJson500 ("error" :: String, 42 :: Int)
 
-throwR :: ProcessRW Int [Text]
+throwR :: ProcessRW REnv [Text]
 throwR = Process $ do
     algo
+
+exceptionR :: ProcessRW REnv [Text]
+exceptionR = Process $ logException appName $ do
+    error "there is an error"

src/Web/Template.hs

@@ -3,8 +3,10 @@ module Web.Template
     module Web.Template.Except
   , module Web.Template.Server
   , module Web.Template.Types
+  , bcdLogFast
   ) where
 
 import           Web.Template.Except
 import           Web.Template.Server
 import           Web.Template.Types
+import           Web.Template.Log (bcdLogFast)

src/Web/Template/Except.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE DeriveGeneric             #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleInstances         #-}
+{-# LANGUAGE MonoLocalBinds            #-}
+{-# LANGUAGE OverloadedStrings         #-}
 {-# LANGUAGE RecordWildCards           #-}
 {-# LANGUAGE StandaloneDeriving        #-}
 
@@ -11,18 +13,26 @@ module Web.Template.Except
   , ScottyError (..)
   , handleEx
   , MonadWebError(..)
+  , ExceptionFormatter
+  , logExceptionWith
+  , logException
   ) where
 
-import           Data.Aeson                (FromJSON (..), ToJSON (..),
-                                            defaultOptions, genericToEncoding)
+import           Control.Exception         (Exception (..), SomeException)
+import           Control.Monad.Catch       (MonadCatch, catch)
+import           Data.Aeson                (FromJSON (..), Object, ToJSON (..),
+                                            defaultOptions, genericToEncoding,
+                                            (.=))
 import           Data.String               (fromString)
+import           Data.Text                 (Text, pack)
 import           GHC.Generics              (Generic)
+import           GHC.Stack
 import           Network.HTTP.Types.Status (Status, status403, status404,
                                             status500)
+import           System.BCD.Log            (MonadBCDLog (..), WithBCDLog)
 import           Web.Scotty.Trans          (ActionT, ScottyError (..), json,
                                             raise, status)
 
-
 instance ScottyError Except where
     stringError = JsonException
     showError = fromString . show
@@ -66,13 +76,63 @@ class MonadWebError m where
   -- | Throw any 'ToJSON'able value with custom HTTP code. The value will be sent
   -- directly as response without any additional formatting.
   --
-  throwJson :: (Show a, ToJSON a) => Status -> a -> m ()
+  throwJson :: (Show e, ToJSON e) => Status -> e -> m a
 
   -- | Specialized version of 'throwJson' that uses @500 Internal Server Error@ code.
   {-# INLINE throwJson500 #-}
-  throwJson500 :: (Show a, ToJSON a) => a -> m ()
+  throwJson500 :: (Show e, ToJSON e) => e -> m a
   throwJson500 = throwJson status500
 
 instance Monad m => MonadWebError (ActionT Except m) where
   {-# INLINE throwJson #-}
   throwJson s e = raise $ CustomJsonException s e
+
+type ExceptionFormatter e a = e -> a
+
+defaultExceptionFormatter :: ExceptionFormatter SomeException Object
+defaultExceptionFormatter _ = "error" .= ("error.exception" :: Text)
+
+handler500
+  :: (Monad m, WithBCDLog m, MonadWebError m, Exception e, Show r, ToJSON r)
+  => Text
+  -> ExceptionFormatter e r
+  -> e -> m a
+handler500 appName formatter e = withFrozenCallStack $ do
+    logError appName $ pack $ displayException e
+    throwJson500 $ formatter e
+
+-- | Run an action, typically a 'Web.Template.Types.WebM', catching all exceptions it may throw.
+--
+-- Exceptions will be logged fully to the logger and route will return @500 Internal Server Error@
+-- with JSON message generated by the formatter.
+--
+-- Since the formatter is polymorphic in exception type, you can control which exception types
+-- to catch, as with 'Control.Exception.catch' from @Control.Exception@.
+--
+-- It's recommended to avoid sending all exception's detail to users for security reasons.
+--
+{-# INLINE logExceptionWith #-}
+logExceptionWith
+  :: (MonadWebError m, MonadCatch m, WithBCDLog m, Exception e, Show r, ToJSON r)
+  => Text                   -- ^ Application name
+  -> ExceptionFormatter e r -- ^ Formatter for exceptions
+  -> m a                    -- ^ Action to run
+  -> m a
+logExceptionWith appName formatter action =
+  withFrozenCallStack $ catch action $ handler500 appName formatter
+
+-- | Specialized version of 'logExceptionWith'. This wrapper will catch all exceptions
+-- (via 'SomeException') and return this JSON:
+--
+-- @
+-- {"error": "error.exception"}
+-- @
+--
+{-# INLINE logException #-}
+logException
+  :: (MonadWebError m, MonadCatch m, WithBCDLog m)
+  => Text -- ^ Application name
+  -> m a  -- ^ Action to run
+  -> m a
+logException appName =
+  withFrozenCallStack $ logExceptionWith appName defaultExceptionFormatter

src/Web/Template/Log.hs

@@ -1,39 +1,82 @@
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Web.Template.Log
   ( bcdlog
+  , bcdLogFast
   ) where
 
-import qualified Data.ByteString.Char8                as BS8 (pack)
+import           Control.Monad.Trans                  (lift)
+import           Data.Aeson                           (pairs, (.=))
+import           Data.Aeson.Encoding                  (encodingToLazyByteString)
 import           Data.Default                         (Default (..))
-import           Data.Monoid                          ((<>))
+import           Data.Has                             (Has)
 import           Data.Text                            (Text, pack, unpack)
 import           Data.Text.Encoding                   (decodeUtf8)
 import           Data.Time                            (ZonedTime,
                                                        defaultTimeLocale,
                                                        formatTime, parseTimeM)
+import           GHC.Stack                            (withFrozenCallStack)
 import           Network.HTTP.Types.Status            (Status (..))
 import           Network.Wai                          (Middleware, rawPathInfo,
                                                        requestMethod)
 import           Network.Wai.Logger                   (ZonedDate)
-import           Network.Wai.Middleware.RequestLogger (OutputFormat (..),
-                                                       OutputFormatter,
+import           Network.Wai.Middleware.RequestLogger (Destination (..),
+                                                       OutputFormat (..),
+                                                       OutputFormatterWithDetails,
+                                                       destination,
                                                        mkRequestLogger,
                                                        outputFormat)
-import           System.BCD.Log                       (Level (..), Log (..),
-                                                       format)
+import           System.BCD.Log                       (Level (..),
+                                                       MonadBCDLog (..))
 import           System.IO.Unsafe                     (unsafePerformIO)
-import           System.Log.FastLogger                (toLogStr)
+import           System.Log.FastLogger                (LoggerSet, toLogStr)
+import           Web.Scotty.Trans                     (ActionT)
+
+import           Web.Template.Types                   (Env)
 
 {-# NOINLINE bcdlog #-}
 bcdlog :: Middleware
-bcdlog = unsafePerformIO $ mkRequestLogger def {outputFormat = CustomOutputFormat formatter}
+bcdlog = unsafePerformIO $ mkRequestLogger def {outputFormat = CustomOutputFormatWithDetails (formatter "scotty")}
+
+-- | Make @wai@ request logger that formats lines per BCD log format
+-- and sends them to @fast-logger@'s 'LoggerSet'.
+--
+bcdLogFast
+  :: LoggerSet     -- ^ Target logger
+  -> Text          -- ^ Application name
+  -> IO Middleware
+bcdLogFast ls appName = mkRequestLogger
+  def
+    { destination  = Logger ls
+    , outputFormat = CustomOutputFormatWithDetails (formatter appName)
+    }
+
+formatter :: Text -> OutputFormatterWithDetails
+formatter appName zonedDate request status _ duration _ _ = do
+    let statusC = statusCode status
+    let method  = decodeUtf8 $ requestMethod request
+    let url     = decodeUtf8 $ rawPathInfo request
 
-formatter :: OutputFormatter
-formatter zonedDate request status _ = do
-    let msg' = requestMethod request <> " " <> rawPathInfo request <> " " <> (BS8.pack . show . statusCode $ status)
-    let log' = Log (toIso zonedDate) (toMs zonedDate) INFO "scotty" (decodeUtf8 msg')
-    (toLogStr . format $ log') <> "\n"
+    let msg' = method <> " " <> url <> " " <> pack (show statusC)
+
+    -- Construct extended log record effectively by rendering directly to JSON, without
+    -- intermediate Value step.
+    let res = pairs
+          (  "datetime"  .= toIso zonedDate
+          <> "timestamp" .= toMs zonedDate
+          <> "level"     .= INFO
+          <> "app"       .= appName
+          <> "msg"       .= msg'
+          <> "status"    .= statusC
+          <> "url"       .= url
+          -- duration :: NominalDiffTime contains seconds, multiply by 1000 to get milliseconds
+          <> "duration"  .= (realToFrac (duration * 1000) :: Double)
+          )
+
+    toLogStr (encodingToLazyByteString res) <> "\n"
   where
     toIso :: ZonedDate -> Text
     toIso = pack . maybe "1970-01-01T00:00:00+0000" (formatTime defaultTimeLocale "%FT%T%z") . parseZonedDate
@@ -43,3 +86,29 @@ formatter zonedDate request status _ = do
 
     parseZonedDate :: ZonedDate -> Maybe ZonedTime
     parseZonedDate = parseTimeM True defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z" . unpack . decodeUtf8
+
+-- | If your 'Web.Template.Types.WebM's Reader environment has a 'LoggerSet', this instance
+-- will let you use logging in your routes.
+--
+instance {-# OVERLAPPING #-} (Has LoggerSet r, Monoid w) => MonadBCDLog (ActionT e (Env r w s)) where
+  {-# INLINE logMsg #-}
+  logMsg a l m = withFrozenCallStack $ lift $ logMsg a l m
+
+  -- These definitions are duplicated to avoid extra entries in stack.
+  -- Without this logger would report the location of this instance instead of
+  -- the location of concrete usage.
+
+  {-# INLINE logDebug #-}
+  logDebug a = withFrozenCallStack $ logMsg a DEBUG
+
+  {-# INLINE logInfo #-}
+  logInfo a = withFrozenCallStack $ logMsg a INFO
+
+  {-# INLINE logWarning #-}
+  logWarning a = withFrozenCallStack $ logMsg a WARNING
+
+  {-# INLINE logError #-}
+  logError a = withFrozenCallStack $ logMsg a ERROR
+
+  {-# INLINE logCritical #-}
+  logCritical a = withFrozenCallStack $ logMsg a CRITICAL