katip 0.8.8.0 → 0.8.8.1

raw patch · 5 files changed

+87/−13 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• changelog.md +4/−0
• katip.cabal +3/−3
• src/Katip/Core.hs +59/−6
• src/Katip/Format/Time.hs +4/−2
• src/Katip/Scribes/Handle.hs +17/−2

@@ -1,3 +1,7 @@+0.8.8.1+=======+* Improve logging performance (4x) via inlining [#151](https://github.com/Soostone/katip/pull/151)+ 0.8.8.0 ======= * Add support for rendering arrays in the log context to the handle scribe [#150](https://github.com/Soostone/katip/pull/150)

@@ -1,5 +1,5 @@ name:                katip-version:             0.8.8.0+version:             0.8.8.1 synopsis:            A structured logging framework. description:   Katip is a structured logging framework. See README.md for more details.@@ -84,7 +84,7 @@    hs-source-dirs:      src   default-language:    Haskell2010-  ghc-options:        -Wall+  ghc-options:        -Wall -O2   if flag(lib-Werror)     ghc-options: -Werror   if os(windows)@@ -133,7 +133,7 @@   main-is: Main.hs   hs-source-dirs: bench   default-language:    Haskell2010-  ghc-options: -O2 -Wall -threaded -rtsopts -with-rtsopts=-N+  ghc-options: -O2 -Wall -threaded -rtsopts "-with-rtsopts=-N"   if flag(lib-Werror)     ghc-options: -Werror   build-depends:

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveLift #-}+{-# LANGUAGE BangPatterns               #-} {-# LANGUAGE CPP                        #-} {-# LANGUAGE DefaultSignatures          #-} {-# LANGUAGE DeriveFunctor              #-}@@ -103,6 +104,7 @@               [x] -> Just x               []  -> Nothing -- no parse               _   -> Nothing -- Ambiguous parse+{-# INLINE readMay #-}   -------------------------------------------------------------------------------@@ -122,6 +124,7 @@ -- | Ready namespace for emission with dots to join the segments. intercalateNs :: Namespace -> [Text] intercalateNs (Namespace xs) = intersperse "." xs+{-# INLINE intercalateNs #-}   -------------------------------------------------------------------------------@@ -156,8 +159,9 @@   -------------------------------------------------------------------------------+{-# INLINE renderSeverity #-} renderSeverity :: Severity -> Text-renderSeverity s = case s of+renderSeverity !s = case s of       DebugS     -> "Debug"       InfoS      -> "Info"       NoticeS    -> "Notice"@@ -169,6 +173,7 @@   -------------------------------------------------------------------------------+{-# INLINE textToSeverity #-} textToSeverity :: Text -> Maybe Severity textToSeverity = go . T.toLower   where@@ -220,11 +225,13 @@  instance Semigroup LogStr where   (LogStr a) <> (LogStr b) = LogStr (a <> b)+  {-# INLINE (<>) #-}   instance Monoid LogStr where     mappend = (<>)     mempty = LogStr mempty+    {-# INLINE mempty #-}   instance FromJSON LogStr where@@ -238,18 +245,21 @@ -- lazy variants. logStr :: StringConv a Text => a -> LogStr logStr t = LogStr (B.fromText $ toS t)+{-# INLINE logStr #-}   ------------------------------------------------------------------------------- -- | Shorthand for 'logStr' ls :: StringConv a Text => a -> LogStr ls = logStr+{-# INLINE ls #-}   ------------------------------------------------------------------------------- -- | Convert any showable type into a 'LogStr'. showLS :: Show a => a -> LogStr showLS = ls . show+{-# INLINE showLS #-}   -------------------------------------------------------------------------------@@ -262,14 +272,14 @@ mkThreadIdText = ThreadIdText . stripPrefix' "ThreadId " . T.pack . show   where     stripPrefix' pfx t = fromMaybe t (T.stripPrefix pfx t)-+{-# INLINE mkThreadIdText #-}  ------------------------------------------------------------------------------- -- | This has everything each log message will contain. data Item a = Item {       _itemApp       :: Namespace     , _itemEnv       :: Environment-    , _itemSeverity  :: Severity+    , _itemSeverity  :: {-# UNPACK #-} !Severity     , _itemThread    :: ThreadIdText     , _itemHost      :: HostName     , _itemProcess   :: ProcessID@@ -398,10 +408,12 @@  processIDToText :: ProcessID -> Text processIDToText = toS . show+{-# INLINE processIDToText #-}   textToProcessID :: Text -> Maybe ProcessID textToProcessID = readMay . toS+{-# INLINE textToProcessID #-}   newtype ProcessIDJs = ProcessIDJs {@@ -445,6 +457,7 @@ equivalentPayloadSelection AllKeys AllKeys = True equivalentPayloadSelection (SomeKeys a) (SomeKeys b) = Set.fromList a == Set.fromList b equivalentPayloadSelection _ _ = False+{-# INLINE equivalentPayloadSelection #-}  ------------------------------------------------------------------------------- -- | Katip requires JSON objects to be logged as context. This@@ -516,6 +529,7 @@ toKey :: a -> a toKey = id #endif+{-# INLINE toKey #-}   instance ToObject SimpleLogPayload@@ -539,6 +553,7 @@ -- | Construct a simple log from any JSON item. sl :: ToJSON a => Text -> a -> SimpleLogPayload sl a b = SimpleLogPayload [(a, AnyLogPayload b)]+{-# INLINE sl #-}   -------------------------------------------------------------------------------@@ -548,6 +563,7 @@ payloadObject verb a = case FT.foldMap (flip payloadKeys a) [(V0)..verb] of     AllKeys     -> toObject a     SomeKeys ks -> filterElems ks $ toObject a+{-# INLINE payloadObject #-}  #if MIN_VERSION_aeson(2, 0, 0) filterElems :: [Text] -> KM.KeyMap v -> KM.KeyMap v@@ -556,6 +572,7 @@ filterElems :: [Text] -> HM.HashMap Text v -> HM.HashMap Text v filterElems ks = HM.filterWithKey (\ k _ -> k `FT.elem` ks) #endif+{-# INLINE filterElems #-}   -------------------------------------------------------------------------------@@ -564,6 +581,7 @@ -- messages should use this to obtain their payload. itemJson :: LogItem a => Verbosity -> Item a -> A.Value itemJson verb a = toJSON $ a & itemPayload %~ payloadObject verb+{-# INLINE itemJson #-}   -------------------------------------------------------------------------------@@ -611,12 +629,15 @@   -- | AND together 2 permit functions+ permitAND :: PermitFunc -> PermitFunc -> PermitFunc permitAND f1 f2 = \a -> liftA2 (&&) (f1 a) (f2 a)+{-# INLINE permitAND #-}  -- | OR together 2 permit functions permitOR :: PermitFunc -> PermitFunc -> PermitFunc permitOR f1 f2 = \a -> liftA2 (||) (f1 a) (f2 a)+{-# INLINE permitOR #-}   data Scribe = Scribe {@@ -626,7 +647,7 @@    -- ^ Provide a __blocking__ finalizer to call when your scribe is    -- removed. All pending writes should be flushed synchronously. If    -- this is not relevant to your scribe, return () is fine.-   , scribePermitItem :: PermitFunc+   , scribePermitItem :: !PermitFunc    -- ^ Provide a filtering function to allow the item to be logged,    --   or not.  It can check Severity or some string in item's    --   body. The initial value of this is usually created from@@ -637,7 +658,7 @@  whenM :: Monad m => m Bool -> m () -> m () whenM mbool = (>>=) mbool . flip when-+{-# INLINE whenM #-}  -- | Combine two scribes. Publishes to the left scribe if the left -- would permit the item and to the right scribe if the right would@@ -650,10 +671,12 @@            )            (finA `finally` finB)            (permitOR permitA permitB)+  {-# INLINE (<>) #-}   instance Monoid Scribe where     mempty = Scribe (const (return ())) (return ()) (permitItem DebugS)+    {-# INLINE mempty #-}     mappend = (<>)  @@ -675,6 +698,7 @@ -- Most new scribes will use this as a base for their 'PermitFunc' permitItem :: Monad m => Severity -> Item a -> m Bool permitItem sev item = return (_itemSeverity item >= sev)+{-# INLINE permitItem #-}   -------------------------------------------------------------------------------@@ -716,6 +740,7 @@   <*> pure env   <*> mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime, updateFreq = 1000 }   <*> pure mempty+{-# INLINE initLogEnv#-}   -------------------------------------------------------------------------------@@ -742,6 +767,7 @@    let sh = ScribeHandle (scribe { scribeFinalizer = fin }) queue   return (le & logEnvScribes %~ M.insert nm sh)+{-# INLINE registerScribe#-}   -------------------------------------------------------------------------------@@ -757,7 +783,7 @@           void (tryAny (write a))           go         PoisonPill -> return ()-+{-# INLINE spawnScribeWorker #-}  ------------------------------------------------------------------------------- data ScribeSettings = ScribeSettings {@@ -853,59 +879,81 @@  instance Katip m => Katip (ReaderT s m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = mapReaderT . localLogEnv+    {-# INLINE localLogEnv #-}   #if !MIN_VERSION_either(4, 5, 0) instance Katip m => Katip (EitherT s m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = mapEitherT . localLogEnv+    {-# INLINE localLogEnv #-} #endif   instance Katip m => Katip (ExceptT s m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = mapExceptT . localLogEnv+    {-# INLINE localLogEnv #-}   instance Katip m => Katip (MaybeT m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = mapMaybeT . localLogEnv+    {-# INLINE localLogEnv #-}   instance Katip m => Katip (StateT s m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = mapStateT . localLogEnv+    {-# INLINE localLogEnv #-}   instance (Katip m, Monoid w) => Katip (RWST r w s m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = mapRWST . localLogEnv+    {-# INLINE localLogEnv #-}   instance (Katip m, Monoid w) => Katip (Strict.RWST r w s m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = Strict.mapRWST . localLogEnv+    {-# INLINE localLogEnv #-}   instance Katip m => Katip (Strict.StateT s m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = Strict.mapStateT . localLogEnv+    {-# INLINE localLogEnv #-}   instance (Katip m, Monoid s) => Katip (WriterT s m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = mapWriterT . localLogEnv+    {-# INLINE localLogEnv #-}   instance (Katip m, Monoid s) => Katip (Strict.WriterT s m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = Strict.mapWriterT . localLogEnv+    {-# INLINE localLogEnv #-}   instance (Katip m) => Katip (ResourceT m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = transResourceT . localLogEnv+    {-# INLINE localLogEnv #-}   -------------------------------------------------------------------------------@@ -956,6 +1004,7 @@ -- | Execute 'KatipT' on a log env. runKatipT :: LogEnv -> KatipT m a -> m a runKatipT le (KatipT f) = runReaderT f le+{-# INLINE runKatipT #-}   -------------------------------------------------------------------------------@@ -994,6 +1043,7 @@             <*> _logEnvTimer             <*> pure (_logEnvApp <> ns)             <*> pure loc)+{-# INLINE logItem#-}  -- | Log already constructed 'Item'. This is the lowest level function that other log* --   functions use.@@ -1008,6 +1058,7 @@       FT.forM_ (M.elems _logEnvScribes) $ \ ScribeHandle {..} -> do         whenM (scribePermitItem shScribe item) $           void $ atomically (tryWriteTBQueue shChan (NewItem item))+{-# INLINE logKatipItem#-}  ------------------------------------------------------------------------------- tryWriteTBQueue@@ -1019,6 +1070,7 @@   full <- isFullTBQueue q   unless full (writeTBQueue q a)   return (not full)+{-# INLINE tryWriteTBQueue#-}   -------------------------------------------------------------------------------@@ -1035,6 +1087,7 @@   -- ^ The log message   -> m () logF a ns sev msg = logItem a ns Nothing sev msg+{-# INLINE logF#-}   

@@ -41,7 +41,7 @@     return (buf, 19)   where     toText (arr, len) = Text arr 0 len-{-# INLINEABLE formatAsLogTime #-}+{-# INLINE formatAsLogTime #-}  -- | Format 'UTCTime' into a Iso8601 format. --@@ -68,7 +68,7 @@     return (buf, next + 1)   where     toText (arr, len) = Text arr 0 len-{-# INLINEABLE formatAsIso8601 #-}+{-# INLINE formatAsIso8601 #-}  -- | Writes the @YYYY-MM-DD@ part of timestamp writeDay :: TA.MArray s -> Int -> Day -> ST s Int@@ -115,6 +115,7 @@     T s1 s2 = twoDigits (fromIntegral real)     (real, frac) = ss `quotRem` pico     pico = 1000000000000 -- number of picoseconds  in 1 second+{-# INLINE writeTimeOfDay #-}  writeFracSeconds :: TA.MArray s -> Int -> Int64 -> ST s Int writeFracSeconds buf off frac =@@ -129,6 +130,7 @@   where     (mics, mills) = frac `quotRem` micro     micro = 1000000 -- number of microseconds in 1 second+{-# INLINE writeFracSeconds #-}  writeDigit6 :: TA.MArray s -> Int -> Int -> ST s () writeDigit6 buf off i =

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, OverloadedStrings #-}  module Katip.Scribes.Handle where @@ -31,24 +31,30 @@  ------------------------------------------------------------------------------- brackets :: Builder -> Builder-brackets m = fromText "[" M.<> m <> fromText "]"+brackets m = "[" M.<> m <> "]"+{-# INLINE brackets #-}  ------------------------------------------------------------------------------- getKeys :: LogItem s => Verbosity -> s -> [Builder] getKeys verb a = concat (toBuilders (payloadObject verb a))+{-# INLINE getKeys #-}  #if MIN_VERSION_aeson(2, 0, 0) toBuilders :: KM.KeyMap Value -> [[Builder]] toBuilders = fmap (renderPair . first K.toText) . KM.toList+{-# INLINE toBuilders #-}  toTxtKeyList :: KM.KeyMap v -> [(Text, v)] toTxtKeyList mp = first K.toText <$> KM.toList mp+{-# INLINE toTxtKeyList #-} #else toBuilders :: HM.HashMap Text Value -> [[Builder]] toBuilders = fmap renderPair . HM.toList+{-# INLINE toBuilders #-}  toTxtKeyList :: HM.HashMap Text v -> [(Text, v)] toTxtKeyList = HM.toList+{-# INLINE toTxtKeyList #-} #endif  renderPair :: (Text, Value) -> [Builder]@@ -64,6 +70,7 @@     formatNumber :: Scientific -> String     formatNumber n =       formatScientific Generic (if isFloating n then Nothing else Just 0) n+{-# INLINE renderPair #-}  ------------------------------------------------------------------------------- data ColorStrategy@@ -87,6 +94,7 @@ -- handle. Handle mode is set to 'LineBuffering' automatically. mkHandleScribe :: ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe mkHandleScribe = mkHandleScribeWithFormatter bracketFormat+{-# INLINE mkHandleScribe #-}  -- | Logs to a file handle such as stdout, stderr, or a file. Takes a custom -- `ItemFormatter` that can be used to format `Item` as needed.@@ -110,6 +118,7 @@         bracket_ (takeMVar lock) (putMVar lock ()) $           T.hPutStrLn h $ toLazyText $ itemFormatter colorize verb i   return $ Scribe logger (hFlush h) permitF+{-# INLINE mkHandleScribeWithFormatter #-}  ------------------------------------------------------------------------------- @@ -123,6 +132,7 @@   h <- openFile f AppendMode   Scribe logger finalizer permit <- mkHandleScribe (ColorLog False) h permitF verb   return (Scribe logger (finalizer `finally` hClose h) permit)+{-# INLINE mkFileScribe #-}  ------------------------------------------------------------------------------- @@ -136,6 +146,7 @@ formatItem :: LogItem a => ItemFormatter a formatItem = bracketFormat {-# DEPRECATED formatItem "Use bracketFormat instead" #-}+{-# INLINE formatItem #-}  -- | A traditional 'bracketed' log format. Contexts and other information will -- be flattened out into bracketed fields. For example:@@ -160,6 +171,7 @@     ks = map brackets $ getKeys verb _itemPayload     renderSeverity' severity =       colorBySeverity withColor severity (renderSeverity severity)+{-# INLINE bracketFormat #-}  -- | Logs items as JSON. This can be useful in circumstances where you already -- have infrastructure that is expecting JSON to be logged to a standard stream@@ -173,6 +185,7 @@   fromText $     colorBySeverity withColor (_itemSeverity i) $       toStrict $ decodeUtf8 $ encode $ itemJson verb i+{-# INLINE jsonFormat #-}  -- | Color a text message based on `Severity`. `ErrorS` and more severe errors -- are colored red, `WarningS` is colored yellow, and all other messages are@@ -191,6 +204,7 @@     colorize c s       | withColor = "\ESC[" <> c <> "m" <> s <> "\ESC[0m"       | otherwise = s+{-# INLINE colorBySeverity #-}  -- | Provides a simple log environment with 1 scribe going to -- stdout. This is a decent example of how to build a LogEnv and is@@ -201,3 +215,4 @@   le <- initLogEnv "io" "io"   lh <- mkHandleScribe ColorIfTerminal stdout permit verb   registerScribe "stdout" lh defaultScribeSettings le+{-# INLINE ioLogEnv #-}