katip 0.4.1.0 → 0.5.0.0

raw patch · 11 files changed

+642/−307 lines, 11 filesdep +filepathdep +safe-exceptionsdep +stmdep −exceptionsdep −unagi-chandep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: filepath, safe-exceptions, stm

Dependencies removed: exceptions, unagi-chan

Dependency ranges changed: containers

API changes (from Hackage documentation)

Files

• bench/Main.hs +48/−46
• changelog.md +7/−0
• examples/example.hs +27/−41
• examples/example_lens.hs +26/−41
• katip.cabal +9/−3
• src/Katip.hs +41/−7
• src/Katip/Core.hs +202/−56
• src/Katip/Monadic.hs +136/−69
• src/Katip/Scribes/Handle.hs +18/−40
• test/Katip/Tests.hs +123/−1
• test/Katip/Tests/Scribes/Handle.hs +5/−3

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns               #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE StandaloneDeriving         #-}@@ -10,11 +11,13 @@ ------------------------------------------------------------------------------- import           Control.Concurrent import           Control.DeepSeq+import           Control.Exception.Safe+import           Control.Monad import           Criterion.Main import           Data.Aeson-import           Data.Monoid              as M-import           Data.Time.Calendar-import           Data.Time.Clock+import           Data.Monoid            as M+import           System.Directory+import           System.FilePath import           System.IO import           System.Posix -------------------------------------------------------------------------------@@ -30,39 +33,45 @@  ------------------------------------------------------------------------------- handleScribeBench :: Benchmark-handleScribeBench = bgroup "Katip.Scribes.Handle" [-      env setupHandleEnv $ \ ~((Scribe push, _), tid) ->-      bench "Bytestring Builder" $-        whnfIO $ (push (exItem tid))-    ]+handleScribeBench = bgroup "Katip.Scribes.Handle" $+  flip map destinations $ \dest -> bgroup (show dest) [+   -- This is variably wildly on disk performance but should be a+   -- better test since a push test basically just tests how fast your+   -- queue structure is.+     bench "full env, flush 1000 writes" $+       whnfIO $ do+         le <- setupHandleLogEnv dest+         runKatipT le $ replicateM_ 1000 $ logItem ExPayload "namespace" Nothing InfoS "example"+         closeScribes le+   ]+  where+    destinations = [DevNull, TempFile]+    --destinations = [DevNull]   --------------------------------------------------------------------------------setupHandleEnv :: IO ((Scribe, Finaliser), ThreadIdText)-setupHandleEnv = do-      scribe <- setup-      tid <- myThreadId-      return (scribe, mkThreadIdText tid)+data HandleDest = DevNull | TempFile deriving (Show, Eq)   --------------------------------------------------------------------------------exItem :: ThreadIdText -> Item ExPayload-exItem tid = Item {-      _itemApp = Namespace ["app"]-    , _itemEnv = Environment "production"-    , _itemSeverity = WarningS-    , _itemThread = tid-    , _itemHost = "example"-    , _itemProcess = CPid 123-    , _itemPayload = ExPayload-    , _itemMessage = "message"-    , _itemTime = mkUTCTime 2015 3 14 1 5 9-    , _itemNamespace = Namespace ["foo"]-    , _itemLoc = Nothing-    }+instance NFData LogEnv where+  rnf (LogEnv !_ !_ !_ !_ !_ !_) = () +setupHandleLogEnv :: HandleDest -> IO LogEnv+setupHandleLogEnv hd = do+  (scr, _) <- setupHandleEnv hd+  registerScribe "handle" scr defaultScribeSettings =<< initLogEnv "katip-bench" "bench" + -------------------------------------------------------------------------------+setupHandleEnv :: HandleDest -> IO (Scribe, ThreadIdText)+setupHandleEnv dest = do+  scribe <- setup dest+  tid <- myThreadId+  return (scribe, mkThreadIdText tid)+++------------------------------------------------------------------------------- data ExPayload = ExPayload  instance ToJSON ExPayload where@@ -75,28 +84,21 @@   --------------------------------------------------------------------------------mkUTCTime :: Integer -> Int -> Int -> DiffTime -> DiffTime -> DiffTime -> UTCTime-mkUTCTime y mt d h mn s = UTCTime day dt-  where-    day = fromGregorian y mt d-    dt = h * 60 * 60 + mn * 60 + s-----------------------------------------------------------------------------------setup :: IO (Scribe, Finaliser)-setup = do-  h <- openFile "/dev/null" WriteMode-  (s, f) <- mkHandleScribe ColorIfTerminal h DebugS V0-  return (s, F f)+setup :: HandleDest -> IO Scribe+setup dest = do+  outFile <- case dest of+    TempFile -> do+      tmp <- getTemporaryDirectory+      return (tmp </> "katip-bench.log")+    DevNull -> return ("/dev/null")+  h <- openFile outFile WriteMode+  s <- mkHandleScribe ColorIfTerminal h DebugS V0+  let cleanupHandle = hClose h `finally` (when (dest == TempFile) (removeLink outFile))+  return s { scribeFinalizer = scribeFinalizer s `finally` cleanupHandle}   ------------------------------------------------------------------------------- deriving instance NFData ThreadIdText -newtype Finaliser = F (IO ())- instance NFData Scribe where-  rnf (Scribe _) = ()--instance NFData Finaliser where-  rnf (F _) = ()+  rnf (Scribe a b) = (a :: Item ExPayload -> IO ()) `seq` b `seq` ()

@@ -1,3 +1,10 @@+0.5.0.0+=======+* Improved documentation.+* Add built-in buffering to scribes.+  Scribes now allocate a bounded queue (with configurable size). Rather than writes being synchronous to all scribes, they simply attempt to write into the bounded queue of each scribe. If any of the scribes is too far behind and the queue is full, the write is dropped. This also means that closing scribes is now an IO operation that happens synchrounsly.+* Added local-like functions to Katip and KatipContext typeclasses. This allows us to generalize `katipNoLogging`, `katipAddNamespace`, and `katipAddContext` to be available to anything with a `Katip` or `KatipContext` instance rather than having to reimplement these functions all the time.+ 0.4.1.0 ======= * Add Katip instances for Strict StateT, WriterT, RWST.

