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