From bb76ec11872462316fa8e8564efafd4e3c225a16 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Sat, 14 Sep 2019 19:00:16 +0300 Subject: [PATCH] version 0.1.1.7: logging --- CHANGELOG.md | 8 ++++ README.md | 6 +++ app/Main.hs | 74 +++++++++++++++++++---------- src/Web/Template.hs | 2 + src/Web/Template/Except.hs | 70 ++++++++++++++++++++++++++-- src/Web/Template/Log.hs | 95 ++++++++++++++++++++++++++++++++------ web-template.cabal | 13 ++++-- 7 files changed, 221 insertions(+), 47 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index dea198a..24f5583 100644 --- a/CHANGELOG.md +++ b/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. diff --git a/README.md b/README.md index 651f385..94c66ea 100644 --- a/README.md +++ b/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"} +``` diff --git a/app/Main.hs b/app/Main.hs index e20e5d7..ffeea78 100644 --- a/app/Main.hs +++ b/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" diff --git a/src/Web/Template.hs b/src/Web/Template.hs index 3f54c37..3d1feed 100644 --- a/src/Web/Template.hs +++ b/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) diff --git a/src/Web/Template/Except.hs b/src/Web/Template/Except.hs index 72668b7..f275b8b 100644 --- a/src/Web/Template/Except.hs +++ b/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 diff --git a/src/Web/Template/Log.hs b/src/Web/Template/Log.hs index cf9481f..df0affc 100644 --- a/src/Web/Template/Log.hs +++ b/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 diff --git a/web-template.cabal b/web-template.cabal index 2fc9e03..92e3674 100644 --- a/web-template.cabal +++ b/web-template.cabal @@ -1,5 +1,5 @@ name: web-template -version: 0.1.1.6 +version: 0.1.1.7 synopsis: Web template description: Web template includes: @@ -27,20 +27,21 @@ library , Web.Template.Log build-depends: base >= 4.7 && < 5 , aeson - , bytestring , bcd-log , cookie , data-default + , data-has + , exceptions , fast-logger , http-types , mtl , scotty , text + , time , wai , wai-extra , wai-logger , warp - , time default-language: Haskell2010 executable web-template @@ -48,10 +49,12 @@ executable web-template main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base - , web-template - , text + , bcd-log + , fast-logger , mtl , scotty + , text + , web-template default-language: Haskell2010 source-repository head