@@ -0,0 +1,78 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Main
3+ ( main
4+ ) where
5+
6+
7+-------------------------------------------------------------------------------
8+import Control.Concurrent
9+import Control.Monad.IO.Class
10+import CriterionPlus
11+import Data.Aeson
12+import Data.Monoid
13+import Data.Text (Text)
14+import Data.Time.Calendar
15+import Data.Time.Clock
16+import System.IO
17+import System.Posix
18+-------------------------------------------------------------------------------
19+import Katip.Core
20+import Katip.Scribes.Handle
21+-------------------------------------------------------------------------------
22+
23+main :: IO ()
24+main = benchmark $
25+ handleScribeBench
26+
27+
28+-------------------------------------------------------------------------------
29+handleScribeBench :: Benchmark ()
30+handleScribeBench = standoff "Katip.Scribes.Handle" $ do
31+ subject "Bytestring Builder" $ do
32+ pause
33+ (Scribe push) <- liftIO setupBB
34+ tid <- liftIO myThreadId
35+ continue
36+ whnfIO $ push $ exItem tid
37+
38+
39+-------------------------------------------------------------------------------
40+exItem :: ThreadId -> Item ExPayload
41+exItem tid = Item {
42+ itemApp = Namespace ["app"]
43+ , itemEnv = Environment "production"
44+ , itemSeverity = Info
45+ , itemThread = tid
46+ , itemHost = "example"
47+ , itemProcess = CPid 123
48+ , itemPayload = ExPayload
49+ , itemMessage = "message"
50+ , itemTime = mkUTCTime 2015 3 14 1 5 9
51+ , itemNamespace = Namespace ["foo"]
52+ , itemLoc = Nothing
53+ }
54+
55+
56+-------------------------------------------------------------------------------
57+data ExPayload = ExPayload
58+
59+instance ToJSON ExPayload where
60+ toJSON _ = Object mempty
61+
62+instance LogContext ExPayload where
63+ payloadKeys _ _ = AllKeys
64+
65+
66+-------------------------------------------------------------------------------
67+mkUTCTime :: Integer -> Int -> Int -> DiffTime -> DiffTime -> DiffTime -> UTCTime
68+mkUTCTime y mt d h mn s = UTCTime day dt
69+ where
70+ day = fromGregorian y mt d
71+ dt = h * 60 * 60 + mn * 60 + s
72+
73+
74+-------------------------------------------------------------------------------
75+setupBB :: IO Scribe
76+setupBB = do
77+ h <- openFile "/dev/null" WriteMode
78+ mkHandleScribe h Debug V0