Blammo 1.0.1.1 → 1.0.2.1
raw patch · 9 files changed
+225/−30 lines, 9 filesdep +dlistdep +mtldep +unliftio
Dependencies added: dlist, mtl, unliftio
Files
- Blammo.cabal +10/−2
- CHANGELOG.md +5/−1
- README.lhs +1/−3
- README.md +1/−3
- src/Blammo/Logging.hs +7/−9
- src/Blammo/Logging/Logger.hs +78/−2
- src/Blammo/Logging/Test.hs +33/−0
- src/Network/Wai/Middleware/Logging.hs +56/−10
- tests/Blammo/Logging/LoggerSpec.hs +34/−0
Blammo.cabal view
@@ -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
CHANGELOG.md view
@@ -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)
README.lhs view
@@ -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 -- ...
README.md view
@@ -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 -- ...
src/Blammo/Logging.hs view
@@ -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
src/Blammo/Logging/Logger.hs view
@@ -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+ )
+ src/Blammo/Logging/Test.hs view
@@ -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
src/Network/Wai/Middleware/Logging.hs view
@@ -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
+ tests/Blammo/Logging/LoggerSpec.hs view
@@ -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")]