katip 0.2.0.0 → 0.3.0.0

raw patch · 9 files changed

+184/−41 lines, 9 filesdep +asyncdep +regex-tdfadep +semigroupsdep −regex-tdfa-rcdep ~template-haskelldep ~timedep ~transformers-basePVP ok

version bump matches the API change (PVP)

Dependencies added: async, regex-tdfa, semigroups

Dependencies removed: regex-tdfa-rc

Dependency ranges changed: template-haskell, time, transformers-base

API changes (from Hackage documentation)

Files

• bench/Main.hs +7/−4
• changelog.md +13/−0
• examples/example.hs +37/−4
• examples/example_lens.hs +37/−5
• katip.cabal +10/−8
• src/Katip.hs +1/−0
• src/Katip/Core.hs +44/−13
• src/Katip/Monadic.hs +23/−4
• src/Katip/Scribes/Handle.hs +12/−3

@@ -12,7 +12,7 @@ import           Control.DeepSeq import           Criterion.Main import           Data.Aeson-import           Data.Monoid          as M+import           Data.Monoid              as M import           Data.Time.Calendar import           Data.Time.Clock import           System.IO@@ -31,12 +31,15 @@ ------------------------------------------------------------------------------- handleScribeBench :: Benchmark handleScribeBench = bgroup "Katip.Scribes.Handle" [-      env setupEnv $ \ ~(Scribe push, tid) ->+      env setupHandleEnv $ \ ~(Scribe push, tid) ->       bench "Bytestring Builder" $         whnfIO $ push $ exItem tid     ]-  where-    setupEnv = do+++-------------------------------------------------------------------------------+setupHandleEnv :: IO (Scribe, ThreadIdText)+setupHandleEnv = do       scribe <- setup       tid <- myThreadId       return (scribe, mkThreadIdText tid)

@@ -1,3 +1,16 @@+0.3.0.0+=======+* Switch from `regex-tdfa-rc` to `regex-tdfa`.+* Add `katipNoLogging` combinator.+* Add `Semigroup` instances.+* Drop `ToJSON` superclass requirement fro `ToObject`. Instead,+  `ToObject` will provide a default instance for types with an+  instance for `ToJSON`. This gets us to the same place as before+  without having to add a broader instance for something that's only+  going to show up in logs as an Object.+* Add a simple MVar lock for file handle scribes to avoid interleaved+  log lines from concurrent inputs.+ 0.2.0.0 ======= 

@@ -1,19 +1,24 @@ {-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-} module Main     ( main     ) where   --------------------------------------------------------------------------------import qualified Control.Applicative  as A+import qualified Control.Applicative         as A+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           Data.Monoid                 as M+import           System.IO                   (stdout) ------------------------------------------------------------------------------- import           Katip -------------------------------------------------------------------------------@@ -45,6 +50,8 @@       $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"       confrabulateWidgets     $(logTM) InfoS "Namespace and context are back to normal"+    noLogging $+      $(logTM) DebugS "You'll never see this log message!"   -------------------------------------------------------------------------------@@ -78,9 +85,29 @@ ------------------------------------------------------------------------------- newtype MyStack m a = MyStack {       unStack :: ReaderT MyState m a-    } deriving (MonadReader MyState, Functor, A.Applicative, Monad, MonadIO)+    } 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+-- MonadTransControl/MonadBaseControl are a pain to implement, so I've+-- included them. Note that KatipT and KatipContextT already do this work for you.+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 @@ -102,6 +129,12 @@ -- | Add a layer of namespace to the logs only for the given block addNamespace :: (MonadReader MyState m) => Namespace -> m a -> m a addNamespace ns = local (\r -> r { msKNamespace = msKNamespace r <> ns })+++-------------------------------------------------------------------------------+-- | Disable all log output temporarily+noLogging :: (MonadReader MyState m) => m a -> m a+noLogging = local (\r -> r { msLogEnv = clearScribes (msLogEnv r)})   -------------------------------------------------------------------------------

