git.iko.soy/typeable/katip
on master help sign in
Merge remote-tracking branch 'remotes/origin/color-handle'

Conflicts: katip.cabal

commitad3a2401310fc65dd9ac2cde4a02c94fc8325405 authorOzgun Ataman <ozgun.ataman@soostone.com> dateSun 1 Mar 2015, 20:55 (12 years ago) parentb120a852a6b6ed
3 files changed+136−21
compare with master
unifiedsplit
bench/Main.hs+79 katip.cabal+24−5 src/Katip/Scribes/Handle.hs+33−16
bench/Main.hsnew file+79
@@ -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
1212cabal-version: >=1.10
1313
1414library
15− exposed-modules:
15+ exposed-modules:
1616 Katip
1717 Katip.Core
1818 Katip.Scribes.Handle
1919
20− -- other-modules:
21− default-extensions:
20+ -- other-modules:
21+ default-extensions:
2222 DeriveGeneric
2323 FlexibleContexts
2424 GeneralizedNewtypeDeriving
@@ -28,7 +28,7 @@ library
2828 TemplateHaskell
2929 OverloadedStrings
3030
31− build-depends:
31+ build-depends:
3232 base >=4.6 && <4.7
3333 , aeson >=0.7 && <0.8
3434 , auto-update >= 0.1 && < 0.2
@@ -49,4 +49,23 @@ library
4949
5050 hs-source-dirs: src
5151 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
88import Blaze.ByteString.Builder
99import Blaze.ByteString.Builder.Char.Utf8
1010import Control.Lens
11+import Control.Monad
1112import Data.Aeson.Lens
1213import qualified Data.ByteString.Char8 as B
1314import qualified Data.HashMap.Strict as HM
@@ -46,23 +47,40 @@ renderPrim NullPrim = fromByteString "null"
4647mkHandleScribe :: Handle -> Severity -> Verbosity -> IO Scribe
4748mkHandleScribe h sev verb = do
4849 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.putStrLn $ toByteString msg
63− else return ()
50+ colorize <- hIsTerminalDevice h
51+ return $ Scribe $ \ i@Item{..} -> do
52+ when (itemSeverity >= sev) $
53+ B.hPutStrLn h $ toByteString $ formatItem colorize verb i
6454
6555
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+
6684
6785-------------------------------------------------------------------------------
6886-- | An implicit environment to enable logging directly ouf of the IO monad.
@@ -78,4 +96,3 @@ _ioLogEnv = unsafePerformIO $ do
7896-- | A default IO instance to make prototype development easy. User
7997-- your own 'Monad' for production.
8098instance Katip IO where getLogEnv = return _ioLogEnv
81−