@@ -2,20 +2,30 @@
22
33module Katip.Scribes.Handle
44 ( mkHandleScribe
5+ -- * exported for benchmarking
6+ , mkHandleScribe'
7+ , bbFormat
8+ , colorFormat
59 ) where
610
711-------------------------------------------------------------------------------
812import Blaze.ByteString.Builder
913import Blaze.ByteString.Builder.Char.Utf8
1014import Control.Lens
15+import Control.Monad
16+import qualified Data.String as S
1117import Data.Aeson.Lens
1218import qualified Data.ByteString.Char8 as B
1319import qualified Data.HashMap.Strict as HM
1420import Data.Monoid
21+import Data.Text.Lazy (pack, fromStrict, fromChunks)
22+import Data.Text.Lazy.Encoding
1523import Data.Time
1624import System.IO
1725import System.IO.Unsafe (unsafePerformIO)
1826import System.Locale
27+
28+import qualified Text.PrettyPrint.Leijen.Text as PP
1929-------------------------------------------------------------------------------
2030import Katip.Core
2131-------------------------------------------------------------------------------
@@ -44,24 +54,59 @@ renderPrim NullPrim = fromByteString "null"
4454
4555-------------------------------------------------------------------------------
4656mkHandleScribe :: Handle -> Severity -> Verbosity -> IO Scribe
47−mkHandleScribe h sev verb = do
57+mkHandleScribe = mkHandleScribe' bbFormat
58+
59+
60+-------------------------------------------------------------------------------
61+mkHandleScribe' :: (forall a. LogContext a => Verbosity -> Item a -> Builder) -> Handle -> Severity -> Verbosity -> IO Scribe
62+mkHandleScribe' fmt h sev verb = do
4863 hSetBuffering h LineBuffering
49− return $ Scribe $ \ Item{..} -> do
50− let nowStr = fromString $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" itemTime
51− ks = map brackets $ getKeys verb itemPayload
52− msg = brackets nowStr <>
53− brackets (mconcat $ map fromText $ intercalateNs itemNamespace) <>
54− brackets (fromText (renderSeverity itemSeverity)) <>
55− brackets (fromString itemHost) <>
56− brackets (fromString (show itemProcess)) <>
57− brackets (fromString (show itemThread)) <>
58− mconcat ks <>
59− maybe mempty (brackets . fromString . locationToString) itemLoc <>
60− fromText " " <> fromText itemMessage
61− if itemSeverity >= sev
62− then B.hPutStrLn h $ toByteString msg
63− else return ()
64+ return $ Scribe $ \ i@Item{..} -> do
65+ when (itemSeverity >= sev) $
66+ B.hPutStrLn h $ toByteString $ fmt verb i
67+
6468
69+-------------------------------------------------------------------------------
70+bbFormat verb Item{..} =
71+ brackets nowStr <>
72+ brackets (mconcat $ map fromText $ intercalateNs itemNamespace) <>
73+ brackets (fromText (renderSeverity itemSeverity)) <>
74+ brackets (fromString itemHost) <>
75+ brackets (fromString (show itemProcess)) <>
76+ brackets (fromString (show itemThread)) <>
77+ mconcat ks <>
78+ maybe mempty (brackets . fromString . locationToString) itemLoc <>
79+ fromText " " <> fromText itemMessage
80+ where
81+ nowStr = fromString $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" itemTime
82+ ks = map brackets $ getKeys verb itemPayload
83+
84+
85+-------------------------------------------------------------------------------
86+colorFormat verb Item{..} = disp $
87+ PP.brackets (PP.string nowStr) <>
88+ PP.brackets (PP.string $ fromChunks $ intercalateNs itemNamespace) <>
89+ PP.brackets (PP.string $ fromStrict (renderSeverity' itemSeverity)) <>
90+ PP.brackets (PP.string $ pack itemHost) <>
91+ PP.brackets (PP.string $ pack (show itemProcess)) <>
92+ PP.brackets (PP.string $ pack (show itemThread)) <>
93+ mconcat ks <>
94+ maybe mempty (PP.brackets . S.fromString . locationToString) itemLoc <>
95+ PP.space <> PP.string (fromStrict itemMessage)
96+ where
97+ disp = fromLazyByteString . encodeUtf8 . PP.displayT . PP.renderCompact
98+ nowStr = pack $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" itemTime
99+ ks = map (PP.brackets . PP.string . decodeUtf8 . toLazyByteString) $ getKeys verb itemPayload
100+ renderSeverity' s = case s of
101+ Emergency -> red $ renderSeverity s
102+ Alert -> red $ renderSeverity s
103+ Critical -> red $ renderSeverity s
104+ Error -> red $ renderSeverity s
105+ Warning -> yellow $ renderSeverity s
106+ _ -> renderSeverity s
107+ red = colorize "31"
108+ yellow = colorize "33"
109+ colorize c s = "\ESC["<> c <> "m" <> s <> "\ESC[0m"
65110
66111
67112-------------------------------------------------------------------------------