@@ -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