@@ -1,24 +1,32 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE RecordWildCards #-}
3−{-# LANGUAGE TemplateHaskell #-}
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE TemplateHaskell #-}
45module Main
56 ( main
67 ) where
78
89
910-------------------------------------------------------------------------------
10−import Control.Lens hiding (mapping)
11+import Control.Applicative
12+import Control.Lens hiding (mapping, (.=))
1113import Control.Monad
1214import Control.Monad.IO.Class
1315import Data.Aeson
1416import Data.Aeson.Lens
17+import Data.Aeson.Types
18+import qualified Data.HashMap.Strict as HM
1519import qualified Data.Map as M
1620import Data.Monoid
21+import Data.Scientific
22+import qualified Data.Vector as V
1723import Database.Bloodhound hiding (key)
1824import Network.HTTP.Client
1925import Network.HTTP.Types.Status
26+import Test.QuickCheck.Instances ()
2027import Test.Tasty
2128import Test.Tasty.HUnit
29+import Test.Tasty.QuickCheck
2230-------------------------------------------------------------------------------
2331import Katip
2432import Katip.Scribes.ElasticSearch
@@ -29,6 +37,7 @@ main :: IO ()
2937main = defaultMain $ testGroup "katip-elasticsearch"
3038 [
3139 withResource setupSearch teardownSearch esTests
40+ , typeAnnotatedTests
3241 ]
3342
3443
@@ -36,7 +45,7 @@ main = defaultMain $ testGroup "katip-elasticsearch"
3645setupSearch :: IO (Scribe, IO ())
3746setupSearch = do
3847 bh recreateESSchema
39− mkEsScribe defaultEsScribeCfg svr ixn mn DebugS V3
48+ mkEsScribe defaultEsScribeCfg { essAnnotateTypes = True } svr ixn mn DebugS V3
4049
4150
4251-------------------------------------------------------------------------------
@@ -51,13 +60,73 @@ esTests :: IO (Scribe, IO ()) -> TestTree
5160esTests setup = testGroup "elasticsearch scribe"
5261 [
5362 testCase "it flushes to elasticsearch" $ withTestLogging setup $ \done -> do
54− $(logT) () mempty InfoS "A test message"
63+ $(logT) (ExampleCtx True) mempty InfoS "A test message"
5564 liftIO $ do
5665 done
5766 logs <- getLogs
5867 length logs @?= 1
5968 let l = head logs
6069 l ^? key "_source" . key "msg" . _String @?= Just "A test message"
70+ l ^? key "_source" . key "data" . key "whatever::boolean" . _Bool @?= Just True
71+ ]
72+
73+
74+-------------------------------------------------------------------------------
75+data ExampleCtx = ExampleCtx {
76+ ecBool :: Bool
77+ }
78+
79+instance ToJSON ExampleCtx where
80+ toJSON c = object ["whatever" .= ecBool c]
81+
82+
83+instance ToObject ExampleCtx
84+
85+
86+instance LogItem ExampleCtx where
87+ payloadKeys _ _ = AllKeys
88+
89+-------------------------------------------------------------------------------
90+typeAnnotatedTests :: TestTree
91+typeAnnotatedTests = testGroup "TypeAnnotated"
92+ [
93+ testCase "annotates values on toJSON" $ do
94+ toJSON (TypeAnnotated exampleValue) @?= annotatedExampleValue
95+ , testCase "deannotates on parseJSON" $ do
96+ parseEither parseJSON (toJSON exampleValue) @?= Right exampleValue
97+ , testProperty "roundtrips the same as raw" $ \(v :: Value) ->
98+ let res = typeAnnotatedValue <$> (parseEither parseJSON (toJSON (TypeAnnotated v)))
99+ in res === Right v
100+ ]
101+
102+
103+-------------------------------------------------------------------------------
104+exampleValue :: Value
105+exampleValue = Array $ V.fromList [Null, Object ob]
106+ where
107+ ob = HM.fromList [ ("a bool", Bool False)
108+ , ("a long", Number 24)
109+ , ("a double", Number 52.3)
110+ , ("a string", String "s")
111+ , ("a null", Null)
112+ , ("a map", Object (HM.singleton "baz" (Bool True)))
113+ ]
114+
115+
116+-------------------------------------------------------------------------------
117+annotatedExampleValue :: Value
118+annotatedExampleValue = Array $ V.fromList
119+ [
120+ Null
121+ , Object $ HM.fromList
122+ [
123+ ("a map",Object $ HM.fromList [("baz::boolean", Bool True)])
124+ , ("a bool::boolean", Bool False)
125+ , ("a null::null", Null)
126+ , ("a string::string", String "s")
127+ , ("a double::double", Number 52.3)
128+ , ("a long::long", Number 24.0)
129+ ]
61130 ]
62131
63132
@@ -126,3 +195,21 @@ createESSchema :: BH IO Reply
126195createESSchema = do
127196 createIndex ixs ixn
128197 putMapping ixn mn mapping
198+
199+
200+-------------------------------------------------------------------------------
201+instance Arbitrary Value where
202+ arbitrary = oneof
203+ [ Object <$> reduceSize arbitrary
204+ , Array . V.fromList <$> reduceSize arbitrary
205+ , String <$> arbitrary
206+ , Number <$> (scientific <$> arbitrary <*> arbitrary)
207+ , Bool <$> arbitrary
208+ , pure Null
209+ ]
210+
211+
212+-------------------------------------------------------------------------------
213+-- | Reduce the size of Arbitrary input for the given generator
214+reduceSize :: Gen a -> Gen a
215+reduceSize f = sized $ \ n -> resize (n `div` 2) f