git.iko.soy/typeable/katip
on master help sign in
Merge remote-tracking branch 'remotes/origin/color-handle'
ad3a240Ozgun Ataman
bench/Main.hsnew file+79
compare with master
unifiedsplit
@@ -0,0 +1,79 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Main
3+ ( main
4+ ) where
5+
6+
7+-------------------------------------------------------------------------------
8+import Blaze.ByteString.Builder
9+import Control.Concurrent
10+import Control.Monad.IO.Class
11+import CriterionPlus
12+import Data.Aeson
13+import Data.Monoid
14+import Data.Text (Text)
15+import Data.Time.Calendar
16+import Data.Time.Clock
17+import System.IO
18+import System.Posix
19+-------------------------------------------------------------------------------
20+import Katip.Core
21+import Katip.Scribes.Handle
22+-------------------------------------------------------------------------------
23+
24+main :: IO ()
25+main = benchmark $
26+ handleScribeBench
27+
28+
29+-------------------------------------------------------------------------------
30+handleScribeBench :: Benchmark ()
31+handleScribeBench = standoff "Katip.Scribes.Handle" $
32+ subject "Bytestring Builder" $ do
33+ pause
34+ (Scribe push) <- liftIO setup
35+ tid <- liftIO myThreadId
36+ continue
37+ whnfIO $ push $ exItem tid
38+
39+
40+-------------------------------------------------------------------------------
41+exItem :: ThreadId -> Item ExPayload
42+exItem tid = Item {
43+ itemApp = Namespace ["app"]
44+ , itemEnv = Environment "production"
45+ , itemSeverity = Warning
46+ , itemThread = tid
47+ , itemHost = "example"
48+ , itemProcess = CPid 123
49+ , itemPayload = ExPayload
50+ , itemMessage = "message"
51+ , itemTime = mkUTCTime 2015 3 14 1 5 9
52+ , itemNamespace = Namespace ["foo"]
53+ , itemLoc = Nothing
54+ }
55+
56+
57+-------------------------------------------------------------------------------
58+data ExPayload = ExPayload
59+
60+instance ToJSON ExPayload where
61+ toJSON _ = Object mempty
62+
63+instance LogContext ExPayload where
64+ payloadKeys _ _ = AllKeys
65+
66+
67+-------------------------------------------------------------------------------
68+mkUTCTime :: Integer -> Int -> Int -> DiffTime -> DiffTime -> DiffTime -> UTCTime
69+mkUTCTime y mt d h mn s = UTCTime day dt
70+ where
71+ day = fromGregorian y mt d
72+ dt = h * 60 * 60 + mn * 60 + s
73+
74+
75+-------------------------------------------------------------------------------
76+setup :: IO Scribe
77+setup = do
78+ h <- openFile "/dev/null" WriteMode
79+ mkHandleScribe h Debug V0
katip.cabal+24−5
@@ -12,13 +12,13 @@ build-type: Simple
12cabal-version: >=1.10
12cabal-version: >=1.10
13
13
14library
14library
15− exposed-modules:
15+ exposed-modules:
16 Katip
16 Katip
17 Katip.Core
17 Katip.Core
18 Katip.Scribes.Handle
18 Katip.Scribes.Handle
19
19
20− -- other-modules:
20+ -- other-modules:
21− default-extensions:
21+ default-extensions:
22 DeriveGeneric
22 DeriveGeneric
23 FlexibleContexts
23 FlexibleContexts
24 GeneralizedNewtypeDeriving
24 GeneralizedNewtypeDeriving
@@ -28,7 +28,7 @@ library
28 TemplateHaskell
28 TemplateHaskell
29 OverloadedStrings
29 OverloadedStrings
30
30
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 , auto-update >= 0.1 && < 0.2
34 , auto-update >= 0.1 && < 0.2
@@ -49,4 +49,23 @@ library
49
49
50 hs-source-dirs: src
50 hs-source-dirs: src
51 default-language: Haskell2010
51 default-language: Haskell2010
52− ghc-options: -Wall
52+ ghc-options: -Wall
53+
54+
55+benchmark bench
56+ type: exitcode-stdio-1.0
57+ main-is: Main.hs
58+ hs-source-dirs: bench
59+ default-language: Haskell2010
60+ ghc-options: -O2
61+ build-depends:
62+ base
63+ , aeson
64+ , blaze-builder
65+ , katip
66+ , criterion >= 0.8 && < 1.0
67+ , criterion-plus
68+ , unix
69+ , text
70+ , time
71+ , transformers
src/Katip/Scribes/Handle.hs+33−16
@@ -8,6 +8,7 @@ module Katip.Scribes.Handle
8import Blaze.ByteString.Builder
8import Blaze.ByteString.Builder
9import Blaze.ByteString.Builder.Char.Utf8
9import Blaze.ByteString.Builder.Char.Utf8
10import Control.Lens
10import Control.Lens
11+import Control.Monad
11import Data.Aeson.Lens
12import Data.Aeson.Lens
12import qualified Data.ByteString.Char8 as B
13import qualified Data.ByteString.Char8 as B
13import qualified Data.HashMap.Strict as HM
14import qualified Data.HashMap.Strict as HM
@@ -46,23 +47,40 @@ renderPrim NullPrim = fromByteString "null"
46mkHandleScribe :: Handle -> Severity -> Verbosity -> IO Scribe
47mkHandleScribe :: Handle -> Severity -> Verbosity -> IO Scribe
47mkHandleScribe h sev verb = do
48mkHandleScribe h sev verb = do
48 hSetBuffering h LineBuffering
49 hSetBuffering h LineBuffering
50+ colorize <- hIsTerminalDevice h
49− return $ Scribe $ \ Item{..} -> do
51+ 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
52+ when (itemSeverity >= sev) $
62− then B.putStrLn $ toByteString msg
53+ B.hPutStrLn h $ toByteString $ formatItem colorize verb i
63− else return ()
64
54
65
55
56+-------------------------------------------------------------------------------
57+formatItem :: LogContext a => Bool -> Verbosity -> Item a -> Builder
58+formatItem withColor verb Item{..} =
59+ brackets nowStr <>
60+ brackets (mconcat $ map fromText $ intercalateNs itemNamespace) <>
61+ brackets (fromText (renderSeverity' itemSeverity)) <>
62+ brackets (fromString itemHost) <>
63+ brackets (fromString (show itemProcess)) <>
64+ brackets (fromString (show itemThread)) <>
65+ mconcat ks <>
66+ maybe mempty (brackets . fromString . locationToString) itemLoc <>
67+ fromText " " <> fromText itemMessage
68+ where
69+ nowStr = fromString $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" itemTime
70+ ks = map brackets $ getKeys verb itemPayload
71+ renderSeverity' s = case s of
72+ Emergency -> red $ renderSeverity s
73+ Alert -> red $ renderSeverity s
74+ Critical -> red $ renderSeverity s
75+ Error -> red $ renderSeverity s
76+ Warning -> yellow $ renderSeverity s
77+ _ -> renderSeverity s
78+ red = colorize "31"
79+ yellow = colorize "33"
80+ colorize c s
81+ | withColor = "\ESC["<> c <> "m" <> s <> "\ESC[0m"
82+ | otherwise = s
83+
66
84
67-------------------------------------------------------------------------------
85-------------------------------------------------------------------------------
68-- | An implicit environment to enable logging directly ouf of the IO monad.
86-- | An implicit environment to enable logging directly ouf of the IO monad.
@@ -78,4 +96,3 @@ _ioLogEnv = unsafePerformIO $ do
78-- | A default IO instance to make prototype development easy. User
96-- | A default IO instance to make prototype development easy. User
79-- your own 'Monad' for production.
97-- your own 'Monad' for production.
80instance Katip IO where getLogEnv = return _ioLogEnv
98instance Katip IO where getLogEnv = return _ioLogEnv
81−