diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -31,14 +31,14 @@ ------------------------------------------------------------------------------- handleScribeBench :: Benchmark handleScribeBench = bgroup "Katip.Scribes.Handle" [ - env setupHandleEnv $ \ ~(Scribe push, tid) -> + env setupHandleEnv $ \ ~((Scribe push, _), tid) -> bench "Bytestring Builder" $ - whnfIO $ push $ exItem tid + whnfIO $ (push (exItem tid)) ] ------------------------------------------------------------------------------- -setupHandleEnv :: IO (Scribe, ThreadIdText) +setupHandleEnv :: IO ((Scribe, Finaliser), ThreadIdText) setupHandleEnv = do scribe <- setup tid <- myThreadId @@ -83,15 +83,20 @@ ------------------------------------------------------------------------------- -setup :: IO Scribe +setup :: IO (Scribe, Finaliser) setup = do h <- openFile "/dev/null" WriteMode - mkHandleScribe ColorIfTerminal h DebugS V0 + (s, f) <- mkHandleScribe ColorIfTerminal h DebugS V0 + return (s, F f) ------------------------------------------------------------------------------- deriving instance NFData ThreadIdText +newtype Finaliser = F (IO ()) instance NFData Scribe where rnf (Scribe _) = () + +instance NFData Finaliser where + rnf (F _) = () diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,7 @@ +0.3.1.5 +======= +* Add Semigroup instance for LogStr. + 0.3.1.4 ======= * Loosen deps on aeson to allow 1.1.0.0 diff --git a/examples/example.hs b/examples/example.hs --- a/examples/example.hs +++ b/examples/example.hs @@ -34,7 +34,7 @@ -- 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 <- mkHandleScribe ColorIfTerminal stdout InfoS V2 + (handleScribe, finaliser) <- mkHandleScribe ColorIfTerminal stdout InfoS V2 let le' = registerScribe "stdout" handleScribe le let s = MyState M.mempty mempty le' runStack s $ do @@ -52,7 +52,7 @@ $(logTM) InfoS "Namespace and context are back to normal" noLogging $ $(logTM) DebugS "You'll never see this log message!" - + finaliser ------------------------------------------------------------------------------- newtype ConfrabLogCTX = ConfrabLogCTX Int diff --git a/examples/example_lens.hs b/examples/example_lens.hs --- a/examples/example_lens.hs +++ b/examples/example_lens.hs @@ -50,7 +50,7 @@ -- 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 <- mkHandleScribe ColorIfTerminal stdout InfoS V2 + (handleScribe, finaliser) <- mkHandleScribe ColorIfTerminal stdout InfoS V2 let le' = registerScribe "stdout" handleScribe le let s = MyState M.mempty mempty le' runStack s $ do @@ -68,6 +68,7 @@ $(logTM) InfoS "Namespace and context are back to normal" noLogging $ $(logTM) DebugS "You'll never see this log message!" + finaliser ------------------------------------------------------------------------------- diff --git a/katip.cabal b/katip.cabal --- a/katip.cabal +++ b/katip.cabal @@ -1,5 +1,5 @@ name: katip -version: 0.3.1.4 +version: 0.3.1.5 synopsis: A structured logging framework. description: Katip is a structured logging framework. See README.md for more details. @@ -55,6 +55,7 @@ build-depends: base >=4.5 && <5 , aeson >=0.6 && <1.2 + , async < 3.0.0.0 , auto-update >= 0.1 && < 0.2 , bytestring >= 0.9 && < 0.11 , containers >=0.4 && <0.6 @@ -76,6 +77,7 @@ , microlens >= 0.2.0.0 && < 0.5 , microlens-th >= 0.1.0.0 && < 0.5 , semigroups + , unagi-chan < 0.5.0.0 hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Katip/Core.hs b/src/Katip/Core.hs --- a/src/Katip/Core.hs +++ b/src/Katip/Core.hs @@ -493,7 +493,7 @@ -- Handle scribe does. -- -- 2. Return a finalizing function that tells the scribe to shut --- down. @katip-elasticsearch@'s @mkEsScribe@ returns a @IO (Scribe, +-- down. @katip-elasticsearch@'s @mkEsScribe@ returns an @IO (Scribe, -- IO ())@. The finalizer will flush any queued log messages and shut -- down gracefully before returning. This can be hooked into your -- application's shutdown routine to ensure you never miss any log @@ -826,7 +826,11 @@ -- `logT` for maximum compatibility. -- -- @logLoc obj mempty InfoS "Hello world"@ +#if MIN_VERSION_base(4, 8, 0) +logLoc :: (Applicative m, LogItem a, Katip m, ?loc :: CallStack) +#else logLoc :: (Applicative m, LogItem a, Katip m) +#endif => a -> Namespace -> Severity diff --git a/src/Katip/Monadic.hs b/src/Katip/Monadic.hs --- a/src/Katip/Monadic.hs +++ b/src/Katip/Monadic.hs @@ -57,11 +57,11 @@ 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.Writer +import Control.Monad.Writer hiding ((<>)) import Data.Aeson import qualified Data.Foldable as FT import qualified Data.HashMap.Strict as HM -import Data.Monoid as M +import Data.Semigroup as Semi import Data.Sequence as Seq import Data.Text (Text) import Language.Haskell.TH @@ -92,7 +92,7 @@ -- Additional note: you should not mappend LogContexts in any sort of -- infinite loop, as it retains all data, so that would be a memory -- leak. -newtype LogContexts = LogContexts (Seq AnyLogContext) deriving (Monoid) +newtype LogContexts = LogContexts (Seq AnyLogContext) deriving (Monoid, Semigroup) instance ToJSON LogContexts where toJSON (LogContexts cs) = @@ -230,7 +230,7 @@ logExceptionM action sev = action `catchAll` \e -> f e >> throwM e where f e = logFM sev (msg e) - msg e = ls ("An exception has occured: " :: Text) M.<> showLS e + msg e = ls ("An exception has occured: " :: Text) Semi.<> showLS e ------------------------------------------------------------------------------- diff --git a/src/Katip/Scribes/Handle.hs b/src/Katip/Scribes/Handle.hs --- a/src/Katip/Scribes/Handle.hs +++ b/src/Katip/Scribes/Handle.hs @@ -3,21 +3,22 @@ module Katip.Scribes.Handle where ------------------------------------------------------------------------------- -import Control.Applicative as A -import Control.Concurrent -import Control.Exception (bracket_) +import Control.Applicative as A 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 System.IO.Unsafe (unsafePerformIO) +import System.IO.Unsafe (unsafePerformIO) +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) ------------------------------------------------------------------------------- @@ -48,6 +49,10 @@ | ColorIfTerminal -- ^ Color if output is a terminal +------------------------------------------------------------------------------- +data WorkerCmd = + NewItem Builder + | PoisonPill ------------------------------------------------------------------------------- -- | Logs to a file handle such as stdout, stderr, or a file. Contexts @@ -57,18 +62,36 @@ -- > [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 +-- +-- 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 ()) 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 - lock <- newMVar () - return $ Scribe $ \ i@Item{..} -> do - when (permitItem sev i) $ bracket_ (takeMVar lock) (putMVar lock ()) $ - T.hPutStrLn h $ toLazyText $ formatItem colorize verb i + let scribe = Scribe $ \i -> + when (permitItem sev i) $ void (U.tryWriteChan inChan (NewItem (formatItem colorize verb i))) + return (scribe, stopWorker worker inChan) + 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{..} = @@ -100,10 +123,11 @@ ------------------------------------------------------------------------------- -- | An implicit environment to enable logging directly ouf of the IO monad. +-- Be careful as this LogEnv won't perform any resource cleanup for you. _ioLogEnv :: LogEnv _ioLogEnv = unsafePerformIO $ do le <- initLogEnv "io" "io" - lh <- mkHandleScribe ColorIfTerminal stdout DebugS V3 + (lh, _) <- mkHandleScribe ColorIfTerminal stdout DebugS V3 return $ registerScribe "stdout" lh le {-# NOINLINE _ioLogEnv #-} diff --git a/test/Katip/Tests/Scribes/Handle.hs b/test/Katip/Tests/Scribes/Handle.hs --- a/test/Katip/Tests/Scribes/Handle.hs +++ b/test/Katip/Tests/Scribes/Handle.hs @@ -33,8 +33,9 @@ tests = testGroup "Katip.Scribes.Handle" [ withResource setup teardown $ \setupScribe -> testCase "logs the correct data" $ do - (path, h, le) <- setupScribe + (path, h, fin, le) <- setupScribe runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message" + fin 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 @@ -73,18 +74,18 @@ ------------------------------------------------------------------------------- -setup :: IO (FilePath, Handle, LogEnv) +setup :: IO (FilePath, Handle, IO (), LogEnv) setup = do tempDir <- getTemporaryDirectory (fp, h) <- openTempFile tempDir "katip.log" - s <- mkHandleScribe (ColorLog False) h DebugS V3 + (s, finaliser) <- mkHandleScribe (ColorLog False) h DebugS V3 le <- initLogEnv "katip-test" "test" - return (fp, h, registerScribe "handle" s le) + return (fp, h, finaliser, registerScribe "handle" s le) ------------------------------------------------------------------------------- -teardown :: (FilePath, Handle, LogEnv) -> IO () -teardown (_, h, _) = do +teardown :: (FilePath, Handle, IO (), LogEnv) -> IO () +teardown (_, h, _, _) = do chk <- hIsOpen h when chk $ hClose h