katip 0.8.5.0 → 0.8.6.0
raw patch · 16 files changed
+1089/−1104 lines, 16 filesdep ~textsetup-changed
Dependency ranges changed: text
Files
- README.md +1/−1
- Setup.hs +1/−0
- bench/Main.hs +44/−44
- changelog.md +5/−1
- examples/example.hs +36/−46
- examples/example_lens.hs +35/−44
- katip.cabal +1/−1
- src/Katip.hs +187/−173
- src/Katip/Core.hs +5/−28
- src/Katip/Format/Time.hs +77/−88
- src/Katip/Monadic.hs +205/−202
- src/Katip/Scribes/Handle.hs +60/−61
- test/Katip/Tests.hs +207/−202
- test/Katip/Tests/Format/Time.hs +45/−48
- test/Katip/Tests/Scribes/Handle.hs +170/−157
- test/Main.hs +10/−8
README.md view
@@ -16,7 +16,7 @@ add context that will be automatically merged in with existing log context. -* *Easy to Integration:* Katip was designed to be easily integrated+* *Easy Integration:* Katip was designed to be easily integrated into existing monads. By using typeclasses for logging facilities, individual subsystems and even libraries can easily add their own namespacing and context without having any knowledge of their
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
bench/Main.hs view
@@ -1,58 +1,61 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module Main- ( main- ) where +module Main+ ( main,+ )+where --------------------------------------------------------------------------------import Control.Concurrent-import Control.DeepSeq-import Control.Exception.Safe-import Control.Monad-import Criterion.Main-import Data.Aeson-import Data.Monoid as M-import System.Directory-import System.FilePath-import System.IO-import System.Posix+import Control.Concurrent+import Control.DeepSeq+import Control.Exception.Safe+import Control.Monad+import Criterion.Main+import Data.Aeson+import Data.Monoid as M --------------------------------------------------------------------------------import Katip.Core-import Katip.Scribes.Handle+import Katip.Core+import Katip.Scribes.Handle+import System.Directory+import System.FilePath+import System.IO+import System.Posix+ ------------------------------------------------------------------------------- main :: IO ()-main = defaultMain [- handleScribeBench- ]-+main =+ defaultMain+ [ handleScribeBench+ ] ------------------------------------------------------------------------------- handleScribeBench :: Benchmark handleScribeBench = bgroup "Katip.Scribes.Handle" $- flip map destinations $ \dest -> bgroup (show dest) [- -- This is variably wildly on disk performance but should be a- -- better test since a push test basically just tests how fast your- -- queue structure is.- bench "full env, flush 1000 writes" $- whnfIO $ do- le <- setupHandleLogEnv dest- runKatipT le $ replicateM_ 1000 $ logItem ExPayload "namespace" Nothing InfoS "example"- closeScribes le- ]+ flip map destinations $ \dest ->+ bgroup+ (show dest)+ [ -- This is variably wildly on disk performance but should be a+ -- better test since a push test basically just tests how fast your+ -- queue structure is.+ bench "full env, flush 1000 writes" $+ whnfIO $ do+ le <- setupHandleLogEnv dest+ runKatipT le $ replicateM_ 1000 $ logItem ExPayload "namespace" Nothing InfoS "example"+ closeScribes le+ ] where destinations = [DevNull, TempFile]- --destinations = [DevNull] +--destinations = [DevNull] ------------------------------------------------------------------------------- data HandleDest = DevNull | TempFile deriving (Show, Eq) - ------------------------------------------------------------------------------- instance NFData LogEnv where rnf (LogEnv !_ !_ !_ !_ !_ !_) = ()@@ -62,7 +65,6 @@ (scr, _) <- setupHandleEnv hd registerScribe "handle" scr defaultScribeSettings =<< initLogEnv "katip-bench" "bench" - ------------------------------------------------------------------------------- setupHandleEnv :: HandleDest -> IO (Scribe, ThreadIdText) setupHandleEnv dest = do@@ -70,7 +72,6 @@ tid <- myThreadId return (scribe, mkThreadIdText tid) - ------------------------------------------------------------------------------- data ExPayload = ExPayload @@ -82,7 +83,6 @@ instance LogItem ExPayload where payloadKeys _ _ = AllKeys - ------------------------------------------------------------------------------- setup :: HandleDest -> IO Scribe setup dest = do@@ -94,14 +94,14 @@ h <- openFile outFile WriteMode s <- mkHandleScribe ColorIfTerminal h (permitItem DebugS) V0 let cleanupHandle = hClose h `finally` (when (dest == TempFile) (removeLink outFile))- return s { scribeFinalizer = scribeFinalizer s `finally` cleanupHandle}-+ return s {scribeFinalizer = scribeFinalizer s `finally` cleanupHandle} ------------------------------------------------------------------------------- deriving instance NFData ThreadIdText instance NFData Scribe where- rnf (Scribe a b p) = (a :: Item ExPayload -> IO ())- `seq` b- `seq` (p :: Item ExPayload -> IO Bool)- `seq` ()+ rnf (Scribe a b p) =+ (a :: Item ExPayload -> IO ())+ `seq` b+ `seq` (p :: Item ExPayload -> IO Bool)+ `seq` ()
changelog.md view
@@ -1,6 +1,10 @@+0.8.6.0+=======+* GHC 8.10 compatibility+ 0.8.5.0 =======-* Add MonadResource instances (#121)[https://github.com/Soostone/katip/pull/121]+* Add MonadResource instances [#121](https://github.com/Soostone/katip/pull/121) 0.8.4.0 =======
examples/example.hs view
@@ -1,29 +1,30 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-module Main- ( main- ) where+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} +module Main+ ( main,+ )+where --------------------------------------------------------------------------------import qualified Control.Applicative as A-import Control.Exception-import Control.Monad.Base-import Control.Monad.Reader-import Control.Monad.Trans.Control-import Data.Aeson-import Data.Monoid as M-import System.IO (stdout)---------------------------------------------------------------------------------import Katip+import qualified Control.Applicative as A+import Control.Exception+import Control.Monad.Base+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Data.Aeson+import Data.Monoid as M -------------------------------------------------------------------------------+import Katip+import System.IO (stdout) +------------------------------------------------------------------------------- -- | An example of advanced katip usage. Be sure to check out -- example_lens.hs for a slightly cleaner and more general pattern.@@ -49,47 +50,41 @@ -- use this to stack up various contextual details throughout your -- code and they will be flattened out and combined in the log -- output.- katipAddNamespace "confrabulation" $ katipAddContext (ConfrabLogCTX 42) $ do- $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"- confrabulateWidgets+ katipAddNamespace "confrabulation" $+ katipAddContext (ConfrabLogCTX 42) $ do+ $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"+ confrabulateWidgets $(logTM) InfoS "Namespace and context are back to normal" katipNoLogging $ $(logTM) DebugS "You'll never see this log message!" - ------------------------------------------------------------------------------- newtype ConfrabLogCTX = ConfrabLogCTX Int - instance ToJSON ConfrabLogCTX where toJSON (ConfrabLogCTX factor) = object ["confrab_factor" .= factor] - instance ToObject ConfrabLogCTX - instance LogItem ConfrabLogCTX where payloadKeys _verb _a = AllKeys - ------------------------------------------------------------------------------- confrabulateWidgets :: (Monad m) => m () confrabulateWidgets = return () - --------------------------------------------------------------------------------data MyState = MyState {- msKNamespace :: Namespace- , msKContext :: LogContexts- , msLogEnv :: LogEnv+data MyState = MyState+ { msKNamespace :: Namespace,+ msKContext :: LogContexts,+ msLogEnv :: LogEnv } - --------------------------------------------------------------------------------newtype MyStack m a = MyStack {- unStack :: ReaderT MyState m a- } deriving (MonadReader MyState, Functor, A.Applicative, Monad, MonadIO, MonadTrans)-+newtype MyStack m a = MyStack+ { unStack :: ReaderT MyState m a+ }+ deriving (MonadReader MyState, Functor, A.Applicative, Monad, MonadIO, MonadTrans) -- MonadBase, MonadTransControl, and MonadBaseControl aren't strictly -- needed for this example, but they are commonly required and@@ -98,30 +93,25 @@ instance MonadBase b m => MonadBase b (MyStack m) where liftBase = liftBaseDefault - instance MonadTransControl MyStack where type StT MyStack a = StT (ReaderT Int) a liftWith = defaultLiftWith MyStack unStack restoreT = defaultRestoreT MyStack - instance MonadBaseControl b m => MonadBaseControl b (MyStack m) where type StM (MyStack m) a = ComposeSt MyStack m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM - instance (MonadIO m) => Katip (MyStack m) where getLogEnv = asks msLogEnv- localLogEnv f (MyStack m) = MyStack (local (\s -> s { msLogEnv = f (msLogEnv s)}) m)-+ localLogEnv f (MyStack m) = MyStack (local (\s -> s {msLogEnv = f (msLogEnv s)}) m) instance (MonadIO m) => KatipContext (MyStack m) where getKatipContext = asks msKContext- localKatipContext f (MyStack m) = MyStack (local (\s -> s { msKContext = f (msKContext s)}) m)+ localKatipContext f (MyStack m) = MyStack (local (\s -> s {msKContext = f (msKContext s)}) m) getKatipNamespace = asks msKNamespace- localKatipNamespace f (MyStack m) = MyStack (local (\s -> s { msKNamespace = f (msKNamespace s)}) m)-+ localKatipNamespace f (MyStack m) = MyStack (local (\s -> s {msKNamespace = f (msKNamespace s)}) m) ------------------------------------------------------------------------------- runStack :: MyState -> MyStack m a -> m a
examples/example_lens.hs view
@@ -1,46 +1,46 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-module Main- ( main- ) where+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} +module Main+ ( main,+ )+where --------------------------------------------------------------------------------import Control.Applicative as A-import Control.Exception-import Control.Lens hiding ((.=))-import Control.Monad.Base-import Control.Monad.Reader-import Control.Monad.Trans.Control-import Data.Aeson-import Data.Monoid as M-import System.IO (stdout)---------------------------------------------------------------------------------import Katip+import Control.Applicative as A+import Control.Exception+import Control.Lens hiding ((.=))+import Control.Monad.Base+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Data.Aeson+import Data.Monoid as M -------------------------------------------------------------------------------+import Katip+import System.IO (stdout) +------------------------------------------------------------------------------- -data MyState = MyState {- _msKNamespace :: Namespace- , _msKContext :: LogContexts- , _msLogEnv :: LogEnv+data MyState = MyState+ { _msKNamespace :: Namespace,+ _msKContext :: LogContexts,+ _msLogEnv :: LogEnv } - -- This gives us HasMyState, which is helpful for complex stacks where -- MyState may be nested somewhere deeper inside a larger data -- structure. You can keep functions that operate on MyState as -- general as possible. makeClassy ''MyState - -------------------------------------------------------------------------------+ -- | An example of advanced katip usage with Lens. main :: IO () main = do@@ -64,39 +64,34 @@ -- use this to stack up various contextual details throughout your -- code and they will be flattened out and combined in the log -- output.- katipAddNamespace "confrabulation" $ katipAddContext (ConfrabLogCTX 42) $ do- $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"- confrabulateWidgets+ katipAddNamespace "confrabulation" $+ katipAddContext (ConfrabLogCTX 42) $ do+ $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"+ confrabulateWidgets $(logTM) InfoS "Namespace and context are back to normal" katipNoLogging $ $(logTM) DebugS "You'll never see this log message!" - ------------------------------------------------------------------------------- newtype ConfrabLogCTX = ConfrabLogCTX Int - instance ToJSON ConfrabLogCTX where toJSON (ConfrabLogCTX factor) = object ["confrab_factor" .= factor] - instance ToObject ConfrabLogCTX - instance LogItem ConfrabLogCTX where payloadKeys _verb _a = AllKeys - ------------------------------------------------------------------------------- confrabulateWidgets :: (Monad m) => m () confrabulateWidgets = return () - --------------------------------------------------------------------------------newtype MyStack m a = MyStack {- unStack :: ReaderT MyState m a- } deriving (MonadReader MyState, Functor, A.Applicative, Monad, MonadIO, MonadTrans)-+newtype MyStack m a = MyStack+ { unStack :: ReaderT MyState m a+ }+ deriving (MonadReader MyState, Functor, A.Applicative, Monad, MonadIO, MonadTrans) -- MonadBase, MonadTransControl, and MonadBaseControl aren't strictly -- needed for this example, but they are commonly required and@@ -105,13 +100,11 @@ instance MonadBase b m => MonadBase b (MyStack m) where liftBase = liftBaseDefault - instance MonadTransControl MyStack where type StT MyStack a = StT (ReaderT Int) a liftWith = defaultLiftWith MyStack unStack restoreT = defaultRestoreT MyStack - instance MonadBaseControl b m => MonadBaseControl b (MyStack m) where type StM (MyStack m) a = ComposeSt MyStack m a liftBaseWith = defaultLiftBaseWith@@ -121,13 +114,11 @@ getLogEnv = view msLogEnv localLogEnv f (MyStack m) = MyStack (local (over msLogEnv f) m) - instance (MonadIO m) => KatipContext (MyStack m) where getKatipContext = view msKContext localKatipContext f (MyStack m) = MyStack (local (over msKContext f) m) getKatipNamespace = view msKNamespace localKatipNamespace f (MyStack m) = MyStack (local (over msKNamespace f) m)- ------------------------------------------------------------------------------- runStack :: MyState -> MyStack m a -> m a
katip.cabal view
@@ -1,5 +1,5 @@ name: katip-version: 0.8.5.0+version: 0.8.6.0 synopsis: A structured logging framework. description: Katip is a structured logging framework. See README.md for more details.
src/Katip.hs view
@@ -6,6 +6,8 @@ -- -- @ --+-- {-# LANGUAGE OverloadedStrings #-}+-- {-# LANGUAGE TemplateHaskell #-} -- import Control.Exception -- import Katip --@@ -14,7 +16,7 @@ -- handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem InfoS) V2 -- let makeLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv \"MyApp\" \"production\" -- -- closeScribes will stop accepting new logs, flush existing ones and clean up resources--- bracket makeLogEnv closeScribes $ \le -> do+-- bracket makeLogEnv closeScribes $ \\le -> do -- let initialContext = () -- this context will be attached to every log in your app and merged w/ subsequent contexts -- let initialNamespace = "main" -- runKatipContextT le initialContext initialNamespace $ do@@ -27,6 +29,14 @@ -- -- @ --+-- And here is the output:+--+-- @+-- [2021-06-14 20:24:24][MyApp.main][Info][yourhostname][PID 14420][ThreadId 27][main:Main app/Main.hs:26:9] Hello Katip+-- [2021-06-14 20:24:24][MyApp.main.additional_namespace][Warning][yourhostname][PID 14420][ThreadId 27][some_context:True][main:Main app/Main.hs:29:11] Now we're getting fancy+--+-- @+-- -- Another common case that you have some sort of App monad that's -- based on ReaderT with some Config state. This is a perfect place to -- insert read-only katip state:@@ -94,202 +104,206 @@ -- unsupported format or service. If you think it would be useful to -- others, consider releasing your own package. module Katip- (-- -- * Framework Types- Namespace (..)- , Environment (..)- , Severity (..)- , renderSeverity- , textToSeverity- , Verbosity (..)- , ToObject (..)- , LogItem (..)- , Item(..)- , ThreadIdText(..)- , PayloadSelection (..)- , Scribe (..)- , LogEnv (..)- , SimpleLogPayload, sl- , defaultScribeSettings- , ScribeSettings- , scribeBufferSize- , _scribeBufferSize+ ( -- * Framework Types+ Namespace (..),+ Environment (..),+ Severity (..),+ renderSeverity,+ textToSeverity,+ Verbosity (..),+ ToObject (..),+ LogItem (..),+ Item (..),+ ThreadIdText (..),+ PayloadSelection (..),+ Scribe (..),+ LogEnv (..),+ SimpleLogPayload,+ sl,+ defaultScribeSettings,+ ScribeSettings,+ scribeBufferSize,+ _scribeBufferSize, -- ** @lens@-compatible Lenses- , itemApp- , itemEnv- , itemSeverity- , itemThread- , itemHost- , itemProcess- , itemPayload- , itemMessage- , itemTime- , itemNamespace- , itemLoc- , logEnvHost- , logEnvPid- , logEnvApp- , logEnvEnv- , logEnvTimer- , logEnvScribes+ itemApp,+ itemEnv,+ itemSeverity,+ itemThread,+ itemHost,+ itemProcess,+ itemPayload,+ itemMessage,+ itemTime,+ itemNamespace,+ itemLoc,+ logEnvHost,+ logEnvPid,+ logEnvApp,+ logEnvEnv,+ logEnvTimer,+ logEnvScribes, -- * A Built-in Monad For Simple Logging- , KatipT (..)- , runKatipT+ KatipT (..),+ runKatipT, -- * Initializing Loggers- , initLogEnv- , registerScribe+ initLogEnv,+ registerScribe,+ -- * Dropping scribes temporarily- , unregisterScribe- , clearScribes+ unregisterScribe,+ clearScribes,+ -- * Finalizing scribes at shutdown- , closeScribes- , closeScribe+ closeScribes,+ closeScribe, -- * Logging Functions- , LogStr (..)- , logStr, ls, showLS+ LogStr (..),+ logStr,+ ls,+ showLS, -- ** 'Katip' Logging Functions -- $katiplogging- , Katip (..)- , logF- , logMsg- , logT- , logLoc- , logItem- , logKatipItem- , logException+ Katip (..),+ logF,+ logMsg,+ logT,+ logLoc,+ logItem,+ logKatipItem,+ logException,+ -- ** 'KatipContext': Logging With Context -- $katipcontextlogging- , KatipContext (..)- , logFM- , logTM- , logLocM- , logItemM- , logExceptionM- , AnyLogContext- , LogContexts, liftPayload+ KatipContext (..),+ logFM,+ logTM,+ logLocM,+ logItemM,+ logExceptionM,+ AnyLogContext,+ LogContexts,+ liftPayload,+ -- *** Temporarily Changing Logging Behavior- , katipAddNamespace- , katipAddContext- , katipNoLogging+ katipAddNamespace,+ katipAddContext,+ katipNoLogging, -- * Included Scribes- , mkHandleScribe- , mkHandleScribeWithFormatter- , mkFileScribe- , ColorStrategy (..)- , ItemFormatter- , bracketFormat- , jsonFormat+ mkHandleScribe,+ mkHandleScribeWithFormatter,+ mkFileScribe,+ ColorStrategy (..),+ ItemFormatter,+ bracketFormat,+ jsonFormat, -- * Tools for implementing Scribes- , PermitFunc- , permitAND- , permitOR- , permitItem- , payloadObject- , itemJson+ PermitFunc,+ permitAND,+ permitOR,+ permitItem,+ payloadObject,+ itemJson, -- * KatipContextT - Utility transformer that provides Katip and KatipContext instances- , KatipContextT- , runKatipContextT- ) where+ KatipContextT,+ runKatipContextT,+ )+where --------------------------------------------------------------------------------import Katip.Core-import Katip.Monadic-import Katip.Scribes.Handle-----------------------------------------------------------------------------------{- $katiplogging-- These logging functions use the basic 'Katip' constraint and thus-will require varying degrees of explicit detail such as 'Namespace'-and individual log items to be passed in. These can be described as-the primitives of Katip logging. If you find yourself making multiple-log statements within a logical logging context for your app, you may-want to look into the 'KatipContext' family of logging functions like-'logFM' and 'logTM'. 'KatipContext' in most applications should be-considered the default. Here's an example of the pain point:--@-doDatabaseThings = do- connId <- getConnectionId- logF (ConnectionIDContext connId) "database" InfoS "Doing database stuff"- \-\- ...- logF (ConnectionIDContext connId) "database" InfoS "Wow, passing in the same context is getting tedious"-@--Another pain point to look out for is nesting actions that log in-each other. Let's say you were writing a web app. You want to capture-some detail such as the user's ID in the logs, but you also want that-info to show up in doDatabaseThings' logs so you can associate those-two pieces of information:---@-webRequestHandler = do- uid <- getUserId- logF (UserIDContext uid) "web" InfoS "Starting web request"- doDatabaseThings-@--In the above example, doDatabaseThings would overwrite that-UserIDContext with its own context and namespace. Sometimes this is-what you want and that's why 'logF' and other functions which only-require 'Katip' exist. If you are interested in combining log-contexts and namespaces, see 'KatipContext'.--}---{- $katipcontextlogging-- These logging functions use the 'KatipContext' constraint which is a-superclass of 'Katip' that also has a mechanism for keeping track of-the current context and namespace. This means a few things:--1. Functions that use 'KatipContext' like 'logFM' and 'logTM' do not-require you to pass in 'LogItem's or 'Namespaces', they pull them from-the monadic environment.--2. It becomes easy to add functions which add namespaces and/or-contexts to the current stack of them. You can (and should) make that-action scoped to a monadic action so that when it finishes, the-previous context and namespace will be automatically restored.---'KatipContextT' provides a simple, 'ReaderT'-based implementation of-the 'KatipContext' typeclass, and provides 'katipAddContext' and-'katipAddNamespace' functions to append to the context for the-duration of a block:---@-main = do- le <- initLogEnv "MyApp" "production"- \-\- set up scribes here- runKatipContext le () "main" $ do- katipAddNamespace "nextlevel" $ do- $(logTM) InfoS "Logs here will have namespace MyApp.main.nextlevel"-- katipAddContext TrivialContext $ do- $(logTM) InfoS "Logs here will have context from TrivialContext"+import Katip.Core+import Katip.Monadic+import Katip.Scribes.Handle - katipAddContext AnotherContext $ do- $(logTM) InfoS "Logs here will have context from TrivialContext *merged with* context from AnotherContext!"+------------------------------------------------------------------------------- - $(logTM) InfoS "Log context restored to () and namespace to MyApp.main"-@+-- $katiplogging+--+-- These logging functions use the basic 'Katip' constraint and thus+-- will require varying degrees of explicit detail such as 'Namespace'+-- and individual log items to be passed in. These can be described as+-- the primitives of Katip logging. If you find yourself making multiple+-- log statements within a logical logging context for your app, you may+-- want to look into the 'KatipContext' family of logging functions like+-- 'logFM' and 'logTM'. 'KatipContext' in most applications should be+-- considered the default. Here's an example of the pain point:+--+-- @+-- doDatabaseThings = do+-- connId <- getConnectionId+-- logF (ConnectionIDContext connId) "database" InfoS "Doing database stuff"+-- \-\- ...+-- logF (ConnectionIDContext connId) "database" InfoS "Wow, passing in the same context is getting tedious"+-- @+--+-- Another pain point to look out for is nesting actions that log in+-- each other. Let's say you were writing a web app. You want to capture+-- some detail such as the user's ID in the logs, but you also want that+-- info to show up in doDatabaseThings' logs so you can associate those+-- two pieces of information:+--+--+-- @+-- webRequestHandler = do+-- uid <- getUserId+-- logF (UserIDContext uid) "web" InfoS "Starting web request"+-- doDatabaseThings+-- @+--+-- In the above example, doDatabaseThings would overwrite that+-- UserIDContext with its own context and namespace. Sometimes this is+-- what you want and that's why 'logF' and other functions which only+-- require 'Katip' exist. If you are interested in combining log+-- contexts and namespaces, see 'KatipContext'. -'katipAddNamespace' and 'katipAddContext' are one-liners, implemented-in terms of 'local' from 'MonadReader'. If you have a custom monad-transformer stack and want to add your own version of these, check out-<https://github.com/Soostone/katip/tree/master/katip/examples these-examples>.--}+-- $katipcontextlogging+--+-- These logging functions use the 'KatipContext' constraint which is a+-- superclass of 'Katip' that also has a mechanism for keeping track of+-- the current context and namespace. This means a few things:+--+-- 1. Functions that use 'KatipContext' like 'logFM' and 'logTM' do not+-- require you to pass in 'LogItem's or 'Namespaces', they pull them from+-- the monadic environment.+--+-- 2. It becomes easy to add functions which add namespaces and/or+-- contexts to the current stack of them. You can (and should) make that+-- action scoped to a monadic action so that when it finishes, the+-- previous context and namespace will be automatically restored.+--+--+-- 'KatipContextT' provides a simple, 'ReaderT'-based implementation of+-- the 'KatipContext' typeclass, and provides 'katipAddContext' and+-- 'katipAddNamespace' functions to append to the context for the+-- duration of a block:+--+--+-- @+-- main = do+-- le <- initLogEnv "MyApp" "production"+-- \-\- set up scribes here+-- runKatipContext le () "main" $ do+-- katipAddNamespace "nextlevel" $ do+-- $(logTM) InfoS "Logs here will have namespace MyApp.main.nextlevel"+--+-- katipAddContext TrivialContext $ do+-- $(logTM) InfoS "Logs here will have context from TrivialContext"+--+-- katipAddContext AnotherContext $ do+-- $(logTM) InfoS "Logs here will have context from TrivialContext *merged with* context from AnotherContext!"+--+-- $(logTM) InfoS "Log context restored to () and namespace to MyApp.main"+-- @+--+-- 'katipAddNamespace' and 'katipAddContext' are one-liners, implemented+-- in terms of 'local' from 'MonadReader'. If you have a custom monad+-- transformer stack and want to add your own version of these, check out+-- <https://github.com/Soostone/katip/tree/master/katip/examples these+-- examples>.
src/Katip/Core.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveLift #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveFunctor #-}@@ -103,7 +104,7 @@ -- IsString/OverloadedStrings, so "foo" will result in Namespace -- ["foo"]. newtype Namespace = Namespace { unNamespace :: [Text] }- deriving (Eq,Show,Read,Ord,Generic,ToJSON,FromJSON,SG.Semigroup,Monoid)+ deriving (Eq,Show,Read,Ord,Generic,ToJSON,FromJSON,SG.Semigroup,Monoid,TH.Lift) instance IsString Namespace where fromString s = Namespace [fromString s]@@ -131,7 +132,7 @@ | CriticalS -- ^ Severe situations | AlertS -- ^ Take immediate action | EmergencyS -- ^ System is unusable- deriving (Eq, Ord, Show, Read, Generic, Enum, Bounded)+ deriving (Eq, Ord, Show, Read, Generic, Enum, Bounded, TH.Lift) -------------------------------------------------------------------------------@@ -143,7 +144,7 @@ -- - 'V3' implies the maximum amount of payload information. -- - Anything in between is left to the discretion of the developer. data Verbosity = V0 | V1 | V2 | V3- deriving (Eq, Ord, Show, Read, Generic, Enum, Bounded)+ deriving (Eq, Ord, Show, Read, Generic, Enum, Bounded, TH.Lift) -------------------------------------------------------------------------------@@ -665,7 +666,7 @@ ---------------------------------------------------------------------------------- | Create a reasonable default InitLogEnv. Uses an 'AutoUdate' which+-- | Create a reasonable default InitLogEnv. Uses an 'AutoUpdate' which -- updates the timer every 1ms. If you need even more timestamp -- precision at the cost of performance, consider setting -- '_logEnvTimer' with 'getCurrentTime'.@@ -1031,30 +1032,6 @@ -> LogStr -> m () logMsg ns sev msg = logF () ns sev msg---instance TH.Lift Namespace where- lift (Namespace xs) =- let xs' = map T.unpack xs- in [| Namespace (map T.pack xs') |]---instance TH.Lift Verbosity where- lift V0 = [| V0 |]- lift V1 = [| V1 |]- lift V2 = [| V2 |]- lift V3 = [| V3 |]---instance TH.Lift Severity where- lift DebugS = [| DebugS |]- lift InfoS = [| InfoS |]- lift NoticeS = [| NoticeS |]- lift WarningS = [| WarningS |]- lift ErrorS = [| ErrorS |]- lift CriticalS = [| CriticalS |]- lift AlertS = [| AlertS |]- lift EmergencyS = [| EmergencyS |] -- | Lift a location into an Exp.
src/Katip/Format/Time.hs view
@@ -1,19 +1,18 @@ -- | Time and memory efficient time encoding helper functions.--- module Katip.Format.Time- ( formatAsLogTime- , formatAsIso8601- ) where--import Control.Monad.ST (ST)+ ( formatAsLogTime,+ formatAsIso8601,+ )+where -import Data.Int (Int64)-import qualified Data.Text.Array as TA-import Data.Text (Text)-import Data.Text.Internal (Text(..))-import Data.Time (UTCTime(..), toGregorian, Day, DiffTime)-import Data.Word (Word16)-import Unsafe.Coerce (unsafeCoerce)+import Control.Monad.ST (ST)+import Data.Int (Int64)+import Data.Text (Text)+import qualified Data.Text.Array as TA+import Data.Text.Internal (Text (..))+import Data.Time (Day, DiffTime, UTCTime (..), toGregorian)+import Data.Word (Word16)+import Unsafe.Coerce (unsafeCoerce) -- Note: All functions here are optimized to never allocate anything -- on heap. At least on ghc 8.0.1 no extra strictness annotations are@@ -21,22 +20,20 @@ -- -- Exported functions are INLINEABLE - -- | Format 'UTCTime' into a short human readable format. -- -- >>> formatAsLogTime $ UTCTime (fromGregorian 2016 1 23) 5025.123456789012 -- "2016-01-23 01:23:45"--- formatAsLogTime :: UTCTime -> Text-formatAsLogTime (UTCTime day time) = toText $ TA.run2 $ do- buf <- TA.new 19 -- length "2016-10-20 12:34:56"- _ <- writeDay buf 0 day- TA.unsafeWrite buf 10 0x20 -- space- _ <- writeTimeOfDay False buf 11 (diffTimeOfDay64 time)- return (buf, 19)+formatAsLogTime (UTCTime day time) = toText $+ TA.run2 $ do+ buf <- TA.new 19 -- length "2016-10-20 12:34:56"+ _ <- writeDay buf 0 day+ TA.unsafeWrite buf 10 0x20 -- space+ _ <- writeTimeOfDay False buf 11 (diffTimeOfDay64 time)+ return (buf, 19) where- toText (arr, len) = Text arr 0 len-+ toText (arr, len) = Text arr 0 len {-# INLINEABLE formatAsLogTime #-} -- | Format 'UTCTime' into a Iso8601 format.@@ -54,16 +51,16 @@ -- formatAsIso8601 :: UTCTime -> Text-formatAsIso8601 (UTCTime day time) = toText $ TA.run2 $ do- buf <- TA.new 33 -- length "2016-10-20 12:34:56.123456789012Z"- _ <- writeDay buf 0 day- TA.unsafeWrite buf 10 0x54 -- T- next <- writeTimeOfDay True buf 11 (diffTimeOfDay64 time)- TA.unsafeWrite buf next 0x5A -- Z- return (buf, next+1)+formatAsIso8601 (UTCTime day time) = toText $+ TA.run2 $ do+ buf <- TA.new 33 -- length "2016-10-20 12:34:56.123456789012Z"+ _ <- writeDay buf 0 day+ TA.unsafeWrite buf 10 0x54 -- T+ next <- writeTimeOfDay True buf 11 (diffTimeOfDay64 time)+ TA.unsafeWrite buf next 0x5A -- Z+ return (buf, next + 1) where- toText (arr, len) = Text arr 0 len-+ toText (arr, len) = Text arr 0 len {-# INLINEABLE formatAsIso8601 #-} -- | Writes the @YYYY-MM-DD@ part of timestamp@@ -82,20 +79,19 @@ TA.unsafeWrite buf (off + 9) d2 return (off + 10) where- (yr,m,d) = toGregorian day+ (yr, m, d) = toGregorian day (y1, ya) = fromIntegral (abs yr) `quotRem` 1000 (y2, yb) = ya `quotRem` 100 (y3, y4) = yb `quotRem` 10- T m1 m2 = twoDigits m- T d1 d2 = twoDigits d+ T m1 m2 = twoDigits m+ T d1 d2 = twoDigits d {-# INLINE writeDay #-} -- | Write time of day, optionally with sub seconds writeTimeOfDay :: Bool -> TA.MArray s -> Int -> TimeOfDay64 -> ST s Int writeTimeOfDay doSubSeconds buf off (TOD hh mm ss) = do-- TA.unsafeWrite buf off h1+ TA.unsafeWrite buf off h1 TA.unsafeWrite buf (off + 1) h2 TA.unsafeWrite buf (off + 2) 0x3A -- colon TA.unsafeWrite buf (off + 3) m1@@ -104,52 +100,47 @@ TA.unsafeWrite buf (off + 6) s1 TA.unsafeWrite buf (off + 7) s2 if doSubSeconds && frac /= 0- then writeFracSeconds buf (off + 8) frac- else return (off + 8)+ then writeFracSeconds buf (off + 8) frac+ else return (off + 8) where- T h1 h2 = twoDigits hh- T m1 m2 = twoDigits mm- T s1 s2 = twoDigits (fromIntegral real)- (real,frac) = ss `quotRem` pico- pico = 1000000000000 -- number of picoseconds in 1 second-+ T h1 h2 = twoDigits hh+ T m1 m2 = twoDigits mm+ T s1 s2 = twoDigits (fromIntegral real)+ (real, frac) = ss `quotRem` pico+ pico = 1000000000000 -- number of picoseconds in 1 second writeFracSeconds :: TA.MArray s -> Int -> Int64 -> ST s Int writeFracSeconds buf off frac = do TA.unsafeWrite buf off 0x2e -- period if mills == 0- then do- writeTrunc6 buf (off + 1) (fromIntegral mics)- else do- writeDigit6 buf (off + 1) (fromIntegral mics)- writeTrunc6 buf (off + 7) (fromIntegral mills)-+ then do+ writeTrunc6 buf (off + 1) (fromIntegral mics)+ else do+ writeDigit6 buf (off + 1) (fromIntegral mics)+ writeTrunc6 buf (off + 7) (fromIntegral mills) where- (mics, mills) = frac `quotRem` micro- micro = 1000000 -- number of microseconds in 1 second-+ (mics, mills) = frac `quotRem` micro+ micro = 1000000 -- number of microseconds in 1 second writeDigit6 :: TA.MArray s -> Int -> Int -> ST s () writeDigit6 buf off i = do writeDigit3 buf off f1- writeDigit3 buf (off+3) f2+ writeDigit3 buf (off + 3) f2 where- (f1, f2) = i `quotRem` 1000-+ (f1, f2) = i `quotRem` 1000 {-# INLINE writeDigit6 #-} writeDigit3 :: TA.MArray s -> Int -> Int -> ST s () writeDigit3 buf off i = do TA.unsafeWrite buf off (digit d1)- TA.unsafeWrite buf (off+1) (digit d2)- TA.unsafeWrite buf (off+2) (digit d3)+ TA.unsafeWrite buf (off + 1) (digit d2)+ TA.unsafeWrite buf (off + 2) (digit d3) where (d1, d) = i `quotRem` 100 (d2, d3) = d `quotRem` 10- {-# INLINE writeDigit3 #-} writeTrunc6 :: TA.MArray s -> Int -> Int -> ST s Int@@ -158,35 +149,30 @@ then writeTrunc3 buf off f1 else do writeDigit3 buf off f1- writeTrunc3 buf (off+3) f2+ writeTrunc3 buf (off + 3) f2 where- (f1, f2) = i `quotRem` 1000-+ (f1, f2) = i `quotRem` 1000 {-# INLINE writeTrunc6 #-} - writeTrunc3 :: TA.MArray s -> Int -> Int -> ST s Int writeTrunc3 buf off i- | d == 0 = do- TA.unsafeWrite buf off (digit d1)- return (off+1)- | d3 == 0 = do- TA.unsafeWrite buf off (digit d1)- TA.unsafeWrite buf (off+1) (digit d2)- return (off+2)-- | otherwise = do- TA.unsafeWrite buf off (digit d1)- TA.unsafeWrite buf (off+1) (digit d2)- TA.unsafeWrite buf (off+2) (digit d3)- return (off+3)+ | d == 0 = do+ TA.unsafeWrite buf off (digit d1)+ return (off + 1)+ | d3 == 0 = do+ TA.unsafeWrite buf off (digit d1)+ TA.unsafeWrite buf (off + 1) (digit d2)+ return (off + 2)+ | otherwise = do+ TA.unsafeWrite buf off (digit d1)+ TA.unsafeWrite buf (off + 1) (digit d2)+ TA.unsafeWrite buf (off + 2) (digit d3)+ return (off + 3) where (d1, d) = i `quotRem` 100 (d2, d3) = d `quotRem` 10- {-# INLINE writeTrunc3 #-} - -- Following code was adapted from aeson package. -- -- Copyright: (c) 2015-2016 Bryan O'Sullivan@@ -195,19 +181,22 @@ data T = T {-# UNPACK #-} !Word16 {-# UNPACK #-} !Word16 twoDigits :: Int -> T-twoDigits a = T (digit hi) (digit lo)- where (hi,lo) = a `quotRem` 10+twoDigits a = T (digit hi) (digit lo)+ where+ (hi, lo) = a `quotRem` 10 digit :: Int -> Word16 digit x = fromIntegral (x + 48) --data TimeOfDay64 = TOD {-# UNPACK #-} !Int- {-# UNPACK #-} !Int- {-# UNPACK #-} !Int64+data TimeOfDay64+ = TOD+ {-# UNPACK #-} !Int+ {-# UNPACK #-} !Int+ {-# UNPACK #-} !Int64 diffTimeOfDay64 :: DiffTime -> TimeOfDay64 diffTimeOfDay64 t = TOD (fromIntegral h) (fromIntegral m) s- where (h,mp) = fromIntegral pico `quotRem` 3600000000000000- (m,s) = mp `quotRem` 60000000000000- pico = unsafeCoerce t :: Integer+ where+ (h, mp) = fromIntegral pico `quotRem` 3600000000000000+ (m, s) = mp `quotRem` 60000000000000+ pico = unsafeCoerce t :: Integer
src/Katip/Monadic.hs view
@@ -1,95 +1,103 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+ #if MIN_VERSION_base(4, 9, 0) {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} #endif+ -- | Provides support for treating payloads and namespaces as -- composable contexts. The common pattern would be to provide a -- 'KatipContext' instance for your base monad. module Katip.Monadic- (- -- * Monadic variants of logging functions from "Katip.Core"- logFM- , logTM- , logLocM- , logItemM- , logExceptionM+ ( -- * Monadic variants of logging functions from "Katip.Core"+ logFM,+ logTM,+ logLocM,+ logItemM,+ logExceptionM, -- * Machinery for merging typed log payloads/contexts- , KatipContext(..)- , AnyLogContext- , LogContexts- , liftPayload+ KatipContext (..),+ AnyLogContext,+ LogContexts,+ liftPayload, -- * KatipContextT - Utility transformer that provides Katip and KatipContext instances- , KatipContextT(..)- , runKatipContextT- , katipAddNamespace- , katipAddContext- , KatipContextTState(..)- , NoLoggingT (..)- , askLoggerIO- ) where-+ KatipContextT (..),+ runKatipContextT,+ katipAddNamespace,+ katipAddContext,+ KatipContextTState (..),+ NoLoggingT (..),+ askLoggerIO,+ )+where --------------------------------------------------------------------------------import Control.Applicative-import Control.Exception.Safe-import Control.Monad.Base-import Control.Monad.Error.Class+import Control.Applicative+import Control.Exception.Safe+import Control.Monad.Base+import Control.Monad.Error.Class #if MIN_VERSION_base(4, 9, 0) import qualified Control.Monad.Fail as MF #endif-import Control.Monad.IO.Class-import Control.Monad.IO.Unlift-import Control.Monad.Reader-import Control.Monad.State-import Control.Monad.Trans.Control+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans.Control #if !MIN_VERSION_either(4, 5, 0) import Control.Monad.Trans.Either (EitherT, mapEitherT) #endif-import Control.Monad.Trans.Except (ExceptT, mapExceptT)-import Control.Monad.Trans.Identity (IdentityT, mapIdentityT)-import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)-import Control.Monad.Trans.Resource (MonadResource,- ResourceT, transResourceT)-import Control.Monad.Trans.RWS (RWST, mapRWST)-import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST, mapRWST)-import qualified Control.Monad.Trans.State.Strict as Strict (StateT, mapStateT)-import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT,- mapWriterT)-import Control.Monad.Writer hiding ((<>))-import Data.Aeson-import qualified Data.Foldable as FT-import qualified Data.HashMap.Strict as HM-import Data.Semigroup as Semi-import Data.Sequence as Seq-import Data.Text (Text)+import Control.Monad.Trans.Except (ExceptT, mapExceptT)+import Control.Monad.Trans.Identity (IdentityT, mapIdentityT)+import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)+import Control.Monad.Trans.RWS (RWST, mapRWST)+import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST, mapRWST)+import Control.Monad.Trans.Resource+ ( MonadResource,+ ResourceT,+ transResourceT,+ )+import qualified Control.Monad.Trans.State.Strict as Strict (StateT, mapStateT)+import qualified Control.Monad.Trans.Writer.Strict as Strict+ ( WriterT,+ mapWriterT,+ )+import Control.Monad.Writer hiding ((<>))+import Data.Aeson+import qualified Data.Foldable as FT+import qualified Data.HashMap.Strict as HM+import Data.Semigroup as Semi+import Data.Sequence as Seq+import Data.Text (Text) #if MIN_VERSION_base(4, 8, 0) #if !MIN_VERSION_base(4, 9, 0) import GHC.SrcLoc #endif-import GHC.Stack+import GHC.Stack #endif-import Language.Haskell.TH+ --------------------------------------------------------------------------------import Katip.Core+import Katip.Core+import Language.Haskell.TH+ ------------------------------------------------------------------------------- -- | A wrapper around a log context that erases type information so -- that contexts from multiple layers can be combined intelligently. data AnyLogContext where- AnyLogContext :: (LogItem a) => a -> AnyLogContext-+ AnyLogContext :: (LogItem a) => a -> AnyLogContext -------------------------------------------------------------------------------+ -- | Heterogeneous list of log contexts that provides a smart -- 'LogContext' instance for combining multiple payload policies. This -- is critical for log contexts deep down in a stack to be able to@@ -109,31 +117,31 @@ newtype LogContexts = LogContexts (Seq AnyLogContext) deriving (Monoid, Semigroup) instance ToJSON LogContexts where- toJSON (LogContexts cs) =- -- flip mappend to get right-biased merge- Object $ FT.foldr (flip mappend) mempty $ fmap (\(AnyLogContext v) -> toObject v) cs+ toJSON (LogContexts cs) =+ -- flip mappend to get right-biased merge+ Object $ FT.foldr (flip mappend) mempty $ fmap (\(AnyLogContext v) -> toObject v) cs instance ToObject LogContexts instance LogItem LogContexts where- payloadKeys verb (LogContexts vs) = FT.foldr (flip mappend) mempty $ fmap payloadKeys' vs- where- -- To ensure AllKeys doesn't leak keys from other values when- -- combined, we resolve AllKeys to its equivalent SomeKeys- -- representation first.- payloadKeys' (AnyLogContext v) = case payloadKeys verb v of- AllKeys -> SomeKeys $ HM.keys $ toObject v- x -> x-+ payloadKeys verb (LogContexts vs) = FT.foldr (flip mappend) mempty $ fmap payloadKeys' vs+ where+ -- To ensure AllKeys doesn't leak keys from other values when+ -- combined, we resolve AllKeys to its equivalent SomeKeys+ -- representation first.+ payloadKeys' (AnyLogContext v) = case payloadKeys verb v of+ AllKeys -> SomeKeys $ HM.keys $ toObject v+ x -> x -------------------------------------------------------------------------------+ -- | Lift a log context into the generic wrapper so that it can -- combine with the existing log context. liftPayload :: (LogItem a) => a -> LogContexts liftPayload = LogContexts . Seq.singleton . AnyLogContext - -------------------------------------------------------------------------------+ -- | A monadic context that has an inherant way to get logging context -- and namespace. Examples include a web application monad or database -- monad. The @local@ variants are just like @local@ from Reader and@@ -144,10 +152,13 @@ -- own in each app. class Katip m => KatipContext m where getKatipContext :: m LogContexts+ -- | Temporarily modify the current context for the duration of the -- supplied monad. Used in 'katipAddContext' localKatipContext :: (LogContexts -> LogContexts) -> m a -> m a+ getKatipNamespace :: m Namespace+ -- | Temporarily modify the current namespace for the duration of the -- supplied monad. Used in 'katipAddNamespace' localKatipNamespace :: (Namespace -> Namespace) -> m a -> m a@@ -158,14 +169,12 @@ getKatipNamespace = lift getKatipNamespace localKatipNamespace = mapIdentityT . localKatipNamespace - instance (KatipContext m, Katip (MaybeT m)) => KatipContext (MaybeT m) where getKatipContext = lift getKatipContext localKatipContext = mapMaybeT . localKatipContext getKatipNamespace = lift getKatipNamespace localKatipNamespace = mapMaybeT . localKatipNamespace - #if !MIN_VERSION_either(4, 5, 0) instance (KatipContext m, Katip (EitherT e m)) => KatipContext (EitherT e m) where getKatipContext = lift getKatipContext@@ -174,114 +183,105 @@ localKatipNamespace = mapEitherT . localKatipNamespace #endif - instance (KatipContext m, Katip (ReaderT r m)) => KatipContext (ReaderT r m) where getKatipContext = lift getKatipContext localKatipContext = mapReaderT . localKatipContext getKatipNamespace = lift getKatipNamespace localKatipNamespace = mapReaderT . localKatipNamespace - instance (KatipContext m, Katip (ResourceT m)) => KatipContext (ResourceT m) where getKatipContext = lift getKatipContext localKatipContext = transResourceT . localKatipContext getKatipNamespace = lift getKatipNamespace localKatipNamespace = transResourceT . localKatipNamespace - instance (KatipContext m, Katip (Strict.StateT s m)) => KatipContext (Strict.StateT s m) where getKatipContext = lift getKatipContext localKatipContext = Strict.mapStateT . localKatipContext getKatipNamespace = lift getKatipNamespace localKatipNamespace = Strict.mapStateT . localKatipNamespace - instance (KatipContext m, Katip (StateT s m)) => KatipContext (StateT s m) where getKatipContext = lift getKatipContext localKatipContext = mapStateT . localKatipContext getKatipNamespace = lift getKatipNamespace localKatipNamespace = mapStateT . localKatipNamespace - instance (KatipContext m, Katip (ExceptT e m)) => KatipContext (ExceptT e m) where getKatipContext = lift getKatipContext localKatipContext = mapExceptT . localKatipContext getKatipNamespace = lift getKatipNamespace localKatipNamespace = mapExceptT . localKatipNamespace - instance (Monoid w, KatipContext m, Katip (Strict.WriterT w m)) => KatipContext (Strict.WriterT w m) where getKatipContext = lift getKatipContext localKatipContext = Strict.mapWriterT . localKatipContext getKatipNamespace = lift getKatipNamespace localKatipNamespace = Strict.mapWriterT . localKatipNamespace - instance (Monoid w, KatipContext m, Katip (WriterT w m)) => KatipContext (WriterT w m) where getKatipContext = lift getKatipContext localKatipContext = mapWriterT . localKatipContext getKatipNamespace = lift getKatipNamespace localKatipNamespace = mapWriterT . localKatipNamespace - instance (Monoid w, KatipContext m, Katip (Strict.RWST r w s m)) => KatipContext (Strict.RWST r w s m) where getKatipContext = lift getKatipContext localKatipContext = Strict.mapRWST . localKatipContext getKatipNamespace = lift getKatipNamespace localKatipNamespace = Strict.mapRWST . localKatipNamespace - instance (Monoid w, KatipContext m, Katip (RWST r w s m)) => KatipContext (RWST r w s m) where getKatipContext = lift getKatipContext localKatipContext = mapRWST . localKatipContext getKatipNamespace = lift getKatipNamespace localKatipNamespace = mapRWST . localKatipNamespace - deriving instance (Monad m, KatipContext m) => KatipContext (KatipT m) -------------------------------------------------------------------------------+ -- | Log with everything, including a source code location. This is -- very low level and you typically can use 'logTM' in its -- place. Automatically supplies payload and namespace.-logItemM- :: (Applicative m, KatipContext m, HasCallStack)- => Maybe Loc- -> Severity- -> LogStr- -> m ()+logItemM ::+ (Applicative m, KatipContext m, HasCallStack) =>+ Maybe Loc ->+ Severity ->+ LogStr ->+ m () logItemM loc sev msg = do- ctx <- getKatipContext- ns <- getKatipNamespace- logItem ctx ns loc sev msg-+ ctx <- getKatipContext+ ns <- getKatipNamespace+ logItem ctx ns loc sev msg -------------------------------------------------------------------------------+ -- | Log with full context, but without any code -- location. Automatically supplies payload and namespace.-logFM- :: (Applicative m, KatipContext m)- => Severity- -- ^ Severity of the message- -> LogStr- -- ^ The log message- -> m ()+logFM ::+ (Applicative m, KatipContext m) =>+ -- | Severity of the message+ Severity ->+ -- | The log message+ LogStr ->+ m () logFM sev msg = do ctx <- getKatipContext ns <- getKatipNamespace logF ctx ns sev msg - -------------------------------------------------------------------------------+ -- | 'Loc'-tagged logging when using template-haskell. Automatically -- supplies payload and namespace. -- -- @$(logTM) InfoS "Hello world"@ logTM :: ExpQ-logTM = [| logItemM (Just $(getLocTH)) |]-+logTM = [|logItemM (Just $(getLocTH))|] -------------------------------------------------------------------------------+ -- | 'Loc'-tagged logging when using 'GHC.Stack.getCallStack' implicit-callstacks>. -- Automatically supplies payload and namespace. --@@ -296,30 +296,33 @@ -- `logTM` for maximum compatibility. -- -- @logLocM InfoS "Hello world"@-logLocM :: (Applicative m, KatipContext m, HasCallStack)- => Severity- -> LogStr- -> m ()+logLocM ::+ (Applicative m, KatipContext m, HasCallStack) =>+ Severity ->+ LogStr ->+ m () logLocM = logItemM getLoc - -------------------------------------------------------------------------------+ -- | Perform an action while logging any exceptions that may occur. -- Inspired by 'onException`. -- -- >>>> error "foo" `logExceptionM` ErrorS-logExceptionM- :: (KatipContext m, MonadCatch m, Applicative m)- => m a -- ^ Main action to run- -> Severity -- ^ Severity- -> m a+logExceptionM ::+ (KatipContext m, MonadCatch m, Applicative m) =>+ -- | Main action to run+ m a ->+ -- | Severity+ Severity ->+ m a logExceptionM action sev = action `catchAny` \e -> f e >> throwM e where f e = logFM sev (msg e) msg e = ls ("An exception has occurred: " :: Text) Semi.<> showLS e - -------------------------------------------------------------------------------+ -- | Provides a simple transformer that defines a 'KatipContext' -- instance for a fixed namespace and context. Just like 'KatipT', you -- should use this if you prefer an explicit transformer stack and@@ -336,77 +339,74 @@ -- $(logTM) InfoS "Look, I can log in IO and retain context!" -- doOtherStuff -- @-newtype KatipContextT m a = KatipContextT {- unKatipContextT :: ReaderT KatipContextTState m a- } deriving ( Functor- , Applicative- , Monad- , MonadIO- , MonadThrow- , MonadCatch- , MonadMask- , MonadBase b- , MonadState s- , MonadWriter w- , MonadError e- , MonadPlus- , MonadResource- , Alternative- , MonadFix- , MonadTrans- )---data KatipContextTState = KatipContextTState {- ltsLogEnv :: !LogEnv- , ltsContext :: !LogContexts- , ltsNamespace :: !Namespace- }+newtype KatipContextT m a = KatipContextT+ { unKatipContextT :: ReaderT KatipContextTState m a+ }+ deriving+ ( Functor,+ Applicative,+ Monad,+ MonadIO,+ MonadThrow,+ MonadCatch,+ MonadMask,+ MonadBase b,+ MonadState s,+ MonadWriter w,+ MonadError e,+ MonadPlus,+ MonadResource,+ Alternative,+ MonadFix,+ MonadTrans+ ) +data KatipContextTState = KatipContextTState+ { ltsLogEnv :: !LogEnv,+ ltsContext :: !LogContexts,+ ltsNamespace :: !Namespace+ } instance MonadTransControl KatipContextT where- type StT KatipContextT a = StT (ReaderT KatipContextTState) a- liftWith = defaultLiftWith KatipContextT unKatipContextT- restoreT = defaultRestoreT KatipContextT- {-# INLINE liftWith #-}- {-# INLINE restoreT #-}-+ type StT KatipContextT a = StT (ReaderT KatipContextTState) a+ liftWith = defaultLiftWith KatipContextT unKatipContextT+ restoreT = defaultRestoreT KatipContextT+ {-# INLINE liftWith #-}+ {-# INLINE restoreT #-} instance (MonadBaseControl b m) => MonadBaseControl b (KatipContextT m) where type StM (KatipContextT m) a = ComposeSt KatipContextT m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM - -- Reader is a passthrough. We don't expose our internal reader so as not to conflict instance (MonadReader r m) => MonadReader r (KatipContextT m) where- ask = lift ask- local f (KatipContextT (ReaderT m)) = KatipContextT $ ReaderT $ \r ->+ ask = lift ask+ local f (KatipContextT (ReaderT m)) = KatipContextT $+ ReaderT $ \r -> local f (m r) - instance (MonadIO m) => Katip (KatipContextT m) where getLogEnv = KatipContextT $ ReaderT $ \lts -> return (ltsLogEnv lts)- localLogEnv f (KatipContextT m) = KatipContextT (local (\s -> s { ltsLogEnv = f (ltsLogEnv s)}) m)-+ localLogEnv f (KatipContextT m) = KatipContextT (local (\s -> s {ltsLogEnv = f (ltsLogEnv s)}) m) instance (MonadIO m) => KatipContext (KatipContextT m) where getKatipContext = KatipContextT $ ReaderT $ \lts -> return (ltsContext lts)- localKatipContext f (KatipContextT m) = KatipContextT $ local (\s -> s { ltsContext = f (ltsContext s)}) m+ localKatipContext f (KatipContextT m) = KatipContextT $ local (\s -> s {ltsContext = f (ltsContext s)}) m getKatipNamespace = KatipContextT $ ReaderT $ \lts -> return (ltsNamespace lts)- localKatipNamespace f (KatipContextT m) = KatipContextT $ local (\s -> s { ltsNamespace = f (ltsNamespace s)}) m+ localKatipNamespace f (KatipContextT m) = KatipContextT $ local (\s -> s {ltsNamespace = f (ltsNamespace s)}) m -instance MonadUnliftIO m => MonadUnliftIO (KatipContextT m) where #if MIN_VERSION_unliftio_core(0, 2, 0)+instance MonadUnliftIO m => MonadUnliftIO (KatipContextT m) where withRunInIO inner = KatipContextT $ ReaderT $ \lts -> withRunInIO $ \run -> inner (run . runKatipContextT (ltsLogEnv lts) (ltsContext lts) (ltsNamespace lts)) #else+instance MonadUnliftIO m => MonadUnliftIO (KatipContextT m) where askUnliftIO = KatipContextT $ withUnliftIO $ \u -> pure (UnliftIO (unliftIO u . unKatipContextT)) #endif - #if MIN_VERSION_base(4, 9, 0) instance MF.MonadFail m => MF.MonadFail (KatipContextT m) where fail msg = lift (MF.fail msg)@@ -419,20 +419,20 @@ where lts = KatipContextTState le (liftPayload ctx) ns - -------------------------------------------------------------------------------+ -- | Append a namespace segment to the current namespace for the given -- monadic action, then restore the previous state -- afterwards. Works with anything implementing KatipContext.-katipAddNamespace- :: (KatipContext m)- => Namespace- -> m a- -> m a+katipAddNamespace ::+ (KatipContext m) =>+ Namespace ->+ m a ->+ m a katipAddNamespace ns = localKatipNamespace (<> ns) - -------------------------------------------------------------------------------+ -- | Append some context to the current context for the given monadic -- action, then restore the previous state afterwards. Important note: -- be careful using this in a loop. If you're using something like@@ -444,62 +444,66 @@ -- redundant contexts and even if they all merge on log, they are -- stored in a sequence and will leak memory. Works with anything -- implementing KatipContext.-katipAddContext- :: ( LogItem i- , KatipContext m- )- => i- -> m a- -> m a+katipAddContext ::+ ( LogItem i,+ KatipContext m+ ) =>+ i ->+ m a ->+ m a katipAddContext i = localKatipContext (<> (liftPayload i)) -newtype NoLoggingT m a = NoLoggingT {- runNoLoggingT :: m a- } deriving ( Functor- , Applicative- , Monad- , MonadIO- , MonadThrow- , MonadCatch- , MonadMask- , MonadBase b- , MonadState s- , MonadWriter w- , MonadError e- , MonadPlus- , Alternative- , MonadFix- , MonadReader r- )+newtype NoLoggingT m a = NoLoggingT+ { runNoLoggingT :: m a+ }+ deriving+ ( Functor,+ Applicative,+ Monad,+ MonadIO,+ MonadThrow,+ MonadCatch,+ MonadMask,+ MonadBase b,+ MonadState s,+ MonadWriter w,+ MonadError e,+ MonadPlus,+ Alternative,+ MonadFix,+ MonadReader r+ ) instance MonadTrans NoLoggingT where lift = NoLoggingT instance MonadTransControl NoLoggingT where- type StT NoLoggingT a = a- liftWith f = NoLoggingT $ f runNoLoggingT- restoreT = NoLoggingT- {-# INLINE liftWith #-}- {-# INLINE restoreT #-}+ type StT NoLoggingT a = a+ liftWith f = NoLoggingT $ f runNoLoggingT+ restoreT = NoLoggingT+ {-# INLINE liftWith #-}+ {-# INLINE restoreT #-} instance MonadBaseControl b m => MonadBaseControl b (NoLoggingT m) where- type StM (NoLoggingT m) a = StM m a- liftBaseWith f = NoLoggingT $- liftBaseWith $ \runInBase ->- f $ runInBase . runNoLoggingT- restoreM = NoLoggingT . restoreM+ type StM (NoLoggingT m) a = StM m a+ liftBaseWith f = NoLoggingT $+ liftBaseWith $ \runInBase ->+ f $ runInBase . runNoLoggingT+ restoreM = NoLoggingT . restoreM -instance MonadUnliftIO m => MonadUnliftIO (NoLoggingT m) where++ #if MIN_VERSION_unliftio_core(0, 2, 0)+instance MonadUnliftIO m => MonadUnliftIO (NoLoggingT m) where withRunInIO inner = NoLoggingT $ withRunInIO $ \run -> inner (run . runNoLoggingT) #else+instance MonadUnliftIO m => MonadUnliftIO (NoLoggingT m) where askUnliftIO = NoLoggingT $ withUnliftIO $ \u -> pure (UnliftIO (unliftIO u . runNoLoggingT)) #endif - instance MonadIO m => Katip (NoLoggingT m) where getLogEnv = liftIO (initLogEnv "NoLoggingT" "no-logging") localLogEnv = const id@@ -509,7 +513,6 @@ localKatipContext = const id getKatipNamespace = pure mempty localKatipNamespace = const id- -- | Convenience function for when you have to integrate with a third -- party API that takes a generic logging function as an argument.
src/Katip/Scribes/Handle.hs view
@@ -1,38 +1,37 @@ module Katip.Scribes.Handle where --------------------------------------------------------------------------------import Control.Applicative as A-import Control.Concurrent-import Control.Exception (bracket_, finally)-import Data.Aeson-import Data.Text.Lazy (toStrict)-import Data.Text.Lazy.Encoding (decodeUtf8)-import qualified Data.HashMap.Strict as HM-import Data.Monoid as M-import Data.Scientific as S-import Data.Text (Text)-import Data.Text.Lazy.Builder-import Data.Text.Lazy.IO as T-import System.IO---------------------------------------------------------------------------------import Katip.Core-import Katip.Format.Time (formatAsLogTime)+import Control.Applicative as A+import Control.Concurrent+import Control.Exception (bracket_, finally)+import Data.Aeson+import qualified Data.HashMap.Strict as HM+import Data.Monoid as M+import Data.Scientific as S+import Data.Text (Text)+import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder+import Data.Text.Lazy.Encoding (decodeUtf8)+import Data.Text.Lazy.IO as T -------------------------------------------------------------------------------+import Katip.Core+import Katip.Format.Time (formatAsLogTime)+import System.IO +------------------------------------------------------------------------------- ------------------------------------------------------------------------------- brackets :: Builder -> Builder brackets m = fromText "[" M.<> m <> fromText "]" - ------------------------------------------------------------------------------- getKeys :: LogItem s => Verbosity -> s -> [Builder] getKeys verb a = concat (renderPair A.<$> HM.toList (payloadObject verb a)) where renderPair :: (Text, Value) -> [Builder]- renderPair (k,v) =+ renderPair (k, v) = case v of- Object o -> concat [renderPair (k <> "." <> k', v') | (k', v') <- HM.toList o]+ Object o -> concat [renderPair (k <> "." <> k', v') | (k', v') <- HM.toList o] String t -> [fromText (k <> ":" <> t)] Number n -> [fromText (k <> ":") <> fromString (formatNumber n)] Bool b -> [fromText (k <> ":") <> fromString (show b)]@@ -42,16 +41,16 @@ formatNumber n = formatScientific Generic (if isFloating n then Nothing else Just 0) n - ------------------------------------------------------------------------------- data ColorStrategy- = ColorLog Bool- -- ^ Whether to use color control chars in log output- | ColorIfTerminal- -- ^ Color if output is a terminal+ = -- | Whether to use color control chars in log output+ ColorLog Bool+ | -- | Color if output is a terminal+ ColorIfTerminal deriving (Show, Eq) -------------------------------------------------------------------------------+ -- | Logs to a file handle such as stdout, stderr, or a file. Contexts -- and other information will be flattened out into bracketed -- fields. For example:@@ -70,25 +69,26 @@ -- -- Returns the newly-created `Scribe`. The finalizer flushes the -- handle. Handle mode is set to 'LineBuffering' automatically.-mkHandleScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a)- -> ColorStrategy- -> Handle- -> PermitFunc- -> Verbosity- -> IO Scribe+mkHandleScribeWithFormatter ::+ (forall a. LogItem a => ItemFormatter a) ->+ ColorStrategy ->+ Handle ->+ PermitFunc ->+ Verbosity ->+ IO Scribe mkHandleScribeWithFormatter itemFormatter cs h permitF verb = do- hSetBuffering h LineBuffering- colorize <- case cs of- ColorIfTerminal -> hIsTerminalDevice h- ColorLog b -> return b- lock <- newMVar ()- let logger i@Item{..} = do- bracket_ (takeMVar lock) (putMVar lock ()) $- T.hPutStrLn h $ toLazyText $ itemFormatter colorize verb i- return $ Scribe logger (hFlush h) permitF-+ hSetBuffering h LineBuffering+ colorize <- case cs of+ ColorIfTerminal -> hIsTerminalDevice h+ ColorLog b -> return b+ lock <- newMVar ()+ let logger i@Item {} = do+ bracket_ (takeMVar lock) (putMVar lock ()) $+ T.hPutStrLn h $ toLazyText $ itemFormatter colorize verb i+ return $ Scribe logger (hFlush h) permitF -------------------------------------------------------------------------------+ -- | A specialization of 'mkHandleScribe' that takes a 'FilePath' -- instead of a 'Handle'. It is responsible for opening the file in -- 'AppendMode' and will close the file handle on@@ -100,8 +100,8 @@ Scribe logger finalizer permit <- mkHandleScribe (ColorLog False) h permitF verb return (Scribe logger (finalizer `finally` hClose h) permit) - -------------------------------------------------------------------------------+ -- | A custom ItemFormatter for logging `Item`s. Takes a `Bool` indicating -- whether to colorize the output, `Verbosity` of output, and an `Item` to -- format.@@ -109,7 +109,6 @@ -- See `bracketFormat` and `jsonFormat` for examples. type ItemFormatter a = Bool -> Verbosity -> Item a -> Builder - formatItem :: LogItem a => ItemFormatter a formatItem = bracketFormat {-# DEPRECATED formatItem "Use bracketFormat instead" #-}@@ -121,16 +120,17 @@ -- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][PID 1724][ThreadId 1154][confrab_factor:42.0][main:Helpers.Logging Helpers/Logging.hs:41:9] Confrabulating widgets, with extra namespace and context -- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal bracketFormat :: LogItem a => ItemFormatter a-bracketFormat withColor verb Item{..} =- brackets nowStr <>- brackets (mconcat $ map fromText $ intercalateNs _itemNamespace) <>- brackets (fromText (renderSeverity' _itemSeverity)) <>- brackets (fromString _itemHost) <>- brackets ("PID " <> fromString (show _itemProcess)) <>- brackets ("ThreadId " <> fromText (getThreadIdText _itemThread)) <>- mconcat ks <>- maybe mempty (brackets . fromString . locationToString) _itemLoc <>- fromText " " <> (unLogStr _itemMessage)+bracketFormat withColor verb Item {..} =+ brackets nowStr+ <> brackets (mconcat $ map fromText $ intercalateNs _itemNamespace)+ <> brackets (fromText (renderSeverity' _itemSeverity))+ <> brackets (fromString _itemHost)+ <> brackets ("PID " <> fromString (show _itemProcess))+ <> brackets ("ThreadId " <> fromText (getThreadIdText _itemThread))+ <> mconcat ks+ <> maybe mempty (brackets . fromString . locationToString) _itemLoc+ <> fromText " "+ <> (unLogStr _itemMessage) where nowStr = fromText (formatAsLogTime _itemTime) ks = map brackets $ getKeys verb _itemPayload@@ -147,8 +147,8 @@ jsonFormat :: LogItem a => ItemFormatter a jsonFormat withColor verb i = fromText $- colorBySeverity withColor (_itemSeverity i) $- toStrict $ decodeUtf8 $ encode $ itemJson verb i+ colorBySeverity withColor (_itemSeverity i) $+ toStrict $ decodeUtf8 $ encode $ itemJson verb i -- | Color a text message based on `Severity`. `ErrorS` and more severe errors -- are colored red, `WarningS` is colored yellow, and all other messages are@@ -156,18 +156,17 @@ colorBySeverity :: Bool -> Severity -> Text -> Text colorBySeverity withColor severity msg = case severity of EmergencyS -> red msg- AlertS -> red msg- CriticalS -> red msg- ErrorS -> red msg- WarningS -> yellow msg- _ -> msg+ AlertS -> red msg+ CriticalS -> red msg+ ErrorS -> red msg+ WarningS -> yellow msg+ _ -> msg where red = colorize "31" yellow = colorize "33" colorize c s- | withColor = "\ESC["<> c <> "m" <> s <> "\ESC[0m"+ | withColor = "\ESC[" <> c <> "m" <> s <> "\ESC[0m" | otherwise = s- -- | Provides a simple log environment with 1 scribe going to -- stdout. This is a decent example of how to build a LogEnv and is
test/Katip/Tests.hs view
@@ -1,155 +1,159 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module Katip.Tests- ( tests- ) where +module Katip.Tests+ ( tests,+ )+where --------------------------------------------------------------------------------import Control.Applicative as A-import Control.Concurrent.STM-import Control.Exception.Safe-import Data.Aeson-import qualified Data.HashMap.Strict as HM-import qualified Data.Map.Strict as M-import Data.Monoid as Monoid-import Data.Text (Text)-import qualified Data.Text.Lazy.Builder as B-import Data.Time-import Data.Time.Clock.POSIX-import Language.Haskell.TH-import Lens.Micro (ASetter, (&), (.~))-import System.Posix.Types-import Test.QuickCheck.Instances ()-import Test.Tasty-import Test.Tasty.HUnit-import Test.Tasty.QuickCheck---------------------------------------------------------------------------------import Katip-import Katip.Core+import Control.Applicative as A+import Control.Concurrent.STM+import Control.Exception.Safe+import Data.Aeson+import qualified Data.HashMap.Strict as HM+import qualified Data.Map.Strict as M+import Data.Monoid as Monoid+import Data.Text (Text)+import qualified Data.Text.Lazy.Builder as B+import Data.Time+import Data.Time.Clock.POSIX -------------------------------------------------------------------------------+import Katip+import Katip.Core+import Language.Haskell.TH+import Lens.Micro (ASetter, (&), (.~))+import System.Posix.Types+import Test.QuickCheck.Instances ()+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck +------------------------------------------------------------------------------- tests :: TestTree-tests = testGroup "Katip"- [- testProperty "JSON cycle Item" $ \(i :: Item ()) ->- prop_json_cycle i- , testProperty "JSON cycle verbosity" $ \(v :: Verbosity) ->- prop_json_cycle v- , eqItemTests- , testProperty "renderSeverity/textToSeverity cycle" $ \sev ->- textToSeverity(renderSeverity sev) === Just sev- , testProperty "processIDToText/textToProcessID cycle" $ \pid ->- textToProcessID (processIDToText pid) === Just pid- , testCase "processIDToText is just the number" $ do- processIDToText 123 @?= "123"- , logContextsTests- , closeScribeTests- , closeScribesTests- , loggingTests- ]-+tests =+ testGroup+ "Katip"+ [ testProperty "JSON cycle Item" $ \(i :: Item ()) ->+ prop_json_cycle i,+ testProperty "JSON cycle verbosity" $ \(v :: Verbosity) ->+ prop_json_cycle v,+ eqItemTests,+ testProperty "renderSeverity/textToSeverity cycle" $ \sev ->+ textToSeverity (renderSeverity sev) === Just sev,+ testProperty "processIDToText/textToProcessID cycle" $ \pid ->+ textToProcessID (processIDToText pid) === Just pid,+ testCase "processIDToText is just the number" $ do+ processIDToText 123 @?= "123",+ logContextsTests,+ closeScribeTests,+ closeScribesTests,+ loggingTests+ ] ------------------------------------------------------------------------------- logContextsTests :: TestTree-logContextsTests = testGroup "logContexts"- [- testCase "overwrites with the right-hand side (right-bias)" $ do- let l1 = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("a" :: Text))])- l2 = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("b" :: Text))])- l3 = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("c" :: Text))])- both = l1 <> l2 <> l3- toObject both @?= HM.singleton "foo" (String "c")- , testCase "respects payloadKeys for each constituent payload" $ do- let everything = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("a" :: Text))])- conservative = liftPayload (ConservativePayload "always" "rarely")- both = everything <> conservative- payloadKeys V2 both @?= SomeKeys ["often_shown", "rarely_shown", "foo"]- payloadKeys V1 both @?= SomeKeys ["often_shown", "foo"]- ]-+logContextsTests =+ testGroup+ "logContexts"+ [ testCase "overwrites with the right-hand side (right-bias)" $ do+ let l1 = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("a" :: Text))])+ l2 = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("b" :: Text))])+ l3 = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("c" :: Text))])+ both = l1 <> l2 <> l3+ toObject both @?= HM.singleton "foo" (String "c"),+ testCase "respects payloadKeys for each constituent payload" $ do+ let everything = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("a" :: Text))])+ conservative = liftPayload (ConservativePayload "always" "rarely")+ both = everything <> conservative+ payloadKeys V2 both @?= SomeKeys ["often_shown", "rarely_shown", "foo"]+ payloadKeys V1 both @?= SomeKeys ["often_shown", "foo"]+ ] ------------------------------------------------------------------------------- closeScribeTests :: TestTree-closeScribeTests = testGroup "closeScribe"- [ testCase "removes the specified scribe" $ do- (scr, finalizerCalled) <- trivialScribe- le <- registerScribe "trivial" scr defaultScribeSettings =<< initLogEnv "ns" "test"- le' <- closeScribe "trivial" le- closed <- atomically (readTVar finalizerCalled)- assertBool "finalizer called" closed- assertBool "should not have trivial key in scribes" (not (M.member "trivial" (_logEnvScribes le')))- , testCase "does nothing for a missing scribe" $ do- le <- initLogEnv "ns" "test"- le' <- closeScribe "nah" le- assertBool "does not affect scribes" (M.null (_logEnvScribes le'))- , testCase "re-throws finalizer exceptions" $ do- (scr, finalizerCalled) <- brokenScribe 1- le <- registerScribe "broken" scr defaultScribeSettings =<< initLogEnv "ns" "test"- res <- try (closeScribe "broken" le)- closed <- atomically (readTVar finalizerCalled)- assertBool "finalizer called" closed- case res of- Left (ScribeBroken scribeNo) -> scribeNo @?= 1- Right _ -> assertFailure "Expected to throw a ScribeBroken but it did not"- ]-+closeScribeTests =+ testGroup+ "closeScribe"+ [ testCase "removes the specified scribe" $ do+ (scr, finalizerCalled) <- trivialScribe+ le <- registerScribe "trivial" scr defaultScribeSettings =<< initLogEnv "ns" "test"+ le' <- closeScribe "trivial" le+ closed <- atomically (readTVar finalizerCalled)+ assertBool "finalizer called" closed+ assertBool "should not have trivial key in scribes" (not (M.member "trivial" (_logEnvScribes le'))),+ testCase "does nothing for a missing scribe" $ do+ le <- initLogEnv "ns" "test"+ le' <- closeScribe "nah" le+ assertBool "does not affect scribes" (M.null (_logEnvScribes le')),+ testCase "re-throws finalizer exceptions" $ do+ (scr, finalizerCalled) <- brokenScribe 1+ le <- registerScribe "broken" scr defaultScribeSettings =<< initLogEnv "ns" "test"+ res <- try (closeScribe "broken" le)+ closed <- atomically (readTVar finalizerCalled)+ assertBool "finalizer called" closed+ case res of+ Left (ScribeBroken scribeNo) -> scribeNo @?= 1+ Right _ -> assertFailure "Expected to throw a ScribeBroken but it did not"+ ] ------------------------------------------------------------------------------- loggingTests :: TestTree-loggingTests = testGroup "logging"- [ testCase "logs in order with contexts, namespaces, etc" $ do- (le, items) <- recordingEnv- runKatipContextT le (sl "base_context" (42 :: Int)) "base_namespace" $ do- $(logTM) InfoS "basic log"- katipNoLogging $ do- $(logTM) InfoS "you cant see this"- katipAddNamespace "added" $ do- katipAddNamespace "namespace" $ do- $(logTM) InfoS "with namespaces"- katipAddContext (sl "additional" True) $ do- $(logTM) InfoS "additional context"- _ <- closeScribes le- summary <- fmap summarizeItem <$> readTVarIO items- let baseCtx = HM.singleton "base_context" (Number 42)- let baseNS = "tests" <> "base_namespace"- summary @?=- [ (baseNS, baseCtx, "basic log")- , (baseNS <> "added" <> "namespace", baseCtx, "with namespaces")- , (baseNS <> "added", HM.insert "additional" (Bool True) baseCtx, "additional context")- ]- , testCase "Katip.Monadic.logLocM" $ do- (le, items) <- recordingEnv- runKatipContextT le (sl "base_context" (42 :: Int)) "base_namespace" $ logLocM InfoS "basic log"- _ <- closeScribes le- loggedItems <- readTVarIO items- let loc = _itemLoc (head loggedItems)- fmap loc_module loc @?= Just "Katip.Tests"- ]+loggingTests =+ testGroup+ "logging"+ [ testCase "logs in order with contexts, namespaces, etc" $ do+ (le, items) <- recordingEnv+ runKatipContextT le (sl "base_context" (42 :: Int)) "base_namespace" $ do+ $(logTM) InfoS "basic log"+ katipNoLogging $ do+ $(logTM) InfoS "you cant see this"+ katipAddNamespace "added" $ do+ katipAddNamespace "namespace" $ do+ $(logTM) InfoS "with namespaces"+ katipAddContext (sl "additional" True) $ do+ $(logTM) InfoS "additional context"+ _ <- closeScribes le+ summary <- fmap summarizeItem <$> readTVarIO items+ let baseCtx = HM.singleton "base_context" (Number 42)+ let baseNS = "tests" <> "base_namespace"+ summary+ @?= [ (baseNS, baseCtx, "basic log"),+ (baseNS <> "added" <> "namespace", baseCtx, "with namespaces"),+ (baseNS <> "added", HM.insert "additional" (Bool True) baseCtx, "additional context")+ ],+ testCase "Katip.Monadic.logLocM" $ do+ (le, items) <- recordingEnv+ runKatipContextT le (sl "base_context" (42 :: Int)) "base_namespace" $ logLocM InfoS "basic log"+ _ <- closeScribes le+ loggedItems <- readTVarIO items+ let loc = _itemLoc (head loggedItems)+ fmap loc_module loc @?= Just "Katip.Tests"+ ] where recordingEnv :: IO (LogEnv, TVar [Item Object]) recordingEnv = do items <- newTVarIO Monoid.mempty- let scribe = Scribe- { liPush = \i -> atomically (modifyTVar' items (<> [toObject <$> i]))- , scribeFinalizer = return ()- , scribePermitItem = permitItem DebugS- }+ let scribe =+ Scribe+ { liPush = \i -> atomically (modifyTVar' items (<> [toObject <$> i])),+ scribeFinalizer = return (),+ scribePermitItem = permitItem DebugS+ } le1 <- initLogEnv "tests" "test" le2 <- registerScribe "recorder" scribe defaultScribeSettings le1 return (le2, items) summarizeItem :: Item Object -> (Namespace, Object, LogStr) summarizeItem Item {..} = (_itemNamespace, _itemPayload, _itemMessage) - ------------------------------------------------------------------------------- trivialScribe :: IO (Scribe, TVar Bool) trivialScribe = do@@ -157,7 +161,6 @@ let finalizer = atomically (writeTVar finalizerCalled True) return (Scribe (const (return ())) finalizer (permitItem DebugS), finalizerCalled) - ------------------------------------------------------------------------------- brokenScribe :: Int -> IO (Scribe, TVar Bool) brokenScribe scribeNum = do@@ -167,66 +170,65 @@ throw (ScribeBroken scribeNum) return (Scribe (const (return ())) finalizer (permitItem DebugS), finalizerCalled) - ------------------------------------------------------------------------------- data BrokenScribeError = ScribeBroken Int deriving (Show, Typeable) - instance Exception BrokenScribeError ------------------------------------------------------------------------------- closeScribesTests :: TestTree-closeScribesTests = testGroup "closeScribes"- [ testCase "returns a log env with no scribes" $ do- (scr, finalizerCalled) <- trivialScribe- le <- registerScribe "trivial" scr defaultScribeSettings =<< initLogEnv "ns" "test"- le' <- closeScribes le- closed <- atomically (readTVar finalizerCalled)- assertBool "finalizer called" closed- assertBool "remvoes all scribes" (M.null (_logEnvScribes le'))- , testCase "throws the first exception encountered after closing all scribes" $ do- (scr1, finalizerCalled1) <- brokenScribe 1- (scr2, finalizerCalled2) <- brokenScribe 2- le <- registerScribe "broken2" scr2 defaultScribeSettings =<< registerScribe "broken1" scr1 defaultScribeSettings =<< initLogEnv "ns" "test"- res <- try (closeScribes le)- closed1 <- atomically (readTVar finalizerCalled1)- assertBool "finalizer 1 called" closed1- closed2 <- atomically (readTVar finalizerCalled2)- assertBool "finalizer 2 called" closed2- case res of- Left (ScribeBroken scribeNo) -> scribeNo @?= 1- Right _ -> assertFailure "Expected to throw a ScribeBroken but it did not"- ]-+closeScribesTests =+ testGroup+ "closeScribes"+ [ testCase "returns a log env with no scribes" $ do+ (scr, finalizerCalled) <- trivialScribe+ le <- registerScribe "trivial" scr defaultScribeSettings =<< initLogEnv "ns" "test"+ le' <- closeScribes le+ closed <- atomically (readTVar finalizerCalled)+ assertBool "finalizer called" closed+ assertBool "remvoes all scribes" (M.null (_logEnvScribes le')),+ testCase "throws the first exception encountered after closing all scribes" $ do+ (scr1, finalizerCalled1) <- brokenScribe 1+ (scr2, finalizerCalled2) <- brokenScribe 2+ le <- registerScribe "broken2" scr2 defaultScribeSettings =<< registerScribe "broken1" scr1 defaultScribeSettings =<< initLogEnv "ns" "test"+ res <- try (closeScribes le)+ closed1 <- atomically (readTVar finalizerCalled1)+ assertBool "finalizer 1 called" closed1+ closed2 <- atomically (readTVar finalizerCalled2)+ assertBool "finalizer 2 called" closed2+ case res of+ Left (ScribeBroken scribeNo) -> scribeNo @?= 1+ Right _ -> assertFailure "Expected to throw a ScribeBroken but it did not"+ ] --------------------------------------------------------------------------------data ConservativePayload = ConservativePayload {- oftenShown :: Text- , rarelyShown :: Text- }-+data ConservativePayload = ConservativePayload+ { oftenShown :: Text,+ rarelyShown :: Text+ } instance ToJSON ConservativePayload where- toJSON ConservativePayload {..} = object ["often_shown" .= oftenShown- ,"rarely_shown" .= rarelyShown]-+ toJSON ConservativePayload {..} =+ object+ [ "often_shown" .= oftenShown,+ "rarely_shown" .= rarelyShown+ ] instance ToObject ConservativePayload - instance LogItem ConservativePayload where payloadKeys V1 _ = SomeKeys ["often_shown"] payloadKeys V0 _ = SomeKeys []- payloadKeys _ _ = AllKeys+ payloadKeys _ _ = AllKeys ------------------------------------------------------------------------------- prop_json_cycle :: (ToJSON a, FromJSON a, Eq a, Show a) => a -> Property prop_json_cycle a = eitherDecode (encode a) === Right a - ------------------------------------------------------------------------------- instance Arbitrary a => Arbitrary (Item a) where- arbitrary = Item+ arbitrary =+ Item A.<$> arbitrary <*> arbitrary <*> arbitrary@@ -239,56 +241,57 @@ <*> arbitrary <*> arbitrary - --------------------------------------------------------------------------------newtype CleanUTCTime = CleanUTCTime {- getCleanUTCTime :: UTCTime- }-+newtype CleanUTCTime = CleanUTCTime+ { getCleanUTCTime :: UTCTime+ } ------------------------------------------------------------------------------- -- Work around time parsing precision issues in aeson instance Arbitrary CleanUTCTime where- arbitrary = CleanUTCTime . posixSecondsToUTCTime . fromInteger <$> arbitrary-+ arbitrary = CleanUTCTime . posixSecondsToUTCTime . fromInteger <$> arbitrary ------------------------------------------------------------------------------- deriving instance Arbitrary Namespace+ deriving instance Arbitrary Environment+ deriving instance Arbitrary ThreadIdText-deriving instance Arbitrary CPid +deriving instance Arbitrary CPid ------------------------------------------------------------------------------- instance Arbitrary Loc where- arbitrary = do- f <- arbitrary- p <- arbitrary- m <- arbitrary- s <- arbitrary- return $ Loc f p m s s-+ arbitrary = do+ f <- arbitrary+ p <- arbitrary+ m <- arbitrary+ s <- arbitrary+ return $ Loc f p m s s ------------------------------------------------------------------------------- instance Arbitrary Verbosity where- arbitrary = oneof $ map pure [V0, V1, V2, V3]+ arbitrary = oneof $ map pure [V0, V1, V2, V3] ------------------------------------------------------------------------------- instance Arbitrary Severity where- arbitrary = oneof $ map pure [ DebugS- , InfoS- , NoticeS- , WarningS- , ErrorS- , CriticalS- , AlertS- , EmergencyS- ]-+ arbitrary =+ oneof $+ map+ pure+ [ DebugS,+ InfoS,+ NoticeS,+ WarningS,+ ErrorS,+ CriticalS,+ AlertS,+ EmergencyS+ ] ------------------------------------------------------------------------------- instance Arbitrary LogStr where- arbitrary = LogStr . B.fromText <$> arbitrary+ arbitrary = LogStr . B.fromText <$> arbitrary ------------------------------------------------------------------------------- -- Somewhat test whether all fields are taken into account in `==`@@ -300,20 +303,22 @@ #endif eqItemTests :: TestTree-eqItemTests = testGroup "Eq Item"- [ testProperty "itemApp" $ prop_field itemApp- , testProperty "itemEnv" $ prop_field itemEnv- , testProperty "itemSeverity" $ prop_field itemSeverity- , testProperty "itemThread" $ prop_field itemThread- , testProperty "itemHost" $ prop_field itemHost- , testProperty "itemProcess" $ prop_field itemProcess- , testProperty "itemPayload" $ prop_field itemPayload- , testProperty "itemMessage" $ prop_field itemMessage- , testProperty "itemTime" $ prop_field itemTime- , testProperty "itemNamespace" $ prop_field itemNamespace- , testProperty "itemLoc" $ prop_field itemLoc- ]+eqItemTests =+ testGroup+ "Eq Item"+ [ testProperty "itemApp" $ prop_field itemApp,+ testProperty "itemEnv" $ prop_field itemEnv,+ testProperty "itemSeverity" $ prop_field itemSeverity,+ testProperty "itemThread" $ prop_field itemThread,+ testProperty "itemHost" $ prop_field itemHost,+ testProperty "itemProcess" $ prop_field itemProcess,+ testProperty "itemPayload" $ prop_field itemPayload,+ testProperty "itemMessage" $ prop_field itemMessage,+ testProperty "itemTime" $ prop_field itemTime,+ testProperty "itemNamespace" $ prop_field itemNamespace,+ testProperty "itemLoc" $ prop_field itemLoc+ ] where prop_field :: Eq a => ASetter (Item ()) (Item ()) a a -> Item () -> a -> a -> Bool prop_field field item f1 f2 =- ((item & field .~ f1) == (item & field .~ f2)) == (f1 == f2)+ ((item & field .~ f1) == (item & field .~ f2)) == (f1 == f2)
test/Katip/Tests/Format/Time.hs view
@@ -1,55 +1,51 @@ module Katip.Tests.Format.Time- ( tests- ) where+ ( tests,+ )+where --------------------------------------------------------------------------------import Data.Aeson (toJSON)-import qualified Data.Text as Text-import Data.Time-import Data.Time.Clock.POSIX+import Data.Aeson (toJSON)+import qualified Data.Text as Text+import Data.Time+import Data.Time.Clock.POSIX import qualified Data.Time.Locale.Compat as LC-import Test.Tasty-import Test.Tasty.HUnit-import Test.Tasty.QuickCheck --------------------------------------------------------------------------------import Katip.Format.Time--------------------------------------------------------------------------------+import Katip.Format.Time+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck +------------------------------------------------------------------------------- tests :: TestTree-tests = testGroup "Katip.Format.Time"- [ testCase "formatAsLogTime" $ do- assertEqual "time 1" (formatDT t1) (formatAsLogTime t1)- assertEqual "time 2" (formatDT t2) (formatAsLogTime t2)- assertEqual "time 3" (formatDT t3) (formatAsLogTime t3)- assertEqual "time 4" (formatDT t4) (formatAsLogTime t4)- assertEqual "time 5" (formatDT t5) (formatAsLogTime t5)-- , testCase "formatAsIso8601" $ do- assertEqual "time 1" (formatDTISO t1) (formatAsIso8601 t1)- assertEqual "time 2" (formatDTISO t2) (formatAsIso8601 t2)- assertEqual "time 3" (formatDTISO t3) (formatAsIso8601 t3)- assertEqual "time 4" (formatDTISO t4) (formatAsIso8601 t4)- assertEqual "time 5" (formatDTISO t5) (formatAsIso8601 t5)-- , testCase "formatAsIso8601 Aeson" $ do- assertEqual "time 1" (toJSON t1) (toJSON $ formatAsIso8601 t1)- assertEqual "time 2" (toJSON t2) (toJSON $ formatAsIso8601 t2)- assertEqual "time 3" (toJSON t3) (toJSON $ formatAsIso8601 t3)- assertEqual "time 4" (toJSON t4) (toJSON $ formatAsIso8601 t4)- assertEqual "time 5" (toJSON t5) (toJSON $ formatAsIso8601 t5)--- , testProperty "LogTime same as Date.Time" $ \(ArbUTCTime t) ->- prop_format_log t-- , testProperty "ISO 8601 same as Date.Time" $ \(ArbUTCTime t) ->- prop_format_iso t-- , testProperty "ISO 8601 same as Aeson" $ \(ArbUTCTime t) ->- prop_format_aeson t-- ]+tests =+ testGroup+ "Katip.Format.Time"+ [ testCase "formatAsLogTime" $ do+ assertEqual "time 1" (formatDT t1) (formatAsLogTime t1)+ assertEqual "time 2" (formatDT t2) (formatAsLogTime t2)+ assertEqual "time 3" (formatDT t3) (formatAsLogTime t3)+ assertEqual "time 4" (formatDT t4) (formatAsLogTime t4)+ assertEqual "time 5" (formatDT t5) (formatAsLogTime t5),+ testCase "formatAsIso8601" $ do+ assertEqual "time 1" (formatDTISO t1) (formatAsIso8601 t1)+ assertEqual "time 2" (formatDTISO t2) (formatAsIso8601 t2)+ assertEqual "time 3" (formatDTISO t3) (formatAsIso8601 t3)+ assertEqual "time 4" (formatDTISO t4) (formatAsIso8601 t4)+ assertEqual "time 5" (formatDTISO t5) (formatAsIso8601 t5),+ testCase "formatAsIso8601 Aeson" $ do+ assertEqual "time 1" (toJSON t1) (toJSON $ formatAsIso8601 t1)+ assertEqual "time 2" (toJSON t2) (toJSON $ formatAsIso8601 t2)+ assertEqual "time 3" (toJSON t3) (toJSON $ formatAsIso8601 t3)+ assertEqual "time 4" (toJSON t4) (toJSON $ formatAsIso8601 t4)+ assertEqual "time 5" (toJSON t5) (toJSON $ formatAsIso8601 t5),+ testProperty "LogTime same as Date.Time" $ \(ArbUTCTime t) ->+ prop_format_log t,+ testProperty "ISO 8601 same as Date.Time" $ \(ArbUTCTime t) ->+ prop_format_iso t,+ testProperty "ISO 8601 same as Aeson" $ \(ArbUTCTime t) ->+ prop_format_aeson t+ ] where t1 = UTCTime (fromGregorian 2016 12 34) 5025.123456789012 t2 = UTCTime (fromGregorian 2016 1 23) 5025.123@@ -72,10 +68,11 @@ prop_format_aeson :: UTCTime -> Property prop_format_aeson a = toJSON a === toJSON (formatAsIso8601 a) - newtype ArbUTCTime = ArbUTCTime UTCTime- deriving (Show)+ deriving (Show) instance Arbitrary ArbUTCTime where- arbitrary = fmap (ArbUTCTime . posixSecondsToUTCTime . fromInteger)- arbitrary+ arbitrary =+ fmap+ (ArbUTCTime . posixSecondsToUTCTime . fromInteger)+ arbitrary
test/Katip/Tests/Scribes/Handle.hs view
@@ -1,92 +1,94 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+ module Katip.Tests.Scribes.Handle- ( tests- ) where+ ( tests,+ )+where --------------------------------------------------------------------------------import Control.Monad-import Data.Aeson-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy as BL-import Data.Monoid as M-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as LT-import qualified Data.Text.Lazy.Builder as LT-import Data.Time-import Language.Haskell.TH.Syntax (Loc (..))-import Lens.Micro ((.~))-import System.Directory-import System.IO-import Test.Tasty-import Test.Tasty.Golden-import Test.Tasty.HUnit-import Text.Regex.TDFA---------------------------------------------------------------------------------import Katip+import Control.Monad+import Data.Aeson+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as BL+import Data.Monoid as M+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Builder as LT+import Data.Time -------------------------------------------------------------------------------+import Katip+import Language.Haskell.TH.Syntax (Loc (..))+import Lens.Micro ((.~))+import System.Directory+import System.IO+import Test.Tasty+import Test.Tasty.Golden+import Test.Tasty.HUnit+import Text.Regex.TDFA +------------------------------------------------------------------------------- tests :: TestTree-tests = testGroup "Katip.Scribes.Handle"- [- withResource setup teardown $ \setupScribe -> testCase "logs the correct data" $ do- (path, h, fin, le) <- setupScribe- runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message"- fin- runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "wont make it in"- hClose h- res <- readFile path- let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[PID [:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String- let matches = res =~ pat- assertBool (show res M.<> " did not match") matches- , withResource setupFile (const (return ())) $ \setupScribe -> testCase "logs correct data to a file" $ do- (path, fin, le) <- setupScribe- runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message"- fin- runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "wont make it in"- res <- readFile path- let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[PID [:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String- let matches = res =~ pat- assertBool (show res <> " did not match") matches- , withResource setupTempFile teardownTempFile $ \setupFn ->- goldenVsString "Text-golden"- "test/Katip/Tests/Scribes/Handle-text.golden"- (setupFn >>= writeTextLog)- , withResource setupTempFile teardownTempFile $ \setupFn ->- goldenVsString "Json-golden"- "test/Katip/Tests/Scribes/Handle-json.golden"- (setupFn >>= writeJsonLog)- ]-+tests =+ testGroup+ "Katip.Scribes.Handle"+ [ withResource setup teardown $ \setupScribe -> testCase "logs the correct data" $ do+ (path, h, fin, le) <- setupScribe+ runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message"+ fin+ runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "wont make it in"+ hClose h+ res <- readFile path+ let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[PID [:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String+ let matches = res =~ pat+ assertBool (show res M.<> " did not match") matches,+ withResource setupFile (const (return ())) $ \setupScribe -> testCase "logs correct data to a file" $ do+ (path, fin, le) <- setupScribe+ runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message"+ fin+ runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "wont make it in"+ res <- readFile path+ let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[PID [:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String+ let matches = res =~ pat+ assertBool (show res <> " did not match") matches,+ withResource setupTempFile teardownTempFile $ \setupFn ->+ goldenVsString+ "Text-golden"+ "test/Katip/Tests/Scribes/Handle-text.golden"+ (setupFn >>= writeTextLog),+ withResource setupTempFile teardownTempFile $ \setupFn ->+ goldenVsString+ "Json-golden"+ "test/Katip/Tests/Scribes/Handle-json.golden"+ (setupFn >>= writeJsonLog)+ ] --------------------------------------------------------------------------------data DummyLogItem = DummyLogItem {- dliNote :: Text- }-+data DummyLogItem = DummyLogItem+ { dliNote :: Text+ } instance ToJSON DummyLogItem where- toJSON dli = object- [ "note" .= object [ "deep" .= dliNote dli- ]- ]-+ toJSON dli =+ object+ [ "note"+ .= object+ [ "deep" .= dliNote dli+ ]+ ] instance ToObject DummyLogItem - instance LogItem DummyLogItem where payloadKeys _ _ = AllKeys - ------------------------------------------------------------------------------- dummyLogItem :: DummyLogItem dummyLogItem = DummyLogItem "some note" - ------------------------------------------------------------------------------- setup :: IO (FilePath, Handle, IO (), LogEnv) setup = do@@ -97,14 +99,12 @@ le' <- registerScribe "handle" s defaultScribeSettings le return (fp, h, void (closeScribes le'), le') - ------------------------------------------------------------------------------- teardown :: (a, Handle, b, c) -> IO () teardown (_, h, _, _) = do chk <- hIsOpen h when chk $ hClose h - ------------------------------------------------------------------------------- setupFile :: IO (FilePath, IO (), LogEnv) setupFile = do@@ -116,7 +116,6 @@ le' <- registerScribe "handle" s defaultScribeSettings le return (fp, void (closeScribes le'), le') - -- Following code tests Handle scribe output against a golden file. -- This test will fail on non utf8 locales because golden file is in utf-8. -- It generates all meaningfull variations of Item, and also tests@@ -125,109 +124,123 @@ -- Note: currently Handle scribe does not write Array items at all ------------------------------------------------------------------------------- data AllTypesLogItem = AllTypesLogItem- { atlText :: Text- , atlNum :: Int- , atlFloat :: Float- , atlList :: [Text]- , atlSub :: Maybe DummyLogItem- }-+ { atlText :: Text,+ atlNum :: Int,+ atlFloat :: Float,+ atlList :: [Text],+ atlSub :: Maybe DummyLogItem+ } instance ToJSON AllTypesLogItem where- toJSON it = object- [ "text" .= atlText it- , "num" .= atlNum it- , "float" .= atlFloat it- , "list" .= atlList it- , "sub" .= atlSub it- ]-+ toJSON it =+ object+ [ "text" .= atlText it,+ "num" .= atlNum it,+ "float" .= atlFloat it,+ "list" .= atlList it,+ "sub" .= atlSub it+ ] instance ToObject AllTypesLogItem - instance LogItem AllTypesLogItem where payloadKeys _ _ = AllKeys - ------------------------------------------------------------------------------- theItem :: Item DummyLogItem-theItem = Item (Namespace ["app"])- (Environment "production")- (InfoS)- (ThreadIdText "1337")- "example"- 7331- dummyLogItem- "message"- (mkUTCTime 2016 6 12 12 34 56)- (Namespace ["foo"])- Nothing+theItem =+ Item+ (Namespace ["app"])+ (Environment "production")+ (InfoS)+ (ThreadIdText "1337")+ "example"+ 7331+ dummyLogItem+ "message"+ (mkUTCTime 2016 6 12 12 34 56)+ (Namespace ["foo"])+ Nothing genItems :: [Item DummyLogItem]-genItems = concat $- [ [ itemSeverity .~ s $ theItem- | s <- [minBound .. maxBound]- ]- , [ itemThread .~ (ThreadIdText . T.pack $ show t) $ theItem- | t <- [0 :: Int, 1, 1337, 2147483647]- ]- , [ itemHost .~ h $ theItem- | h <- ["example", "www.example.com", "127.0.0.1"]- ]- , [ itemProcess .~ p $ theItem- | p <- [0, 1, 1337, 2147483647]- ]- , [ itemMessage .~ LogStr m $ theItem- | m <- [ "message"- , "message\nwith newline"- , LT.fromLazyText (LT.replicate 40 " a really long message")- , "сообщение"- , "哈囉世界"- ]- ]- , [ itemTime .~ t $ theItem- | t <- genDates- ]- , [ itemNamespace .~ Namespace ns $ theItem- | ns <- [ ["foo"]- , ["foo", "bar"]- , ["фу", "бар"]- , ["with\nnewline"] ]- ]- , [ itemLoc .~ l $ theItem | l <- genLocs+genItems =+ concat $+ [ [ itemSeverity .~ s $ theItem+ | s <- [minBound .. maxBound]+ ],+ [ itemThread .~ (ThreadIdText . T.pack $ show t) $ theItem+ | t <- [0 :: Int, 1, 1337, 2147483647]+ ],+ [ itemHost .~ h $ theItem+ | h <- ["example", "www.example.com", "127.0.0.1"]+ ],+ [ itemProcess .~ p $ theItem+ | p <- [0, 1, 1337, 2147483647]+ ],+ [ itemMessage .~ LogStr m $ theItem+ | m <-+ [ "message",+ "message\nwith newline",+ LT.fromLazyText (LT.replicate 40 " a really long message"),+ "сообщение",+ "哈囉世界"+ ]+ ],+ [ itemTime .~ t $ theItem+ | t <- genDates+ ],+ [ itemNamespace .~ Namespace ns $ theItem+ | ns <-+ [ ["foo"],+ ["foo", "bar"],+ ["фу", "бар"],+ ["with\nnewline"]+ ]+ ],+ [ itemLoc .~ l $ theItem | l <- genLocs+ ] ]- ] genDates :: [UTCTime] genDates =- [ mkUTCTime 2000 1 1 0 0 0.0- , mkUTCTime 2123 12 31 23 59 59.999999999999- , mkUTCTime 2016 10 10 1 1 5.0- , mkUTCTime 2100 12 31 12 59 10.1- , mkUTCTime 1982 1 1 12 30 0.000000000001+ [ mkUTCTime 2000 1 1 0 0 0.0,+ mkUTCTime 2123 12 31 23 59 59.999999999999,+ mkUTCTime 2016 10 10 1 1 5.0,+ mkUTCTime 2100 12 31 12 59 10.1,+ mkUTCTime 1982 1 1 12 30 0.000000000001 ] genLocs :: [Maybe Loc] genLocs =- [ Nothing- , Just $ Loc "path/Some/Module.hs"- "main"- "Some.Module"- (30,1) (30,14)- , Just $ Loc "путь/Some/Module.hs"- "main"- "Some.Module"- (3000,9000) (4000,1)+ [ Nothing,+ Just $+ Loc+ "path/Some/Module.hs"+ "main"+ "Some.Module"+ (30, 1)+ (30, 14),+ Just $+ Loc+ "путь/Some/Module.hs"+ "main"+ "Some.Module"+ (3000, 9000)+ (4000, 1) ] genTypedItems :: [Item AllTypesLogItem] genTypedItems = [ itemPayload .~ p $ theItem- | p <- [ AllTypesLogItem "" 0 0.0 [] Nothing- , AllTypesLogItem "note" 10 5.5 ["one", "two", "three"]- (Just dummyLogItem)- ]+ | p <-+ [ AllTypesLogItem "" 0 0.0 [] Nothing,+ AllTypesLogItem+ "note"+ 10+ 5.5+ ["one", "two", "three"]+ (Just dummyLogItem)+ ] ] mkUTCTime :: Integer -> Int -> Int -> DiffTime -> DiffTime -> DiffTime -> UTCTime@@ -243,12 +256,12 @@ writeJsonLog :: (FilePath, Handle) -> IO (BL.ByteString) writeJsonLog = writeFormattedLog jsonFormat -writeFormattedLog :: (forall a . LogItem a => ItemFormatter a) -> (FilePath, Handle) -> IO (BL.ByteString)+writeFormattedLog :: (forall a. LogItem a => ItemFormatter a) -> (FilePath, Handle) -> IO (BL.ByteString) writeFormattedLog format (path, h) = do- mapM_ (put . formatOne) genItems- mapM_ (put . formatOne) genTypedItems- hClose h- BL.readFile path+ mapM_ (put . formatOne) genItems+ mapM_ (put . formatOne) genTypedItems+ hClose h+ BL.readFile path where formatOne :: LogItem a => Item a -> Text formatOne = LT.toStrict . LT.toLazyText . format False V3@@ -256,11 +269,11 @@ setupTempFile :: IO (FilePath, Handle) setupTempFile = do- tempDir <- getTemporaryDirectory- (fp, h) <- openBinaryTempFile tempDir "katip.log"- return (fp, h)+ tempDir <- getTemporaryDirectory+ (fp, h) <- openBinaryTempFile tempDir "katip.log"+ return (fp, h) teardownTempFile :: (FilePath, Handle) -> IO () teardownTempFile (_, h) = do- chk <- hIsOpen h- when chk $ hClose h+ chk <- hIsOpen h+ when chk $ hClose h
test/Main.hs view
@@ -1,21 +1,23 @@ module Main (main) where --------------------------------------------------------------------------------import Test.Tasty+ ------------------------------------------------------------------------------- import qualified Katip.Tests import qualified Katip.Tests.Format.Time import qualified Katip.Tests.Scribes.Handle--------------------------------------------------------------------------------+import Test.Tasty +------------------------------------------------------------------------------- main :: IO () main = defaultMain testSuite testSuite :: TestTree-testSuite = testGroup "katip"- [- Katip.Tests.tests- , Katip.Tests.Format.Time.tests- , Katip.Tests.Scribes.Handle.tests- ]+testSuite =+ testGroup+ "katip"+ [ Katip.Tests.tests,+ Katip.Tests.Format.Time.tests,+ Katip.Tests.Scribes.Handle.tests+ ]