git.iko.soy/typeable/katip
on master help sign in
Merge pull request #37 from sopvop/faster-time

Faster time encoding for Handle Scribe

commit2f1cb9b420e4dc296a6f8631d9fbf89558c07e44 authorMichael Xavier <michael@michaelxavier.net> dateMon 31 Oct 2016, 08:27 (10 years ago) parentf7dd15380e0a75
7 files changed+501−7
compare with master
unifiedsplit
katip/katip.cabal+5−2 katip/src/Katip/Format/Time.hs+213 katip/src/Katip/Scribes/Handle.hs+2−3 katip/test/Katip/Tests/Format/Time.hs+81 katip/test/Katip/Tests/Scribes/Handle-text.golden+40 katip/test/Katip/Tests/Scribes/Handle.hs+158−2 katip/test/Main.hs+2
katip/katip.cabal+5−2
@@ -37,6 +37,7 @@ library
3737 exposed-modules:
3838 Katip
3939 Katip.Core
40+ Katip.Format.Time
4041 Katip.Monadic
4142 Katip.Scribes.Handle
4243
@@ -63,7 +64,6 @@ library
6364 , template-haskell >= 2.8 && < 2.12
6465 , text >= 0.11 && <1.3
6566 , time >= 1 && < 1.7
66− , time-locale-compat >= 0.1.0.1 && < 0.2
6767 , transformers >= 0.3 && < 0.6
6868 , transformers-compat
6969 , unix >= 2.5 && < 2.8
@@ -90,18 +90,21 @@ test-suite test
9090 build-depends: base
9191 , katip
9292 , aeson
93+ , bytestring
9394 , tasty >= 0.10.1.2
95+ , tasty-golden
9496 , tasty-hunit
9597 , tasty-quickcheck
9698 , quickcheck-instances
9799 , template-haskell
98100 , text
99101 , time
102+ , time-locale-compat >= 0.1.0.1 && < 0.2
100103 , temporary
101104 , directory
102105 , regex-tdfa
103106 , unordered-containers
104−
107+ , microlens
105108
106109benchmark bench
107110 type: exitcode-stdio-1.0
katip/src/Katip/Format/Time.hsnew file+213
@@ -0,0 +1,213 @@
1+-- | Time and memory efficient time encoding helper functions.
2+--
3+module Katip.Format.Time
4+ ( formatAsLogTime
5+ , formatAsIso8601
6+ ) where
7+
8+import Control.Monad.ST (ST)
9+
10+import Data.Int (Int64)
11+import qualified Data.Text.Array as TA
12+import Data.Text (Text)
13+import Data.Text.Internal (Text(..))
14+import Data.Time (UTCTime(..), toGregorian, Day, DiffTime)
15+import Data.Word (Word16)
16+import Unsafe.Coerce (unsafeCoerce)
17+
18+-- Note: All functions here are optimized to never allocate anything
19+-- on heap. At least on ghc 8.0.1 no extra strictness annotations are
20+-- seem to be needed.
21+--
22+-- Exported functions are INLINEABLE
23+
24+
25+-- | Format 'UTCTime' into a short human readable format.
26+--
27+-- >>> formatAsLogTime $ UTCTime (fromGregorian 2016 1 23) 5025.123456789012
28+-- "2016-01-23 01:23:45"
29+--
30+formatAsLogTime :: UTCTime -> Text
31+formatAsLogTime (UTCTime day time) = toText $ TA.run2 $ do
32+ buf <- TA.new 19 -- length "2016-10-20 12:34:56"
33+ _ <- writeDay buf 0 day
34+ TA.unsafeWrite buf 10 0x20 -- space
35+ _ <- writeTimeOfDay False buf 11 (diffTimeOfDay64 time)
36+ return (buf, 19)
37+ where
38+ toText (arr, len) = Text arr 0 len
39+
40+{-# INLINEABLE formatAsLogTime #-}
41+
42+-- | Format 'UTCTime' into a Iso8601 format.
43+--
44+-- Note that this function may overcommit up to 12*2 bytes, depending
45+-- on sub-second precision. If this is an issue, make a copy with a
46+-- 'Data.Text.copy'.
47+--
48+-- >>> formatAsIso8601 $ UTCTime (fromGregorian 2016 1 23) 5025.123456789012
49+-- "2016-11-23T01:23:45.123456789012Z"
50+-- >>> formatAsIso8601 $ UTCTime (fromGregorian 2016 1 23) 5025.123
51+-- "2016-01-23T01:23:45.123Z"
52+-- >>> formatAsIso8601 $ UTCTime (fromGregorian 2016 1 23) 5025
53+-- "2016-01-23T01:23:45Z"
54+
55+--
56+formatAsIso8601 :: UTCTime -> Text
57+formatAsIso8601 (UTCTime day time) = toText $ TA.run2 $ do
58+ buf <- TA.new 33 -- length "2016-10-20 12:34:56.123456789012Z"
59+ _ <- writeDay buf 0 day
60+ TA.unsafeWrite buf 10 0x54 -- T
61+ next <- writeTimeOfDay True buf 11 (diffTimeOfDay64 time)
62+ TA.unsafeWrite buf next 0x5A -- Z
63+ return (buf, next+1)
64+ where
65+ toText (arr, len) = Text arr 0 len
66+
67+{-# INLINEABLE formatAsIso8601 #-}
68+
69+-- | Writes the @YYYY-MM-DD@ part of timestamp
70+writeDay :: TA.MArray s -> Int -> Day -> ST s Int
71+writeDay buf off day =
72+ do
73+ TA.unsafeWrite buf (off + 0) (digit y1)
74+ TA.unsafeWrite buf (off + 1) (digit y2)
75+ TA.unsafeWrite buf (off + 2) (digit y3)
76+ TA.unsafeWrite buf (off + 3) (digit y4)
77+ TA.unsafeWrite buf (off + 4) 0x2d -- dash
78+ TA.unsafeWrite buf (off + 5) m1
79+ TA.unsafeWrite buf (off + 6) m2
80+ TA.unsafeWrite buf (off + 7) 0x2d -- dash
81+ TA.unsafeWrite buf (off + 8) d1
82+ TA.unsafeWrite buf (off + 9) d2
83+ return (off + 10)
84+ where
85+ (yr,m,d) = toGregorian day
86+ (y1, ya) = fromIntegral (abs yr) `quotRem` 1000
87+ (y2, yb) = ya `quotRem` 100
88+ (y3, y4) = yb `quotRem` 10
89+ T m1 m2 = twoDigits m
90+ T d1 d2 = twoDigits d
91+{-# INLINE writeDay #-}
92+
93+-- | Write time of day, optionally with sub seconds
94+writeTimeOfDay :: Bool -> TA.MArray s -> Int -> TimeOfDay64 -> ST s Int
95+writeTimeOfDay doSubSeconds buf off (TOD hh mm ss) =
96+ do
97+
98+ TA.unsafeWrite buf off h1
99+ TA.unsafeWrite buf (off + 1) h2
100+ TA.unsafeWrite buf (off + 2) 0x3A -- colon
101+ TA.unsafeWrite buf (off + 3) m1
102+ TA.unsafeWrite buf (off + 4) m2
103+ TA.unsafeWrite buf (off + 5) 0x3A -- colon
104+ TA.unsafeWrite buf (off + 6) s1
105+ TA.unsafeWrite buf (off + 7) s2
106+ if doSubSeconds && frac /= 0
107+ then writeFracSeconds buf (off + 8) frac
108+ else return (off + 8)
109+ where
110+ T h1 h2 = twoDigits hh
111+ T m1 m2 = twoDigits mm
112+ T s1 s2 = twoDigits (fromIntegral real)
113+ (real,frac) = ss `quotRem` pico
114+ pico = 1000000000000 -- number of picoseconds in 1 second
115+
116+
117+writeFracSeconds :: TA.MArray s -> Int -> Int64 -> ST s Int
118+writeFracSeconds buf off frac =
119+ do
120+ TA.unsafeWrite buf off 0x2e -- period
121+ if mills == 0
122+ then do
123+ writeTrunc6 buf (off + 1) (fromIntegral mics)
124+ else do
125+ writeDigit6 buf (off + 1) (fromIntegral mics)
126+ writeTrunc6 buf (off + 7) (fromIntegral mills)
127+
128+ where
129+ (mics, mills) = frac `quotRem` micro
130+ micro = 1000000 -- number of microseconds in 1 second
131+
132+
133+writeDigit6 :: TA.MArray s -> Int -> Int -> ST s ()
134+writeDigit6 buf off i =
135+ do
136+ writeDigit3 buf off f1
137+ writeDigit3 buf (off+3) f2
138+ where
139+ (f1, f2) = i `quotRem` 1000
140+
141+{-# INLINE writeDigit6 #-}
142+
143+writeDigit3 :: TA.MArray s -> Int -> Int -> ST s ()
144+writeDigit3 buf off i =
145+ do
146+ TA.unsafeWrite buf off (digit d1)
147+ TA.unsafeWrite buf (off+1) (digit d2)
148+ TA.unsafeWrite buf (off+2) (digit d3)
149+ where
150+ (d1, d) = i `quotRem` 100
151+ (d2, d3) = d `quotRem` 10
152+
153+{-# INLINE writeDigit3 #-}
154+
155+writeTrunc6 :: TA.MArray s -> Int -> Int -> ST s Int
156+writeTrunc6 buf off i =
157+ if f2 == 0
158+ then writeTrunc3 buf off f1
159+ else do
160+ writeDigit3 buf off f1
161+ writeTrunc3 buf (off+3) f2
162+ where
163+ (f1, f2) = i `quotRem` 1000
164+
165+{-# INLINE writeTrunc6 #-}
166+
167+
168+writeTrunc3 :: TA.MArray s -> Int -> Int -> ST s Int
169+writeTrunc3 buf off i
170+ | d == 0 = do
171+ TA.unsafeWrite buf off (digit d1)
172+ return (off+1)
173+ | d3 == 0 = do
174+ TA.unsafeWrite buf off (digit d1)
175+ TA.unsafeWrite buf (off+1) (digit d2)
176+ return (off+2)
177+
178+ | otherwise = do
179+ TA.unsafeWrite buf off (digit d1)
180+ TA.unsafeWrite buf (off+1) (digit d2)
181+ TA.unsafeWrite buf (off+2) (digit d3)
182+ return (off+3)
183+ where
184+ (d1, d) = i `quotRem` 100
185+ (d2, d3) = d `quotRem` 10
186+
187+{-# INLINE writeTrunc3 #-}
188+
189+
190+-- Following code was adapted from aeson package.
191+--
192+-- Copyright: (c) 2015-2016 Bryan O'Sullivan
193+-- License: BSD3
194+
195+data T = T {-# UNPACK #-} !Word16 {-# UNPACK #-} !Word16
196+
197+twoDigits :: Int -> T
198+twoDigits a = T (digit hi) (digit lo)
199+ where (hi,lo) = a `quotRem` 10
200+
201+digit :: Int -> Word16
202+digit x = fromIntegral (x + 48)
203+
204+
205+data TimeOfDay64 = TOD {-# UNPACK #-} !Int
206+ {-# UNPACK #-} !Int
207+ {-# UNPACK #-} !Int64
208+
209+diffTimeOfDay64 :: DiffTime -> TimeOfDay64
210+diffTimeOfDay64 t = TOD (fromIntegral h) (fromIntegral m) s
211+ where (h,mp) = fromIntegral pico `quotRem` 3600000000000000
212+ (m,s) = mp `quotRem` 60000000000000
213+ pico = unsafeCoerce t :: Integer
katip/src/Katip/Scribes/Handle.hs+2−3
@@ -13,12 +13,11 @@ import Data.Monoid
1313import Data.Text (Text)
1414import Data.Text.Lazy.Builder
1515import Data.Text.Lazy.IO as T
16−import Data.Time
17−import qualified Data.Time.Locale.Compat as LC
1816import System.IO
1917import System.IO.Unsafe (unsafePerformIO)
2018-------------------------------------------------------------------------------
2119import Katip.Core
20+import Katip.Format.Time (formatAsLogTime)
2221-------------------------------------------------------------------------------
2322
2423
@@ -83,7 +82,7 @@ formatItem withColor verb Item{..} =
8382 maybe mempty (brackets . fromString . locationToString) _itemLoc <>
8483 fromText " " <> (unLogStr _itemMessage)
8584 where
86− nowStr = fromString $ formatTime LC.defaultTimeLocale "%Y-%m-%d %H:%M:%S" _itemTime
85+ nowStr = fromText (formatAsLogTime _itemTime)
8786 ks = map brackets $ getKeys verb _itemPayload
8887 renderSeverity' s = case s of
8988 EmergencyS -> red $ renderSeverity s
katip/test/Katip/Tests/Format/Time.hsnew file+81
@@ -0,0 +1,81 @@
1+
2+module Katip.Tests.Format.Time
3+ ( tests
4+ ) where
5+
6+import Data.Aeson (toJSON)
7+import qualified Data.Text as Text
8+import Data.Time
9+import Data.Time.Clock.POSIX
10+import qualified Data.Time.Locale.Compat as LC
11+
12+import Test.Tasty
13+import Test.Tasty.HUnit
14+import Test.Tasty.QuickCheck
15+
16+import Katip.Format.Time
17+
18+tests :: TestTree
19+tests = testGroup "Katip.Format.Time"
20+ [ testCase "formatAsLogTime" $ do
21+ assertEqual "time 1" (formatDT t1) (formatAsLogTime t1)
22+ assertEqual "time 2" (formatDT t2) (formatAsLogTime t2)
23+ assertEqual "time 3" (formatDT t3) (formatAsLogTime t3)
24+ assertEqual "time 4" (formatDT t4) (formatAsLogTime t4)
25+ assertEqual "time 5" (formatDT t5) (formatAsLogTime t5)
26+
27+ , testCase "formatAsIso8601" $ do
28+ assertEqual "time 1" (formatDTISO t1) (formatAsIso8601 t1)
29+ assertEqual "time 2" (formatDTISO t2) (formatAsIso8601 t2)
30+ assertEqual "time 3" (formatDTISO t3) (formatAsIso8601 t3)
31+ assertEqual "time 4" (formatDTISO t4) (formatAsIso8601 t4)
32+ assertEqual "time 5" (formatDTISO t5) (formatAsIso8601 t5)
33+
34+ , testCase "formatAsIso8601 Aeson" $ do
35+ assertEqual "time 1" (toJSON t1) (toJSON $ formatAsIso8601 t1)
36+ assertEqual "time 2" (toJSON t2) (toJSON $ formatAsIso8601 t2)
37+ assertEqual "time 3" (toJSON t3) (toJSON $ formatAsIso8601 t3)
38+ assertEqual "time 4" (toJSON t4) (toJSON $ formatAsIso8601 t4)
39+ assertEqual "time 5" (toJSON t5) (toJSON $ formatAsIso8601 t5)
40+
41+
42+ , testProperty "LogTime same as Date.Time" $ \(ArbUTCTime t) ->
43+ prop_format_log t
44+
45+ , testProperty "ISO 8601 same as Date.Time" $ \(ArbUTCTime t) ->
46+ prop_format_iso t
47+
48+ , testProperty "ISO 8601 same as Aeson" $ \(ArbUTCTime t) ->
49+ prop_format_aeson t
50+
51+ ]
52+ where
53+ t1 = UTCTime (fromGregorian 2016 12 34) 5025.123456789012
54+ t2 = UTCTime (fromGregorian 2016 1 23) 5025.123
55+ t3 = UTCTime (fromGregorian 16 12 1) 025
56+ t4 = UTCTime (fromGregorian 2000 1 1) 0.000000000001
57+ t5 = UTCTime (fromGregorian 2000 12 31) 0.100000000001
58+
59+formatDT :: UTCTime -> Text.Text
60+formatDT = Text.pack . formatTime LC.defaultTimeLocale "%0Y-%m-%d %H:%M:%S"
61+
62+formatDTISO :: UTCTime -> Text.Text
63+formatDTISO = Text.pack . formatTime LC.defaultTimeLocale "%0Y-%m-%dT%H:%M:%S%QZ"
64+
65+prop_format_log :: UTCTime -> Property
66+prop_format_log a = formatDT a === formatAsLogTime a
67+
68+prop_format_iso :: UTCTime -> Property
69+prop_format_iso a = formatDTISO a === formatAsIso8601 a
70+
71+prop_format_aeson :: UTCTime -> Property
72+prop_format_aeson a = toJSON a === toJSON (formatAsIso8601 a)
73+
74+
75+newtype ArbUTCTime = ArbUTCTime {
76+ unArbUTCTime :: UTCTime
77+ } deriving (Show)
78+
79+instance Arbitrary ArbUTCTime where
80+ arbitrary = fmap (ArbUTCTime . posixSecondsToUTCTime . fromInteger)
81+ arbitrary
katip/test/Katip/Tests/Scribes/Handle-text.goldennew file+40
@@ -0,0 +1,40 @@
1+[2016-06-12 12:34:56][foo][Debug][example][7331][1337][note.deep:some note] message
2+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message
3+[2016-06-12 12:34:56][foo][Notice][example][7331][1337][note.deep:some note] message
4+[2016-06-12 12:34:56][foo][Warning][example][7331][1337][note.deep:some note] message
5+[2016-06-12 12:34:56][foo][Error][example][7331][1337][note.deep:some note] message
6+[2016-06-12 12:34:56][foo][Critical][example][7331][1337][note.deep:some note] message
7+[2016-06-12 12:34:56][foo][Alert][example][7331][1337][note.deep:some note] message
8+[2016-06-12 12:34:56][foo][Emergency][example][7331][1337][note.deep:some note] message
9+[2016-06-12 12:34:56][foo][Info][example][7331][0][note.deep:some note] message
10+[2016-06-12 12:34:56][foo][Info][example][7331][1][note.deep:some note] message
11+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message
12+[2016-06-12 12:34:56][foo][Info][example][7331][2147483647][note.deep:some note] message
13+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message
14+[2016-06-12 12:34:56][foo][Info][www.example.com][7331][1337][note.deep:some note] message
15+[2016-06-12 12:34:56][foo][Info][127.0.0.1][7331][1337][note.deep:some note] message
16+[2016-06-12 12:34:56][foo][Info][example][0][1337][note.deep:some note] message
17+[2016-06-12 12:34:56][foo][Info][example][1][1337][note.deep:some note] message
18+[2016-06-12 12:34:56][foo][Info][example][1337][1337][note.deep:some note] message
19+[2016-06-12 12:34:56][foo][Info][example][2147483647][1337][note.deep:some note] message
20+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message
21+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message
22+with newline
23+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message
24+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] сообщение
25+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] 哈囉世界
26+[2000-01-01 00:00:00][foo][Info][example][7331][1337][note.deep:some note] message
27+[2123-12-31 23:59:59][foo][Info][example][7331][1337][note.deep:some note] message
28+[2016-10-10 01:01:05][foo][Info][example][7331][1337][note.deep:some note] message
29+[2100-12-31 12:59:10][foo][Info][example][7331][1337][note.deep:some note] message
30+[1982-01-01 12:30:00][foo][Info][example][7331][1337][note.deep:some note] message
31+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message
32+[2016-06-12 12:34:56][foo.bar][Info][example][7331][1337][note.deep:some note] message
33+[2016-06-12 12:34:56][фу.бар][Info][example][7331][1337][note.deep:some note] message
34+[2016-06-12 12:34:56][with
35+newline][Info][example][7331][1337][note.deep:some note] message
36+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message
37+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note][main:Some.Module path/Some/Module.hs:30:1] message
38+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note][main:Some.Module путь/Some/Module.hs:3000:9000] message
39+[2016-06-12 12:34:56][foo][Info][example][7331][1337][sub:null][text:][num:0.0][float:0.0] message
40+[2016-06-12 12:34:56][foo][Info][example][7331][1337][sub.note.deep:some note][text:note][num:10.0][float:5.5] message
katip/test/Katip/Tests/Scribes/Handle.hs+158−2
@@ -6,17 +6,26 @@ module Katip.Tests.Scribes.Handle
66-------------------------------------------------------------------------------
77import Control.Monad
88import Data.Aeson
9+import qualified Data.ByteString.Lazy as BL
910import Data.Monoid
10−import Data.Text (Text)
11−import qualified Data.Text.IO as T
11+import Data.Text (Text)
12+import qualified Data.Text as T
13+import qualified Data.Text.IO as T
14+import qualified Data.Text.Lazy as LT
15+import qualified Data.Text.Lazy.Builder as LT
16+import Data.Time
17+import Language.Haskell.TH.Syntax (Loc (..))
18+import Lens.Micro ((.~))
1219import System.Directory
1320import System.IO
1421import System.IO.Temp
1522import Test.Tasty
23+import Test.Tasty.Golden
1624import Test.Tasty.HUnit
1725import Text.Regex.TDFA
1826-------------------------------------------------------------------------------
1927import Katip
28+import Katip.Scribes.Handle
2029-------------------------------------------------------------------------------
2130
2231
@@ -31,6 +40,10 @@ tests = testGroup "Katip.Scribes.Handle"
3140 let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[[:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String
3241 let matches = res =~ pat
3342 assertBool (res <> " did not match") matches
43+ , withResource setupTempFile teardownTempFile $ \setup ->
44+ goldenVsString "Text-golden"
45+ "test/Katip/Tests/Scribes/Handle-text.golden"
46+ (setup >>= writeTextLog)
3447 ]
3548
3649
@@ -74,3 +87,146 @@ teardown :: (FilePath, Handle, LogEnv) -> IO ()
7487teardown (_, h, _) = do
7588 chk <- hIsOpen h
7689 when chk $ hClose h
90+
91+
92+
93+-- Following code tests Handle scribe output against a golden file.
94+-- This test will fail on non utf8 locales because golden file is in utf-8.
95+-- It generates all meaningfull variations of Item, and also tests
96+-- writing of payload of different Aeson constructors
97+--
98+-- Note: currently Handle scribe does not write Array items at all
99+-------------------------------------------------------------------------------
100+data AllTypesLogItem = AllTypesLogItem
101+ { atlText :: Text
102+ , atlNum :: Int
103+ , atlFloat :: Float
104+ , atlList :: [Text]
105+ , atlSub :: Maybe DummyLogItem
106+ }
107+
108+
109+instance ToJSON AllTypesLogItem where
110+ toJSON it = object
111+ [ "text" .= atlText it
112+ , "num" .= atlNum it
113+ , "float" .= atlFloat it
114+ , "list" .= atlList it
115+ , "sub" .= atlSub it
116+ ]
117+
118+
119+instance ToObject AllTypesLogItem
120+
121+
122+instance LogItem AllTypesLogItem where
123+ payloadKeys _ _ = AllKeys
124+
125+
126+-------------------------------------------------------------------------------
127+theItem :: Item DummyLogItem
128+theItem = Item (Namespace ["app"])
129+ (Environment "production")
130+ (InfoS)
131+ (ThreadIdText "1337")
132+ "example"
133+ 7331
134+ dummyLogItem
135+ "message"
136+ (mkUTCTime 2016 6 12 12 34 56)
137+ (Namespace ["foo"])
138+ Nothing
139+
140+genItems :: [Item DummyLogItem]
141+genItems = concat $
142+ [ [ itemSeverity .~ s $ theItem
143+ | s <- [minBound .. maxBound]
144+ ]
145+ , [ itemThread .~ (ThreadIdText . T.pack $ show t) $ theItem
146+ | t <- [0, 1, 1337, 2147483647]
147+ ]
148+ , [ itemHost .~ h $ theItem
149+ | h <- ["example", "www.example.com", "127.0.0.1"]
150+ ]
151+ , [ itemProcess .~ p $ theItem
152+ | p <- [0, 1, 1337, 2147483647]
153+ ]
154+ , [ itemMessage .~ LogStr m $ theItem
155+ | m <- [ "message"
156+ , "message\nwith newline"
157+ , LT.fromLazyText (LT.replicate 40 " a really long message")
158+ , "сообщение"
159+ , "哈囉世界"
160+ ]
161+ ]
162+ , [ itemTime .~ t $ theItem
163+ | t <- genDates
164+ ]
165+ , [ itemNamespace .~ Namespace ns $ theItem
166+ | ns <- [ ["foo"]
167+ , ["foo", "bar"]
168+ , ["фу", "бар"]
169+ , ["with\nnewline"] ]
170+ ]
171+ , [ itemLoc .~ l $ theItem | l <- genLocs
172+ ]
173+ ]
174+
175+genDates :: [UTCTime]
176+genDates =
177+ [ mkUTCTime 2000 1 1 0 0 0.0
178+ , mkUTCTime 2123 12 31 23 59 59.999999999999
179+ , mkUTCTime 2016 10 10 1 1 5.0
180+ , mkUTCTime 2100 12 31 12 59 10.1
181+ , mkUTCTime 1982 1 1 12 30 0.000000000001
182+ ]
183+
184+genLocs :: [Maybe Loc]
185+genLocs =
186+ [ Nothing
187+ , Just $ Loc "path/Some/Module.hs"
188+ "main"
189+ "Some.Module"
190+ (30,1) (30,14)
191+ , Just $ Loc "путь/Some/Module.hs"
192+ "main"
193+ "Some.Module"
194+ (3000,9000) (4000,1)
195+ ]
196+
197+genTypedItems :: [Item AllTypesLogItem]
198+genTypedItems =
199+ [ itemPayload .~ p $ theItem
200+ | p <- [ AllTypesLogItem "" 0 0.0 [] Nothing
201+ , AllTypesLogItem "note" 10 5.5 ["one", "two", "three"]
202+ (Just dummyLogItem)
203+ ]
204+ ]
205+
206+mkUTCTime :: Integer -> Int -> Int -> DiffTime -> DiffTime -> DiffTime -> UTCTime
207+mkUTCTime y mt d h mn s = UTCTime day dt
208+ where
209+ day = fromGregorian y mt d
210+ dt = h * 60 * 60 + mn * 60 + s
211+
212+-------------------------------------------------------------------------------
213+writeTextLog :: (FilePath, Handle) -> IO (BL.ByteString)
214+writeTextLog (path, h) = do
215+ mapM_ (T.hPutStrLn h . formatOne) genItems
216+ mapM_ (T.hPutStrLn h . formatOne) genTypedItems
217+ hClose h
218+ BL.readFile path
219+ where
220+ formatOne :: LogItem a => Item a -> Text
221+ formatOne = LT.toStrict . LT.toLazyText . formatItem False V3
222+
223+setupTempFile :: IO (FilePath, Handle)
224+setupTempFile = do
225+ tempDir <- getTemporaryDirectory
226+ (fp, h) <- openBinaryTempFile tempDir "katip.log"
227+ return (fp, h)
228+
229+teardownTempFile :: (FilePath, Handle) -> IO ()
230+teardownTempFile (_, h) = do
231+ chk <- hIsOpen h
232+ when chk $ hClose h
katip/test/Main.hs+2
@@ -4,6 +4,7 @@ module Main (main) where
44import Test.Tasty
55-------------------------------------------------------------------------------
66import qualified Katip.Tests
7+import qualified Katip.Tests.Format.Time
78import qualified Katip.Tests.Scribes.Handle
89-------------------------------------------------------------------------------
910
@@ -15,5 +16,6 @@ testSuite :: TestTree
1516testSuite = testGroup "katip"
1617 [
1718 Katip.Tests.tests
19+ , Katip.Tests.Format.Time.tests
1820 , Katip.Tests.Scribes.Handle.tests
1921 ]