git.iko.soy/typeable/bloodhound
on 58f4771 help sign in
typeable/bloodhound/tests/tests.hs
560 lines 23 kB history raw
1{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE ScopedTypeVariables #-}
5module Main where
7import Control.Applicative
8import Control.Monad
9import Data.Aeson
10import Data.HashMap.Strict (fromList)
11import Data.List (nub)
12import Data.List.NonEmpty (NonEmpty (..))
13import qualified Data.Map.Strict as M
14import Data.Text (Text)
15import qualified Data.Text as T
16import Data.Time.Calendar (Day (..))
17import Data.Time.Clock (UTCTime (..), secondsToDiffTime)
18import qualified Data.Vector as V
19import Database.Bloodhound
20import GHC.Generics (Generic)
21import Network.HTTP.Client
22import qualified Network.HTTP.Types.Status as NHTS
23import Prelude hiding (filter, putStrLn)
24import Test.Hspec
26import Test.Hspec.QuickCheck (prop)
27import Test.QuickCheck
29testServer :: Server
30testServer = Server "http://localhost:9200"
31testIndex :: IndexName
32testIndex = IndexName "bloodhound-tests-twitter-1"
33testMapping :: MappingName
34testMapping = MappingName "tweet"
36validateStatus :: Response body -> Int -> Expectation
37validateStatus resp expected =
38 (NHTS.statusCode $ responseStatus resp)
39 `shouldBe` (expected :: Int)
41createExampleIndex :: IO Reply
42createExampleIndex = createIndex testServer defaultIndexSettings testIndex
43deleteExampleIndex :: IO Reply
44deleteExampleIndex = deleteIndex testServer testIndex
46data ServerVersion = ServerVersion Int Int Int deriving (Show, Eq, Ord)
48es14 :: ServerVersion
49es14 = ServerVersion 1 4 0
51es13 :: ServerVersion
52es13 = ServerVersion 1 3 0
54es12 :: ServerVersion
55es12 = ServerVersion 1 2 0
57es11 :: ServerVersion
58es11 = ServerVersion 1 1 0
60es10 :: ServerVersion
61es10 = ServerVersion 1 0 0
63serverBranch :: ServerVersion -> ServerVersion
64serverBranch (ServerVersion majorVer minorVer patchVer) =
65 ServerVersion majorVer minorVer patchVer
67mkServerVersion :: [Int] -> Maybe ServerVersion
68mkServerVersion [majorVer, minorVer, patchVer] =
69 Just (ServerVersion majorVer minorVer patchVer)
70mkServerVersion _ = Nothing
72getServerVersion :: Server -> IO (Maybe ServerVersion)
73getServerVersion s = liftM extractVersion (getStatus s)
74 where
75 version' = T.splitOn "." . number . version
76 toInt = read . T.unpack
77 parseVersion v = map toInt (version' v)
78 extractVersion = join . liftM (mkServerVersion . parseVersion)
82testServerBranch :: IO (Maybe ServerVersion)
83testServerBranch = getServerVersion testServer >>= \v -> return $ liftM serverBranch v
85atleast :: ServerVersion -> IO Bool
86atleast v = testServerBranch >>= \x -> return $ x >= Just (serverBranch v)
88atmost :: ServerVersion -> IO Bool
89atmost v = testServerBranch >>= \x -> return $ x <= Just (serverBranch v)
91is :: ServerVersion -> IO Bool
92is v = testServerBranch >>= \x -> return $ x == Just (serverBranch v)
94when' :: Monad m => m Bool -> m () -> m ()
95when' b f = b >>= \x -> when x f
97data Location = Location { lat :: Double
98 , lon :: Double } deriving (Eq, Generic, Show)
100data Tweet = Tweet { user :: Text
101 , postDate :: UTCTime
102 , message :: Text
103 , age :: Int
104 , location :: Location }
105 deriving (Eq, Generic, Show)
107instance ToJSON Tweet
108instance FromJSON Tweet
109instance ToJSON Location
110instance FromJSON Location
112data TweetMapping = TweetMapping deriving (Eq, Show)
114instance ToJSON TweetMapping where
115 toJSON TweetMapping =
116 object ["tweet" .=
117 object ["properties" .=
118 object ["location" .= object ["type" .= ("geo_point" :: Text)]]]]
120exampleTweet :: Tweet
121exampleTweet = Tweet { user = "bitemyapp"
122 , postDate = UTCTime
123 (ModifiedJulianDay 55000)
124 (secondsToDiffTime 10)
125 , message = "Use haskell!"
126 , age = 10000
127 , location = Location 40.12 (-71.34) }
129otherTweet :: Tweet
130otherTweet = Tweet { user = "notmyapp"
131 , postDate = UTCTime
132 (ModifiedJulianDay 55000)
133 (secondsToDiffTime 11)
134 , message = "Use haskell!"
135 , age = 1000
136 , location = Location 40.12 (-71.34) }
138insertData :: IO ()
139insertData = do
140 _ <- deleteExampleIndex
141 _ <- createExampleIndex
142 _ <- putMapping testServer testIndex testMapping TweetMapping
143 _ <- indexDocument testServer testIndex testMapping exampleTweet (DocId "1")
144 _ <- refreshIndex testServer testIndex
145 return ()
147insertOther :: IO ()
148insertOther = do
149 _ <- indexDocument testServer testIndex testMapping otherTweet (DocId "2")
150 _ <- refreshIndex testServer testIndex
151 return ()
153searchTweet :: Search -> IO (Either String Tweet)
154searchTweet search = do
155 reply <- searchByIndex testServer testIndex search
156 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
157 let myTweet = fmap (hitSource . head . hits . searchHits) result
158 return myTweet
160searchExpectNoResults :: Search -> IO ()
161searchExpectNoResults search = do
162 reply <- searchByIndex testServer testIndex search
163 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
164 let emptyHits = fmap (hits . searchHits) result
165 emptyHits `shouldBe` Right []
167searchExpectAggs :: Search -> IO ()
168searchExpectAggs search = do
169 reply <- searchAll testServer search
170 let isEmpty x = return (M.null x)
171 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
172 (result >>= aggregations >>= isEmpty) `shouldBe` Just False
174searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) => Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> IO ()
175searchValidBucketAgg search aggKey extractor = do
176 reply <- searchAll testServer search
177 let bucketDocs = docCount . head . buckets
178 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
179 let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x)
180 count `shouldBe` Just 1
182searchTermsAggHint :: [ExecutionHint] -> IO ()
183searchTermsAggHint hints = do
184 let terms hint = TermsAgg $ (mkTermsAggregation "user") { termExecutionHint = Just hint }
185 let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint
186 forM_ hints $ searchExpectAggs . search
187 forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
189searchTweetHighlight :: Search -> IO (Either String (Maybe HitHighlight))
190searchTweetHighlight search = do
191 reply <- searchByIndex testServer testIndex search
192 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
193 let myHighlight = fmap (hitHighlight . head . hits . searchHits) result
194 return myHighlight
196data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
197instance FromJSON BulkTest
198instance ToJSON BulkTest
200noDuplicates :: Eq a => [a] -> Bool
201noDuplicates xs = nub xs == xs
203instance Arbitrary RegexpFlags where
204 arbitrary = oneof [ pure AllRegexpFlags
205 , pure NoRegexpFlags
206 , SomeRegexpFlags <$> arbitrary
207 ]
209instance Arbitrary a => Arbitrary (NonEmpty a) where
210 arbitrary = liftA2 (:|) arbitrary arbitrary
212instance Arbitrary RegexpFlag where
213 arbitrary = oneof [ pure AnyString
214 , pure Automaton
215 , pure Complement
216 , pure Empty
217 , pure Intersection
218 , pure Interval
219 ]
221main :: IO ()
222main = hspec $ do
224 describe "index create/delete API" $ do
225 it "creates and then deletes the requested index" $ do
226 -- priming state.
227 _ <- deleteExampleIndex
228 resp <- createExampleIndex
229 deleteResp <- deleteExampleIndex
230 validateStatus resp 200
231 validateStatus deleteResp 200
234 describe "document API" $ do
235 it "indexes, gets, and then deletes the generated document" $ do
236 _ <- insertData
237 docInserted <- getDocument testServer testIndex testMapping (DocId "1")
238 let newTweet = eitherDecode
239 (responseBody docInserted) :: Either String (EsResult Tweet)
240 fmap _source newTweet `shouldBe` Right exampleTweet
243 describe "bulk API" $ do
244 it "inserts all documents we request" $ do
245 _ <- insertData
246 let firstTest = BulkTest "blah"
247 let secondTest = BulkTest "bloo"
248 let firstDoc = BulkIndex testIndex
249 testMapping (DocId "2") (toJSON firstTest)
250 let secondDoc = BulkCreate testIndex
251 testMapping (DocId "3") (toJSON secondTest)
252 let stream = V.fromList [firstDoc, secondDoc]
253 _ <- bulk testServer stream
254 _ <- refreshIndex testServer testIndex
255 fDoc <- getDocument testServer testIndex testMapping (DocId "2")
256 sDoc <- getDocument testServer testIndex testMapping (DocId "3")
257 let maybeFirst = eitherDecode $ responseBody fDoc :: Either String (EsResult BulkTest)
258 let maybeSecond = eitherDecode $ responseBody sDoc :: Either String (EsResult BulkTest)
259 fmap _source maybeFirst `shouldBe` Right firstTest
260 fmap _source maybeSecond `shouldBe` Right secondTest
263 describe "query API" $ do
264 it "returns document for term query and identity filter" $ do
265 _ <- insertData
266 let query = TermQuery (Term "user" "bitemyapp") Nothing
267 let filter = IdentityFilter <&&> IdentityFilter
268 let search = mkSearch (Just query) (Just filter)
269 myTweet <- searchTweet search
270 myTweet `shouldBe` Right exampleTweet
272 it "returns document for match query" $ do
273 _ <- insertData
274 let query = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
275 let search = mkSearch (Just query) Nothing
276 myTweet <- searchTweet search
277 myTweet `shouldBe` Right exampleTweet
279 it "returns document for multi-match query" $ do
280 _ <- insertData
281 let fields = [FieldName "user", FieldName "message"]
282 let query = QueryMultiMatchQuery $ mkMultiMatchQuery fields (QueryString "bitemyapp")
283 let search = mkSearch (Just query) Nothing
284 myTweet <- searchTweet search
285 myTweet `shouldBe` Right exampleTweet
287 it "returns document for bool query" $ do
288 _ <- insertData
289 let innerQuery = QueryMatchQuery $
290 mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
291 let query = QueryBoolQuery $
292 mkBoolQuery [innerQuery] [] []
293 let search = mkSearch (Just query) Nothing
294 myTweet <- searchTweet search
295 myTweet `shouldBe` Right exampleTweet
297 it "returns document for boosting query" $ do
298 _ <- insertData
299 let posQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
300 let negQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "notmyapp")
301 let query = QueryBoostingQuery $ BoostingQuery posQuery negQuery (Boost 0.2)
302 let search = mkSearch (Just query) Nothing
303 myTweet <- searchTweet search
304 myTweet `shouldBe` Right exampleTweet
306 it "returns document for common terms query" $ do
307 _ <- insertData
308 let query = QueryCommonTermsQuery $
309 CommonTermsQuery (FieldName "user")
310 (QueryString "bitemyapp")
311 (CutoffFrequency 0.0001)
312 Or Or Nothing Nothing Nothing Nothing
313 let search = mkSearch (Just query) Nothing
314 myTweet <- searchTweet search
315 myTweet `shouldBe` Right exampleTweet
318 describe "sorting" $ do
319 it "returns documents in the right order" $ do
320 _ <- insertData
321 _ <- insertOther
322 let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
323 let search = Search Nothing
324 (Just IdentityFilter) (Just [sortSpec]) Nothing Nothing
325 False 0 10
326 reply <- searchByIndex testServer testIndex search
327 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
328 let myTweet = fmap (hitSource . head . hits . searchHits) result
329 myTweet `shouldBe` Right otherTweet
332 describe "filtering API" $ do
333 it "returns document for composed boolmatch and identity" $ do
334 _ <- insertData
335 let queryFilter = BoolFilter (MustMatch (Term "user" "bitemyapp") False)
336 <&&> IdentityFilter
337 let search = mkSearch Nothing (Just queryFilter)
338 myTweet <- searchTweet search
339 myTweet `shouldBe` Right exampleTweet
341 it "returns document for term filter" $ do
342 _ <- insertData
343 let termFilter = TermFilter (Term "user" "bitemyapp") False
344 let search = mkSearch Nothing (Just termFilter)
345 myTweet <- searchTweet search
346 myTweet `shouldBe` Right exampleTweet
348 it "returns document for existential filter" $ do
349 _ <- insertData
350 let search = mkSearch Nothing (Just (ExistsFilter (FieldName "user")))
351 myTweet <- searchTweet search
352 myTweet `shouldBe` Right exampleTweet
354 it "returns document for geo boundingbox filter" $ do
355 _ <- insertData
356 let box = GeoBoundingBox (LatLon 40.73 (-74.1)) (LatLon 40.10 (-71.12))
357 let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False GeoFilterMemory
358 let geoFilter = GeoBoundingBoxFilter bbConstraint
359 let search = mkSearch Nothing (Just geoFilter)
360 myTweet <- searchTweet search
361 myTweet `shouldBe` Right exampleTweet
363 it "doesn't return document for nonsensical boundingbox filter" $ do
364 _ <- insertData
365 let box = GeoBoundingBox (LatLon 0.73 (-4.1)) (LatLon 0.10 (-1.12))
366 let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False GeoFilterMemory
367 let geoFilter = GeoBoundingBoxFilter bbConstraint
368 let search = mkSearch Nothing (Just geoFilter)
369 searchExpectNoResults search
371 it "returns document for geo distance filter" $ do
372 _ <- insertData
373 let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
374 let distance = Distance 10.0 Miles
375 let optimizeBbox = OptimizeGeoFilterType GeoFilterMemory
376 let geoFilter = GeoDistanceFilter geoPoint distance SloppyArc optimizeBbox False
377 let search = mkSearch Nothing (Just geoFilter)
378 myTweet <- searchTweet search
379 myTweet `shouldBe` Right exampleTweet
381 it "returns document for geo distance range filter" $ do
382 _ <- insertData
383 let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
384 let distanceRange = DistanceRange (Distance 0.0 Miles) (Distance 10.0 Miles)
385 let geoFilter = GeoDistanceRangeFilter geoPoint distanceRange
386 let search = mkSearch Nothing (Just geoFilter)
387 myTweet <- searchTweet search
388 myTweet `shouldBe` Right exampleTweet
390 it "doesn't return document for wild geo distance range filter" $ do
391 _ <- insertData
392 let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
393 let distanceRange = DistanceRange (Distance 100.0 Miles) (Distance 1000.0 Miles)
394 let geoFilter = GeoDistanceRangeFilter geoPoint distanceRange
395 let search = mkSearch Nothing (Just geoFilter)
396 searchExpectNoResults search
398 it "returns document for geo polygon filter" $ do
399 _ <- insertData
400 let points = [LatLon 40.0 (-70.00),
401 LatLon 40.0 (-72.00),
402 LatLon 41.0 (-70.00),
403 LatLon 41.0 (-72.00)]
404 let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points
405 let search = mkSearch Nothing (Just geoFilter)
406 myTweet <- searchTweet search
407 myTweet `shouldBe` Right exampleTweet
409 it "doesn't return document for bad geo polygon filter" $ do
410 _ <- insertData
411 let points = [LatLon 40.0 (-70.00),
412 LatLon 40.0 (-71.00),
413 LatLon 41.0 (-70.00),
414 LatLon 41.0 (-71.00)]
415 let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points
416 let search = mkSearch Nothing (Just geoFilter)
417 searchExpectNoResults search
419 it "returns document for ids filter" $ do
420 _ <- insertData
421 let filter = IdsFilter (MappingName "tweet") [DocId "1"]
422 let search = mkSearch Nothing (Just filter)
423 myTweet <- searchTweet search
424 myTweet `shouldBe` Right exampleTweet
426 it "returns document for range filter" $ do
427 _ <- insertData
428 let filter = RangeFilter (FieldName "age")
429 (Right (RangeLtGt (LessThan 100000.0) (GreaterThan 1000.0)))
430 RangeExecutionIndex False
431 let search = mkSearch Nothing (Just filter)
432 myTweet <- searchTweet search
433 myTweet `shouldBe` Right exampleTweet
435 it "returns document for regexp filter" $ do
436 _ <- insertData
437 let filter = RegexpFilter (FieldName "user") (Regexp "bite.*app")
438 AllRegexpFlags (CacheName "test") False (CacheKey "key")
439 let search = mkSearch Nothing (Just filter)
440 myTweet <- searchTweet search
441 myTweet `shouldBe` Right exampleTweet
443 it "doesn't return document for non-matching regexp filter" $ do
444 _ <- insertData
445 let filter = RegexpFilter (FieldName "user")
446 (Regexp "boy") AllRegexpFlags
447 (CacheName "test") False (CacheKey "key")
448 let search = mkSearch Nothing (Just filter)
449 searchExpectNoResults search
451 describe "Aggregation API" $ do
452 it "returns term aggregation results" $ do
453 _ <- insertData
454 let terms = TermsAgg $ mkTermsAggregation "user"
455 let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
456 searchExpectAggs search
457 searchValidBucketAgg search "users" toTerms
459 it "can give collection hint parameters to term aggregations" $ when' (atleast es13) $ do
460 _ <- insertData
461 let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
462 let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
463 searchExpectAggs search
464 searchValidBucketAgg search "users" toTerms
466 it "can give execution hint paramters to term aggregations" $ when' (atmost es11) $ do
467 _ <- insertData
468 searchTermsAggHint [Map, Ordinals]
470 it "can give execution hint paramters to term aggregations" $ when' (is es12) $ do
471 _ <- insertData
472 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map, Ordinals]
474 it "can give execution hint paramters to term aggregations" $ when' (atleast es12) $ do
475 _ <- insertData
476 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map]
478 it "returns date histogram aggregation results" $ do
479 _ <- insertData
480 let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute
481 let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram)
482 searchExpectAggs search
483 searchValidBucketAgg search "byDate" toDateHistogram
485 it "returns date histogram using fractional date" $ do
486 _ <- insertData
487 let periods = [Year, Quarter, Month, Week, Day, Hour, Minute, Second]
488 let fractionals = map (FractionalInterval 1.5) [Weeks, Days, Hours, Minutes, Seconds]
489 let intervals = periods ++ fractionals
490 let histogram = mkDateHistogram (FieldName "postDate")
491 let search interval = mkAggregateSearch Nothing $ mkAggregations "byDate" $ DateHistogramAgg (histogram interval)
492 let expect interval = searchExpectAggs (search interval)
493 let valid interval = searchValidBucketAgg (search interval) "byDate" toDateHistogram
494 forM_ intervals expect
495 forM_ intervals valid
497 describe "Highlights API" $ do
499 it "returns highlight from query when there should be one" $ do
500 _ <- insertData
501 _ <- insertOther
502 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
503 let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
505 let search = mkHighlightSearch (Just query) testHighlight
506 myHighlight <- searchTweetHighlight search
507 myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use <em>haskell</em>!"])]))
509 it "doesn't return highlight from a query when it shouldn't" $ do
510 _ <- insertData
511 _ <- insertOther
512 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
513 let testHighlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]
515 let search = mkHighlightSearch (Just query) testHighlight
516 myHighlight <- searchTweetHighlight search
517 myHighlight `shouldBe` Right Nothing
521 describe "ToJSON RegexpFlags" $ do
522 it "generates the correct JSON for AllRegexpFlags" $
523 toJSON AllRegexpFlags `shouldBe` String "ALL"
525 it "generates the correct JSON for NoRegexpFlags" $
526 toJSON NoRegexpFlags `shouldBe` String "NONE"
528 it "generates the correct JSON for SomeRegexpFlags" $
529 let flags = AnyString :| [ Automaton
530 , Complement
531 , Empty
532 , Intersection
533 , Interval ]
534 in toJSON (SomeRegexpFlags flags) `shouldBe` String "ANYSTRING|AUTOMATON|COMPLEMENT|EMPTY|INTERSECTION|INTERVAL"
536 prop "removes duplicates from flags" $ \(flags :: RegexpFlags) ->
537 let String str = toJSON flags
538 flagStrs = T.splitOn "|" str
539 in noDuplicates flagStrs
541 describe "omitNulls" $ do
542 it "checks that omitNulls drops list elements when it should" $
543 let dropped = omitNulls $ [ "test1" .= (toJSON ([] :: [Int]))
544 , "test2" .= (toJSON ("some value" :: Text))]
545 in dropped `shouldBe` Object (fromList [("test2", String "some value")])
547 it "checks that omitNulls doesn't drop list elements when it shouldn't" $
548 let notDropped = omitNulls $ [ "test1" .= (toJSON ([1] :: [Int]))
549 , "test2" .= (toJSON ("some value" :: Text))]
550 in notDropped `shouldBe` Object (fromList [ ("test1", Array (V.fromList [Number 1.0]))
551 , ("test2", String "some value")])
552 it "checks that omitNulls drops non list elements when it should" $
553 let dropped = omitNulls $ [ "test1" .= (toJSON Null)
554 , "test2" .= (toJSON ("some value" :: Text))]
555 in dropped `shouldBe` Object (fromList [("test2", String "some value")])
556 it "checks that omitNulls doesn't drop non list elements when it shouldn't" $
557 let notDropped = omitNulls $ [ "test1" .= (toJSON (1 :: Int))
558 , "test2" .= (toJSON ("some value" :: Text))]
559 in notDropped `shouldBe` Object (fromList [ ("test1", Number 1.0)
560 , ("test2", String "some value")])