@@ -13,6 +13,7 @@  ------------------------------------------------------------------------------- import qualified Control.Applicative         as A+import           Control.Exception import           Control.Monad.Base import           Control.Monad.Reader import           Control.Monad.Trans.Control@@ -28,32 +29,34 @@ -- example_lens.hs for a slightly cleaner and more general pattern. main :: IO () main = do-  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   -- 'unregisterScribe' and 'registerScribe' to make it possible to-  -- hot-swap scribes at runtime if you need to.-  (handleScribe, finaliser) <- mkHandleScribe ColorIfTerminal stdout InfoS V2-  let le' = registerScribe "stdout" handleScribe le-  let s = MyState M.mempty mempty le'-  runStack s $ do-    $(logTM) InfoS "Started"-    -- this will add "confrabulation" to the current namespace, making-    -- logs made under this block have the namespace of-    -- "main.confrabulation". Further, ConfrabLogCTX's key/value-    -- context will also get merged with the context above it. You can-    -- use this to stack up various contextual details throughout your-    -- code and they will be flattened out and combined in the log-    -- output.-    addNamespace "confrabulation" $ addContext (ConfrabLogCTX 42) $ do-      $(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!"-  finaliser+  -- hot-swap scribes at runtime if you need to. 'closeScribes' is+  -- blocking and flushes all messages out of a scribe and cleans up+  -- resources that were allocated at creation.+  handleScribe <- mkHandleScribe ColorIfTerminal stdout InfoS V2+  let mkLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv "MyApp" "production"+  bracket mkLogEnv closeScribes $ \le -> do+    let s = MyState M.mempty mempty le+    runStack s $ do+      $(logTM) InfoS "Started"+      -- this will add "confrabulation" to the current namespace, making+      -- logs made under this block have the namespace of+      -- "main.confrabulation". Further, ConfrabLogCTX's key/value+      -- context will also get merged with the context above it. You can+      -- use this to stack up various contextual details throughout your+      -- code and they will be flattened out and combined in the log+      -- output.+      katipAddNamespace "confrabulation" $ katipAddContext (ConfrabLogCTX 42) $ do+        $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"+        confrabulateWidgets+      $(logTM) InfoS "Namespace and context are back to normal"+      katipNoLogging $+        $(logTM) DebugS "You'll never see this log message!" + ------------------------------------------------------------------------------- newtype ConfrabLogCTX = ConfrabLogCTX Int @@ -110,31 +113,14 @@  instance (MonadIO m) => Katip (MyStack m) where   getLogEnv = asks msLogEnv+  localLogEnv f (MyStack m) = MyStack (local (\s -> s { msLogEnv = f (msLogEnv s)}) m)   instance (MonadIO m) => KatipContext (MyStack m) where   getKatipContext = asks msKContext+  localKatipContext f (MyStack m) = MyStack (local (\s -> s { msKContext = f (msKContext s)}) m)   getKatipNamespace = asks msKNamespace------------------------------------------------------------------------------------- | Merge some context into the log only for the given block-addContext :: (LogItem i, MonadReader MyState m) => i -> m a -> m a-addContext i = local (\r -> r { msKContext = msKContext r <> ctxs })-  where-    ctxs = liftPayload i------------------------------------------------------------------------------------- | 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)})+  localKatipNamespace f (MyStack m) = MyStack (local (\s -> s { msKNamespace = f (msKNamespace s)}) m)   -------------------------------------------------------------------------------

@@ -13,6 +13,7 @@  ------------------------------------------------------------------------------- import           Control.Applicative         as A+import           Control.Exception import           Control.Lens                hiding ((.=)) import           Control.Monad.Base import           Control.Monad.Reader@@ -43,31 +44,32 @@ -- | An example of advanced katip usage with Lens. main :: IO () main = do-  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   -- 'unregisterScribe' and 'registerScribe' to make it possible to-  -- hot-swap scribes at runtime if you need to.-  (handleScribe, finaliser) <- mkHandleScribe ColorIfTerminal stdout InfoS V2-  let le' = registerScribe "stdout" handleScribe le-  let s = MyState M.mempty mempty le'-  runStack s $ do-    $(logTM) InfoS "Started"-    -- this will add "confrabulation" to the current namespace, making-    -- logs made under this block have the namespace of-    -- "main.confrabulation". Further, ConfrabLogCTX's key/value-    -- context will also get merged with the context above it. You can-    -- use this to stack up various contextual details throughout your-    -- code and they will be flattened out and combined in the log-    -- output.-    addNamespace "confrabulation" $ addContext (ConfrabLogCTX 42) $ do-      $(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!"-  finaliser+  -- hot-swap scribes at runtime if you need to. 'closeScribes' is+  -- blocking and flushes all messages out of a scribe and cleans up+  -- resources that were allocated at creation.+  handleScribe <- mkHandleScribe ColorIfTerminal stdout InfoS V2+  let mkLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv "MyApp" "production"+  bracket mkLogEnv closeScribes $ \le -> do+    let s = MyState M.mempty mempty le+    runStack s $ do+      $(logTM) InfoS "Started"+      -- this will add "confrabulation" to the current namespace, making+      -- logs made under this block have the namespace of+      -- "main.confrabulation". Further, ConfrabLogCTX's key/value+      -- context will also get merged with the context above it. You can+      -- use this to stack up various contextual details throughout your+      -- code and they will be flattened out and combined in the log+      -- output.+      katipAddNamespace "confrabulation" $ katipAddContext (ConfrabLogCTX 42) $ do+        $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"+        confrabulateWidgets+      $(logTM) InfoS "Namespace and context are back to normal"+      katipNoLogging $+        $(logTM) DebugS "You'll never see this log message!"   -------------------------------------------------------------------------------@@ -117,31 +119,14 @@  instance (MonadIO m) => Katip (MyStack m) where   getLogEnv = view msLogEnv+  localLogEnv f (MyStack m) = MyStack (local (over msLogEnv f) m)   instance (MonadIO m) => KatipContext (MyStack m) where   getKatipContext = view msKContext+  localKatipContext f (MyStack m) = MyStack (local (over msKContext f) m)   getKatipNamespace = view msKNamespace------------------------------------------------------------------------------------- | Merge some context into the log only for the given block-addContext :: (LogItem i, MonadReader r m, HasMyState r) => i -> m a -> m a-addContext i = local (\r -> r & msKContext <>~ ctxs)-  where-    ctxs = liftPayload i------------------------------------------------------------------------------------- | 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)+  localKatipNamespace f (MyStack m) = MyStack (local (over msKNamespace f) m)   -------------------------------------------------------------------------------

@@ -1,5 +1,5 @@ name:                katip-version:             0.4.1.0+version:             0.5.0.0 synopsis:            A structured logging framework. description:   Katip is a structured logging framework. See README.md for more details.@@ -60,7 +60,7 @@                , bytestring >= 0.9 && < 0.11                , containers >=0.4 && <0.6                , either >= 4 && < 4.5-               , exceptions >= 0.5 && < 0.9+               , safe-exceptions >= 0.1.0.0                , hostname >=1.0 && <1.1                , old-locale >= 1.0 && < 1.1                , string-conv >= 0.1 && < 0.2@@ -77,7 +77,7 @@                , microlens >= 0.2.0.0 && < 0.5                , microlens-th >= 0.1.0.0 && < 0.5                , semigroups-               , unagi-chan < 0.5.0.0+               , stm >= 2.4    hs-source-dirs:      src   default-language:    Haskell2010@@ -117,6 +117,9 @@                , regex-tdfa                , unordered-containers                , microlens+               , containers+               , stm+               , safe-exceptions   ghc-options: -Wall   if flag(lib-Werror)     ghc-options: -Werror@@ -142,3 +145,6 @@                , transformers                , deepseq                , async+               , filepath+               , safe-exceptions+               , directory

