diff --git a/Blammo.cabal b/Blammo.cabal --- a/Blammo.cabal +++ b/Blammo.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: Blammo -version: 1.0.1.1 +version: 1.0.2.1 license: MIT license-file: LICENSE maintainer: Freckle Education @@ -28,6 +28,7 @@ Blammo.Logging.LogSettings.LogLevels Blammo.Logging.Simple Blammo.Logging.Terminal + Blammo.Logging.Test Data.Aeson.Compat Network.Wai.Middleware.Logging @@ -51,14 +52,17 @@ case-insensitive >=1.2.1.0, clock >=0.8, containers >=0.6.2.1, + dlist >=0.8.0.8, envparse >=0.4.1, exceptions >=0.10.4, fast-logger >=3.0.2, http-types >=0.12.3, lens >=4.18.1, monad-logger-aeson >=0.2.0.1, + mtl >=2.2.2, text >=1.2.4.0, time >=1.9.3, + unliftio >=0.2.13.1, unliftio-core >=0.1.2.0, unordered-containers >=0.2.10.0, vector >=0.12.1.2, @@ -105,6 +109,7 @@ main-is: Spec.hs hs-source-dirs: tests other-modules: + Blammo.Logging.LoggerSpec Blammo.Logging.LogSettings.LogLevelsSpec Paths_Blammo @@ -121,8 +126,11 @@ build-depends: Blammo -any, + aeson >=1.5.2.0, base >=4.13.0.0 && <5, - hspec >=2.7.6 + hspec >=2.7.6, + mtl >=2.2.2, + text >=1.2.4.0 if impl(ghc >=9.2) ghc-options: -Wno-missing-kind-signatures diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,8 @@ -## [_Unreleased_](https://github.com/freckle/blammo/compare/v1.0.0.1...main) +## [_Unreleased_](https://github.com/freckle/blammo/compare/v1.0.2.0...main) + +## [v1.0.2.0](https://github.com/freckle/blammo/compare/v1.0.1.0...v1.0.2.0) + +- Add ability to capture and retrieve logged messages, for testing ## [v1.0.1.0](https://github.com/freckle/blammo/compare/v1.0.0.0...v1.0.1.0) diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -218,7 +218,7 @@ loggerIO defaultLoc -- TODO: there may be a way to get a CallStack/Loc "Amazonka" - (\case + (case level of AWS.Info -> LevelInfo AWS.Error -> LevelError AWS.Debug -> LevelDebug @@ -263,8 +263,6 @@ ## Integration with Yesod ```hs -import Blammo.Logging.Logger (getLoggerLoggerSet) - instance HasLogger App where -- ... diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -218,7 +218,7 @@ loggerIO defaultLoc -- TODO: there may be a way to get a CallStack/Loc "Amazonka" - (\case + (case level of AWS.Info -> LevelInfo AWS.Error -> LevelError AWS.Debug -> LevelDebug @@ -263,8 +263,6 @@ ## Integration with Yesod ```hs -import Blammo.Logging.Logger (getLoggerLoggerSet) - instance HasLogger App where -- ... diff --git a/src/Blammo/Logging.hs b/src/Blammo/Logging.hs --- a/src/Blammo/Logging.hs +++ b/src/Blammo/Logging.hs @@ -42,6 +42,7 @@ , logOther -- *** Implicit call stack, with 'LogSource' + , LogSource , logDebugNS , logInfoNS , logWarnNS @@ -60,26 +61,23 @@ import Data.Aeson (Series) import Data.Aeson.Types (Pair) import Data.ByteString (ByteString) -import System.Log.FastLogger (LoggerSet, flushLogStr, pushLogStrLn) runLoggerLoggingT :: (MonadIO m, HasLogger env) => env -> LoggingT m a -> m a runLoggerLoggingT env f = do a <- runLoggingT (filterLogger (getLoggerShouldLog logger) f) - (loggerOutput loggerSet $ getLoggerReformat logger) - a <$ liftIO (flushLogStr loggerSet) - where - logger = env ^. loggerL - loggerSet = getLoggerLoggerSet logger + (loggerOutput logger $ getLoggerReformat logger) + a <$ flushLogStr logger + where logger = env ^. loggerL loggerOutput - :: LoggerSet + :: Logger -> (LogLevel -> ByteString -> ByteString) -> Loc -> LogSource -> LogLevel -> LogStr -> IO () -loggerOutput loggerSet reformat = +loggerOutput logger reformat = defaultOutputWith $ defaultOutputOptions $ \logLevel bytes -> do - pushLogStrLn loggerSet $ toLogStr $ reformat logLevel bytes + pushLogStrLn logger $ toLogStr $ reformat logLevel bytes diff --git a/src/Blammo/Logging/Logger.hs b/src/Blammo/Logging/Logger.hs --- a/src/Blammo/Logging/Logger.hs +++ b/src/Blammo/Logging/Logger.hs @@ -2,19 +2,37 @@ ( Logger , HasLogger(..) , newLogger - , getLoggerLoggerSet , getLoggerReformat , getLoggerShouldLog + , pushLogStrLn + , flushLogStr + + -- * Testing + , newTestLogger + , LoggedMessage(..) + , getLoggedMessages + , getLoggedMessagesLenient + , getLoggedMessagesUnsafe + + -- * Deprecated + , getLoggerLoggerSet ) where import Prelude import Blammo.Logging.LogSettings import Blammo.Logging.Terminal -import Control.Lens (Lens') +import Blammo.Logging.Test hiding (getLoggedMessages) +import qualified Blammo.Logging.Test as LoggedMessages +import Control.Lens (Lens', view) +import Control.Monad (unless) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Logger.Aeson +import Control.Monad.Reader (MonadReader) import Data.ByteString (ByteString) +import Data.Either (partitionEithers, rights) +import Data.List (intercalate) +import GHC.Stack (HasCallStack) import System.IO (stderr, stdout) import System.Log.FastLogger ( LoggerSet @@ -23,15 +41,19 @@ , newStderrLoggerSet , newStdoutLoggerSet ) +import qualified System.Log.FastLogger as FastLogger (flushLogStr, pushLogStrLn) +import UnliftIO.Exception (throwString) data Logger = Logger { lLoggerSet :: LoggerSet , lReformat :: LogLevel -> ByteString -> ByteString , lShouldLog :: LogSource -> LogLevel -> Bool + , lLoggedMessages :: Maybe LoggedMessages } getLoggerLoggerSet :: Logger -> LoggerSet getLoggerLoggerSet = lLoggerSet +{-# DEPRECATED getLoggerLoggerSet "Internal function, will be removed in a future version" #-} getLoggerReformat :: Logger -> LogLevel -> ByteString -> ByteString getLoggerReformat = lReformat @@ -39,6 +61,18 @@ getLoggerShouldLog :: Logger -> LogSource -> LogLevel -> Bool getLoggerShouldLog = lShouldLog +pushLogStrLn :: MonadIO m => Logger -> LogStr -> m () +pushLogStrLn logger str = case lLoggedMessages logger of + Nothing -> liftIO $ FastLogger.pushLogStrLn loggerSet str + Just lm -> appendLogStr lm str + where loggerSet = getLoggerLoggerSet logger + +flushLogStr :: MonadIO m => Logger -> m () +flushLogStr logger = case lLoggedMessages logger of + Nothing -> liftIO $ FastLogger.flushLogStr loggerSet + Just _ -> pure () + where loggerSet = getLoggerLoggerSet logger + class HasLogger env where loggerL :: Lens' env Logger @@ -67,5 +101,47 @@ LogFormatTerminal -> reformatTerminal useColor lShouldLog = shouldLogLevel settings + lLoggedMessages = Nothing pure $ Logger { .. } + +-- | Create a 'Logger' that will capture log messages instead of logging them +-- +-- See "Blammo.Logging.LoggedMessages" for more details. +-- +newTestLogger :: MonadIO m => LogSettings -> m Logger +newTestLogger settings = go <$> newLogger settings <*> newLoggedMessages + where + go logger loggedMessages = + logger { lReformat = const id, lLoggedMessages = Just loggedMessages } + +-- | Return the logged messages if 'newTestLogger' was used +-- +-- If not, the empty list is returned. +-- +getLoggedMessages + :: (MonadIO m, MonadReader env m, HasLogger env) + => m [Either String LoggedMessage] +getLoggedMessages = do + logger <- view loggerL + maybe (pure []) LoggedMessages.getLoggedMessages $ lLoggedMessages logger + +-- | 'getLoggedMessages' but ignore any messages that fail to parse +getLoggedMessagesLenient + :: (MonadIO m, MonadReader env m, HasLogger env) => m [LoggedMessage] +getLoggedMessagesLenient = rights <$> getLoggedMessages + +-- | 'getLoggedMessages' but 'throwString' if any messages failed to parse +getLoggedMessagesUnsafe + :: (HasCallStack, MonadIO m, MonadReader env m, HasLogger env) + => m [LoggedMessage] +getLoggedMessagesUnsafe = do + (failed, succeeded) <- partitionEithers <$> getLoggedMessages + + succeeded <$ unless + (null failed) + (throwString + $ intercalate "\n" + $ "Messages were logged that didn't parse as LoggedMessage:" + : failed + ) diff --git a/src/Blammo/Logging/Test.hs b/src/Blammo/Logging/Test.hs new file mode 100644 --- /dev/null +++ b/src/Blammo/Logging/Test.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} + +module Blammo.Logging.Test + ( LoggedMessages + , LoggedMessage(..) + , newLoggedMessages + , appendLogStr + , getLoggedMessages + ) where + +import Prelude + +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Logger.Aeson (LogStr, LoggedMessage(..), fromLogStr) +import Data.Aeson (eitherDecodeStrict) +import Data.DList (DList) +import qualified Data.DList as DList +import UnliftIO.IORef + +newtype LoggedMessages = LoggedMessages + { _unLoggedMessages :: IORef (DList LogStr) + } + +newLoggedMessages :: MonadIO m => m LoggedMessages +newLoggedMessages = LoggedMessages <$> newIORef DList.empty + +appendLogStr :: MonadIO m => LoggedMessages -> LogStr -> m () +appendLogStr (LoggedMessages ref) str = + atomicModifyIORef' ref $ \x -> (DList.snoc x str, ()) + +getLoggedMessages :: MonadIO m => LoggedMessages -> m [Either String LoggedMessage] +getLoggedMessages (LoggedMessages ref) = + map (eitherDecodeStrict . fromLogStr) . DList.toList <$> readIORef ref diff --git a/src/Network/Wai/Middleware/Logging.hs b/src/Network/Wai/Middleware/Logging.hs --- a/src/Network/Wai/Middleware/Logging.hs +++ b/src/Network/Wai/Middleware/Logging.hs @@ -2,6 +2,13 @@ ( addThreadContext , addThreadContextFromRequest , requestLogger + , requestLoggerWith + + -- * Configuration + , Config + , defaultConfig + , setConfigLogSource + , setConfigGetDestinationIp ) where import Prelude @@ -12,9 +19,11 @@ import Data.Aeson import qualified Data.Aeson.Compat as Key import qualified Data.Aeson.Compat as KeyMap +import Data.ByteString (ByteString) import qualified Data.CaseInsensitive as CI -import Data.Text (pack) -import Data.Text.Encoding (decodeUtf8) +import Data.Text (Text, pack) +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) import Network.HTTP.Types.Header (Header, HeaderName) import Network.HTTP.Types.Status (Status(..)) import Network.Wai @@ -23,6 +32,7 @@ , Response , rawPathInfo , rawQueryString + , remoteHost , requestHeaders , requestMethod , responseHeaders @@ -73,24 +83,55 @@ -- @ -- requestLogger :: HasLogger env => env -> Middleware -requestLogger env app req respond = +requestLogger = requestLoggerWith defaultConfig + +data Config = Config + { cLogSource :: LogSource + , cGetDestinationIp :: Request -> Maybe Text + } + +defaultConfig :: Config +defaultConfig = Config + { cLogSource = "requestLogger" + , cGetDestinationIp = fmap decodeUtf8 . lookupRequestHeader "x-real-ip" + } + +lookupRequestHeader :: HeaderName -> Request -> Maybe ByteString +lookupRequestHeader h = lookup h . requestHeaders + +-- | Change the source used for log messages +-- +-- Default is @requestLogger@. +-- +setConfigLogSource :: LogSource -> Config -> Config +setConfigLogSource x c = c { cLogSource = x } + +-- | Change how the @destinationIp@ field is determined +-- +-- Default is looking up the @x-real-ip@ header. +-- +setConfigGetDestinationIp :: (Request -> Maybe Text) -> Config -> Config +setConfigGetDestinationIp x c = c { cGetDestinationIp = x } + +requestLoggerWith :: HasLogger env => Config -> env -> Middleware +requestLoggerWith config env app req respond = runLoggerLoggingT env $ withRunInIO $ \runInIO -> do begin <- getTime app req $ \resp -> do recvd <- respond resp duration <- toMillis . subtract begin <$> getTime - recvd <$ runInIO (logResponse duration req resp) + recvd <$ runInIO (logResponse config duration req resp) where getTime = Clock.getTime Clock.Monotonic toMillis x = fromIntegral (Clock.toNanoSecs x) / nsPerMs -logResponse :: MonadLogger m => Double -> Request -> Response -> m () -logResponse duration req resp - | statusCode status >= 500 = logError $ message :# details - | statusCode status == 404 = logDebug $ message :# details - | statusCode status >= 400 = logWarn $ message :# details - | otherwise = logDebug $ message :# details +logResponse :: MonadLogger m => Config -> Double -> Request -> Response -> m () +logResponse Config {..} duration req resp + | statusCode status >= 500 = logErrorNS cLogSource $ message :# details + | statusCode status == 404 = logDebugNS cLogSource $ message :# details + | statusCode status >= 400 = logWarnNS cLogSource $ message :# details + | otherwise = logDebugNS cLogSource $ message :# details where message = decodeUtf8 (requestMethod req) @@ -109,6 +150,8 @@ [ "code" .= statusCode status , "message" .= decodeUtf8 (statusMessage status) ] + , "clientIp" .= show (remoteHost req) + , "destinationIp" .= cGetDestinationIp req , "durationMs" .= duration , "requestHeaders" .= headerObject ["authorization", "cookie"] (requestHeaders req) @@ -127,3 +170,6 @@ nsPerMs :: Double nsPerMs = 1000000 + +decodeUtf8 :: ByteString -> Text +decodeUtf8 = decodeUtf8With lenientDecode diff --git a/tests/Blammo/Logging/LoggerSpec.hs b/tests/Blammo/Logging/LoggerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Blammo/Logging/LoggerSpec.hs @@ -0,0 +1,34 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Blammo.Logging.LoggerSpec + ( spec + ) where + +import Prelude + +import Blammo.Logging +import Blammo.Logging.Logger +import Control.Monad.Reader (runReaderT) +import Data.Aeson (Value(..)) +import qualified Data.Aeson.Compat as KeyMap +import Data.Text (Text) +import Test.Hspec + +spec :: Spec +spec = do + describe "newTestLogger" $ do + it "it captures messages to be accessed later" $ do + [Right m1, Right m2] <- do + logger <- newTestLogger defaultLogSettings + runLoggerLoggingT logger $ flip runReaderT logger $ do + logInfo "Hello" + logWarn $ "World" :# ["with" .= ("data" :: Text)] + getLoggedMessages + + loggedMessageLevel m1 `shouldBe` LevelInfo + loggedMessageText m1 `shouldBe` "Hello" + loggedMessageMeta m1 `shouldBe` KeyMap.empty + + loggedMessageLevel m2 `shouldBe` LevelWarn + loggedMessageText m2 `shouldBe` "World" + loggedMessageMeta m2 `shouldBe` KeyMap.fromList [("with", String "data")]