@@ -3,17 +3,19 @@ module Katip.Scribes.Handle where
33-------------------------------------------------------------------------------
44import Control.Applicative as A
55import Control.Concurrent
6−import Control.Exception (bracket_, finally)
6+import Control.Exception (finally)
77import Data.Aeson
8−import Data.Text.Lazy (toStrict)
9−import Data.Text.Lazy.Encoding (decodeUtf8)
10−import qualified Data.HashMap.Strict as HM
8+import Data.Aeson.Text
9+import Data.ByteString.Builder as B
10+import Data.ByteString.Lazy as BL (hPutStr)
1111import Data.Monoid as M
1212import Data.Scientific as S
1313import Data.Text (Text)
14−import Data.Text.Lazy.Builder
15−import Data.Text.Lazy.IO as T
14+import Data.Text.Lazy.Builder as TL
15+import Data.Text.Lazy.Encoding (encodeUtf8)
1616import System.IO
17+import qualified Data.HashMap.Strict as HM
18+
1719-------------------------------------------------------------------------------
1820import Katip.Core
1921import Katip.Format.Time (formatAsLogTime)
@@ -21,15 +23,20 @@ import Katip.Format.Time (formatAsLogTime)
2123
2224
2325-------------------------------------------------------------------------------
24−brackets :: Builder -> Builder
26+brackets :: TL.Builder -> TL.Builder
2527brackets m = fromText "[" M.<> m <> fromText "]"
2628
29+textBuilderToBS :: TL.Builder -> B.Builder
30+textBuilderToBS = B.lazyByteString . encodeUtf8 . toLazyText
31+
32+appendNL :: TL.Builder -> TL.Builder
33+appendNL b = b <> TL.singleton '\n'
2734
2835-------------------------------------------------------------------------------
29−getKeys :: LogItem s => Verbosity -> s -> [Builder]
36+getKeys :: LogItem s => Verbosity -> s -> [TL.Builder]
3037getKeys verb a = concat (renderPair A.<$> HM.toList (payloadObject verb a))
3138 where
32− renderPair :: (Text, Value) -> [Builder]
39+ renderPair :: (Text, Value) -> [TL.Builder]
3340 renderPair (k,v) =
3441 case v of
3542 Object o -> concat [renderPair (k <> "." <> k', v') | (k', v') <- HM.toList o]
@@ -77,14 +84,12 @@ mkHandleScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a)
7784 -> Verbosity
7885 -> IO Scribe
7986mkHandleScribeWithFormatter itemFormatter cs h permitF verb = do
80− hSetBuffering h LineBuffering
8187 colorize <- case cs of
8288 ColorIfTerminal -> hIsTerminalDevice h
8389 ColorLog b -> return b
8490 lock <- newMVar ()
85− let logger i@Item{..} = do
86− bracket_ (takeMVar lock) (putMVar lock ()) $
87− T.hPutStrLn h $ toLazyText $ itemFormatter colorize verb i
91+ let logger i@Item{..} = withMVar lock $ \() -> do
92+ BL.hPutStr h $ toLazyByteString $ itemFormatter colorize verb i
8893 return $ Scribe logger (hFlush h) permitF
8994
9095
@@ -104,10 +109,11 @@ mkFileScribe f permitF verb = do
104109-------------------------------------------------------------------------------
105110-- | A custom ItemFormatter for logging `Item`s. Takes a `Bool` indicating
106111-- whether to colorize the output, `Verbosity` of output, and an `Item` to
107−-- format.
112+-- format. Note that formatter is responsible for appending the newline at the
113+-- end of the string if required
108114--
109115-- See `bracketFormat` and `jsonFormat` for examples.
110−type ItemFormatter a = Bool -> Verbosity -> Item a -> Builder
116+type ItemFormatter a = Bool -> Verbosity -> Item a -> B.Builder
111117
112118
113119formatItem :: LogItem a => ItemFormatter a
@@ -121,10 +127,10 @@ formatItem = bracketFormat
121127-- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][PID 1724][ThreadId 1154][confrab_factor:42.0][main:Helpers.Logging Helpers/Logging.hs:41:9] Confrabulating widgets, with extra namespace and context
122128-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal
123129bracketFormat :: LogItem a => ItemFormatter a
124−bracketFormat withColor verb Item{..} =
130+bracketFormat withColor verb Item{..} = textBuilderToBS $ appendNL $
125131 brackets nowStr <>
126132 brackets (mconcat $ map fromText $ intercalateNs _itemNamespace) <>
127− brackets (fromText (renderSeverity' _itemSeverity)) <>
133+ brackets (renderSeverity' _itemSeverity) <>
128134 brackets (fromString _itemHost) <>
129135 brackets ("PID " <> fromString (show _itemProcess)) <>
130136 brackets ("ThreadId " <> fromText (getThreadIdText _itemThread)) <>
@@ -135,7 +141,7 @@ bracketFormat withColor verb Item{..} =
135141 nowStr = fromText (formatAsLogTime _itemTime)
136142 ks = map brackets $ getKeys verb _itemPayload
137143 renderSeverity' severity =
138− colorBySeverity withColor severity (renderSeverity severity)
144+ colorBySeverity withColor severity (fromText $ renderSeverity severity)
139145
140146-- | Logs items as JSON. This can be useful in circumstances where you already
141147-- have infrastructure that is expecting JSON to be logged to a standard stream
@@ -145,15 +151,15 @@ bracketFormat withColor verb Item{..} =
145151-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp","confrabulation"],"data":{"confrab_factor":42},"app":["MyApp"],"msg":"Confrabulating widgets, with extra namespace and context","pid":"10456","loc":{"loc_col":11,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":53},"host":"myhost.example.com","sev":"Debug","thread":"ThreadId 139"}
146152-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp"],"data":{},"app":["MyApp"],"msg":"Namespace and context are back to normal","pid":"10456","loc":{"loc_col":9,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":55},"host":"myhost.example.com","sev":"Info","thread":"ThreadId 139"}
147153jsonFormat :: LogItem a => ItemFormatter a
148−jsonFormat withColor verb i =
149− fromText $
154+jsonFormat withColor verb i = textBuilderToBS $
155+ appendNL $
150156 colorBySeverity withColor (_itemSeverity i) $
151− toStrict $ decodeUtf8 $ encode $ itemJson verb i
157+ encodeToTextBuilder $ itemJson verb i
152158
153159-- | Color a text message based on `Severity`. `ErrorS` and more severe errors
154160-- are colored red, `WarningS` is colored yellow, and all other messages are
155161-- rendered in the default color.
156−colorBySeverity :: Bool -> Severity -> Text -> Text
162+colorBySeverity :: Bool -> Severity -> TL.Builder -> TL.Builder
157163colorBySeverity withColor severity msg = case severity of
158164 EmergencyS -> red msg
159165 AlertS -> red msg