@@ -1,20 +1,25 @@ {-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-} module Main     ( main     ) where   --------------------------------------------------------------------------------import           Control.Applicative  as A-import           Control.Lens         hiding ((.=))+import           Control.Applicative         as A+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           Data.Monoid                 as M+import           System.IO                   (stdout) ------------------------------------------------------------------------------- import           Katip -------------------------------------------------------------------------------@@ -61,6 +66,8 @@       $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"       confrabulateWidgets     $(logTM) InfoS "Namespace and context are back to normal"+    noLogging $+      $(logTM) DebugS "You'll never see this log message!"   -------------------------------------------------------------------------------@@ -86,9 +93,28 @@ ------------------------------------------------------------------------------- newtype MyStack m a = MyStack {       unStack :: ReaderT MyState m a-    } deriving (MonadReader MyState, Functor, A.Applicative, Monad, MonadIO)+    } 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+-- MonadTransControl/MonadBaseControl are a pain to implement, so I've+-- included them. Note that KatipT and KatipContextT already do this work for you.+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 = view msLogEnv @@ -110,6 +136,12 @@ -- | Add a layer of namespace to the logs only for the given block addNamespace :: (MonadReader r m, HasMyState r) => Namespace -> m a -> m a addNamespace ns = local (\r -> r & msKNamespace <>~ ns)+++-------------------------------------------------------------------------------+-- | Disable all log output temporarily+noLogging :: (MonadReader r m, HasMyState r) => m a -> m a+noLogging = local (\r -> r & msLogEnv %~ clearScribes)   -------------------------------------------------------------------------------

@@ -1,13 +1,13 @@ name:                katip-version:             0.2.0.0+version:             0.3.0.0 synopsis:            A structured logging framework. description:   Katip is a structured logging framework. See README.md for more details.  license:             BSD3 license-file:        LICENSE-author:              Ozgun Ataman-maintainer:          ozgun.ataman@soostone.com+author:              Ozgun Ataman, Michael Xavier+maintainer:          michael.xavier@soostone.com copyright:           Soostone Inc, 2015-2016 category:            Data, Text, Logging homepage:            https://github.com/Soostone/katip@@ -60,9 +60,9 @@                , hostname >=1.0 && <1.1                , old-locale >= 1.0 && < 1.1                , string-conv >= 0.1 && < 0.2-               , template-haskell >= 2.8 && < 2.11+               , template-haskell >= 2.8 && < 2.12                , text >= 0.11 && <1.3-               , time >= 1 && < 1.6+               , time >= 1 && < 1.7                , time-locale-compat >= 0.1.0.1 && < 0.2                , transformers >= 0.3 && < 0.6                , transformers-compat@@ -70,10 +70,11 @@                , unordered-containers >= 0.2 && < 0.3                , monad-control >= 1.0 && < 1.1                , mtl >= 2.0 && < 2.3-               , transformers-base >= 0.3 && < 0.5+               , transformers-base >= 0.3 && < 0.6                , resourcet >= 1.1 && < 1.2                , microlens >= 0.2.0.0 && < 0.5                , microlens-th >= 0.1.0.0 && < 0.5+               , semigroups    hs-source-dirs:      src   default-language:    Haskell2010@@ -98,7 +99,7 @@                , time                , temporary                , directory-               , regex-tdfa-rc+               , regex-tdfa                , unordered-containers  @@ -107,7 +108,7 @@   main-is: Main.hs   hs-source-dirs: bench   default-language:    Haskell2010-  ghc-options: -O2 -Wall+  ghc-options: -O2 -Wall -threaded -rtsopts -with-rtsopts=-N   if flag(lib-Werror)     ghc-options: -Werror   build-depends:@@ -121,3 +122,4 @@                , time                , transformers                , deepseq+               , async