@@ -1,7 +1,32 @@--- | Includes all of the API's youll need to use Katip. Be sure to+-- | Includes all of the APIs youll need to use Katip. Be sure to -- check out the included @examples@ directory for an example of -- usage. --+-- Here's a basic example:+--+-- @+--+-- import Control.Exception+-- import Katip+--+-- main :: IO ()+-- main = do+--   handleScribe <- mkHandleScribe ColorIfTerminal stdout InfoS V2+--   let makeLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv "MyApp" "production"+--   -- closeScribes will stop accepting new logs, flush existing ones and clean up resources+--   bracket makeLogEnv closeScribes $ \le -> do+--     let initialContext = () -- this context will be attached to every log in your app and merged w/ subsequent contexts+--     let initialNamespace = "main"+--     runKatipContextT le initialContext initialNamespace $ do+--       $(logTM) InfoS "Hello Katip"+--       -- This adds a namespace to the current namespace and merges a piece of contextual data into your context+--       katipAddNamespace "additional_namespace" $ katipAddContext (sl "some_context" True) $ do+--         $(logTM) WarningS "Now we're getting fancy"+--       katipNoLogging $ do+--         $(logTM) DebugS "You will never see this!"+--+-- @+-- -- To get up and running, the workflow is generally: -- -- * Set up a 'LogEnv' using 'initLogEnv'.@@ -40,6 +65,10 @@     , Scribe (..)     , LogEnv (..)     , SimpleLogPayload, sl+    , defaultScribeSettings+    , ScribeSettings+    , scribeBufferSize+    , _scribeBufferSize      -- ** @lens@-compatible Lenses     , itemApp@@ -60,15 +89,19 @@     , logEnvTimer     , logEnvScribes -    -- * A Built-in Monad For Logging+    -- * A Built-in Monad For Simple Logging     , KatipT (..)     , runKatipT      -- * Initializing Loggers     , initLogEnv     , registerScribe+    -- * Dropping scribes temporarily     , unregisterScribe     , clearScribes+    -- * Finalizing scribes at shutdown+    , closeScribes+    , closeScribe      -- * Logging Functions     , LogStr (..)@@ -82,7 +115,7 @@     , logT     , logItem     , logException-    -- ** 'KatipContext' Logging Functions+    -- ** 'KatipContext': Logging With Context     -- $katipcontextlogging     , KatipContext (..)     , logFM@@ -91,6 +124,10 @@     , logExceptionM     , AnyLogContext     , LogContexts, liftPayload+    -- *** Temporarily Changing Logging Behavior+    , katipAddNamespace+    , katipAddContext+    , katipNoLogging      -- * Included Scribes     , mkHandleScribe@@ -104,9 +141,6 @@     -- * KatipContextT - Utility transformer that provides Katip and KatipContext instances     , KatipContextT     , runKatipContextT-    , katipAddNamespace-    , katipAddContext-    , katipNoLogging     ) where  -------------------------------------------------------------------------------@@ -136,7 +170,7 @@ @  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+each other. Let's say you were writing a web app. You want to capture some detail such as the user's ID in the logs, but you also want that info to show up in doDatabaseThings' logs so you can associate those two pieces of information:

