diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -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) diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 ======= diff --git a/examples/example.hs b/examples/example.hs --- a/examples/example.hs +++ b/examples/example.hs @@ -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)}) ------------------------------------------------------------------------------- diff --git a/examples/example_lens.hs b/examples/example_lens.hs --- a/examples/example_lens.hs +++ b/examples/example_lens.hs @@ -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) ------------------------------------------------------------------------------- diff --git a/katip.cabal b/katip.cabal --- a/katip.cabal +++ b/katip.cabal @@ -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 diff --git a/src/Katip.hs b/src/Katip.hs --- a/src/Katip.hs +++ b/src/Katip.hs @@ -106,6 +106,7 @@ , runKatipContextT , katipAddNamespace , katipAddContext + , katipNoLogging ) where ------------------------------------------------------------------------------- diff --git a/src/Katip/Core.hs b/src/Katip/Core.hs --- a/src/Katip/Core.hs +++ b/src/Katip/Core.hs @@ -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 diff --git a/src/Katip/Monadic.hs b/src/Katip/Monadic.hs --- a/src/Katip/Monadic.hs +++ b/src/Katip/Monadic.hs @@ -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) 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 @@ -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