@@ -106,6 +106,7 @@     , runKatipContextT     , katipAddNamespace     , katipAddContext+    , katipNoLogging     ) where  -------------------------------------------------------------------------------

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP                        #-}+{-# LANGUAGE DefaultSignatures          #-} {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE ExistentialQuantification  #-}@@ -13,6 +14,9 @@ {-# LANGUAGE TemplateHaskell            #-} {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE UndecidableInstances       #-}+#if MIN_VERSION_base(4, 9, 0)+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+#endif -- | This module is not meant to be imported directly and may contain -- internal mechanisms that will change without notice. module Katip.Core where@@ -40,7 +44,7 @@ import qualified Data.HashMap.Strict          as HM import           Data.List import qualified Data.Map.Strict              as M-import           Data.Monoid+import           Data.Semigroup import           Data.String import           Data.String.Conv import           Data.Text                    (Text)@@ -49,7 +53,9 @@ import           Data.Time import           GHC.Generics                 hiding (to) #if MIN_VERSION_base(4, 8, 0)+#if !MIN_VERSION_base(4, 9, 0) import           GHC.SrcLoc+#endif import           GHC.Stack #endif import           Language.Haskell.TH@@ -75,7 +81,7 @@ -- IsString/OverloadedStrings, so "foo" will result in Namespace -- ["foo"]. newtype Namespace = Namespace { unNamespace :: [Text] }-  deriving (Eq,Show,Read,Ord,Generic,ToJSON,FromJSON,Monoid)+  deriving (Eq,Show,Read,Ord,Generic,ToJSON,FromJSON,Semigroup,Monoid)  instance IsString Namespace where     fromString s = Namespace [fromString s]@@ -163,10 +169,16 @@ instance IsString LogStr where     fromString = LogStr . B.fromString ++instance Semigroup LogStr where+  (LogStr a) <> (LogStr b) = LogStr (a <> b)++ instance Monoid LogStr where-    mappend (LogStr a) (LogStr b) = LogStr (a `mappend` b)+    mappend = (<>)     mempty = LogStr mempty + instance FromJSON LogStr where     parseJSON = A.withText "LogStr" parseLogStr       where@@ -181,7 +193,7 @@   ---------------------------------------------------------------------------------- | Shorthand for 'logMsg'+-- | Shorthand for 'logStr' ls :: StringConv a Text => a -> LogStr ls = logStr @@ -335,11 +347,15 @@     | SomeKeys [Text]     deriving (Show, Eq) +instance Semigroup PayloadSelection where+  AllKeys <> _ = AllKeys+  _ <> AllKeys = AllKeys+  SomeKeys as <> SomeKeys bs = SomeKeys (as <> bs)++ instance Monoid PayloadSelection where     mempty = SomeKeys []-    mappend AllKeys _ = AllKeys-    mappend _ AllKeys = AllKeys-    mappend (SomeKeys as) (SomeKeys bs) = SomeKeys (as++bs)+    mappend = (<>)   -------------------------------------------------------------------------------@@ -352,8 +368,9 @@ -- a ToJSON instance like: -- -- > instance ToObject Foo-class ToJSON a => ToObject a where+class ToObject a where     toObject :: a -> A.Object+    default toObject :: ToJSON a => a -> A.Object     toObject v = case toJSON v of       A.Object o -> o       _        -> mempty@@ -402,15 +419,22 @@     toJSON (SimpleLogPayload as) = object $ map go as       where go (k, AnyLogPayload v) = k A..= v + instance ToObject SimpleLogPayload + instance LogItem SimpleLogPayload where     payloadKeys V0 _ = SomeKeys []     payloadKeys _ _ = AllKeys ++instance Semigroup SimpleLogPayload where+  SimpleLogPayload a <> SimpleLogPayload b = SimpleLogPayload (a <> b)++ instance Monoid SimpleLogPayload where     mempty = SimpleLogPayload []-    SimpleLogPayload a `mappend` SimpleLogPayload b = SimpleLogPayload (a `mappend` b)+    mappend = (<>)   -------------------------------------------------------------------------------@@ -472,11 +496,15 @@     }  +instance Semigroup Scribe where+  (Scribe a) <> (Scribe b) = Scribe $ \ item -> do+    a item+    b item++ instance Monoid Scribe where     mempty = Scribe $ const $ return ()-    mappend (Scribe a) (Scribe b) = Scribe $ \ item -> do-      a item-      b item+    mappend = (<>)   -------------------------------------------------------------------------------@@ -551,7 +579,10 @@  ------------------------------------------------------------------------------- -- | Unregister *all* scribes. Logs will go off into space from this--- point onward until new scribes are added.+-- point onward until new scribes are added. Note that you could use+-- this with `local` if you're using a Reader based stack to+-- temporarily disable log output. See `katipNoLogging` for an+-- example. clearScribes     :: LogEnv     -> LogEnv

