git.iko.soy/typeable/bloodhound
on 3e5220c help sign in
typeable/bloodhound/tests/V5/Test/Common.hs
292 lines 10 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE TemplateHaskell #-}
4module Test.Common where
6import Test.Import
8import qualified Data.Map as M
9import qualified Data.SemVer as SemVer
10import qualified Network.HTTP.Types.Status as NHTS
12testServer :: Server
13testServer = Server "http://localhost:9200"
14testIndex :: IndexName
15testIndex = IndexName "bloodhound-tests-twitter-1"
16testMapping :: MappingName
17testMapping = MappingName "tweet"
19withTestEnv :: BH IO a -> IO a
20withTestEnv = withBH defaultManagerSettings testServer
22data Location = Location { lat :: Double
23 , lon :: Double } deriving (Eq, Show)
25data Tweet = Tweet { user :: Text
26 , postDate :: UTCTime
27 , message :: Text
28 , age :: Int
29 , location :: Location
30 , extra :: Maybe Text }
31 deriving (Eq, Show)
33$(deriveJSON defaultOptions ''Location)
34$(deriveJSON defaultOptions ''Tweet)
36data ParentMapping = ParentMapping deriving (Eq, Show)
38instance ToJSON ParentMapping where
39 toJSON ParentMapping =
40 object ["properties" .=
41 object [ "user" .= object ["type" .= ("string" :: Text)
42 , "fielddata" .= True
43 ]
44 -- Serializing the date as a date is breaking other tests, mysteriously.
45 -- , "postDate" .= object [ "type" .= ("date" :: Text)
46 -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
47 , "message" .= object ["type" .= ("string" :: Text)]
48 , "age" .= object ["type" .= ("integer" :: Text)]
49 , "location" .= object ["type" .= ("geo_point" :: Text)]
50 , "extra" .= object ["type" .= ("keyword" :: Text)]
51 ]]
53es11 :: SemVer.Version
54es11 = SemVer.version 1 1 0 [] []
56es13 :: SemVer.Version
57es13 = SemVer.version 1 3 0 [] []
59es12 :: SemVer.Version
60es12 = SemVer.version 1 2 0 [] []
62es14 :: SemVer.Version
63es14 = SemVer.version 1 4 0 [] []
65es15 :: SemVer.Version
66es15 = SemVer.version 1 5 0 [] []
68es16 :: SemVer.Version
69es16 = SemVer.version 1 6 0 [] []
71es20 :: SemVer.Version
72es20 = SemVer.version 2 0 0 [] []
74es50 :: SemVer.Version
75es50 = SemVer.version 5 0 0 [] []
77getServerVersion :: IO (Maybe SemVer.Version)
78getServerVersion = fmap extractVersion <$> withTestEnv getStatus
79 where
80 extractVersion = versionNumber . number . version
82createExampleIndex :: (MonadBH m) => m Reply
83createExampleIndex =
84 createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) testIndex
86deleteExampleIndex :: (MonadBH m) => m Reply
87deleteExampleIndex =
88 deleteIndex testIndex
90validateStatus :: Show body => Response body -> Int -> Expectation
91validateStatus resp expected =
92 if actual == expected
93 then return ()
94 else expectationFailure ("Expected " <> show expected <> " but got " <> show actual <> ": " <> show body)
95 where
96 actual = NHTS.statusCode (responseStatus resp)
97 body = responseBody resp
99data ChildMapping = ChildMapping deriving (Eq, Show)
101instance ToJSON ChildMapping where
102 toJSON ChildMapping =
103 object ["_parent" .= object ["type" .= ("parent" :: Text)]
104 , "properties" .=
105 object [ "user" .= object ["type" .= ("string" :: Text)
106 , "fielddata" .= True
107 ]
108 -- Serializing the date as a date is breaking other tests, mysteriously.
109 -- , "postDate" .= object [ "type" .= ("date" :: Text)
110 -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
111 , "message" .= object ["type" .= ("string" :: Text)]
112 , "age" .= object ["type" .= ("integer" :: Text)]
113 , "location" .= object ["type" .= ("geo_point" :: Text)]
114 , "extra" .= object ["type" .= ("keyword" :: Text)]
115 ]]
117data TweetMapping = TweetMapping deriving (Eq, Show)
119instance ToJSON TweetMapping where
120 toJSON TweetMapping =
121 object ["tweet" .=
122 object ["properties" .=
123 object [ "user" .= object [ "type" .= ("string" :: Text)
124 , "fielddata" .= True
125 ]
126 -- Serializing the date as a date is breaking other tests, mysteriously.
127 -- , "postDate" .= object [ "type" .= ("date" :: Text)
128 -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
129 , "message" .= object ["type" .= ("string" :: Text)]
130 , "age" .= object ["type" .= ("integer" :: Text)]
131 , "location" .= object ["type" .= ("geo_point" :: Text)]
132 , "extra" .= object ["type" .= ("keyword" :: Text)]
133 ]]]
135exampleTweet :: Tweet
136exampleTweet = Tweet { user = "bitemyapp"
137 , postDate = UTCTime
138 (ModifiedJulianDay 55000)
139 (secondsToDiffTime 10)
140 , message = "Use haskell!"
141 , age = 10000
142 , location = Location 40.12 (-71.34)
143 , extra = Nothing }
145tweetWithExtra :: Tweet
146tweetWithExtra = Tweet { user = "bitemyapp"
147 , postDate = UTCTime
148 (ModifiedJulianDay 55000)
149 (secondsToDiffTime 10)
150 , message = "Use haskell!"
151 , age = 10000
152 , location = Location 40.12 (-71.34)
153 , extra = Just "blah blah" }
155newAge :: Int
156newAge = 31337
158newUser :: Text
159newUser = "someotherapp"
161tweetPatch :: Value
162tweetPatch =
163 object [ "age" .= newAge
164 , "user" .= newUser
165 ]
167patchedTweet :: Tweet
168patchedTweet = exampleTweet{age = newAge, user = newUser}
170otherTweet :: Tweet
171otherTweet = Tweet { user = "notmyapp"
172 , postDate = UTCTime
173 (ModifiedJulianDay 55000)
174 (secondsToDiffTime 11)
175 , message = "Use haskell!"
176 , age = 1000
177 , location = Location 40.12 (-71.34)
178 , extra = Nothing }
180resetIndex :: BH IO ()
181resetIndex = do
182 _ <- deleteExampleIndex
183 _ <- createExampleIndex
184 _ <- putMapping testIndex testMapping TweetMapping
185 return ()
187insertData :: BH IO Reply
188insertData = do
189 resetIndex
190 insertData' defaultIndexDocumentSettings
192insertData' :: IndexDocumentSettings -> BH IO Reply
193insertData' ids = do
194 r <- indexDocument testIndex testMapping ids exampleTweet (DocId "1")
195 _ <- refreshIndex testIndex
196 return r
198updateData :: BH IO Reply
199updateData = do
200 r <- updateDocument testIndex testMapping defaultIndexDocumentSettings tweetPatch (DocId "1")
201 _ <- refreshIndex testIndex
202 return r
204insertOther :: BH IO ()
205insertOther = do
206 _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings otherTweet (DocId "2")
207 _ <- refreshIndex testIndex
208 return ()
210insertExtra :: BH IO ()
211insertExtra = do
212 _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings tweetWithExtra (DocId "4")
213 _ <- refreshIndex testIndex
214 return ()
216insertWithSpaceInId :: BH IO ()
217insertWithSpaceInId = do
218 _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "Hello World")
219 _ <- refreshIndex testIndex
220 return ()
222searchTweet :: Search -> BH IO (Either EsError Tweet)
223searchTweet search = do
224 result <- searchTweets search
225 let myTweet :: Either EsError Tweet
226 myTweet = grabFirst result
227 return myTweet
229searchTweets :: Search -> BH IO (Either EsError (SearchResult Tweet))
230searchTweets search = parseEsResponse =<< searchByIndex testIndex search
232searchExpectNoResults :: Search -> BH IO ()
233searchExpectNoResults search = do
234 result <- searchTweets search
235 let emptyHits = fmap (hits . searchHits) result
236 liftIO $
237 emptyHits `shouldBe` Right []
239searchExpectAggs :: Search -> BH IO ()
240searchExpectAggs search = do
241 reply <- searchByIndex testIndex search
242 let isEmpty x = return (M.null x)
243 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
244 liftIO $
245 (result >>= aggregations >>= isEmpty) `shouldBe` Just False
247searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) =>
248 Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH IO ()
249searchValidBucketAgg search aggKey extractor = do
250 reply <- searchByIndex testIndex search
251 let bucketDocs = docCount . head . buckets
252 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
253 let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x)
254 liftIO $
255 count `shouldBe` Just 1
257searchTermsAggHint :: [ExecutionHint] -> BH IO ()
258searchTermsAggHint hints = do
259 let terms hint = TermsAgg $ (mkTermsAggregation "user") { termExecutionHint = Just hint }
260 let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint
261 forM_ hints $ searchExpectAggs . search
262 forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
264searchTweetHighlight :: Search
265 -> BH IO (Either EsError (Maybe HitHighlight))
266searchTweetHighlight search = do
267 result <- searchTweets search
268 let tweetHit :: Either EsError (Maybe (Hit Tweet))
269 tweetHit = fmap (headMay . hits . searchHits) result
270 myHighlight :: Either EsError (Maybe HitHighlight)
271 myHighlight = (join . fmap hitHighlight) <$> tweetHit
272 return myHighlight
274searchExpectSource :: Source -> Either EsError Value -> BH IO ()
275searchExpectSource src expected = do
276 _ <- insertData
277 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
278 let search = (mkSearch (Just query) Nothing) { source = Just src }
279 reply <- searchByIndex testIndex search
280 result <- parseEsResponse reply
281 let value = grabFirst result
282 liftIO $
283 value `shouldBe` expected
285atleast :: SemVer.Version -> IO Bool
286atleast v = getServerVersion >>= \x -> return $ x >= Just v
288atmost :: SemVer.Version -> IO Bool
289atmost v = getServerVersion >>= \x -> return $ x <= Just v
291is :: SemVer.Version -> IO Bool
292is v = getServerVersion >>= \x -> return $ x == Just v