@@ -4,15 +4,17 @@ module Katip.Scribes.Handle where
44import Control.Applicative as A
55import Control.Concurrent
66import Control.Exception (bracket_, finally)
7+import Data.ByteString.Lazy as BL (hPutStr)
8+import Data.ByteString.Builder as B
79import Data.Aeson
8−import Data.Text.Lazy (toStrict)
9−import Data.Text.Lazy.Encoding (decodeUtf8)
10+import Data.Text as T (pack)
11+import Data.Text.Encoding as T
12+import Data.Text.Lazy as TL (toStrict)
13+import Data.Text.Lazy.Encoding as TL (decodeUtf8)
1014import qualified Data.HashMap.Strict as HM
1115import Data.Monoid as M
1216import Data.Scientific as S
1317import Data.Text (Text)
14−import Data.Text.Lazy.Builder
15−import Data.Text.Lazy.IO as T
1618import System.IO
1719-------------------------------------------------------------------------------
1820import Katip.Core
@@ -20,23 +22,26 @@ import Katip.Format.Time (formatAsLogTime)
2022-------------------------------------------------------------------------------
2123
2224
25+
26+fromText :: Text -> Builder
27+fromText = B.byteString . T.encodeUtf8
28+
2329-------------------------------------------------------------------------------
2430brackets :: Builder -> Builder
25−brackets m = fromText "[" M.<> m <> fromText "]"
26−
31+brackets m = fromText "[" <> m <> fromText "]"
2732
2833-------------------------------------------------------------------------------
2934getKeys :: LogItem s => Verbosity -> s -> [Builder]
30−getKeys verb a = concat (renderPair A.<$> HM.toList (payloadObject verb a))
35+getKeys verb a = HM.toList (payloadObject verb a) >>= renderPair
3136 where
3237 renderPair :: (Text, Value) -> [Builder]
3338 renderPair (k,v) =
3439 case v of
3540 Object o -> concat [renderPair (k <> "." <> k', v') | (k', v') <- HM.toList o]
36− String t -> [fromText (k <> ":" <> t)]
37− Number n -> [fromText (k <> ":") <> fromString (formatNumber n)]
38− Bool b -> [fromText (k <> ":") <> fromString (show b)]
39− Null -> [fromText (k <> ":null")]
41+ String t -> [fromText k <> string7 ":" <> fromText t]
42+ Number n -> [fromText k <> string7 ":" <> string7 (formatNumber n)]
43+ Bool b -> [fromText k <> string7 ":" <> string7 (show b)]
44+ Null -> [fromText k <> string7 ":null"]
4045 _ -> mempty -- Can't think of a sensible way to handle arrays
4146 formatNumber :: Scientific -> String
4247 formatNumber n =
@@ -77,14 +82,12 @@ mkHandleScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a)
7782 -> Verbosity
7883 -> IO Scribe
7984mkHandleScribeWithFormatter itemFormatter cs h permitF verb = do
80− hSetBuffering h LineBuffering
8185 colorize <- case cs of
8286 ColorIfTerminal -> hIsTerminalDevice h
8387 ColorLog b -> return b
8488 lock <- newMVar ()
85− let logger i@Item{..} = do
86− bracket_ (takeMVar lock) (putMVar lock ()) $
87− T.hPutStrLn h $ toLazyText $ itemFormatter colorize verb i
89+ let logger i@Item{..} = withMVar lock $ \() -> do
90+ BL.hPutStr h $ toLazyByteString $ itemFormatter colorize verb i
8891 return $ Scribe logger (hFlush h) permitF
8992
9093
@@ -107,7 +110,7 @@ mkFileScribe f permitF verb = do
107110-- format.
108111--
109112-- See `bracketFormat` and `jsonFormat` for examples.
110−type ItemFormatter a = Bool -> Verbosity -> Item a -> Builder
113+type ItemFormatter a = Bool -> Verbosity -> Item a -> B.Builder
111114
112115
113116formatItem :: LogItem a => ItemFormatter a
@@ -125,11 +128,11 @@ bracketFormat withColor verb Item{..} =
125128 brackets nowStr <>
126129 brackets (mconcat $ map fromText $ intercalateNs _itemNamespace) <>
127130 brackets (fromText (renderSeverity' _itemSeverity)) <>
128− brackets (fromString _itemHost) <>
129− brackets ("PID " <> fromString (show _itemProcess)) <>
131+ brackets (fromText (T.pack _itemHost)) <>
132+ brackets ("PID " <> fromText (T.pack $ show _itemProcess)) <>
130133 brackets ("ThreadId " <> fromText (getThreadIdText _itemThread)) <>
131134 mconcat ks <>
132− maybe mempty (brackets . fromString . locationToString) _itemLoc <>
135+ maybe mempty (brackets . fromText . T.pack . locationToString) _itemLoc <>
133136 fromText " " <> (unLogStr _itemMessage)
134137 where
135138 nowStr = fromText (formatAsLogTime _itemTime)
@@ -148,7 +151,7 @@ jsonFormat :: LogItem a => ItemFormatter a
148151jsonFormat withColor verb i =
149152 fromText $
150153 colorBySeverity withColor (_itemSeverity i) $
151− toStrict $ decodeUtf8 $ encode $ itemJson verb i
154+ toStrict $ TL.decodeUtf8 $ encode $ itemJson verb i
152155
153156-- | Color a text message based on `Severity`. `ErrorS` and more severe errors
154157-- are colored red, `WarningS` is colored yellow, and all other messages are