@@ -7,7 +7,9 @@ {-# 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.@@ -31,6 +33,7 @@     , runKatipContextT     , katipAddNamespace     , katipAddContext+    , katipNoLogging     , KatipContextTState(..)     ) where @@ -156,7 +159,7 @@ -- very low level and you typically can use 'logTM' in its -- place. Automaticallysupplies payload and namespace. logItemM-    :: (Applicative m, KatipContext m, Katip m)+    :: (Applicative m, KatipContext m)     => Maybe Loc     -> Severity     -> LogStr@@ -172,7 +175,7 @@ -- | Log with full context, but without any code -- location. Automatically supplies payload and namespace. logFM-  :: (Applicative m, KatipContext m, Katip m)+  :: (Applicative m, KatipContext m)   => Severity   -- ^ Severity of the message   -> LogStr@@ -207,7 +210,7 @@ -- `logTM` for maximum compatibility. -- -- @logLocM InfoS "Hello world"@-logLocM :: (Applicative m, KatipContext m, Katip m)+logLocM :: (Applicative m, KatipContext m)         => Severity         -> LogStr         -> m ()@@ -311,6 +314,8 @@   -------------------------------------------------------------------------------+-- | Append a namespace segment to the current namespace for the given+-- monadic action, then restore the previous state afterwards. katipAddNamespace     :: (Monad m)     => Namespace@@ -321,6 +326,8 @@   -------------------------------------------------------------------------------+-- | Append some context to the current context for the given monadic+-- action, then restore the previous state afterwards. katipAddContext     :: ( LogItem i        , Monad m@@ -330,3 +337,15 @@     -> KatipContextT m a katipAddContext i (KatipContextT f) =   KatipContextT (local (\r -> r { ltsContext = (ltsContext r) <> liftPayload i}) f)+++-------------------------------------------------------------------------------+-- | Disable all scribes for the given monadic action, then restore+-- them afterwards.+katipNoLogging+    :: ( Monad m+       )+    => KatipContextT m a+    -> KatipContextT m a+katipNoLogging (KatipContextT f) =+  KatipContextT (local (\r -> r { ltsLogEnv = clearScribes (ltsLogEnv r)}) f)

@@ -4,11 +4,13 @@  ------------------------------------------------------------------------------- import           Control.Applicative     as A+import           Control.Concurrent+import           Control.Exception       (bracket_) import           Control.Monad import           Data.Aeson import qualified Data.HashMap.Strict     as HM import           Data.Monoid-import Data.Text (Text)+import           Data.Text               (Text) import           Data.Text.Lazy.Builder import           Data.Text.Lazy.IO       as T import           Data.Time@@ -49,15 +51,22 @@   ---------------------------------------------------------------------------------- | Logs to a file handle such as stdout, stderr, or a file.+-- | 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:+--+-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started+-- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][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][1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal mkHandleScribe :: ColorStrategy -> Handle -> Severity -> Verbosity -> IO Scribe mkHandleScribe cs h sev verb = do     hSetBuffering h LineBuffering     colorize <- case cs of       ColorIfTerminal -> hIsTerminalDevice h       ColorLog b -> return b+    lock <- newMVar ()     return $ Scribe $ \ i@Item{..} -> do-      when (permitItem sev i) $+      when (permitItem sev i) $ bracket_ (takeMVar lock) (putMVar lock ()) $         T.hPutStrLn h $ toLazyText $ formatItem colorize verb i