git.iko.soy/typeable/bloodhound
on doc-error-type help sign in
typeable/bloodhound/tests/tests.hs
866 lines 37 kB history raw
1{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# OPTIONS_GHC -fno-warn-orphans #-}
5module Main where
7import Control.Applicative
8import Control.Exception
9import Control.Monad
10import Control.Monad.Reader
11import Data.Aeson
12import qualified Data.HashMap.Strict as HM
13import Data.List (nub)
14import Data.List.NonEmpty (NonEmpty (..))
15import qualified Data.List.NonEmpty as NE
16import qualified Data.Map.Strict as M
17import qualified Data.Maybe as MY
18import Data.Monoid
19import Data.Text (Text)
20import qualified Data.Text as T
21import Data.Time.Calendar (Day (..))
22import Data.Time.Clock (UTCTime (..),
23 secondsToDiffTime)
24import qualified Data.Vector as V
25import Database.Bloodhound
26import GHC.Generics (Generic)
27import Network.HTTP.Client
28import qualified Network.HTTP.Types.Status as NHTS
29import Prelude hiding (filter)
30import Test.Hspec
31import Test.QuickCheck.Property.Monoid (T (..), eq, prop_Monoid)
33import Test.Hspec.QuickCheck (prop)
34import Test.QuickCheck
36testServer :: Server
37testServer = Server "http://localhost:9200"
38testIndex :: IndexName
39testIndex = IndexName "bloodhound-tests-twitter-1"
40testMapping :: MappingName
41testMapping = MappingName "tweet"
43withTestEnv :: BH IO a -> IO a
44withTestEnv = withBH defaultManagerSettings testServer
46validateStatus :: Response body -> Int -> Expectation
47validateStatus resp expected =
48 (NHTS.statusCode $ responseStatus resp)
49 `shouldBe` (expected :: Int)
51createExampleIndex :: BH IO Reply
52createExampleIndex = createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) testIndex
53deleteExampleIndex :: BH IO Reply
54deleteExampleIndex = deleteIndex testIndex
56data ServerVersion = ServerVersion Int Int Int deriving (Show, Eq, Ord)
58es14 :: ServerVersion
59es14 = ServerVersion 1 4 0
61es13 :: ServerVersion
62es13 = ServerVersion 1 3 0
64es12 :: ServerVersion
65es12 = ServerVersion 1 2 0
67es11 :: ServerVersion
68es11 = ServerVersion 1 1 0
70es10 :: ServerVersion
71es10 = ServerVersion 1 0 0
73serverBranch :: ServerVersion -> ServerVersion
74serverBranch (ServerVersion majorVer minorVer patchVer) =
75 ServerVersion majorVer minorVer patchVer
77mkServerVersion :: [Int] -> Maybe ServerVersion
78mkServerVersion [majorVer, minorVer, patchVer] =
79 Just (ServerVersion majorVer minorVer patchVer)
80mkServerVersion _ = Nothing
82getServerVersion :: IO (Maybe ServerVersion)
83getServerVersion = liftM extractVersion (withTestEnv getStatus)
84 where
85 version' = T.splitOn "." . number . version
86 toInt = read . T.unpack
87 parseVersion v = map toInt (version' v)
88 extractVersion = join . liftM (mkServerVersion . parseVersion)
90testServerBranch :: IO (Maybe ServerVersion)
91testServerBranch = getServerVersion >>= \v -> return $ liftM serverBranch v
93atleast :: ServerVersion -> IO Bool
94atleast v = testServerBranch >>= \x -> return $ x >= Just (serverBranch v)
96atmost :: ServerVersion -> IO Bool
97atmost v = testServerBranch >>= \x -> return $ x <= Just (serverBranch v)
99is :: ServerVersion -> IO Bool
100is v = testServerBranch >>= \x -> return $ x == Just (serverBranch v)
102when' :: Monad m => m Bool -> m () -> m ()
103when' b f = b >>= \x -> when x f
105data Location = Location { lat :: Double
106 , lon :: Double } deriving (Eq, Generic, Show)
108data Tweet = Tweet { user :: Text
109 , postDate :: UTCTime
110 , message :: Text
111 , age :: Int
112 , location :: Location }
113 deriving (Eq, Generic, Show)
115instance ToJSON Tweet
116instance FromJSON Tweet
117instance ToJSON Location
118instance FromJSON Location
120data ParentMapping = ParentMapping deriving (Eq, Show)
122instance ToJSON ParentMapping where
123 toJSON ParentMapping =
124 object ["parent" .= Null ]
126data ChildMapping = ChildMapping deriving (Eq, Show)
128instance ToJSON ChildMapping where
129 toJSON ChildMapping =
130 object ["child" .=
131 object ["_parent" .= object ["type" .= ("parent" :: Text)]]
132 ]
134data TweetMapping = TweetMapping deriving (Eq, Show)
136instance ToJSON TweetMapping where
137 toJSON TweetMapping =
138 object ["tweet" .=
139 object ["properties" .=
140 object [ "user" .= object ["type" .= ("string" :: Text)]
141 -- Serializing the date as a date is breaking other tests, mysteriously.
142 -- , "postDate" .= object [ "type" .= ("date" :: Text)
143 -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
144 , "message" .= object ["type" .= ("string" :: Text)]
145 , "age" .= object ["type" .= ("integer" :: Text)]
146 , "location" .= object ["type" .= ("geo_point" :: Text)]
147 ]]]
149exampleTweet :: Tweet
150exampleTweet = Tweet { user = "bitemyapp"
151 , postDate = UTCTime
152 (ModifiedJulianDay 55000)
153 (secondsToDiffTime 10)
154 , message = "Use haskell!"
155 , age = 10000
156 , location = Location 40.12 (-71.34) }
158otherTweet :: Tweet
159otherTweet = Tweet { user = "notmyapp"
160 , postDate = UTCTime
161 (ModifiedJulianDay 55000)
162 (secondsToDiffTime 11)
163 , message = "Use haskell!"
164 , age = 1000
165 , location = Location 40.12 (-71.34) }
167resetIndex :: BH IO ()
168resetIndex = do
169 _ <- deleteExampleIndex
170 _ <- createExampleIndex
171 _ <- putMapping testIndex testMapping TweetMapping
172 return ()
174insertData :: BH IO Reply
175insertData = do
176 resetIndex
177 insertData' defaultIndexDocumentSettings
179insertData' :: IndexDocumentSettings -> BH IO Reply
180insertData' ids = do
181 r <- indexDocument testIndex testMapping ids exampleTweet (DocId "1")
182 _ <- refreshIndex testIndex
183 return r
185insertOther :: BH IO ()
186insertOther = do
187 _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings otherTweet (DocId "2")
188 _ <- refreshIndex testIndex
189 return ()
191insertWithSpaceInId :: BH IO ()
192insertWithSpaceInId = do
193 _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "Hello World")
194 _ <- refreshIndex testIndex
195 return ()
197searchTweet :: Search -> BH IO (Either String Tweet)
198searchTweet search = do
199 result <- searchTweets search
200 let myTweet :: Either String Tweet
201 myTweet = grabFirst result
202 return myTweet
204searchTweets :: Search -> BH IO (Either String (SearchResult Tweet))
205searchTweets search = eitherDecode . responseBody <$> searchByIndex testIndex search
207searchExpectNoResults :: Search -> BH IO ()
208searchExpectNoResults search = do
209 result <- searchTweets search
210 let emptyHits = fmap (hits . searchHits) result
211 liftIO $
212 emptyHits `shouldBe` Right []
214searchExpectAggs :: Search -> BH IO ()
215searchExpectAggs search = do
216 reply <- searchAll search
217 let isEmpty x = return (M.null x)
218 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
219 liftIO $
220 (result >>= aggregations >>= isEmpty) `shouldBe` Just False
222searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) =>
223 Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH IO ()
224searchValidBucketAgg search aggKey extractor = do
225 reply <- searchAll search
226 let bucketDocs = docCount . head . buckets
227 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
228 let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x)
229 liftIO $
230 count `shouldBe` Just 1
232searchTermsAggHint :: [ExecutionHint] -> BH IO ()
233searchTermsAggHint hints = do
234 let terms hint = TermsAgg $ (mkTermsAggregation "user") { termExecutionHint = Just hint }
235 let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint
236 forM_ hints $ searchExpectAggs . search
237 forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
239searchTweetHighlight :: Search -> BH IO (Either String (Maybe HitHighlight))
240searchTweetHighlight search = do
241 result <- searchTweets search
242 let myHighlight = fmap (hitHighlight . head . hits . searchHits) result
243 return myHighlight
245searchExpectSource :: Source -> Either String Value -> BH IO ()
246searchExpectSource src expected = do
247 _ <- insertData
248 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
249 let search = (mkSearch (Just query) Nothing) { source = Just src }
250 reply <- searchAll search
251 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Value)
252 let value = grabFirst result
253 liftIO $
254 value `shouldBe` expected
256data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
257instance FromJSON BulkTest
258instance ToJSON BulkTest
260noDuplicates :: Eq a => [a] -> Bool
261noDuplicates xs = nub xs == xs
263instance Arbitrary RegexpFlags where
264 arbitrary = oneof [ pure AllRegexpFlags
265 , pure NoRegexpFlags
266 , SomeRegexpFlags <$> arbitrary
267 ]
269instance Arbitrary a => Arbitrary (NonEmpty a) where
270 arbitrary = liftA2 (:|) arbitrary arbitrary
272instance Arbitrary RegexpFlag where
273 arbitrary = oneof [ pure AnyString
274 , pure Automaton
275 , pure Complement
276 , pure Empty
277 , pure Intersection
278 , pure Interval
279 ]
281arbitraryScore :: Gen Score
282arbitraryScore = fmap getPositive <$> arbitrary
284instance Arbitrary Text where
285 arbitrary = T.pack <$> arbitrary
287instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) where
288 arbitrary = M.fromList <$> arbitrary
290instance Arbitrary IndexName where
291 arbitrary = IndexName <$> arbitrary
293instance Arbitrary MappingName where
294 arbitrary = MappingName <$> arbitrary
296instance Arbitrary DocId where
297 arbitrary = DocId <$> arbitrary
299instance Arbitrary a => Arbitrary (Hit a) where
300 arbitrary = Hit <$> arbitrary
301 <*> arbitrary
302 <*> arbitrary
303 <*> arbitraryScore
304 <*> arbitrary
305 <*> arbitrary
308instance Arbitrary a => Arbitrary (SearchHits a) where
309 arbitrary = sized $ \n -> resize (n `div` 2) $ do
310 tot <- getPositive <$> arbitrary
311 score <- arbitraryScore
312 hs <- arbitrary
313 return $ SearchHits tot score hs
315getSource :: EsResult a -> Maybe a
316getSource = fmap _source . foundResult
318-- grabFirst :: Either String (SearchResult a) -> Either String a
319grabFirst r =
320 case fmap (hitSource . head . hits . searchHits) r of
321 (Left e) -> Left e
322 (Right Nothing) -> Left "Source was missing"
323 (Right (Just x)) -> Right x
325main :: IO ()
326main = hspec $ do
328 describe "index create/delete API" $ do
329 it "creates and then deletes the requested index" $ withTestEnv $ do
330 -- priming state.
331 _ <- deleteExampleIndex
332 resp <- createExampleIndex
333 deleteResp <- deleteExampleIndex
334 liftIO $ do
335 validateStatus resp 200
336 validateStatus deleteResp 200
338 describe "error parsing" $ do
339 it "can parse EsErrors" $ withTestEnv $ do
340 res <- getDocument (IndexName "bogus") (MappingName "also_bogus") (DocId "bogus_as_well")
341 let errorResp = eitherDecode (responseBody res)
342 liftIO (errorResp `shouldBe` Right (EsError 404 "IndexMissingException[[bogus] missing]"))
344 describe "document API" $ do
345 it "indexes, gets, and then deletes the generated document" $ withTestEnv $ do
346 _ <- insertData
347 docInserted <- getDocument testIndex testMapping (DocId "1")
348 let newTweet = eitherDecode
349 (responseBody docInserted) :: Either String (EsResult Tweet)
350 liftIO $ (fmap getSource newTweet `shouldBe` Right (Just exampleTweet))
352 it "indexes, gets, and then deletes the generated document with a DocId containing a space" $ withTestEnv $ do
353 _ <- insertWithSpaceInId
354 docInserted <- getDocument testIndex testMapping (DocId "Hello World")
355 let newTweet = eitherDecode
356 (responseBody docInserted) :: Either String (EsResult Tweet)
357 liftIO $ (fmap getSource newTweet `shouldBe` Right (Just exampleTweet))
359 it "produces a parseable result when looking up a bogus document" $ withTestEnv $ do
360 doc <- getDocument testIndex testMapping (DocId "bogus")
361 let noTweet = eitherDecode
362 (responseBody doc) :: Either String (EsResult Tweet)
363 liftIO $ fmap foundResult noTweet `shouldBe` Right Nothing
365 it "can use optimistic concurrency control" $ withTestEnv $ do
366 let ev = ExternalDocVersion minBound
367 let cfg = defaultIndexDocumentSettings { idsVersionControl = ExternalGT ev }
368 resetIndex
369 res <- insertData' cfg
370 liftIO $ isCreated res `shouldBe` True
371 res' <- insertData' cfg
372 liftIO $ isVersionConflict res' `shouldBe` True
374 it "indexes two documents in a parent/child relationship and checks that the child exists" $ withTestEnv $ do
375 resetIndex
376 _ <- putMapping testIndex (MappingName "parent") ParentMapping
377 _ <- putMapping testIndex (MappingName "child") ChildMapping
378 _ <- indexDocument testIndex (MappingName "parent") defaultIndexDocumentSettings exampleTweet (DocId "1")
379 let parent = (Just . DocumentParent . DocId) "1"
380 ids = IndexDocumentSettings NoVersionControl parent
381 _ <- indexDocument testIndex (MappingName "child") ids otherTweet (DocId "2")
382 _ <- refreshIndex testIndex
383 exists <- documentExists testIndex (MappingName "child") parent (DocId "2")
384 liftIO $ exists `shouldBe` True
386 describe "template API" $ do
387 it "can create a template" $ withTestEnv $ do
388 let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
389 resp <- putTemplate idxTpl (TemplateName "tweet-tpl")
390 liftIO $ validateStatus resp 200
392 it "can detect if a template exists" $ withTestEnv $ do
393 exists <- templateExists (TemplateName "tweet-tpl")
394 liftIO $ exists `shouldBe` True
396 it "can delete a template" $ withTestEnv $ do
397 resp <- deleteTemplate (TemplateName "tweet-tpl")
398 liftIO $ validateStatus resp 200
400 it "can detect if a template doesn't exist" $ withTestEnv $ do
401 exists <- templateExists (TemplateName "tweet-tpl")
402 liftIO $ exists `shouldBe` False
404 describe "bulk API" $ do
405 it "inserts all documents we request" $ withTestEnv $ do
406 _ <- insertData
407 let firstTest = BulkTest "blah"
408 let secondTest = BulkTest "bloo"
409 let firstDoc = BulkIndex testIndex
410 testMapping (DocId "2") (toJSON firstTest)
411 let secondDoc = BulkCreate testIndex
412 testMapping (DocId "3") (toJSON secondTest)
413 let stream = V.fromList [firstDoc, secondDoc]
414 _ <- bulk stream
415 _ <- refreshIndex testIndex
416 fDoc <- getDocument testIndex testMapping (DocId "2")
417 sDoc <- getDocument testIndex testMapping (DocId "3")
418 let maybeFirst = eitherDecode $ responseBody fDoc :: Either String (EsResult BulkTest)
419 let maybeSecond = eitherDecode $ responseBody sDoc :: Either String (EsResult BulkTest)
420 liftIO $ do
421 fmap getSource maybeFirst `shouldBe` Right (Just firstTest)
422 fmap getSource maybeSecond `shouldBe` Right (Just secondTest)
425 describe "query API" $ do
426 it "returns document for term query and identity filter" $ withTestEnv $ do
427 _ <- insertData
428 let query = TermQuery (Term "user" "bitemyapp") Nothing
429 let filter = IdentityFilter <&&> IdentityFilter
430 let search = mkSearch (Just query) (Just filter)
431 myTweet <- searchTweet search
432 liftIO $
433 myTweet `shouldBe` Right exampleTweet
435 it "returns document for terms query and identity filter" $ withTestEnv $ do
436 _ <- insertData
437 let query = TermsQuery (NE.fromList [(Term "user" "bitemyapp")])
438 let filter = IdentityFilter <&&> IdentityFilter
439 let search = mkSearch (Just query) (Just filter)
440 myTweet <- searchTweet search
441 liftIO $
442 myTweet `shouldBe` Right exampleTweet
444 it "returns document for match query" $ withTestEnv $ do
445 _ <- insertData
446 let query = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
447 let search = mkSearch (Just query) Nothing
448 myTweet <- searchTweet search
449 liftIO $
450 myTweet `shouldBe` Right exampleTweet
452 it "returns document for multi-match query" $ withTestEnv $ do
453 _ <- insertData
454 let flds = [FieldName "user", FieldName "message"]
455 let query = QueryMultiMatchQuery $ mkMultiMatchQuery flds (QueryString "bitemyapp")
456 let search = mkSearch (Just query) Nothing
457 myTweet <- searchTweet search
458 liftIO $
459 myTweet `shouldBe` Right exampleTweet
461 it "returns document for bool query" $ withTestEnv $ do
462 _ <- insertData
463 let innerQuery = QueryMatchQuery $
464 mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
465 let query = QueryBoolQuery $
466 mkBoolQuery [innerQuery] [] []
467 let search = mkSearch (Just query) Nothing
468 myTweet <- searchTweet search
469 liftIO $
470 myTweet `shouldBe` Right exampleTweet
472 it "returns document for boosting query" $ withTestEnv $ do
473 _ <- insertData
474 let posQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
475 let negQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "notmyapp")
476 let query = QueryBoostingQuery $ BoostingQuery posQuery negQuery (Boost 0.2)
477 let search = mkSearch (Just query) Nothing
478 myTweet <- searchTweet search
479 liftIO $
480 myTweet `shouldBe` Right exampleTweet
482 it "returns document for common terms query" $ withTestEnv $ do
483 _ <- insertData
484 let query = QueryCommonTermsQuery $
485 CommonTermsQuery (FieldName "user")
486 (QueryString "bitemyapp")
487 (CutoffFrequency 0.0001)
488 Or Or Nothing Nothing Nothing Nothing
489 let search = mkSearch (Just query) Nothing
490 myTweet <- searchTweet search
491 liftIO $
492 myTweet `shouldBe` Right exampleTweet
495 describe "sorting" $ do
496 it "returns documents in the right order" $ withTestEnv $ do
497 _ <- insertData
498 _ <- insertOther
499 let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
500 let search = Search Nothing
501 (Just IdentityFilter) (Just [sortSpec]) Nothing Nothing
502 False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
503 result <- searchTweets search
504 let myTweet = grabFirst result
505 liftIO $
506 myTweet `shouldBe` Right otherTweet
509 describe "filtering API" $ do
510 it "returns document for composed boolmatch and identity" $ withTestEnv $ do
511 _ <- insertData
512 let queryFilter = BoolFilter (MustMatch (Term "user" "bitemyapp") False)
513 <&&> IdentityFilter
514 let search = mkSearch Nothing (Just queryFilter)
515 myTweet <- searchTweet search
516 liftIO $
517 myTweet `shouldBe` Right exampleTweet
519 it "returns document for term filter" $ withTestEnv $ do
520 _ <- insertData
521 let termFilter = TermFilter (Term "user" "bitemyapp") False
522 let search = mkSearch Nothing (Just termFilter)
523 myTweet <- searchTweet search
524 liftIO $
525 myTweet `shouldBe` Right exampleTweet
527 it "returns document for existential filter" $ withTestEnv $ do
528 _ <- insertData
529 let search = mkSearch Nothing (Just (ExistsFilter (FieldName "user")))
530 myTweet <- searchTweet search
531 liftIO $
532 myTweet `shouldBe` Right exampleTweet
534 it "returns document for geo boundingbox filter" $ withTestEnv $ do
535 _ <- insertData
536 let box = GeoBoundingBox (LatLon 40.73 (-74.1)) (LatLon 40.10 (-71.12))
537 let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False GeoFilterMemory
538 let geoFilter = GeoBoundingBoxFilter bbConstraint
539 let search = mkSearch Nothing (Just geoFilter)
540 myTweet <- searchTweet search
541 liftIO $
542 myTweet `shouldBe` Right exampleTweet
544 it "doesn't return document for nonsensical boundingbox filter" $ withTestEnv $ do
545 _ <- insertData
546 let box = GeoBoundingBox (LatLon 0.73 (-4.1)) (LatLon 0.10 (-1.12))
547 let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False GeoFilterMemory
548 let geoFilter = GeoBoundingBoxFilter bbConstraint
549 let search = mkSearch Nothing (Just geoFilter)
550 searchExpectNoResults search
552 it "returns document for geo distance filter" $ withTestEnv $ do
553 _ <- insertData
554 let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
555 let distance = Distance 10.0 Miles
556 let optimizeBbox = OptimizeGeoFilterType GeoFilterMemory
557 let geoFilter = GeoDistanceFilter geoPoint distance SloppyArc optimizeBbox False
558 let search = mkSearch Nothing (Just geoFilter)
559 myTweet <- searchTweet search
560 liftIO $
561 myTweet `shouldBe` Right exampleTweet
563 it "returns document for geo distance range filter" $ withTestEnv $ do
564 _ <- insertData
565 let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
566 let distanceRange = DistanceRange (Distance 0.0 Miles) (Distance 10.0 Miles)
567 let geoFilter = GeoDistanceRangeFilter geoPoint distanceRange
568 let search = mkSearch Nothing (Just geoFilter)
569 myTweet <- searchTweet search
570 liftIO $
571 myTweet `shouldBe` Right exampleTweet
573 it "doesn't return document for wild geo distance range filter" $ withTestEnv $ do
574 _ <- insertData
575 let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
576 let distanceRange = DistanceRange (Distance 100.0 Miles) (Distance 1000.0 Miles)
577 let geoFilter = GeoDistanceRangeFilter geoPoint distanceRange
578 let search = mkSearch Nothing (Just geoFilter)
579 searchExpectNoResults search
581 it "returns document for geo polygon filter" $ withTestEnv $ do
582 _ <- insertData
583 let points = [LatLon 40.0 (-70.00),
584 LatLon 40.0 (-72.00),
585 LatLon 41.0 (-70.00),
586 LatLon 41.0 (-72.00)]
587 let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points
588 let search = mkSearch Nothing (Just geoFilter)
589 myTweet <- searchTweet search
590 liftIO $
591 myTweet `shouldBe` Right exampleTweet
593 it "doesn't return document for bad geo polygon filter" $ withTestEnv $ do
594 _ <- insertData
595 let points = [LatLon 40.0 (-70.00),
596 LatLon 40.0 (-71.00),
597 LatLon 41.0 (-70.00),
598 LatLon 41.0 (-71.00)]
599 let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points
600 let search = mkSearch Nothing (Just geoFilter)
601 searchExpectNoResults search
603 it "returns document for ids filter" $ withTestEnv $ do
604 _ <- insertData
605 let filter = IdsFilter (MappingName "tweet") [DocId "1"]
606 let search = mkSearch Nothing (Just filter)
607 myTweet <- searchTweet search
608 liftIO $
609 myTweet `shouldBe` Right exampleTweet
611 it "returns document for Double range filter" $ withTestEnv $ do
612 _ <- insertData
613 let filter = RangeFilter (FieldName "age")
614 (RangeDoubleGtLt (GreaterThan 1000.0) (LessThan 100000.0))
615 RangeExecutionIndex False
616 let search = mkSearch Nothing (Just filter)
617 myTweet <- searchTweet search
618 liftIO $
619 myTweet `shouldBe` Right exampleTweet
621 it "returns document for UTCTime date filter" $ withTestEnv $ do
622 _ <- insertData
623 let filter = RangeFilter (FieldName "postDate")
624 (RangeDateGtLt
625 (GreaterThanD (UTCTime
626 (ModifiedJulianDay 54000)
627 (secondsToDiffTime 0)))
628 (LessThanD (UTCTime
629 (ModifiedJulianDay 55000)
630 (secondsToDiffTime 11))))
631 RangeExecutionIndex False
632 let search = mkSearch Nothing (Just filter)
633 myTweet <- searchTweet search
634 liftIO $
635 myTweet `shouldBe` Right exampleTweet
637 it "returns document for regexp filter" $ withTestEnv $ do
638 _ <- insertData
639 let filter = RegexpFilter (FieldName "user") (Regexp "bite.*app")
640 AllRegexpFlags (CacheName "test") False (CacheKey "key")
641 let search = mkSearch Nothing (Just filter)
642 myTweet <- searchTweet search
643 liftIO $
644 myTweet `shouldBe` Right exampleTweet
646 it "doesn't return document for non-matching regexp filter" $ withTestEnv $ do
647 _ <- insertData
648 let filter = RegexpFilter (FieldName "user")
649 (Regexp "boy") AllRegexpFlags
650 (CacheName "test") False (CacheKey "key")
651 let search = mkSearch Nothing (Just filter)
652 searchExpectNoResults search
654 it "returns document for query filter, uncached" $ withTestEnv $ do
655 _ <- insertData
656 let filter = QueryFilter (TermQuery (Term "user" "bitemyapp") Nothing) True
657 search = mkSearch Nothing (Just filter)
658 myTweet <- searchTweet search
659 liftIO $ myTweet `shouldBe` Right exampleTweet
661 it "returns document for query filter, cached" $ withTestEnv $ do
662 _ <- insertData
663 let filter = QueryFilter (TermQuery (Term "user" "bitemyapp") Nothing) False
664 search = mkSearch Nothing (Just filter)
665 myTweet <- searchTweet search
666 liftIO $ myTweet `shouldBe` Right exampleTweet
668 describe "Aggregation API" $ do
669 it "returns term aggregation results" $ withTestEnv $ do
670 _ <- insertData
671 let terms = TermsAgg $ mkTermsAggregation "user"
672 let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
673 searchExpectAggs search
674 searchValidBucketAgg search "users" toTerms
676 it "can give collection hint parameters to term aggregations" $ when' (atleast es13) $ withTestEnv $ do
677 _ <- insertData
678 let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
679 let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
680 searchExpectAggs search
681 searchValidBucketAgg search "users" toTerms
683 it "can give execution hint parameters to term aggregations" $ when' (atmost es11) $ withTestEnv $ do
684 _ <- insertData
685 searchTermsAggHint [Map, Ordinals]
687 it "can give execution hint parameters to term aggregations" $ when' (is es12) $ withTestEnv $ do
688 _ <- insertData
689 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map, Ordinals]
691 it "can give execution hint parameters to term aggregations" $ when' (atleast es12) $ withTestEnv $ do
692 _ <- insertData
693 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map]
696 it "can execute value_count aggregations" $ withTestEnv $ do
697 _ <- insertData
698 _ <- insertOther
699 let ags = mkAggregations "user_count" (ValueCountAgg (FieldValueCount (FieldName "user"))) <>
700 mkAggregations "bogus_count" (ValueCountAgg (FieldValueCount (FieldName "bogus")))
701 let search = mkAggregateSearch Nothing ags
702 let docCountPair k n = (k, object ["value" .= Number n])
703 res <- searchTweets search
704 liftIO $
705 fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "user_count" 2
706 , docCountPair "bogus_count" 0
707 ]))
709 it "can execute filter aggregations" $ withTestEnv $ do
710 _ <- insertData
711 _ <- insertOther
712 let ags = mkAggregations "bitemyapps" (FilterAgg (FilterAggregation (TermFilter (Term "user" "bitemyapp") defaultCache) Nothing)) <>
713 mkAggregations "notmyapps" (FilterAgg (FilterAggregation (TermFilter (Term "user" "notmyapp") defaultCache) Nothing))
714 let search = mkAggregateSearch Nothing ags
715 let docCountPair k n = (k, object ["doc_count" .= Number n])
716 res <- searchTweets search
717 liftIO $
718 fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "bitemyapps" 1
719 , docCountPair "notmyapps" 1
720 ]))
722 it "returns date histogram aggregation results" $ withTestEnv $ do
723 _ <- insertData
724 let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute
725 let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram)
726 searchExpectAggs search
727 searchValidBucketAgg search "byDate" toDateHistogram
729 it "returns date histogram using fractional date" $ withTestEnv $ do
730 _ <- insertData
731 let periods = [Year, Quarter, Month, Week, Day, Hour, Minute, Second]
732 let fractionals = map (FractionalInterval 1.5) [Weeks, Days, Hours, Minutes, Seconds]
733 let intervals = periods ++ fractionals
734 let histogram = mkDateHistogram (FieldName "postDate")
735 let search interval = mkAggregateSearch Nothing $ mkAggregations "byDate" $ DateHistogramAgg (histogram interval)
736 let expect interval = searchExpectAggs (search interval)
737 let valid interval = searchValidBucketAgg (search interval) "byDate" toDateHistogram
738 forM_ intervals expect
739 forM_ intervals valid
741 describe "Highlights API" $ do
743 it "returns highlight from query when there should be one" $ withTestEnv $ do
744 _ <- insertData
745 _ <- insertOther
746 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
747 let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
749 let search = mkHighlightSearch (Just query) testHighlight
750 myHighlight <- searchTweetHighlight search
751 liftIO $
752 myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use <em>haskell</em>!"])]))
754 it "doesn't return highlight from a query when it shouldn't" $ withTestEnv $ do
755 _ <- insertData
756 _ <- insertOther
757 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
758 let testHighlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]
760 let search = mkHighlightSearch (Just query) testHighlight
761 myHighlight <- searchTweetHighlight search
762 liftIO $
763 myHighlight `shouldBe` Right Nothing
765 describe "Source filtering" $ do
767 it "doesn't include source when sources are disabled" $ withTestEnv $ do
768 searchExpectSource
769 NoSource
770 (Left "Source was missing")
772 it "includes a source" $ withTestEnv $ do
773 searchExpectSource
774 (SourcePatterns (PopPattern (Pattern "message")))
775 (Right (Object (HM.fromList [("message", String "Use haskell!")])))
777 it "includes sources" $ withTestEnv $ do
778 searchExpectSource
779 (SourcePatterns (PopPatterns [Pattern "user", Pattern "message"]))
780 (Right (Object (HM.fromList [("user",String "bitemyapp"),("message", String "Use haskell!")])))
782 it "includes source patterns" $ withTestEnv $ do
783 searchExpectSource
784 (SourcePatterns (PopPattern (Pattern "*ge")))
785 (Right (Object (HM.fromList [("age", Number 10000),("message", String "Use haskell!")])))
787 it "excludes source patterns" $ withTestEnv $ do
788 searchExpectSource
789 (SourceIncludeExclude (Include []) (Exclude [Pattern "l*", Pattern "*ge", Pattern "postDate"]))
790 (Right (Object (HM.fromList [("user",String "bitemyapp")])))
792 describe "ToJSON RegexpFlags" $ do
793 it "generates the correct JSON for AllRegexpFlags" $
794 toJSON AllRegexpFlags `shouldBe` String "ALL"
796 it "generates the correct JSON for NoRegexpFlags" $
797 toJSON NoRegexpFlags `shouldBe` String "NONE"
799 it "generates the correct JSON for SomeRegexpFlags" $
800 let flags = AnyString :| [ Automaton
801 , Complement
802 , Empty
803 , Intersection
804 , Interval ]
805 in toJSON (SomeRegexpFlags flags) `shouldBe` String "ANYSTRING|AUTOMATON|COMPLEMENT|EMPTY|INTERSECTION|INTERVAL"
807 prop "removes duplicates from flags" $ \(flags :: RegexpFlags) ->
808 let String str = toJSON flags
809 flagStrs = T.splitOn "|" str
810 in noDuplicates flagStrs
812 describe "omitNulls" $ do
813 it "checks that omitNulls drops list elements when it should" $
814 let dropped = omitNulls $ [ "test1" .= (toJSON ([] :: [Int]))
815 , "test2" .= (toJSON ("some value" :: Text))]
816 in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")])
818 it "checks that omitNulls doesn't drop list elements when it shouldn't" $
819 let notDropped = omitNulls $ [ "test1" .= (toJSON ([1] :: [Int]))
820 , "test2" .= (toJSON ("some value" :: Text))]
821 in notDropped `shouldBe` Object (HM.fromList [ ("test1", Array (V.fromList [Number 1.0]))
822 , ("test2", String "some value")])
823 it "checks that omitNulls drops non list elements when it should" $
824 let dropped = omitNulls $ [ "test1" .= (toJSON Null)
825 , "test2" .= (toJSON ("some value" :: Text))]
826 in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")])
827 it "checks that omitNulls doesn't drop non list elements when it shouldn't" $
828 let notDropped = omitNulls $ [ "test1" .= (toJSON (1 :: Int))
829 , "test2" .= (toJSON ("some value" :: Text))]
830 in notDropped `shouldBe` Object (HM.fromList [ ("test1", Number 1.0)
831 , ("test2", String "some value")])
832 describe "Monoid (SearchHits a)" $ do
833 prop "abides the monoid laws" $ eq $
834 prop_Monoid (T :: T (SearchHits ()))
836 describe "mkDocVersion" $ do
837 prop "can never construct an out of range docVersion" $ \i ->
838 let res = mkDocVersion i
839 in case res of
840 Nothing -> property True
841 Just dv -> (dv >= minBound) .&&.
842 (dv <= maxBound) .&&.
843 docVersionNumber dv === i
845 describe "Enum DocVersion" $ do
846 it "follows the laws of Enum, Bounded" $ do
847 evaluate (succ maxBound :: DocVersion) `shouldThrow` anyErrorCall
848 evaluate (pred minBound :: DocVersion) `shouldThrow` anyErrorCall
849 evaluate (toEnum 0 :: DocVersion) `shouldThrow` anyErrorCall
850 evaluate (toEnum 9200000000000000001 :: DocVersion) `shouldThrow` anyErrorCall
851 enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
852 enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
853 enumFromThen minBound (pred maxBound :: DocVersion) `shouldBe` [minBound, pred maxBound]
855 describe "scan&scroll API" $ do
856 it "returns documents using the scan&scroll API" $ withTestEnv $ do
857 _ <- insertData
858 _ <- insertOther
859 let search = (mkSearch (Just $ MatchAllQuery Nothing) Nothing) { size = (Size 1) }
860 regular_search <- searchTweet search
861 scan_search' <- scanSearch testIndex testMapping search :: BH IO [Hit Tweet]
862 let scan_search = map hitSource scan_search'
863 liftIO $
864 regular_search `shouldBe` Right exampleTweet -- Check that the size restrtiction is being honored
865 liftIO $
866 scan_search `shouldMatchList` [Just exampleTweet, Just otherTweet]