git.iko.soy/typeable/bloodhound
on 5f430a1 help sign in
typeable/bloodhound/tests/V1/Test/Common.hs
289 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.Version as Vers
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 ]
43 -- Serializing the date as a date is breaking other tests, mysteriously.
44 -- , "postDate" .= object [ "type" .= ("date" :: Text)
45 -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
46 , "message" .= object ["type" .= ("string" :: Text)]
47 , "age" .= object ["type" .= ("integer" :: Text)]
48 , "location" .= object ["type" .= ("geo_point" :: Text)]
49 , "extra" .= object ["type" .= ("string" :: Text), "index" .= ("not_analyzed" :: Text)]
50 ]]
52es13 :: Vers.Version
53es13 = Vers.Version [1, 3, 0] []
55es12 :: Vers.Version
56es12 = Vers.Version [1, 2, 0] []
58es11 :: Vers.Version
59es11 = Vers.Version [1, 1, 0] []
61es14 :: Vers.Version
62es14 = Vers.Version [1, 4, 0] []
64es15 :: Vers.Version
65es15 = Vers.Version [1, 5, 0] []
67es16 :: Vers.Version
68es16 = Vers.Version [1, 6, 0] []
70es20 :: Vers.Version
71es20 = Vers.Version [2, 0, 0] []
73es50 :: Vers.Version
74es50 = Vers.Version [5, 0, 0] []
76getServerVersion :: IO (Maybe Vers.Version)
77getServerVersion = fmap extractVersion <$> withTestEnv getStatus
78 where
79 extractVersion = versionNumber . number . version
81createExampleIndex :: (MonadBH m) => m Reply
82createExampleIndex =
83 createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) testIndex
85deleteExampleIndex :: (MonadBH m) => m Reply
86deleteExampleIndex =
87 deleteIndex testIndex
89validateStatus :: Show body => Response body -> Int -> Expectation
90validateStatus resp expected =
91 if actual == expected
92 then return ()
93 else expectationFailure ("Expected " <> show expected <> " but got " <> show actual <> ": " <> show body)
94 where
95 actual = NHTS.statusCode (responseStatus resp)
96 body = responseBody resp
98data ChildMapping = ChildMapping deriving (Eq, Show)
100instance ToJSON ChildMapping where
101 toJSON ChildMapping =
102 object ["_parent" .= object ["type" .= ("parent" :: Text)]
103 , "properties" .=
104 object [ "user" .= object ["type" .= ("string" :: Text)
105 ]
106 -- Serializing the date as a date is breaking other tests, mysteriously.
107 -- , "postDate" .= object [ "type" .= ("date" :: Text)
108 -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
109 , "message" .= object ["type" .= ("string" :: Text)]
110 , "age" .= object ["type" .= ("integer" :: Text)]
111 , "location" .= object ["type" .= ("geo_point" :: Text)]
112 , "extra" .= object ["type" .= ("string" :: Text), "index" .= ("not_analyzed" :: Text)]
113 ]]
115data TweetMapping = TweetMapping deriving (Eq, Show)
117instance ToJSON TweetMapping where
118 toJSON TweetMapping =
119 object ["tweet" .=
120 object ["properties" .=
121 object [ "user" .= object [ "type" .= ("string" :: Text)
122 ]
123 -- Serializing the date as a date is breaking other tests, mysteriously.
124 -- , "postDate" .= object [ "type" .= ("date" :: Text)
125 -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
126 , "message" .= object ["type" .= ("string" :: Text)]
127 , "age" .= object ["type" .= ("integer" :: Text)]
128 , "location" .= object ["type" .= ("geo_point" :: Text)]
129 , "extra" .= object ["type" .= ("string" :: Text), "index" .= ("not_analyzed" :: Text)]
130 ]]]
132exampleTweet :: Tweet
133exampleTweet = Tweet { user = "bitemyapp"
134 , postDate = UTCTime
135 (ModifiedJulianDay 55000)
136 (secondsToDiffTime 10)
137 , message = "Use haskell!"
138 , age = 10000
139 , location = Location 40.12 (-71.34)
140 , extra = Nothing }
142tweetWithExtra :: Tweet
143tweetWithExtra = Tweet { user = "bitemyapp"
144 , postDate = UTCTime
145 (ModifiedJulianDay 55000)
146 (secondsToDiffTime 10)
147 , message = "Use haskell!"
148 , age = 10000
149 , location = Location 40.12 (-71.34)
150 , extra = Just "blah blah" }
152newAge :: Int
153newAge = 31337
155newUser :: Text
156newUser = "someotherapp"
158tweetPatch :: Value
159tweetPatch =
160 object [ "age" .= newAge
161 , "user" .= newUser
162 ]
164patchedTweet :: Tweet
165patchedTweet = exampleTweet{age = newAge, user = newUser}
167otherTweet :: Tweet
168otherTweet = Tweet { user = "notmyapp"
169 , postDate = UTCTime
170 (ModifiedJulianDay 55000)
171 (secondsToDiffTime 11)
172 , message = "Use haskell!"
173 , age = 1000
174 , location = Location 40.12 (-71.34)
175 , extra = Nothing }
177resetIndex :: BH IO ()
178resetIndex = do
179 _ <- deleteExampleIndex
180 _ <- createExampleIndex
181 _ <- putMapping testIndex testMapping TweetMapping
182 return ()
184insertData :: BH IO Reply
185insertData = do
186 resetIndex
187 insertData' defaultIndexDocumentSettings
189insertData' :: IndexDocumentSettings -> BH IO Reply
190insertData' ids = do
191 r <- indexDocument testIndex testMapping ids exampleTweet (DocId "1")
192 _ <- refreshIndex testIndex
193 return r
195updateData :: BH IO Reply
196updateData = do
197 r <- updateDocument testIndex testMapping defaultIndexDocumentSettings tweetPatch (DocId "1")
198 _ <- refreshIndex testIndex
199 return r
201insertOther :: BH IO ()
202insertOther = do
203 _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings otherTweet (DocId "2")
204 _ <- refreshIndex testIndex
205 return ()
207insertExtra :: BH IO ()
208insertExtra = do
209 _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings tweetWithExtra (DocId "4")
210 _ <- refreshIndex testIndex
211 return ()
213insertWithSpaceInId :: BH IO ()
214insertWithSpaceInId = do
215 _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "Hello World")
216 _ <- refreshIndex testIndex
217 return ()
219searchTweet :: Search -> BH IO (Either EsError Tweet)
220searchTweet search = do
221 result <- searchTweets search
222 let myTweet :: Either EsError Tweet
223 myTweet = grabFirst result
224 return myTweet
226searchTweets :: Search -> BH IO (Either EsError (SearchResult Tweet))
227searchTweets search = parseEsResponse =<< searchByIndex testIndex search
229searchExpectNoResults :: Search -> BH IO ()
230searchExpectNoResults search = do
231 result <- searchTweets search
232 let emptyHits = fmap (hits . searchHits) result
233 liftIO $
234 emptyHits `shouldBe` Right []
236searchExpectAggs :: Search -> BH IO ()
237searchExpectAggs search = do
238 reply <- searchByIndex testIndex search
239 let isEmpty x = return (M.null x)
240 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
241 liftIO $
242 (result >>= aggregations >>= isEmpty) `shouldBe` Just False
244searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) =>
245 Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH IO ()
246searchValidBucketAgg search aggKey extractor = do
247 reply <- searchByIndex testIndex search
248 let bucketDocs = docCount . head . buckets
249 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
250 let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x)
251 liftIO $
252 count `shouldBe` Just 1
254searchTermsAggHint :: [ExecutionHint] -> BH IO ()
255searchTermsAggHint hints = do
256 let terms hint = TermsAgg $ (mkTermsAggregation "user") { termExecutionHint = Just hint }
257 let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint
258 forM_ hints $ searchExpectAggs . search
259 forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
261searchTweetHighlight :: Search
262 -> BH IO (Either EsError (Maybe HitHighlight))
263searchTweetHighlight search = do
264 result <- searchTweets search
265 let tweetHit :: Either EsError (Maybe (Hit Tweet))
266 tweetHit = fmap (headMay . hits . searchHits) result
267 myHighlight :: Either EsError (Maybe HitHighlight)
268 myHighlight = (join . fmap hitHighlight) <$> tweetHit
269 return myHighlight
271searchExpectSource :: Source -> Either EsError Value -> BH IO ()
272searchExpectSource src expected = do
273 _ <- insertData
274 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
275 let search = (mkSearch (Just query) Nothing) { source = Just src }
276 reply <- searchByIndex testIndex search
277 result <- parseEsResponse reply
278 let value = grabFirst result
279 liftIO $
280 value `shouldBe` expected
282atleast :: Vers.Version -> IO Bool
283atleast v = getServerVersion >>= \x -> return $ x >= Just v
285atmost :: Vers.Version -> IO Bool
286atmost v = getServerVersion >>= \x -> return $ x <= Just v
288is :: Vers.Version -> IO Bool
289is v = getServerVersion >>= \x -> return $ x == Just v