@@ -5,6 +5,7 @@ {-# LANGUAGE ExistentialQuantification  #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImplicitParams             #-} {-# LANGUAGE MultiParamTypeClasses      #-}@@ -22,11 +23,15 @@ module Katip.Core where  --------------------------------------------------------------------------------import           Control.Applicative          as A+import           Control.Applicative                   as A import           Control.AutoUpdate import           Control.Concurrent+import qualified Control.Concurrent.Async              as Async+import           Control.Concurrent.STM+import qualified Control.Concurrent.STM.TBQueue as BQ+import           Control.Exception.Safe+import           Control.Monad                         (unless, void) import           Control.Monad.Base-import           Control.Monad.Catch import           Control.Monad.IO.Class import           Control.Monad.Trans.Class import           Control.Monad.Trans.Control@@ -34,28 +39,28 @@ import           Control.Monad.Trans.Except import           Control.Monad.Trans.Maybe import           Control.Monad.Trans.Reader-import           Control.Monad.Trans.Resource-import           Control.Monad.Trans.State.Lazy (StateT)-import qualified Control.Monad.Trans.State.Strict as Strict (StateT)-import           Control.Monad.Trans.Writer.Lazy (WriterT)-import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT)-import           Control.Monad.Trans.RWS.Lazy (RWST)-import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST)+import           Control.Monad.Trans.Resource          (ResourceT, transResourceT)+import           Control.Monad.Trans.State.Lazy (StateT, mapStateT)+import qualified Control.Monad.Trans.State.Strict as Strict (StateT, mapStateT)+import           Control.Monad.Trans.Writer.Lazy (WriterT, mapWriterT)+import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT, mapWriterT)+import           Control.Monad.Trans.RWS.Lazy (RWST, mapRWST)+import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST, mapRWST) import           Data.Aeson                   (FromJSON (..), ToJSON (..),                                                object) import qualified Data.Aeson                   as A import           Data.Foldable                as FT import qualified Data.HashMap.Strict          as HM import           Data.List-import qualified Data.Map.Strict              as M+import qualified Data.Map.Strict                       as M import           Data.Semigroup import           Data.String import           Data.String.Conv-import           Data.Text                    (Text)-import qualified Data.Text                    as T-import qualified Data.Text.Lazy.Builder       as B+import           Data.Text                             (Text)+import qualified Data.Text                             as T+import qualified Data.Text.Lazy.Builder                as B import           Data.Time-import           GHC.Generics                 hiding (to)+import           GHC.Generics                          hiding (to) #if MIN_VERSION_base(4, 8, 0) #if !MIN_VERSION_base(4, 9, 0) import           GHC.SrcLoc@@ -63,7 +68,7 @@ import           GHC.Stack #endif import           Language.Haskell.TH-import qualified Language.Haskell.TH.Syntax   as TH+import qualified Language.Haskell.TH.Syntax            as TH import           Lens.Micro import           Lens.Micro.TH import           Network.HostName@@ -79,8 +84,8 @@ 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+              []  -> Nothing -- no parse+              _   -> Nothing -- Ambiguous parse   -------------------------------------------------------------------------------@@ -136,13 +141,13 @@ ------------------------------------------------------------------------------- renderSeverity :: Severity -> Text renderSeverity s = case s of-      DebugS -> "Debug"-      InfoS -> "Info"-      NoticeS -> "Notice"-      WarningS -> "Warning"-      ErrorS -> "Error"-      CriticalS -> "Critical"-      AlertS -> "Alert"+      DebugS     -> "Debug"+      InfoS      -> "Info"+      NoticeS    -> "Notice"+      WarningS   -> "Warning"+      ErrorS     -> "Error"+      CriticalS  -> "Critical"+      AlertS     -> "Alert"       EmergencyS -> "Emergency"  @@ -168,7 +173,7 @@     parseJSON = A.withText "Severity" parseSeverity       where         parseSeverity t = case textToSeverity t of-          Just x -> return x+          Just x  -> return x           Nothing -> fail $ "Invalid Severity " ++ toS t  @@ -347,7 +352,7 @@     parseJSON = A.withText "ProcessID" parseProcessID       where         parseProcessID t = case textToProcessID t of-          Just p -> return $ ProcessIDJs p+          Just p  -> return $ ProcessIDJs p           Nothing -> fail $ "Invalid ProcessIDJs " ++ toS t  @@ -384,7 +389,7 @@     default toObject :: ToJSON a => a -> A.Object     toObject v = case toJSON v of       A.Object o -> o-      _        -> mempty+      _          -> mempty  instance ToObject () instance ToObject A.Object@@ -436,7 +441,7 @@  instance LogItem SimpleLogPayload where     payloadKeys V0 _ = SomeKeys []-    payloadKeys _ _ = AllKeys+    payloadKeys _ _  = AllKeys   instance Semigroup SimpleLogPayload where@@ -459,7 +464,7 @@ -- automatically bubble higher verbosity levels to lower ones. payloadObject :: LogItem a => Verbosity -> a -> A.Object payloadObject verb a = case FT.foldMap (flip payloadKeys a) [(V0)..verb] of-    AllKeys -> toObject a+    AllKeys     -> toObject a     SomeKeys ks -> HM.filterWithKey (\ k _ -> k `FT.elem` ks) $ toObject a  @@ -503,22 +508,38 @@ -- application's shutdown routine to ensure you never miss any log -- messages on shutdown. data Scribe = Scribe {-      liPush :: forall a. LogItem a => Item a -> IO ()-    }+     liPush          :: forall a. LogItem a => Item a -> IO ()+   , scribeFinalizer :: IO ()+   -- ^ Provide a *blocking* finalizer to call when your scribe is+   -- removed. If this is not relevant to your scribe, return () is+   -- fine.+   }   instance Semigroup Scribe where-  (Scribe a) <> (Scribe b) = Scribe $ \ item -> do-    a item-    b item+  (Scribe pushA finA) <> (Scribe pushB finB) =+    Scribe (\item -> pushA item >> pushB item) (finA `finally` finB)   instance Monoid Scribe where-    mempty = Scribe $ const $ return ()+    mempty = Scribe (const (return ())) (return ())     mappend = (<>)   -------------------------------------------------------------------------------+data ScribeHandle = ScribeHandle {+      shScribe :: Scribe+    , shChan :: BQ.TBQueue WorkerMessage+    }+++-------------------------------------------------------------------------------+data WorkerMessage where+  NewItem    :: LogItem a => Item a -> WorkerMessage+  PoisonPill :: WorkerMessage+++------------------------------------------------------------------------------- -- | Should this item be logged given the user's maximum severity? permitItem :: Severity -> Item a -> Bool permitItem sev i = _itemSeverity i >= sev@@ -540,7 +561,7 @@     -- 'AutoUpdate' for high volume logs but note that this may cause     -- some output forms to display logs out of order. Alternatively,     -- you could just use 'getCurrentTime'.-    , _logEnvScribes :: M.Map Text Scribe+    , _logEnvScribes :: M.Map Text ScribeHandle     } makeLenses ''LogEnv @@ -572,28 +593,70 @@     :: Text     -- ^ Name the scribe     -> Scribe-    -> LogEnv+    -> ScribeSettings     -> LogEnv-registerScribe nm h = logEnvScribes %~ M.insert nm h+    -> IO LogEnv+registerScribe nm scribe ScribeSettings {..} le = do+  queue <- atomically (BQ.newTBQueue _scribeBufferSize)+  worker <- spawnScribeWorker scribe queue+  let fin = do+        atomically (BQ.writeTBQueue queue PoisonPill)+        -- wait for our worker to finish final write+        void (Async.waitCatch worker)+        -- wait for scribe to finish final write+        void (scribeFinalizer scribe) +  let sh = ScribeHandle (scribe { scribeFinalizer = fin }) queue+  return (le & logEnvScribes %~ M.insert nm sh) + ---------------------------------------------------------------------------------- | Remove a scribe from the list. All future log calls will no--- longer use this scribe. If the given scribe doesn't exist, its a no-op.+spawnScribeWorker :: Scribe -> BQ.TBQueue WorkerMessage -> IO (Async.Async ())+spawnScribeWorker (Scribe write _) queue = Async.async go+  where+    go = do+      newCmd <- atomically (BQ.readTBQueue queue)+      case newCmd of+        NewItem a  -> do+          -- Swallow any direct exceptions from the+          -- scribe. safe-exceptions won't catch async exceptions.+          void (tryAny (write a))+          go+        PoisonPill -> return ()+++-------------------------------------------------------------------------------+data ScribeSettings = ScribeSettings {+      _scribeBufferSize :: Int+    }++makeLenses ''ScribeSettings+++-- | Reasonable defaults for a scribe. Buffer+-- size of 4096.+defaultScribeSettings :: ScribeSettings+defaultScribeSettings = ScribeSettings 4096+++-------------------------------------------------------------------------------+-- | Remove a scribe from the environment. This does *not* finalize+-- the scribe. This mainly only makes sense to use with something like+-- MonadReader's @local@ function to temporarily disavow a single+-- logger for a block of code. unregisterScribe     :: Text     -- ^ Name of the scribe     -> LogEnv     -> LogEnv-unregisterScribe nm = logEnvScribes %~ M.delete nm+unregisterScribe nm =  logEnvScribes %~ M.delete nm   ---------------------------------------------------------------------------------- | Unregister *all* scribes. Logs will go off into space from this--- 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.+-- | Unregister *all* scribes. Note that this is *not* for closing or+-- finalizing scribes, use 'closeScribes' for that. This mainly only+-- makes sense to use with something like MonadReader's @local@+-- function to temporarily disavow any loggers for a block of code. clearScribes     :: LogEnv     -> LogEnv@@ -601,6 +664,38 @@   -------------------------------------------------------------------------------+-- | Finalize a scribe. The scribe is removed from the environment,+-- its finalizer is called and it can never be written to again. Note+-- that this will throw any exceptions yoru finalizer will throw, and+-- that LogEnv is immutable, so it will not be removed in that case.+closeScribe+    :: Text+    -- ^ Name of the scribe+    -> LogEnv+    -> IO LogEnv+closeScribe nm le = do+  maybe (return ()) (scribeFinalizer . shScribe) (M.lookup nm (_logEnvScribes le))+  return (le & logEnvScribes %~ M.delete nm)+++-------------------------------------------------------------------------------+-- | Call this at the end of your program. This is a blocking call+-- that stop writing to a scribe's queue, waits for the queue to+-- empty, finalizes each scribe in the log environment and then+-- removes it. Finalizers are all run even if one of them throws, but+-- the exception will be re-thrown at the end.+closeScribes+    :: LogEnv+    -> IO LogEnv+closeScribes le = do+  -- We want to run every finalizer here so we'll not save+  -- intermediate logenvs and just clear scribes at the end.+  let actions = [void (closeScribe k le) | k <- M.keys (_logEnvScribes le)]+  FT.foldr finally (return ()) actions+  return (le & logEnvScribes .~ mempty)+++------------------------------------------------------------------------------- -- | 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@@ -610,47 +705,75 @@ -- which keeps a namespace and merged context. You can write simple -- functions that add additional namespacing and merges additional -- context on the fly.+--+-- 'localLogEnv' was added to allow for lexically-scoped modifications+-- of the log env that are reverted when the supplied monad+-- completes. 'katipNoLogging', for example, uses this to temporarily+-- pause log outputs. class MonadIO m => Katip m where     getLogEnv :: m LogEnv+    localLogEnv :: (LogEnv -> LogEnv) -> m a -> m a   instance Katip m => Katip (ReaderT s m) where     getLogEnv = lift getLogEnv+    localLogEnv = mapReaderT . localLogEnv   instance Katip m => Katip (EitherT s m) where     getLogEnv = lift getLogEnv+    localLogEnv = mapEitherT . localLogEnv + instance Katip m => Katip (ExceptT s m) where     getLogEnv = lift getLogEnv+    localLogEnv = mapExceptT . localLogEnv + instance Katip m => Katip (MaybeT m) where     getLogEnv = lift getLogEnv+    localLogEnv = mapMaybeT . localLogEnv + instance Katip m => Katip (StateT s m) where     getLogEnv = lift getLogEnv+    localLogEnv = mapStateT . localLogEnv + instance (Katip m, Monoid w) => Katip (RWST r w s m) where     getLogEnv = lift getLogEnv+    localLogEnv = mapRWST . localLogEnv + instance (Katip m, Monoid w) => Katip (Strict.RWST r w s m) where     getLogEnv = lift getLogEnv+    localLogEnv = Strict.mapRWST . localLogEnv + instance Katip m => Katip (Strict.StateT s m) where     getLogEnv = lift getLogEnv+    localLogEnv = Strict.mapStateT . localLogEnv + instance (Katip m, Monoid s) => Katip (WriterT s m) where     getLogEnv = lift getLogEnv+    localLogEnv = mapWriterT . localLogEnv + instance (Katip m, Monoid s) => Katip (Strict.WriterT s m) where     getLogEnv = lift getLogEnv+    localLogEnv = Strict.mapWriterT . localLogEnv + instance (Katip m) => Katip (ResourceT m) where     getLogEnv = lift getLogEnv+    localLogEnv = transResourceT . localLogEnv   ---------------------------------------------------------------------------------- | A concrete monad you can use to run logging actions.+-- | A concrete monad you can use to run logging actions. Use this if+-- you prefer an explicit monad transformer stack and adding layers as+-- opposed to implementing 'Katip' for your monad. newtype KatipT m a = KatipT { unKatipT :: ReaderT LogEnv m a }   deriving ( Functor, Applicative, Monad, MonadIO            , MonadMask, MonadCatch, MonadThrow, MonadTrans, MonadBase b)@@ -658,6 +781,7 @@  instance MonadIO m => Katip (KatipT m) where     getLogEnv = KatipT ask+    localLogEnv f (KatipT m) = KatipT $ local f m   instance MonadTransControl KatipT where@@ -681,6 +805,17 @@   -------------------------------------------------------------------------------+-- | Disable all scribes for the given monadic action, then restore+-- them afterwards. Works in any Katip monad.+katipNoLogging+    :: ( Katip m+       )+    => m a+    -> m a+katipNoLogging = localLogEnv (\le -> set logEnvScribes mempty le)+++------------------------------------------------------------------------------- -- | Log with everything, including a source code location. This is -- very low level and you typically can use 'logT' in its place. logItem@@ -706,10 +841,21 @@         <*> _logEnvTimer         <*> pure (_logEnvApp <> ns)         <*> pure loc-      FT.forM_ (M.elems _logEnvScribes) $ \ (Scribe h) -> h item+      FT.forM_ (M.elems _logEnvScribes) $ \ ScribeHandle {..} -> atomically (tryWriteTBQueue shChan (NewItem item))   -------------------------------------------------------------------------------+tryWriteTBQueue+    :: TBQueue a+    -> a+    -> STM Bool+    -- ^ Did we write?+tryWriteTBQueue q a = do+  full <- isFullTBQueue q+  unless full (writeTBQueue q a)+  return (not full)++------------------------------------------------------------------------------- -- | Log with full context, but without any code location. logF   :: (Applicative m, LogItem a, Katip m)@@ -738,7 +884,7 @@     -> Severity                 -- ^ Severity     -> m b                      -- ^ Main action being run     -> m b-logException a ns sev action = action `catchAll` \e -> f e >> throwM e+logException a ns sev action = action `catchAny` \e -> f e >> throwM e   where     f e = logF a ns sev (msg e)     msg e = ls (T.pack "An exception has occured: ") <> showLS e@@ -769,14 +915,14 @@   instance TH.Lift Severity where-    lift DebugS = [| DebugS |]-    lift InfoS  = [| InfoS |]-    lift NoticeS  = [| NoticeS |]-    lift WarningS  = [| WarningS |]-    lift ErrorS  = [| ErrorS |]+    lift DebugS     = [| DebugS |]+    lift InfoS      = [| InfoS |]+    lift NoticeS    = [| NoticeS |]+    lift WarningS   = [| WarningS |]+    lift ErrorS     = [| ErrorS |]     lift CriticalS  = [| CriticalS |]-    lift AlertS  = [| AlertS |]-    lift EmergencyS  = [| EmergencyS |]+    lift AlertS     = [| AlertS |]+    lift EmergencyS = [| EmergencyS |]   -- | Lift a location into an Exp.

@@ -33,30 +33,30 @@     , runKatipContextT     , katipAddNamespace     , katipAddContext-    , katipNoLogging     , KatipContextTState(..)     ) where   ------------------------------------------------------------------------------- import           Control.Applicative+import           Control.Exception.Safe import           Control.Monad.Base-import           Control.Monad.Catch import           Control.Monad.Error.Class import           Control.Monad.IO.Class import           Control.Monad.Reader import           Control.Monad.State import           Control.Monad.Trans.Control-import           Control.Monad.Trans.Either        (EitherT)-import           Control.Monad.Trans.Except        (ExceptT)-import           Control.Monad.Trans.Identity      (IdentityT)-import           Control.Monad.Trans.List          (ListT)-import           Control.Monad.Trans.Maybe         (MaybeT)-import           Control.Monad.Trans.Resource      (ResourceT)-import           Control.Monad.Trans.RWS           (RWST)-import qualified Control.Monad.Trans.RWS.Strict    as Strict (RWST)-import qualified Control.Monad.Trans.State.Strict  as Strict (StateT)-import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT)+import           Control.Monad.Trans.Either        (EitherT, mapEitherT)+import           Control.Monad.Trans.Except        (ExceptT, mapExceptT)+import           Control.Monad.Trans.Identity      (IdentityT, mapIdentityT)+import           Control.Monad.Trans.List          (ListT, mapListT)+import           Control.Monad.Trans.Maybe         (MaybeT, mapMaybeT)+import           Control.Monad.Trans.Resource      (ResourceT, transResourceT)+import           Control.Monad.Trans.RWS           (RWST, mapRWST)+import qualified Control.Monad.Trans.RWS.Strict    as Strict (RWST, mapRWST)+import qualified Control.Monad.Trans.State.Strict  as Strict (StateT, mapStateT)+import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT,+                                                              mapWriterT) import           Control.Monad.Writer              hiding ((<>)) import           Data.Aeson import qualified Data.Foldable                     as FT@@ -120,44 +120,121 @@   ---------------------------------------------------------------------------------- | A monadic context that has an inherant way to get logging--- context and namespace. Examples include a web application monad or--- database monad.+-- | A monadic context that has an inherant way to get logging context+-- and namespace. Examples include a web application monad or database+-- monad. The @local@ variants are just like @local@ from Reader and+-- indeed you can easily implement them with @local@ if you happen to+-- be using a Reader in your monad. These give us 'katipAddNamespace'+-- and 'katipAddContext' that works with *any* 'KatipContext', as+-- opposed to making users have to implement these functions on their+-- own in each app. class Katip m => KatipContext m where   getKatipContext :: m LogContexts-  getKatipNamespace   :: m Namespace+  -- | Temporarily modify the current context for the duration of the+  -- supplied monad. Used in 'katipAddContext'+  localKatipContext :: (LogContexts -> LogContexts) -> m a -> m a+  getKatipNamespace :: m Namespace+  -- | Temporarily modify the current namespace for the duration of the+  -- supplied monad. Used in 'katipAddContext'+  localKatipNamespace :: (Namespace -> Namespace) -> m a -> m a ---TODO: is this INLINABLE?-#define TRANS(T) \-  instance (KatipContext m, Katip (T m)) => KatipContext (T m) where \-    getKatipContext = lift getKatipContext; \-    getKatipNamespace = lift getKatipNamespace+instance (KatipContext m, Katip (IdentityT m)) => KatipContext (IdentityT m) where+  getKatipContext = lift getKatipContext+  localKatipContext = mapIdentityT . localKatipContext+  getKatipNamespace = lift getKatipNamespace+  localKatipNamespace = mapIdentityT . localKatipNamespace -#define TRANS_CTX(CTX, T) \-  instance (CTX, KatipContext m, Katip (T m)) => KatipContext (T m) where \-    getKatipContext = lift getKatipContext; \-    getKatipNamespace = lift getKatipNamespace -TRANS(IdentityT)-TRANS(MaybeT)-TRANS(EitherT e)-TRANS(ListT)-TRANS(ReaderT r)-TRANS(ResourceT)-TRANS(Strict.StateT s)-TRANS(StateT s)-TRANS(ExceptT s)-TRANS_CTX(Monoid w, Strict.WriterT w)-TRANS_CTX(Monoid w,        WriterT w)-TRANS_CTX(Monoid w, Strict.RWST r w s)-TRANS_CTX(Monoid w,        RWST r w s)+instance (KatipContext m, Katip (MaybeT m)) => KatipContext (MaybeT m) where+  getKatipContext = lift getKatipContext+  localKatipContext = mapMaybeT . localKatipContext+  getKatipNamespace = lift getKatipNamespace+  localKatipNamespace = mapMaybeT . localKatipNamespace ++instance (KatipContext m, Katip (EitherT e m)) => KatipContext (EitherT e m) where+  getKatipContext = lift getKatipContext+  localKatipContext = mapEitherT . localKatipContext+  getKatipNamespace = lift getKatipNamespace+  localKatipNamespace = mapEitherT . localKatipNamespace+++instance (KatipContext m, Katip (ListT m)) => KatipContext (ListT m) where+  getKatipContext = lift getKatipContext+  localKatipContext = mapListT . localKatipContext+  getKatipNamespace = lift getKatipNamespace+  localKatipNamespace = mapListT . localKatipNamespace+++instance (KatipContext m, Katip (ReaderT r m)) => KatipContext (ReaderT r m) where+  getKatipContext = lift getKatipContext+  localKatipContext = mapReaderT . localKatipContext+  getKatipNamespace = lift getKatipNamespace+  localKatipNamespace = mapReaderT . localKatipNamespace+++instance (KatipContext m, Katip (ResourceT m)) => KatipContext (ResourceT m) where+  getKatipContext = lift getKatipContext+  localKatipContext = transResourceT . localKatipContext+  getKatipNamespace = lift getKatipNamespace+  localKatipNamespace = transResourceT . localKatipNamespace+++instance (KatipContext m, Katip (Strict.StateT s m)) => KatipContext (Strict.StateT s m) where+  getKatipContext = lift getKatipContext+  localKatipContext = Strict.mapStateT . localKatipContext+  getKatipNamespace = lift getKatipNamespace+  localKatipNamespace = Strict.mapStateT . localKatipNamespace+++instance (KatipContext m, Katip (StateT s m)) => KatipContext (StateT s m) where+  getKatipContext = lift getKatipContext+  localKatipContext = mapStateT . localKatipContext+  getKatipNamespace = lift getKatipNamespace+  localKatipNamespace = mapStateT . localKatipNamespace+++instance (KatipContext m, Katip (ExceptT e m)) => KatipContext (ExceptT e m) where+  getKatipContext = lift getKatipContext+  localKatipContext = mapExceptT . localKatipContext+  getKatipNamespace = lift getKatipNamespace+  localKatipNamespace = mapExceptT . localKatipNamespace+++instance (Monoid w, KatipContext m, Katip (Strict.WriterT w m)) => KatipContext (Strict.WriterT w m) where+  getKatipContext = lift getKatipContext+  localKatipContext = Strict.mapWriterT . localKatipContext+  getKatipNamespace = lift getKatipNamespace+  localKatipNamespace = Strict.mapWriterT . localKatipNamespace+++instance (Monoid w, KatipContext m, Katip (WriterT w m)) => KatipContext (WriterT w m) where+  getKatipContext = lift getKatipContext+  localKatipContext = mapWriterT . localKatipContext+  getKatipNamespace = lift getKatipNamespace+  localKatipNamespace = mapWriterT . localKatipNamespace+++instance (Monoid w, KatipContext m, Katip (Strict.RWST r w s m)) => KatipContext (Strict.RWST r w s m) where+  getKatipContext = lift getKatipContext+  localKatipContext = Strict.mapRWST . localKatipContext+  getKatipNamespace = lift getKatipNamespace+  localKatipNamespace = Strict.mapRWST . localKatipNamespace+++instance (Monoid w, KatipContext m, Katip (RWST r w s m)) => KatipContext (RWST r w s m) where+  getKatipContext = lift getKatipContext+  localKatipContext = mapRWST . localKatipContext+  getKatipNamespace = lift getKatipNamespace+  localKatipNamespace = mapRWST . localKatipNamespace++ deriving instance (Monad m, KatipContext m) => KatipContext (KatipT m)  ------------------------------------------------------------------------------- -- | Log with everything, including a source code location. This is -- very low level and you typically can use 'logTM' in its--- place. Automaticallysupplies payload and namespace.+-- place. Automatically supplies payload and namespace. logItemM     :: (Applicative m, KatipContext m)     => Maybe Loc@@ -170,7 +247,6 @@     logItem ctx ns loc sev msg  - ------------------------------------------------------------------------------- -- | Log with full context, but without any code -- location. Automatically supplies payload and namespace.@@ -227,7 +303,7 @@     => m a                      -- ^ Main action to run     -> Severity                 -- ^ Severity     -> m a-logExceptionM action sev = action `catchAll` \e -> f e >> throwM e+logExceptionM action sev = action `catchAny` \e -> f e >> throwM e   where     f e = logFM sev (msg e)     msg e = ls ("An exception has occured: " :: Text) Semi.<> showLS e@@ -235,10 +311,11 @@  ------------------------------------------------------------------------------- -- | Provides a simple transformer that defines a 'KatipContext'--- instance for a fixed namespace and context. You will typically only--- use this if you are forced to run in IO but still want to have your--- log context. This is the slightly more powerful version of KatipT--- in that it provides KatipContext instead of just Katip. For instance:+-- instance for a fixed namespace and context. Just like 'KatipT', you+-- should use this if you prefer an explicit transformer stack and+-- don't want to (or cannot) define 'KatipContext' for your monad+-- . This is the slightly more powerful version of KatipT in that it+-- provides KatipContext instead of just Katip. For instance: -- -- @ --   threadWithLogging = do@@ -299,11 +376,14 @@  instance (MonadIO m) => Katip (KatipContextT m) where   getLogEnv = KatipContextT $ ReaderT $ \lts -> return (ltsLogEnv lts)+  localLogEnv f (KatipContextT m) = KatipContextT (local (\s -> s { ltsLogEnv = f (ltsLogEnv s)}) m)   instance (MonadIO m) => KatipContext (KatipContextT m) where   getKatipContext = KatipContextT $ ReaderT $ \lts -> return (ltsContext lts)+  localKatipContext f (KatipContextT m) = KatipContextT $ local (\s -> s { ltsContext = f (ltsContext s)}) m   getKatipNamespace = KatipContextT $ ReaderT $ \lts -> return (ltsNamespace lts)+  localKatipNamespace f (KatipContextT m) = KatipContextT $ local (\s -> s { ltsNamespace = f (ltsNamespace s)}) m   -------------------------------------------------------------------------------@@ -316,14 +396,13 @@ ------------------------------------------------------------------------------- -- | Append a namespace segment to the current namespace for the given -- monadic action, then restore the previous state--- afterwards.+-- afterwards. Works with anything implementing KatipContext. katipAddNamespace-    :: (Monad m)+    :: (KatipContext m)     => Namespace-    -> KatipContextT m a-    -> KatipContextT m a-katipAddNamespace ns (KatipContextT f) =-  KatipContextT (local (\r -> r { ltsNamespace = (ltsNamespace r) <> ns}) f)+    -> m a+    -> m a+katipAddNamespace ns = localKatipNamespace (<> ns)   -------------------------------------------------------------------------------@@ -336,25 +415,13 @@ -- added. If you instead roll your own recursion and you're recursing -- in the action you provide, you'll instead accumulate tons of -- redundant contexts and even if they all merge on log, they are--- stored in a sequence and will leak memory.+-- stored in a sequence and will leak memory. Works with anything+-- implementing KatipContext. katipAddContext     :: ( LogItem i-       , Monad m+       , KatipContext m        )     => i-    -> KatipContextT m a-    -> 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)+    -> m a+    -> m a+katipAddContext i = localKatipContext (<> (liftPayload i))

