katip 0.1.1.0 → 0.2.0.0

raw patch · 11 files changed

+406/−88 lines, 11 filesdep +microlensdep +microlens-thdep −lensdep −lens-aesondep ~mtldep ~transformersdep ~transformers-basePVP ok

version bump matches the API change (PVP)

Dependencies added: microlens, microlens-th

Dependencies removed: lens, lens-aeson

Dependency ranges changed: mtl, transformers, transformers-base, unordered-containers

API changes (from Hackage documentation)

Files

• README.md +6/−3
• changelog.md +17/−0
• examples/example.hs +3/−2
• examples/example_lens.hs +3/−2
• katip.cabal +14/−6
• src/Katip.hs +108/−13
• src/Katip/Core.hs +109/−37
• src/Katip/Monadic.hs +67/−7
• src/Katip/Scribes/Handle.hs +13/−13
• test/Katip/Tests.hs +58/−1
• test/Katip/Tests/Scribes/Handle.hs +8/−4

@@ -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

@@ -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 ============== 

@@ -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

@@ -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

@@ -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

@@ -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+<https://github.com/Soostone/katip/tree/master/katip/examples these+examples>.+-}

@@ -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 <https://hackage.haskell.org/package/base-4.8.2.0/docs/GHC-Stack.html#v:getCallStack implicit-callstacks>+-- 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

@@ -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 <https://hackage.haskell.org/package/base-4.8.2.0/docs/GHC-Stack.html#v:getCallStack implicit-callstacks>+-- 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)

@@ -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   -------------------------------------------------------------------------------

@@ -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) 

@@ -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