git.iko.soy/typeable/katip
on master help sign in
WIP colorizing
4b43391Michael Xavier
bench/Main.hs+15−2
compare with master
unifiedsplit
@@ -34,6 +34,12 @@ handleScribeBench = standoff "Katip.Scribes.Handle" $ do
34 tid <- liftIO myThreadId
34 tid <- liftIO myThreadId
35 continue
35 continue
36 whnfIO $ push $ exItem tid
36 whnfIO $ push $ exItem tid
37+ subject "Colored" $ do
38+ pause
39+ (Scribe push) <- liftIO setupColor
40+ tid <- liftIO myThreadId
41+ continue
42+ whnfIO $ push $ exItem tid
37
43
38
44
39-------------------------------------------------------------------------------
45-------------------------------------------------------------------------------
@@ -41,7 +47,7 @@ exItem :: ThreadId -> Item ExPayload
41exItem tid = Item {
47exItem tid = Item {
42 itemApp = Namespace ["app"]
48 itemApp = Namespace ["app"]
43 , itemEnv = Environment "production"
49 , itemEnv = Environment "production"
44− , itemSeverity = Info
50+ , itemSeverity = Warning
45 , itemThread = tid
51 , itemThread = tid
46 , itemHost = "example"
52 , itemHost = "example"
47 , itemProcess = CPid 123
53 , itemProcess = CPid 123
@@ -75,4 +81,11 @@ mkUTCTime y mt d h mn s = UTCTime day dt
75setupBB :: IO Scribe
81setupBB :: IO Scribe
76setupBB = do
82setupBB = do
77 h <- openFile "/dev/null" WriteMode
83 h <- openFile "/dev/null" WriteMode
78− mkHandleScribe h Debug V0
84+ mkHandleScribe' bbFormat h Debug V0
85+
86+
87+-------------------------------------------------------------------------------
88+setupColor :: IO Scribe
89+setupColor = do
90+ h <- openFile "/dev/null" WriteMode
91+ mkHandleScribe' colorFormat h Debug V0
katip.cabal+1
@@ -31,6 +31,7 @@ library
31 build-depends:
31 build-depends:
32 base >=4.6 && <4.7
32 base >=4.6 && <4.7
33 , aeson >=0.7 && <0.8
33 , aeson >=0.7 && <0.8
34+ , wl-pprint-text >= 1.1.0.3 && < 1.2
34 , auto-update >= 0.1 && < 0.2
35 , auto-update >= 0.1 && < 0.2
35 , blaze-builder >= 0.3 && < 0.4
36 , blaze-builder >= 0.3 && < 0.4
36 , bytestring >= 0.9 && < 0.11
37 , bytestring >= 0.9 && < 0.11
src/Katip/Scribes/Handle.hs+61−16
@@ -2,20 +2,30 @@
2
2
3module Katip.Scribes.Handle
3module Katip.Scribes.Handle
4 ( mkHandleScribe
4 ( mkHandleScribe
5+ -- * exported for benchmarking
6+ , mkHandleScribe'
7+ , bbFormat
8+ , colorFormat
5 ) where
9 ) where
6
10
7-------------------------------------------------------------------------------
11-------------------------------------------------------------------------------
8import Blaze.ByteString.Builder
12import Blaze.ByteString.Builder
9import Blaze.ByteString.Builder.Char.Utf8
13import Blaze.ByteString.Builder.Char.Utf8
10import Control.Lens
14import Control.Lens
15+import Control.Monad
16+import qualified Data.String as S
11import Data.Aeson.Lens
17import Data.Aeson.Lens
12import qualified Data.ByteString.Char8 as B
18import qualified Data.ByteString.Char8 as B
13import qualified Data.HashMap.Strict as HM
19import qualified Data.HashMap.Strict as HM
14import Data.Monoid
20import Data.Monoid
21+import Data.Text.Lazy (pack, fromStrict, fromChunks)
22+import Data.Text.Lazy.Encoding
15import Data.Time
23import Data.Time
16import System.IO
24import System.IO
17import System.IO.Unsafe (unsafePerformIO)
25import System.IO.Unsafe (unsafePerformIO)
18import System.Locale
26import System.Locale
27+
28+import qualified Text.PrettyPrint.Leijen.Text as PP
19-------------------------------------------------------------------------------
29-------------------------------------------------------------------------------
20import Katip.Core
30import Katip.Core
21-------------------------------------------------------------------------------
31-------------------------------------------------------------------------------
@@ -44,24 +54,59 @@ renderPrim NullPrim = fromByteString "null"
44
54
45-------------------------------------------------------------------------------
55-------------------------------------------------------------------------------
46mkHandleScribe :: Handle -> Severity -> Verbosity -> IO Scribe
56mkHandleScribe :: 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
48 hSetBuffering h LineBuffering
63 hSetBuffering h LineBuffering
49− return $ Scribe $ \ Item{..} -> do
64+ return $ Scribe $ \ i@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
65+ when (itemSeverity >= sev) $
62− then B.hPutStrLn h $ toByteString msg
66+ B.hPutStrLn h $ toByteString $ fmt verb i
63− else return ()
67+
64
68
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"
65
110
66
111
67-------------------------------------------------------------------------------
112-------------------------------------------------------------------------------