@@ -3,21 +3,20 @@ module Katip.Scribes.Handle where  --------------------------------------------------------------------------------import           Control.Applicative as A+import           Control.Applicative    as A+import           Control.Concurrent+import           Control.Exception      (bracket_) import           Control.Monad-import           Control.Exception (onException) import           Data.Aeson-import qualified Data.HashMap.Strict as HM+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.Text.Lazy.IO      as T import           System.IO-import qualified Control.Concurrent.Chan.Unagi.Bounded as U-import           Control.Concurrent.Async ------------------------------------------------------------------------------- import           Katip.Core-import           Katip.Format.Time (formatAsLogTime)+import           Katip.Format.Time      (formatAsLogTime) -------------------------------------------------------------------------------  @@ -49,11 +48,6 @@     -- ^ Color if output is a terminal  --------------------------------------------------------------------------------data WorkerCmd =-    NewItem Builder-  | PoisonPill--------------------------------------------------------------------------------- -- | 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:@@ -62,35 +56,20 @@ -- > [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 ----- Returns the newly-created `Scribe` together with a finaliser the user needs to run to perform resource cleanup.-mkHandleScribe :: ColorStrategy -> Handle -> Severity -> Verbosity -> IO (Scribe, IO ())+-- Returns the newly-created `Scribe`. The finalizer flushes the handle.+mkHandleScribe :: ColorStrategy -> Handle -> Severity -> Verbosity -> IO Scribe mkHandleScribe cs h sev verb = do-  (inChan, outChan) <- U.newChan 4096-  worker <- async $ workerLoop outChan-  flip onException (stopWorker worker inChan) $ do     hSetBuffering h LineBuffering     colorize <- case cs of       ColorIfTerminal -> hIsTerminalDevice h-      ColorLog b -> return b-    let scribe = Scribe $ \i ->-          when (permitItem sev i) $ void (U.tryWriteChan inChan (NewItem (formatItem colorize verb i)))-    return (scribe, stopWorker worker inChan)+      ColorLog b      -> return b+    lock <- newMVar ()+    let logger i@Item{..} = do+          when (permitItem sev i) $ bracket_ (takeMVar lock) (putMVar lock ()) $+            T.hPutStrLn h $ toLazyText $ formatItem colorize verb i+    return $ Scribe logger (hFlush h) -  where-    stopWorker :: Async () -> U.InChan WorkerCmd -> IO ()-    stopWorker worker inChan = do-      U.writeChan inChan PoisonPill-      void $ waitCatch worker -    workerLoop :: U.OutChan WorkerCmd -> IO ()-    workerLoop outChan = do-      newCmd <- U.readChan outChan-      case newCmd of-        NewItem b  -> do-          T.hPutStrLn h $ toLazyText b-          workerLoop outChan-        PoisonPill -> return ()- ------------------------------------------------------------------------------- formatItem :: LogItem a => Bool -> Verbosity -> Item a -> Builder formatItem withColor verb Item{..} =@@ -112,7 +91,7 @@       CriticalS  -> red $ renderSeverity s       ErrorS     -> red $ renderSeverity s       WarningS   -> yellow $ renderSeverity s-      _         -> renderSeverity s+      _          -> renderSeverity s     red = colorize "31"     yellow = colorize "33"     colorize c s@@ -120,7 +99,6 @@       | otherwise = s  -------------------------------------------------------------------------------- -- | Provides a simple log environment with 1 scribe going to -- stdout. This is a decent example of how to build a LogEnv and is -- best for scripts that just need a quick, reasonable set up to log@@ -128,5 +106,5 @@ ioLogEnv :: Severity -> Verbosity -> IO LogEnv ioLogEnv sev verb = do   le <- initLogEnv "io" "io"-  (lh, _) <- mkHandleScribe ColorIfTerminal stdout sev verb-  return $ registerScribe "stdout" lh le+  lh <- mkHandleScribe ColorIfTerminal stdout sev verb+  registerScribe "stdout" lh defaultScribeSettings le

@@ -1,9 +1,11 @@ {-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE RecordWildCards            #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TemplateHaskell            #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Katip.Tests     ( tests@@ -11,9 +13,12 @@   --------------------------------------------------------------------------------import           Control.Applicative as A+import           Control.Applicative       as A+import           Control.Concurrent.STM+import           Control.Exception.Safe import           Data.Aeson import qualified Data.HashMap.Strict       as HM+import qualified Data.Map.Strict           as M import           Data.Monoid import           Data.Text                 (Text) import qualified Data.Text.Lazy.Builder    as B@@ -43,6 +48,9 @@   , testCase "processIDToText is just the number" $ do       processIDToText 123 @?= "123"   , logContextsTests+  , closeScribeTests+  , closeScribesTests+  , loggingTests   ]  @@ -62,6 +70,120 @@           both = everything <> conservative       payloadKeys V2 both @?= SomeKeys ["often_shown", "rarely_shown", "foo"]       payloadKeys V1 both @?= SomeKeys ["often_shown", "foo"]+  ]+++-------------------------------------------------------------------------------+closeScribeTests :: TestTree+closeScribeTests = testGroup "closeScribe"+  [ testCase "removes the specified scribe" $ do+      (scr, finalizerCalled) <- trivialScribe+      le <- registerScribe "trivial" scr defaultScribeSettings =<< initLogEnv "ns" "test"+      le' <- closeScribe "trivial" le+      closed <- atomically (readTVar finalizerCalled)+      assertBool "finalizer called" closed+      assertBool "should not have trivial key in scribes" (not (M.member "trivial" (_logEnvScribes le')))+  , testCase "does nothing for a missing scribe" $ do+      le <- initLogEnv "ns" "test"+      le' <- closeScribe "nah" le+      assertBool "does not affect scribes" (M.null (_logEnvScribes le'))+  , testCase "re-throws finalizer exceptions" $ do+      (scr, finalizerCalled) <- brokenScribe 1+      le <- registerScribe "broken" scr defaultScribeSettings =<< initLogEnv "ns" "test"+      res <- try (closeScribe "broken" le)+      closed <- atomically (readTVar finalizerCalled)+      assertBool "finalizer called" closed+      case res of+        Left (ScribeBroken scribeNo) -> scribeNo @?= 1+        Right _ -> assertFailure "Expected to throw a ScribeBroken but it did not"+  ]+++-------------------------------------------------------------------------------+loggingTests :: TestTree+loggingTests = testGroup "logging"+  [ testCase "logs in order with contexts, namespaces, etc" $ do+      (le, items) <- recordingEnv+      runKatipContextT le (sl "base_context" (42 :: Int)) "base_namespace" $ do+        $(logTM) InfoS "basic log"+        katipNoLogging $ do+          $(logTM) InfoS "you cant see this"+        katipAddNamespace "added" $ do+          katipAddNamespace "namespace" $ do+            $(logTM) InfoS "with namespaces"+          katipAddContext (sl "additional" True) $ do+            $(logTM) InfoS "additional context"+      _ <- closeScribes le+      summary <- fmap summarizeItem <$> readTVarIO items+      let baseCtx = HM.singleton "base_context" (Number 42)+      let baseNS = "tests" <> "base_namespace"+      summary @?=+        [ (baseNS, baseCtx, "basic log")+        , (baseNS <> "added" <> "namespace", baseCtx, "with namespaces")+        , (baseNS <> "added", HM.insert "additional" (Bool True) baseCtx, "additional context")+        ]+  ]+  where+    recordingEnv :: IO (LogEnv, TVar [Item Object])+    recordingEnv = do+      items <- newTVarIO mempty+      let scribe = Scribe+            { liPush = \i -> atomically (modifyTVar' items (<> [toObject <$> i]))+            , scribeFinalizer = return ()+            }+      le1 <- initLogEnv "tests" "test"+      le2 <- registerScribe "recorder" scribe defaultScribeSettings le1+      return (le2, items)+    summarizeItem :: Item Object -> (Namespace, Object, LogStr)+    summarizeItem Item {..} = (_itemNamespace, _itemPayload, _itemMessage)+++-------------------------------------------------------------------------------+trivialScribe :: IO (Scribe, TVar Bool)+trivialScribe = do+  finalizerCalled <- newTVarIO False+  let finalizer = atomically (writeTVar finalizerCalled True)+  return (Scribe (const (return ())) finalizer, finalizerCalled)+++-------------------------------------------------------------------------------+brokenScribe :: Int -> IO (Scribe, TVar Bool)+brokenScribe scribeNum = do+  finalizerCalled <- newTVarIO False+  let finalizer = do+        atomically (writeTVar finalizerCalled True)+        throw (ScribeBroken scribeNum)+  return (Scribe (const (return ())) finalizer, finalizerCalled)+++-------------------------------------------------------------------------------+data BrokenScribeError = ScribeBroken Int deriving (Show, Typeable)+++instance Exception BrokenScribeError++-------------------------------------------------------------------------------+closeScribesTests :: TestTree+closeScribesTests = testGroup "closeScribes"+  [ testCase "returns a log env with no scribes" $ do+      (scr, finalizerCalled) <- trivialScribe+      le <- registerScribe "trivial" scr defaultScribeSettings =<< initLogEnv "ns" "test"+      le' <- closeScribes le+      closed <- atomically (readTVar finalizerCalled)+      assertBool "finalizer called" closed+      assertBool "remvoes all scribes" (M.null (_logEnvScribes le'))+  , testCase "throws the first exception encountered after closing all scribes" $ do+     (scr1, finalizerCalled1) <- brokenScribe 1+     (scr2, finalizerCalled2) <- brokenScribe 2+     le <- registerScribe "broken2" scr2 defaultScribeSettings =<< registerScribe "broken1" scr1 defaultScribeSettings =<< initLogEnv "ns" "test"+     res <- try (closeScribes le)+     closed1 <- atomically (readTVar finalizerCalled1)+     assertBool "finalizer 1 called" closed1+     closed2 <- atomically (readTVar finalizerCalled2)+     assertBool "finalizer 2 called" closed2+     case res of+       Left (ScribeBroken scribeNo) -> scribeNo @?= 1+       Right _ -> assertFailure "Expected to throw a ScribeBroken but it did not"   ]  

@@ -36,11 +36,12 @@        (path, h, fin, le) <- setupScribe        runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message"        fin+       runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "wont make it in"        hClose h        res <- readFile path        let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[[:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String        let matches = res =~ pat-       assertBool (res <> " did not match") matches+       assertBool (show res <> " did not match") matches   , withResource setupTempFile teardownTempFile $ \setupFn ->        goldenVsString "Text-golden"                       "test/Katip/Tests/Scribes/Handle-text.golden"@@ -78,9 +79,10 @@ setup = do   tempDir <- getTemporaryDirectory   (fp, h) <- openTempFile tempDir "katip.log"-  (s, finaliser) <- mkHandleScribe (ColorLog False) h DebugS V3+  s <- mkHandleScribe (ColorLog False) h DebugS V3   le <- initLogEnv "katip-test" "test"-  return (fp, h, finaliser, registerScribe "handle" s le)+  le' <- registerScribe "handle" s defaultScribeSettings le+  return (fp, h, void (closeScribes le'), le')   -------------------------------------------------------------------------------