diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ Katip is a structured logging framework for Haskell. -![Katip](./katip.jpg) +![Katip](https://github.com/Soostone/katip/blob/master/katip/katip.jpg) Kâtip (pronounced kah-tip) is the Turkish word for scribe. @@ -69,8 +69,11 @@ ## Examples -Be sure to look in the [examples](./examples) directory for some examples of how -to integrate Katip into your own stack. + +Be sure to look in the +[examples](https://github.com/Soostone/katip/blob/master/katip/examples) +directory for some examples of how to integrate Katip into your own +stack. ## Contributors diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,20 @@ +0.2.0.0 +======= + +* Add GHC implicit callstack support, add logLoc. +* Drop lens in favor of type-compatible, lighter microlens. +* Renamed `logEnvNs` to clearer `logEnvApp` +* Added `katipAddNamespace` and `katipAddContext` +* Fixed nested objects not rendering in Handle scribe. +* LogContexts Monoid instance is now right-biased rather than left + biased. This better fits the use case. For instance `ctx1 <> ctx2` + will prefer keys in `ctx2` if there are conflicts. This makes the + most sense because functions like `katipAddContext` will `mappend` + on the right side. +* LogContext internally uses a `Seq` instead of a list for better + complexity on context add. +* Improved documentation. + 0.1.1.0 ============== diff --git a/examples/example.hs b/examples/example.hs --- a/examples/example.hs +++ b/examples/example.hs @@ -9,6 +9,7 @@ ------------------------------------------------------------------------------- +import qualified Control.Applicative as A import Control.Monad.Reader import Data.Aeson import Data.Monoid as M @@ -22,7 +23,7 @@ -- lens_example for a slightly cleaner and more general pattern. main :: IO () main = do - le <- initLogEnv "main" "production" + le <- initLogEnv "MyApp" "production" -- We'll set up a scribe that logs to stdout and will only log item -- fields permitted for Verbosity 2 and will throw out Debug -- messages entirely. Note that katip provides facilities like @@ -77,7 +78,7 @@ ------------------------------------------------------------------------------- newtype MyStack m a = MyStack { unStack :: ReaderT MyState m a - } deriving (MonadReader MyState, Functor, Applicative, Monad, MonadIO) + } deriving (MonadReader MyState, Functor, A.Applicative, Monad, MonadIO) instance (MonadIO m) => Katip (MyStack m) where diff --git a/examples/example_lens.hs b/examples/example_lens.hs --- a/examples/example_lens.hs +++ b/examples/example_lens.hs @@ -9,6 +9,7 @@ ------------------------------------------------------------------------------- +import Control.Applicative as A import Control.Lens hiding ((.=)) import Control.Monad.Reader import Data.Aeson @@ -38,7 +39,7 @@ -- lens_example for a slightly cleaner and more general pattern. main :: IO () main = do - le <- initLogEnv "main" "production" + le <- initLogEnv "MyApp" "production" -- We'll set up a scribe that logs to stdout and will only log item -- fields permitted for Verbosity 2 and will throw out Debug -- messages entirely. Note that katip provides facilities like @@ -85,7 +86,7 @@ ------------------------------------------------------------------------------- newtype MyStack m a = MyStack { unStack :: ReaderT MyState m a - } deriving (MonadReader MyState, Functor, Applicative, Monad, MonadIO) + } deriving (MonadReader MyState, Functor, A.Applicative, Monad, MonadIO) instance (MonadIO m) => Katip (MyStack m) where diff --git a/katip.cabal b/katip.cabal --- a/katip.cabal +++ b/katip.cabal @@ -1,5 +1,5 @@ name: katip -version: 0.1.1.0 +version: 0.2.0.0 synopsis: A structured logging framework. description: Katip is a structured logging framework. See README.md for more details. @@ -10,6 +10,8 @@ maintainer: ozgun.ataman@soostone.com copyright: Soostone Inc, 2015-2016 category: Data, Text, Logging +homepage: https://github.com/Soostone/katip +bug-reports: https://github.com/Soostone/katip/issues build-type: Simple cabal-version: >=1.10 extra-source-files: @@ -21,7 +23,12 @@ test/Main.hs test/Katip/Tests.hs test/Katip/Tests/Scribes/Handle.hs +tested-with: GHC == 7.8.4, GHC== 7.10.3 +source-repository head + type: git + location: https://github.com/Soostone/katip.git + flag lib-Werror default: False manual: True @@ -51,22 +58,22 @@ , either >= 4 && < 4.5 , exceptions >= 0.5 && < 0.9 , hostname >=1.0 && <1.1 - , lens >= 4.4 && <4.14 - , lens-aeson < 1.1 , old-locale >= 1.0 && < 1.1 , string-conv >= 0.1 && < 0.2 , template-haskell >= 2.8 && < 2.11 , text >= 0.11 && <1.3 , time >= 1 && < 1.6 , time-locale-compat >= 0.1.0.1 && < 0.2 - , transformers >= 0.3 && < 0.5 + , transformers >= 0.3 && < 0.6 , transformers-compat , unix >= 2.5 && < 2.8 , unordered-containers >= 0.2 && < 0.3 , monad-control >= 1.0 && < 1.1 - , mtl >= 2.2 && < 2.3 - , transformers-base >= 0.4.1 && < 0.5 + , mtl >= 2.0 && < 2.3 + , transformers-base >= 0.3 && < 0.5 , resourcet >= 1.1 && < 1.2 + , microlens >= 0.2.0.0 && < 0.5 + , microlens-th >= 0.1.0.0 && < 0.5 hs-source-dirs: src default-language: Haskell2010 @@ -92,6 +99,7 @@ , temporary , directory , regex-tdfa-rc + , unordered-containers benchmark bench diff --git a/src/Katip.hs b/src/Katip.hs --- a/src/Katip.hs +++ b/src/Katip.hs @@ -26,17 +26,22 @@ ( -- * Framework Types - - Katip (..) - , Namespace (..) + Namespace (..) , Environment (..) , Severity (..) , renderSeverity - , severityText + , textToSeverity , Verbosity (..) , ToObject (..) , LogItem (..) , Item(..) + , ThreadIdText(..) + , PayloadSelection (..) + , Scribe (..) + , LogEnv (..) + , SimpleLogPayload, sl + + -- ** @lens@-compatible Lenses , itemApp , itemEnv , itemSeverity @@ -48,20 +53,12 @@ , itemTime , itemNamespace , itemLoc - , ThreadIdText(..) - , PayloadSelection (..) - , Scribe (..) - , LogEnv (..) , logEnvHost , logEnvPid - , logEnvNs + , logEnvApp , logEnvEnv , logEnvTimer , logEnvScribes - , KatipContext(..) - , AnyLogContext - , LogContexts, liftPayload - , SimpleLogPayload, sl -- * A Built-in Monad For Logging , KatipT (..) @@ -77,15 +74,23 @@ , LogStr (..) , logStr, ls, showLS + -- ** 'Katip' LoggingFunctions + -- $katiplogging + , Katip (..) , logF , logMsg , logT , logItem , logException + -- ** 'KatipContext' Logging Functions + -- $katipcontextlogging + , KatipContext (..) , logFM , logTM , logItemM , logExceptionM + , AnyLogContext + , LogContexts, liftPayload -- * Included Scribes , mkHandleScribe @@ -99,6 +104,8 @@ -- * KatipContextT - Utility transformer that provides Katip and KatipContext instances , KatipContextT , runKatipContextT + , katipAddNamespace + , katipAddContext ) where ------------------------------------------------------------------------------- @@ -106,3 +113,91 @@ 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 +eachother. 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 +UderIDContext 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" + + 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 +. +-} diff --git a/src/Katip/Core.hs b/src/Katip/Core.hs --- a/src/Katip/Core.hs +++ b/src/Katip/Core.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -11,13 +13,14 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +-- | This module is not meant to be imported directly and may contain +-- internal mechanisms that will change without notice. module Katip.Core where ------------------------------------------------------------------------------- import Control.Applicative as A import Control.AutoUpdate import Control.Concurrent -import Control.Lens import Control.Monad.Base import Control.Monad.Catch import Control.Monad.IO.Class @@ -45,13 +48,26 @@ import qualified Data.Text.Lazy.Builder as B import Data.Time import GHC.Generics hiding (to) +#if MIN_VERSION_base(4, 8, 0) +import GHC.SrcLoc +import GHC.Stack +#endif import Language.Haskell.TH import qualified Language.Haskell.TH.Syntax as TH +import Lens.Micro +import Lens.Micro.TH import Network.HostName import System.Posix ------------------------------------------------------------------------------- +readMay :: Read a => String -> Maybe a +readMay s = case [x | (x,t) <- reads s, ("","") <- lex t] of + [x] -> Just x + [] -> Nothing -- no parse + _ -> Nothing -- Ambiguous parse + + ------------------------------------------------------------------------------- -- | Represents a heirarchy of namespaces going from general to -- specific. For instance: ["processname", "subsystem"]. Note that @@ -116,27 +132,25 @@ ------------------------------------------------------------------------------- -severityText :: Prism' Text Severity -severityText = prism renderSeverity toSev - where - toSev "Debug" = Right DebugS - toSev "Info" = Right InfoS - toSev "Notice" = Right NoticeS - toSev "Warning" = Right WarningS - toSev "Error" = Right ErrorS - toSev "Critical" = Right CriticalS - toSev "Alert" = Right AlertS - toSev "Emergency" = Right EmergencyS - toSev x = Left x +textToSeverity :: Text -> Maybe Severity +textToSeverity "Debug" = Just DebugS +textToSeverity "Info" = Just InfoS +textToSeverity "Notice" = Just NoticeS +textToSeverity "Warning" = Just WarningS +textToSeverity "Error" = Just ErrorS +textToSeverity "Critical" = Just CriticalS +textToSeverity "Alert" = Just AlertS +textToSeverity "Emergency" = Just EmergencyS +textToSeverity _ = Nothing -instance ToJSON Severity where - toJSON s = A.String (s ^. re severityText) +instance ToJSON Severity where + toJSON s = A.String (renderSeverity s) instance FromJSON Severity where parseJSON = A.withText "Severity" parseSeverity where - parseSeverity t = case t ^? severityText of + parseSeverity t = case textToSeverity t of Just x -> return x Nothing -> fail $ "Invalid Severity " ++ toS t @@ -289,28 +303,27 @@ <*> (fmap getLocJs <$> o A..: "loc") -processIDText :: Prism' Text ProcessID -processIDText = prism fromProcessID toProcessID - where - fromProcessID = toS . show - toProcessID t = case toS t ^? _Show of - Just i -> Right i - Nothing -> Left t +processIDToText :: ProcessID -> Text +processIDToText = toS . show +textToProcessID :: Text -> Maybe ProcessID +textToProcessID = readMay . toS + + newtype ProcessIDJs = ProcessIDJs { getProcessIDJs :: ProcessID } instance ToJSON ProcessIDJs where - toJSON (ProcessIDJs p) = A.String (p ^. re processIDText) + toJSON (ProcessIDJs p) = A.String (processIDToText p) instance FromJSON ProcessIDJs where parseJSON = A.withText "ProcessID" parseProcessID where - parseProcessID t = case t ^? processIDText of + parseProcessID t = case textToProcessID t of Just p -> return $ ProcessIDJs p Nothing -> fail $ "Invalid ProcessIDJs " ++ toS t @@ -320,6 +333,7 @@ data PayloadSelection = AllKeys | SomeKeys [Text] + deriving (Show, Eq) instance Monoid PayloadSelection where mempty = SomeKeys [] @@ -475,12 +489,18 @@ data LogEnv = LogEnv { _logEnvHost :: HostName , _logEnvPid :: ProcessID - , _logEnvNs :: Namespace + , _logEnvApp :: Namespace + -- ^ Name of application. This will typically never change. This + -- field gets prepended to the namespace of your individual log + -- messages. For example, if your app is MyApp and you write a log + -- using "logItem" and the namespace "WebServer", the final + -- namespace will be "MyApp.WebServer" , _logEnvEnv :: Environment , _logEnvTimer :: IO UTCTime -- ^ Action to fetch the timestamp. You can use something like -- 'AutoUpdate' for high volume logs but note that this may cause - -- some output forms to display logs out of order. + -- some output forms to display logs out of order. Alternatively, + -- you could just use 'getCurrentTime'. , _logEnvScribes :: M.Map Text Scribe } makeLenses ''LogEnv @@ -515,7 +535,7 @@ -> Scribe -> LogEnv -> LogEnv -registerScribe nm h = logEnvScribes . at nm .~ Just h +registerScribe nm h = logEnvScribes %~ M.insert nm h ------------------------------------------------------------------------------- @@ -526,7 +546,7 @@ -- ^ Name of the scribe -> LogEnv -> LogEnv -unregisterScribe nm = logEnvScribes . at nm .~ Nothing +unregisterScribe nm = logEnvScribes %~ M.delete nm ------------------------------------------------------------------------------- @@ -539,8 +559,16 @@ ------------------------------------------------------------------------------- --- | Monads where katip logging actions can be performed -class MonadIO m => Katip m where +-- | Monads where katip logging actions can be performed. Katip is the +-- most basic logging monad. You will typically use this directly if +-- you either don't want to use namespaces/contexts heavily or if you +-- want to pass in specific contexts and/or namespaces at each log site. +-- +-- For something more powerful, look at the docs for 'KatipContext', +-- which keeps a namespace and merged context. You can write simple +-- functions that add additional namespacing and merges additional +-- context on the fly. +class MonadIO m => Katip m where getLogEnv :: m LogEnv @@ -615,7 +643,7 @@ LogEnv{..} <- getLogEnv liftIO $ do item <- Item - <$> pure _logEnvNs + <$> pure _logEnvApp <*> pure _logEnvEnv <*> pure sev <*> (mkThreadIdText <$> myThreadId) @@ -624,7 +652,7 @@ <*> pure a <*> pure msg <*> _logEnvTimer - <*> pure (_logEnvNs <> ns) + <*> pure (_logEnvApp <> ns) <*> pure loc FT.forM_ (M.elems _logEnvScribes) $ \ (Scribe h) -> h item @@ -712,17 +740,61 @@ ------------------------------------------------------------------------------- -- | For use when you want to include location in your logs. This will --- fill the 'Maybe Loc' gap in 'logF' of this module. -getLoc :: Q Exp -getLoc = [| $(location >>= liftLoc) |] +-- fill the 'Maybe Loc' gap in 'logF' of this module, and relies on implicit +-- callstacks when available (GHC > 7.8). +#if MIN_VERSION_base(4, 8, 0) +getLoc :: (?loc :: CallStack) => Maybe Loc +getLoc = case getCallStack ?loc of + [] -> Nothing + xs -> Just . toLoc . last $ xs + where + toLoc :: (String, SrcLoc) -> Loc + toLoc (_, l) = Loc { + loc_filename = srcLocFile l + , loc_package = srcLocPackage l + , loc_module = srcLocModule l + , loc_start = (srcLocStartLine l, srcLocStartCol l) + , loc_end = (srcLocEndLine l, srcLocEndCol l) + } +#else +getLoc :: Maybe Loc +getLoc = Nothing +#endif ------------------------------------------------------------------------------- +-- Like `getLoc`, but uses template-haskell and works with older versions of +-- the compiler (GHC 7.8 or older). +getLocTH :: ExpQ +getLocTH = [| $(location >>= liftLoc) |] + + +------------------------------------------------------------------------------- -- | 'Loc'-tagged logging when using template-haskell. -- -- @$(logT) obj mempty InfoS "Hello world"@ logT :: ExpQ -logT = [| \ a ns sev msg -> logItem a ns (Just $(getLoc)) sev msg |] +logT = [| \ a ns sev msg -> logItem a ns (Just $(getLocTH)) sev msg |] + + +------------------------------------------------------------------------------- +-- | 'Loc'-tagged logging using implicit-callstacks when available. +-- +-- This function does not require template-haskell as it +-- automatically uses +-- when the code is compiled using GHC > 7.8. Using an older version of the +-- compiler will result in the emission of a log line without any location information, +-- so be aware of it. Users using GHC <= 7.8 may want to use the template-haskell function +-- `logT` for maximum compatibility. +-- +-- @logLoc obj mempty InfoS "Hello world"@ +logLoc :: (Applicative m, LogItem a, Katip m) + => a + -> Namespace + -> Severity + -> LogStr + -> m () +logLoc a ns = logItem a ns getLoc -- taken from the file-location package diff --git a/src/Katip/Monadic.hs b/src/Katip/Monadic.hs --- a/src/Katip/Monadic.hs +++ b/src/Katip/Monadic.hs @@ -16,6 +16,7 @@ -- * Monadic variants of logging functions from "Katip.Core" logFM , logTM + , logLocM , logItemM , logExceptionM @@ -28,6 +29,8 @@ -- * KatipContextT - Utility transformer that provides Katip and KatipContext instances , KatipContextT(..) , runKatipContextT + , katipAddNamespace + , katipAddContext , KatipContextTState(..) ) where @@ -53,8 +56,10 @@ import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT) import Control.Monad.Writer import Data.Aeson +import qualified Data.Foldable as FT import qualified Data.HashMap.Strict as HM import Data.Monoid as M +import Data.Sequence as Seq import Data.Text (Text) import Language.Haskell.TH ------------------------------------------------------------------------------- @@ -72,17 +77,29 @@ -- 'LogContext' instance for combining multiple payload policies. This -- is critical for log contexts deep down in a stack to be able to -- inject their own context without worrying about other context that --- has already been set. -newtype LogContexts = LogContexts [AnyLogContext] deriving (Monoid) +-- has already been set. Also note that contexts are treated as a +-- sequence and '<>' will be appended to the right hand side of the +-- sequence. If there are conflicting keys in the contexts, the /right +-- side will take precedence/, which is counter to how monoid works +-- for 'Map' and 'HashMap', so bear that in mind. The reasoning is +-- that if the user is /sequentially/ adding contexts to the right +-- side of the sequence, on conflict the intent is to overwrite with +-- the newer value (i.e. the rightmost value). +-- +-- Additional note: you should not mappend LogContexts in any sort of +-- infinite loop, as it retains all data, so that would be a memory +-- leak. +newtype LogContexts = LogContexts (Seq AnyLogContext) deriving (Monoid) instance ToJSON LogContexts where toJSON (LogContexts cs) = - Object $ mconcat $ map (\(AnyLogContext v) -> toObject v) 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) = mconcat $ map payloadKeys' vs + 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 @@ -96,7 +113,7 @@ -- | 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 . (:[]) . AnyLogContext +liftPayload = LogContexts . Seq.singleton . AnyLogContext ------------------------------------------------------------------------------- @@ -171,12 +188,33 @@ -- | 'Loc'-tagged logging when using template-haskell. Automatically -- supplies payload and namespace. -- --- @$(logt) InfoS "Hello world"@ +-- @$(logTM) InfoS "Hello world"@ logTM :: ExpQ -logTM = [| logItemM (Just $(getLoc)) |] +logTM = [| logItemM (Just $(getLocTH)) |] ------------------------------------------------------------------------------- +-- | 'Loc'-tagged logging when using template-haskell. Automatically +-- supplies payload and namespace. +-- +-- Same consideration as `logLoc` applies. +-- +-- This function does not require template-haskell as it +-- automatically uses +-- when the code is compiled using GHC > 7.8. Using an older version of the +-- compiler will result in the emission of a log line without any location information, +-- so be aware of it. Users using GHC <= 7.8 may want to use the template-haskell function +-- `logTM` for maximum compatibility. +-- +-- @logLocM InfoS "Hello world"@ +logLocM :: (Applicative m, KatipContext m, Katip m) + => Severity + -> LogStr + -> m () +logLocM = logItemM getLoc + + +------------------------------------------------------------------------------- -- | Perform an action while logging any exceptions that may occur. -- Inspired by 'onException`. -- @@ -270,3 +308,25 @@ runKatipContextT le ctx ns = flip runReaderT lts . unKatipContextT where lts = KatipContextTState le (liftPayload ctx) ns + + +------------------------------------------------------------------------------- +katipAddNamespace + :: (Monad m) + => Namespace + -> KatipContextT m a + -> KatipContextT m a +katipAddNamespace ns (KatipContextT f) = + KatipContextT (local (\r -> r { ltsNamespace = (ltsNamespace r) <> ns}) f) + + +------------------------------------------------------------------------------- +katipAddContext + :: ( LogItem i + , Monad m + ) + => i + -> KatipContextT m a + -> KatipContextT m a +katipAddContext i (KatipContextT f) = + KatipContextT (local (\r -> r { ltsContext = (ltsContext r) <> liftPayload i}) f) diff --git a/src/Katip/Scribes/Handle.hs b/src/Katip/Scribes/Handle.hs --- a/src/Katip/Scribes/Handle.hs +++ b/src/Katip/Scribes/Handle.hs @@ -3,11 +3,12 @@ module Katip.Scribes.Handle where ------------------------------------------------------------------------------- -import Control.Lens +import Control.Applicative as A import Control.Monad -import Data.Aeson.Lens +import Data.Aeson import qualified Data.HashMap.Strict as HM import Data.Monoid +import Data.Text (Text) import Data.Text.Lazy.Builder import Data.Text.Lazy.IO as T import Data.Time @@ -26,18 +27,17 @@ ------------------------------------------------------------------------------- getKeys :: LogItem s => Verbosity -> s -> [Builder] -getKeys verb a = payloadObject verb a ^.. - to HM.toList . traverse . to rendPair +getKeys verb a = concat (renderPair A.<$> HM.toList (payloadObject verb a)) where - rendPair (k,v) = fromText k <> fromText ":" <> (v ^. _Primitive . to renderPrim) - - -------------------------------------------------------------------------------- -renderPrim :: Primitive -> Builder -renderPrim (StringPrim t) = fromText t -renderPrim (NumberPrim s) = fromString (show s) -renderPrim (BoolPrim b) = fromString (show b) -renderPrim NullPrim = fromText "null" + renderPair :: (Text, Value) -> [Builder] + renderPair (k,v) = + case v of + Object o -> concat [renderPair (k <> "." <> k', v') | (k', v') <- HM.toList o] + String t -> [fromText (k <> ":" <> t)] + Number n -> [fromText (k <> ":") <> fromString (show n)] + Bool b -> [fromText (k <> ":") <> fromString (show b)] + Null -> [fromText (k <> ":null")] + _ -> mempty -- Can't think of a sensible way to handle arrays ------------------------------------------------------------------------------- diff --git a/test/Katip/Tests.hs b/test/Katip/Tests.hs --- a/test/Katip/Tests.hs +++ b/test/Katip/Tests.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -10,6 +13,9 @@ ------------------------------------------------------------------------------- import Control.Applicative import Data.Aeson +import qualified Data.HashMap.Strict as HM +import Data.Monoid +import Data.Text (Text) import qualified Data.Text.Lazy.Builder as B import Data.Time import Data.Time.Clock.POSIX @@ -17,9 +23,11 @@ import System.Posix.Types import Test.QuickCheck.Instances () import Test.Tasty +import Test.Tasty.HUnit import Test.Tasty.QuickCheck ------------------------------------------------------------------------------- import Katip +import Katip.Core ------------------------------------------------------------------------------- @@ -27,11 +35,57 @@ tests = testGroup "Katip" [ testProperty "JSON cycle Item" $ \(i :: Item ()) -> - prop_json_cycle i + prop_json_cycle i + , 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 ] ------------------------------------------------------------------------------- +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"] + ] + + +------------------------------------------------------------------------------- +data ConservativePayload = ConservativePayload { + oftenShown :: Text + , rarelyShown :: Text + } + + +instance ToJSON ConservativePayload where + 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 + +------------------------------------------------------------------------------- prop_json_cycle :: (ToJSON a, FromJSON a, Eq a, Show a) => a -> Property prop_json_cycle a = eitherDecode (encode a) === Right a @@ -69,6 +123,9 @@ deriving instance Arbitrary Environment deriving instance Arbitrary ThreadIdText deriving instance Arbitrary CPid +#if !MIN_VERSION_base(4, 8, 0) +deriving instance Eq Loc +#endif deriving instance Eq LogStr deriving instance (Eq a) => Eq (Item a) diff --git a/test/Katip/Tests/Scribes/Handle.hs b/test/Katip/Tests/Scribes/Handle.hs --- a/test/Katip/Tests/Scribes/Handle.hs +++ b/test/Katip/Tests/Scribes/Handle.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Katip.Tests.Scribes.Handle ( tests ) where @@ -6,6 +6,7 @@ ------------------------------------------------------------------------------- import Control.Monad import Data.Aeson +import Data.Monoid import Data.Text (Text) import qualified Data.Text.IO as T import System.Directory @@ -27,9 +28,9 @@ runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message" hClose h res <- readFile path - let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[[:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note:some note\\] test message" :: String + let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[[:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String let matches = res =~ pat - matches @?= True + assertBool (res <> " did not match") matches ] @@ -40,7 +41,10 @@ instance ToJSON DummyLogItem where - toJSON (DummyLogItem n) = object ["note" .= n] + toJSON (DummyLogItem n) = object + [ "note" .= object [ "deep" .= n + ] + ] instance ToObject DummyLogItem