@@ -0,0 +1,98 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Katip.Tests.Scribes.Datadog.TCP
3+ ( tests
4+ ) where
5+
6+
7+-------------------------------------------------------------------------------
8+import Control.Concurrent.Async
9+import qualified Control.Exception.Safe as EX
10+import qualified Data.Aeson as A
11+import qualified Data.Conduit as C
12+import qualified Data.Conduit.Binary as CB
13+import qualified Data.Conduit.List as CL
14+import qualified Data.Conduit.Network as CN
15+import Data.Foldable (toList)
16+import qualified Data.HashMap.Strict as HM
17+import Data.IORef
18+import Data.Sequence ((|>))
19+import Data.Text
20+import Test.Tasty
21+import Test.Tasty.HUnit
22+-------------------------------------------------------------------------------
23+import Katip
24+import Katip.Scribes.Datadog.TCP
25+-------------------------------------------------------------------------------
26+
27+
28+
29+tests :: TestTree
30+tests = testGroup "Katip.Scribes.Datadog.TCP"
31+ [ testCase "logs well-formed messages in order" $ do
32+ logs <- collectLogs $ do
33+ logItem (sl "foo" ("bar" :: Text)) "mynamespace" noLoc InfoS "a message"
34+ logs @?=
35+ [ CapturedLog
36+ { capturedLog_namespace = Namespace ["katip-datadog-tests", "mynamespace"]
37+ , capturedLog_data = A.Object (HM.singleton "foo" (A.String "bar"))
38+ , capturedLog_sev = InfoS
39+ , capturedLog_message = "a message"
40+ }
41+ ]
42+ ]
43+ where
44+ noLoc = Nothing
45+
46+
47+-------------------------------------------------------------------------------
48+-- | A log type parsed out of the fake datadog agent's buffer
49+data CapturedLog = CapturedLog
50+ { capturedLog_namespace :: Namespace
51+ , capturedLog_data :: A.Value
52+ , capturedLog_sev :: Severity
53+ , capturedLog_message :: Text
54+ } deriving (Show, Eq)
55+
56+
57+instance A.FromJSON CapturedLog where
58+ parseJSON = A.withObject "CapturedLog" $ \o -> do
59+ message <- o A..: "message"
60+ sev <- o A..: "severity"
61+ dta <- o A..: "data"
62+ namespace <- o A..: "ns"
63+ pure $ CapturedLog
64+ { capturedLog_namespace = namespace
65+ , capturedLog_data = dta
66+ , capturedLog_sev = sev
67+ , capturedLog_message = message
68+ }
69+
70+-------------------------------------------------------------------------------
71+collectLogs :: KatipT IO () -> IO [CapturedLog]
72+collectLogs f = do
73+ capturedRef <- newIORef mempty
74+ withAsync (startServer capturedRef) $ \_worker -> do
75+ EX.bracket mkLE closeLE $ \le -> do
76+ runKatipT le f
77+ toList <$> readIORef capturedRef
78+ where
79+ closeLE = closeScribes
80+ port = 1337
81+ mkLE = do
82+ dataDogScribeSettings <- mkDataDogScribeSettings (localAgentConnectionParams (fromInteger port)) NoAuthLocal
83+ scribe <- mkDataDogScribe dataDogScribeSettings DebugS V3
84+ registerScribe "datadog" scribe defaultScribeSettings =<< initLogEnv "katip-datadog-tests" "test"
85+ startServer capturedRef = CN.runTCPServer (CN.serverSettings (fromInteger port) "*") $ \appData -> C.runConduit $
86+ CN.appSource appData C..|
87+ CB.lines C..|
88+ CL.map A.eitherDecodeStrict C..|
89+ CL.mapM_ (\parseResult -> case parseResult of
90+ Left e -> EX.throwM (ParseError e)
91+ (Right capturedLog) -> modifyIORef' capturedRef (\captured -> captured |> capturedLog))
92+
93+
94+-------------------------------------------------------------------------------
95+newtype ParseError = ParseError String
96+ deriving (Show)
97+
98+instance EX.Exception ParseError