git.iko.soy/typeable/katip
on master help sign in
Experiment using aeson's time formatter
77aaf46Michael Xavier
katip/bench/Main.hs+14−2
compare with master
unifiedsplit
@@ -34,6 +34,18 @@ handleScribeBench = bgroup "Katip.Scribes.Handle" [
34 env setupEnv $ \ ~(Scribe push, tid) ->
34 env setupEnv $ \ ~(Scribe push, tid) ->
35 bench "Bytestring Builder" $
35 bench "Bytestring Builder" $
36 whnfIO $ push $ exItem tid
36 whnfIO $ push $ exItem tid
37+ , bgroup "formatItem"
38+ [ bench "with color" $
39+ whnf (formatItem True V3) (exItem (ThreadIdText "1"))
40+ , bench "without color" $
41+ whnf (formatItem False V3) (exItem (ThreadIdText "1"))
42+ ]
43+ , bgroup "formatItem'"
44+ [ bench "with color" $
45+ whnf (formatItem' True V3) (exItem (ThreadIdText "1"))
46+ , bench "without color" $
47+ whnf (formatItem' False V3) (exItem (ThreadIdText "1"))
48+ ]
37 ]
49 ]
38 where
50 where
39 setupEnv = do
51 setupEnv = do
@@ -73,9 +85,9 @@ instance LogItem ExPayload where
73
85
74-------------------------------------------------------------------------------
86-------------------------------------------------------------------------------
75mkUTCTime :: Integer -> Int -> Int -> DiffTime -> DiffTime -> DiffTime -> UTCTime
87mkUTCTime :: Integer -> Int -> Int -> DiffTime -> DiffTime -> DiffTime -> UTCTime
76−mkUTCTime y mt d h mn s = UTCTime day dt
88+mkUTCTime y mt d h mn s = UTCTime dy dt
77 where
89 where
78− day = fromGregorian y mt d
90+ dy = fromGregorian y mt d
79 dt = h * 60 * 60 + mn * 60 + s
91 dt = h * 60 * 60 + mn * 60 + s
80
92
81
93
katip/src/Katip/Scribes/Handle.hs+131−7
@@ -1,20 +1,26 @@
1+{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE RecordWildCards #-}
2−
3module Katip.Scribes.Handle where
3module Katip.Scribes.Handle where
4
4
5-------------------------------------------------------------------------------
5-------------------------------------------------------------------------------
6−import Control.Applicative as A
6+import Control.Applicative as A
7import Control.Monad
7import Control.Monad
8import Data.Aeson
8import Data.Aeson
9+import Data.Aeson.Internal.Time
10+import qualified Data.ByteString.Builder as B
11+import Data.ByteString.Builder.Prim ((>$<), (>*<))
12+import qualified Data.ByteString.Builder.Prim as BP
13+import Data.Char (chr)
9−import qualified Data.HashMap.Strict as HM
14+import qualified Data.HashMap.Strict as HM
10import Data.Monoid
15import Data.Monoid
11−import Data.Text (Text)
16+import Data.Text (Text)
12import Data.Text.Lazy.Builder
17import Data.Text.Lazy.Builder
13−import Data.Text.Lazy.IO as T
18+import Data.Text.Lazy.Encoding (decodeUtf8)
19+import Data.Text.Lazy.IO as T
14import Data.Time
20import Data.Time
15−import qualified Data.Time.Locale.Compat as LC
21+import qualified Data.Time.Locale.Compat as LC
16import System.IO
22import System.IO
17−import System.IO.Unsafe (unsafePerformIO)
23+import System.IO.Unsafe (unsafePerformIO)
18-------------------------------------------------------------------------------
24-------------------------------------------------------------------------------
19import Katip.Core
25import Katip.Core
20-------------------------------------------------------------------------------
26-------------------------------------------------------------------------------
@@ -96,6 +102,124 @@ formatItem withColor verb Item{..} =
96 | otherwise = s
102 | otherwise = s
97
103
98
104
105+-------------------------------------------------------------------------------
106+formatItem' :: LogItem a => Bool -> Verbosity -> Item a -> Builder
107+formatItem' withColor verb Item{..} =
108+ brackets nowStr <>
109+ brackets (mconcat $ map fromText $ intercalateNs _itemNamespace) <>
110+ brackets (fromText (renderSeverity' _itemSeverity)) <>
111+ brackets (fromString _itemHost) <>
112+ brackets (fromString (show _itemProcess)) <>
113+ brackets (fromText (getThreadIdText _itemThread)) <>
114+ mconcat ks <>
115+ maybe mempty (brackets . fromString . locationToString) _itemLoc <>
116+ fromText " " <> (unLogStr _itemMessage)
117+ where
118+ nowStr = fromLazyText $ decodeUtf8 $ B.toLazyByteString $ utcTime _itemTime
119+ ks = map brackets $ getKeys verb _itemPayload
120+ renderSeverity' s = case s of
121+ EmergencyS -> red $ renderSeverity s
122+ AlertS -> red $ renderSeverity s
123+ CriticalS -> red $ renderSeverity s
124+ ErrorS -> red $ renderSeverity s
125+ WarningS -> yellow $ renderSeverity s
126+ _ -> renderSeverity s
127+ red = colorize "31"
128+ yellow = colorize "33"
129+ colorize c s
130+ | withColor = "\ESC["<> c <> "m" <> s <> "\ESC[0m"
131+ | otherwise = s
132+
133+
134+-------------------------------------------------------------------------------
135+utcTime :: UTCTime -> B.Builder
136+utcTime (UTCTime d s) = dayTime d (diffTimeOfDay64 s) <> B.char7 'Z'
137+{-# INLINE utcTime #-}
138+
139+
140+dayTime :: Day -> TimeOfDay64 -> B.Builder
141+dayTime d t = day d <> B.char7 'T' <> timeOfDay64 t
142+{-# INLINE dayTime #-}
143+
144+
145+timeOfDay64 :: TimeOfDay64 -> B.Builder
146+timeOfDay64 (TOD h m s)
147+ | frac == 0 = hhmmss -- omit subseconds if 0
148+ | otherwise = hhmmss <> BP.primBounded showFrac frac
149+ where
150+ hhmmss = BP.primBounded (ascii8 (hh,(hl,(':',(mh,(ml,(':',(sh,sl')))))))) ()
151+ !(T hh hl) = twoDigits h
152+ !(T mh ml) = twoDigits m
153+ !(T sh sl') = twoDigits (fromIntegral real)
154+ (real,frac) = s `quotRem` pico
155+ showFrac = (\x -> ('.', x)) >$< (BP.liftFixedToBounded BP.char7 >*< trunc12)
156+ trunc12 = (`quotRem` micro) >$<
157+ BP.condB (\(_,y) -> y == 0) (fst >$< trunc6) (digits6 >*< trunc6)
158+ digits6 = ((`quotRem` milli) . fromIntegral) >$< (digits3 >*< digits3)
159+ trunc6 = ((`quotRem` milli) . fromIntegral) >$<
160+ BP.condB (\(_,y) -> y == 0) (fst >$< trunc3) (digits3 >*< trunc3)
161+ digits3 = (`quotRem` 10) >$< (digits2 >*< digits1)
162+ digits2 = (`quotRem` 10) >$< (digits1 >*< digits1)
163+ digits1 = BP.liftFixedToBounded (digit >$< BP.char7)
164+ trunc3 = BP.condB (== 0) BP.emptyB $
165+ (`quotRem` 100) >$< (digits1 >*< trunc2)
166+ trunc2 = BP.condB (== 0) BP.emptyB $
167+ (`quotRem` 10) >$< (digits1 >*< trunc1)
168+ trunc1 = BP.condB (== 0) BP.emptyB digits1
169+
170+ pico = 1000000000000 -- number of picoseconds in 1 second
171+ micro = 1000000 -- number of microseconds in 1 second
172+ milli = 1000 -- number of milliseconds in 1 second
173+{-# INLINE timeOfDay64 #-}
174+
175+
176+day :: Day -> B.Builder
177+day dd = encodeYear yr <>
178+ BP.primBounded (ascii6 ('-',(mh,(ml,('-',(dh,dl)))))) ()
179+ where (yr,m,d) = toGregorian dd
180+ !(T mh ml) = twoDigits m
181+ !(T dh dl) = twoDigits d
182+ encodeYear y
183+ | y >= 1000 = B.integerDec y
184+ | y > 0 =
185+ let (ab,c) = fromIntegral y `quotRem` 10
186+ (a,b) = ab `quotRem` 10
187+ in BP.primBounded (ascii4 ('0',(digit a,(digit b,digit c)))) ()
188+ | otherwise =
189+ error "Data.Aeson.Encode.Builder.day: years BCE not supported"
190+{-# INLINE day #-}
191+
192+
193+ascii8 :: (Char, (Char, (Char, (Char, (Char, (Char, (Char, Char)))))))
194+ -> BP.BoundedPrim a
195+ascii8 cs = BP.liftFixedToBounded $ const cs >$<
196+ BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*<
197+ BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7
198+{-# INLINE ascii8 #-}
199+
200+
201+data T = T {-# UNPACK #-} !Char {-# UNPACK #-} !Char
202+
203+
204+twoDigits :: Int -> T
205+twoDigits a = T (digit hi) (digit lo)
206+ where (hi,lo) = a `quotRem` 10
207+
208+digit :: Int -> Char
209+digit x = chr (x + 48)
210+
211+
212+ascii4 :: (Char, (Char, (Char, Char))) -> BP.BoundedPrim a
213+ascii4 cs = BP.liftFixedToBounded $ const cs >$<
214+ BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7
215+{-# INLINE ascii4 #-}
216+
217+
218+ascii6 :: (Char, (Char, (Char, (Char, (Char, Char))))) -> BP.BoundedPrim a
219+ascii6 cs = BP.liftFixedToBounded $ const cs >$<
220+ BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7
221+{-# INLINE ascii6 #-}
222+
99-------------------------------------------------------------------------------
223-------------------------------------------------------------------------------
100-- | An implicit environment to enable logging directly ouf of the IO monad.
224-- | An implicit environment to enable logging directly ouf of the IO monad.
101_ioLogEnv :: LogEnv
225_ioLogEnv :: LogEnv