git.iko.soy/typeable/bloodhound
on low-level-scroll help sign in
typeable/bloodhound/tests/tests.hs
871 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 where
261 parseJSON = genericParseJSON defaultOptions
262instance ToJSON BulkTest where
263 toJSON = genericToJSON defaultOptions
265noDuplicates :: Eq a => [a] -> Bool
266noDuplicates xs = nub xs == xs
268instance Arbitrary RegexpFlags where
269 arbitrary = oneof [ pure AllRegexpFlags
270 , pure NoRegexpFlags
271 , SomeRegexpFlags <$> arbitrary
272 ]
274instance Arbitrary a => Arbitrary (NonEmpty a) where
275 arbitrary = liftA2 (:|) arbitrary arbitrary
277instance Arbitrary RegexpFlag where
278 arbitrary = oneof [ pure AnyString
279 , pure Automaton
280 , pure Complement
281 , pure Empty
282 , pure Intersection
283 , pure Interval
284 ]
286arbitraryScore :: Gen Score
287arbitraryScore = fmap getPositive <$> arbitrary
289instance Arbitrary Text where
290 arbitrary = T.pack <$> arbitrary
292instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) where
293 arbitrary = M.fromList <$> arbitrary
295instance Arbitrary IndexName where
296 arbitrary = IndexName <$> arbitrary
298instance Arbitrary MappingName where
299 arbitrary = MappingName <$> arbitrary
301instance Arbitrary DocId where
302 arbitrary = DocId <$> arbitrary
304instance Arbitrary a => Arbitrary (Hit a) where
305 arbitrary = Hit <$> arbitrary
306 <*> arbitrary
307 <*> arbitrary
308 <*> arbitraryScore
309 <*> arbitrary
310 <*> arbitrary
313instance Arbitrary a => Arbitrary (SearchHits a) where
314 arbitrary = sized $ \n -> resize (n `div` 2) $ do
315 tot <- getPositive <$> arbitrary
316 score <- arbitraryScore
317 hs <- arbitrary
318 return $ SearchHits tot score hs
320getSource :: EsResult a -> Maybe a
321getSource = fmap _source . foundResult
323grabFirst :: Either String (SearchResult a) -> Either String a
324grabFirst r =
325 case fmap (hitSource . head . hits . searchHits) r of
326 (Left e) -> Left e
327 (Right Nothing) -> Left "Source was missing"
328 (Right (Just x)) -> Right x
330main :: IO ()
331main = hspec $ do
333 describe "index create/delete API" $ do
334 it "creates and then deletes the requested index" $ withTestEnv $ do
335 -- priming state.
336 _ <- deleteExampleIndex
337 resp <- createExampleIndex
338 deleteResp <- deleteExampleIndex
339 liftIO $ do
340 validateStatus resp 200
341 validateStatus deleteResp 200
343 describe "error parsing" $ do
344 it "can parse EsErrors" $ withTestEnv $ do
345 res <- getDocument (IndexName "bogus") (MappingName "also_bogus") (DocId "bogus_as_well")
346 let errorResp = eitherDecode (responseBody res)
347 liftIO (errorResp `shouldBe` Right (EsError 404 "IndexMissingException[[bogus] missing]"))
349 describe "document API" $ do
350 it "indexes, gets, and then deletes the generated document" $ withTestEnv $ do
351 _ <- insertData
352 docInserted <- getDocument testIndex testMapping (DocId "1")
353 let newTweet = eitherDecode
354 (responseBody docInserted) :: Either String (EsResult Tweet)
355 liftIO $ (fmap getSource newTweet `shouldBe` Right (Just exampleTweet))
357 it "indexes, gets, and then deletes the generated document with a DocId containing a space" $ withTestEnv $ do
358 _ <- insertWithSpaceInId
359 docInserted <- getDocument testIndex testMapping (DocId "Hello World")
360 let newTweet = eitherDecode
361 (responseBody docInserted) :: Either String (EsResult Tweet)
362 liftIO $ (fmap getSource newTweet `shouldBe` Right (Just exampleTweet))
364 it "produces a parseable result when looking up a bogus document" $ withTestEnv $ do
365 doc <- getDocument testIndex testMapping (DocId "bogus")
366 let noTweet = eitherDecode
367 (responseBody doc) :: Either String (EsResult Tweet)
368 liftIO $ fmap foundResult noTweet `shouldBe` Right Nothing
370 it "can use optimistic concurrency control" $ withTestEnv $ do
371 let ev = ExternalDocVersion minBound
372 let cfg = defaultIndexDocumentSettings { idsVersionControl = ExternalGT ev }
373 resetIndex
374 res <- insertData' cfg
375 liftIO $ isCreated res `shouldBe` True
376 res' <- insertData' cfg
377 liftIO $ isVersionConflict res' `shouldBe` True
379 it "indexes two documents in a parent/child relationship and checks that the child exists" $ withTestEnv $ do
380 resetIndex
381 _ <- putMapping testIndex (MappingName "parent") ParentMapping
382 _ <- putMapping testIndex (MappingName "child") ChildMapping
383 _ <- indexDocument testIndex (MappingName "parent") defaultIndexDocumentSettings exampleTweet (DocId "1")
384 let parent = (Just . DocumentParent . DocId) "1"
385 ids = IndexDocumentSettings NoVersionControl parent
386 _ <- indexDocument testIndex (MappingName "child") ids otherTweet (DocId "2")
387 _ <- refreshIndex testIndex
388 exists <- documentExists testIndex (MappingName "child") parent (DocId "2")
389 liftIO $ exists `shouldBe` True
391 describe "template API" $ do
392 it "can create a template" $ withTestEnv $ do
393 let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
394 resp <- putTemplate idxTpl (TemplateName "tweet-tpl")
395 liftIO $ validateStatus resp 200
397 it "can detect if a template exists" $ withTestEnv $ do
398 exists <- templateExists (TemplateName "tweet-tpl")
399 liftIO $ exists `shouldBe` True
401 it "can delete a template" $ withTestEnv $ do
402 resp <- deleteTemplate (TemplateName "tweet-tpl")
403 liftIO $ validateStatus resp 200
405 it "can detect if a template doesn't exist" $ withTestEnv $ do
406 exists <- templateExists (TemplateName "tweet-tpl")
407 liftIO $ exists `shouldBe` False
409 describe "bulk API" $ do
410 it "inserts all documents we request" $ withTestEnv $ do
411 _ <- insertData
412 let firstTest = BulkTest "blah"
413 let secondTest = BulkTest "bloo"
414 let firstDoc = BulkIndex testIndex
415 testMapping (DocId "2") (toJSON firstTest)
416 let secondDoc = BulkCreate testIndex
417 testMapping (DocId "3") (toJSON secondTest)
418 let stream = V.fromList [firstDoc, secondDoc]
419 _ <- bulk stream
420 _ <- refreshIndex testIndex
421 fDoc <- getDocument testIndex testMapping (DocId "2")
422 sDoc <- getDocument testIndex testMapping (DocId "3")
423 let maybeFirst = eitherDecode $ responseBody fDoc :: Either String (EsResult BulkTest)
424 let maybeSecond = eitherDecode $ responseBody sDoc :: Either String (EsResult BulkTest)
425 liftIO $ do
426 fmap getSource maybeFirst `shouldBe` Right (Just firstTest)
427 fmap getSource maybeSecond `shouldBe` Right (Just secondTest)
430 describe "query API" $ do
431 it "returns document for term query and identity filter" $ withTestEnv $ do
432 _ <- insertData
433 let query = TermQuery (Term "user" "bitemyapp") Nothing
434 let filter = IdentityFilter <&&> IdentityFilter
435 let search = mkSearch (Just query) (Just filter)
436 myTweet <- searchTweet search
437 liftIO $
438 myTweet `shouldBe` Right exampleTweet
440 it "returns document for terms query and identity filter" $ withTestEnv $ do
441 _ <- insertData
442 let query = TermsQuery (NE.fromList [(Term "user" "bitemyapp")])
443 let filter = IdentityFilter <&&> IdentityFilter
444 let search = mkSearch (Just query) (Just filter)
445 myTweet <- searchTweet search
446 liftIO $
447 myTweet `shouldBe` Right exampleTweet
449 it "returns document for match query" $ withTestEnv $ do
450 _ <- insertData
451 let query = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
452 let search = mkSearch (Just query) Nothing
453 myTweet <- searchTweet search
454 liftIO $
455 myTweet `shouldBe` Right exampleTweet
457 it "returns document for multi-match query" $ withTestEnv $ do
458 _ <- insertData
459 let flds = [FieldName "user", FieldName "message"]
460 let query = QueryMultiMatchQuery $ mkMultiMatchQuery flds (QueryString "bitemyapp")
461 let search = mkSearch (Just query) Nothing
462 myTweet <- searchTweet search
463 liftIO $
464 myTweet `shouldBe` Right exampleTweet
466 it "returns document for bool query" $ withTestEnv $ do
467 _ <- insertData
468 let innerQuery = QueryMatchQuery $
469 mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
470 let query = QueryBoolQuery $
471 mkBoolQuery [innerQuery] [] []
472 let search = mkSearch (Just query) Nothing
473 myTweet <- searchTweet search
474 liftIO $
475 myTweet `shouldBe` Right exampleTweet
477 it "returns document for boosting query" $ withTestEnv $ do
478 _ <- insertData
479 let posQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
480 let negQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "notmyapp")
481 let query = QueryBoostingQuery $ BoostingQuery posQuery negQuery (Boost 0.2)
482 let search = mkSearch (Just query) Nothing
483 myTweet <- searchTweet search
484 liftIO $
485 myTweet `shouldBe` Right exampleTweet
487 it "returns document for common terms query" $ withTestEnv $ do
488 _ <- insertData
489 let query = QueryCommonTermsQuery $
490 CommonTermsQuery (FieldName "user")
491 (QueryString "bitemyapp")
492 (CutoffFrequency 0.0001)
493 Or Or Nothing Nothing Nothing Nothing
494 let search = mkSearch (Just query) Nothing
495 myTweet <- searchTweet search
496 liftIO $
497 myTweet `shouldBe` Right exampleTweet
500 describe "sorting" $ do
501 it "returns documents in the right order" $ withTestEnv $ do
502 _ <- insertData
503 _ <- insertOther
504 let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
505 let search = Search Nothing
506 (Just IdentityFilter) (Just [sortSpec]) Nothing Nothing
507 False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
508 result <- searchTweets search
509 let myTweet = grabFirst result
510 liftIO $
511 myTweet `shouldBe` Right otherTweet
514 describe "filtering API" $ do
515 it "returns document for composed boolmatch and identity" $ withTestEnv $ do
516 _ <- insertData
517 let queryFilter = BoolFilter (MustMatch (Term "user" "bitemyapp") False)
518 <&&> IdentityFilter
519 let search = mkSearch Nothing (Just queryFilter)
520 myTweet <- searchTweet search
521 liftIO $
522 myTweet `shouldBe` Right exampleTweet
524 it "returns document for term filter" $ withTestEnv $ do
525 _ <- insertData
526 let termFilter = TermFilter (Term "user" "bitemyapp") False
527 let search = mkSearch Nothing (Just termFilter)
528 myTweet <- searchTweet search
529 liftIO $
530 myTweet `shouldBe` Right exampleTweet
532 it "returns document for existential filter" $ withTestEnv $ do
533 _ <- insertData
534 let search = mkSearch Nothing (Just (ExistsFilter (FieldName "user")))
535 myTweet <- searchTweet search
536 liftIO $
537 myTweet `shouldBe` Right exampleTweet
539 it "returns document for geo boundingbox filter" $ withTestEnv $ do
540 _ <- insertData
541 let box = GeoBoundingBox (LatLon 40.73 (-74.1)) (LatLon 40.10 (-71.12))
542 let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False GeoFilterMemory
543 let geoFilter = GeoBoundingBoxFilter bbConstraint
544 let search = mkSearch Nothing (Just geoFilter)
545 myTweet <- searchTweet search
546 liftIO $
547 myTweet `shouldBe` Right exampleTweet
549 it "doesn't return document for nonsensical boundingbox filter" $ withTestEnv $ do
550 _ <- insertData
551 let box = GeoBoundingBox (LatLon 0.73 (-4.1)) (LatLon 0.10 (-1.12))
552 let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False GeoFilterMemory
553 let geoFilter = GeoBoundingBoxFilter bbConstraint
554 let search = mkSearch Nothing (Just geoFilter)
555 searchExpectNoResults search
557 it "returns document for geo distance filter" $ withTestEnv $ do
558 _ <- insertData
559 let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
560 let distance = Distance 10.0 Miles
561 let optimizeBbox = OptimizeGeoFilterType GeoFilterMemory
562 let geoFilter = GeoDistanceFilter geoPoint distance SloppyArc optimizeBbox False
563 let search = mkSearch Nothing (Just geoFilter)
564 myTweet <- searchTweet search
565 liftIO $
566 myTweet `shouldBe` Right exampleTweet
568 it "returns document for geo distance range filter" $ withTestEnv $ do
569 _ <- insertData
570 let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
571 let distanceRange = DistanceRange (Distance 0.0 Miles) (Distance 10.0 Miles)
572 let geoFilter = GeoDistanceRangeFilter geoPoint distanceRange
573 let search = mkSearch Nothing (Just geoFilter)
574 myTweet <- searchTweet search
575 liftIO $
576 myTweet `shouldBe` Right exampleTweet
578 it "doesn't return document for wild geo distance range filter" $ withTestEnv $ do
579 _ <- insertData
580 let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
581 let distanceRange = DistanceRange (Distance 100.0 Miles) (Distance 1000.0 Miles)
582 let geoFilter = GeoDistanceRangeFilter geoPoint distanceRange
583 let search = mkSearch Nothing (Just geoFilter)
584 searchExpectNoResults search
586 it "returns document for geo polygon filter" $ withTestEnv $ do
587 _ <- insertData
588 let points = [LatLon 40.0 (-70.00),
589 LatLon 40.0 (-72.00),
590 LatLon 41.0 (-70.00),
591 LatLon 41.0 (-72.00)]
592 let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points
593 let search = mkSearch Nothing (Just geoFilter)
594 myTweet <- searchTweet search
595 liftIO $
596 myTweet `shouldBe` Right exampleTweet
598 it "doesn't return document for bad geo polygon filter" $ withTestEnv $ do
599 _ <- insertData
600 let points = [LatLon 40.0 (-70.00),
601 LatLon 40.0 (-71.00),
602 LatLon 41.0 (-70.00),
603 LatLon 41.0 (-71.00)]
604 let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points
605 let search = mkSearch Nothing (Just geoFilter)
606 searchExpectNoResults search
608 it "returns document for ids filter" $ withTestEnv $ do
609 _ <- insertData
610 let filter = IdsFilter (MappingName "tweet") [DocId "1"]
611 let search = mkSearch Nothing (Just filter)
612 myTweet <- searchTweet search
613 liftIO $
614 myTweet `shouldBe` Right exampleTweet
616 it "returns document for Double range filter" $ withTestEnv $ do
617 _ <- insertData
618 let filter = RangeFilter (FieldName "age")
619 (RangeDoubleGtLt (GreaterThan 1000.0) (LessThan 100000.0))
620 RangeExecutionIndex False
621 let search = mkSearch Nothing (Just filter)
622 myTweet <- searchTweet search
623 liftIO $
624 myTweet `shouldBe` Right exampleTweet
626 it "returns document for UTCTime date filter" $ withTestEnv $ do
627 _ <- insertData
628 let filter = RangeFilter (FieldName "postDate")
629 (RangeDateGtLt
630 (GreaterThanD (UTCTime
631 (ModifiedJulianDay 54000)
632 (secondsToDiffTime 0)))
633 (LessThanD (UTCTime
634 (ModifiedJulianDay 55000)
635 (secondsToDiffTime 11))))
636 RangeExecutionIndex False
637 let search = mkSearch Nothing (Just filter)
638 myTweet <- searchTweet search
639 liftIO $
640 myTweet `shouldBe` Right exampleTweet
642 it "returns document for regexp filter" $ withTestEnv $ do
643 _ <- insertData
644 let filter = RegexpFilter (FieldName "user") (Regexp "bite.*app")
645 AllRegexpFlags (CacheName "test") False (CacheKey "key")
646 let search = mkSearch Nothing (Just filter)
647 myTweet <- searchTweet search
648 liftIO $
649 myTweet `shouldBe` Right exampleTweet
651 it "doesn't return document for non-matching regexp filter" $ withTestEnv $ do
652 _ <- insertData
653 let filter = RegexpFilter (FieldName "user")
654 (Regexp "boy") AllRegexpFlags
655 (CacheName "test") False (CacheKey "key")
656 let search = mkSearch Nothing (Just filter)
657 searchExpectNoResults search
659 it "returns document for query filter, uncached" $ withTestEnv $ do
660 _ <- insertData
661 let filter = QueryFilter (TermQuery (Term "user" "bitemyapp") Nothing) True
662 search = mkSearch Nothing (Just filter)
663 myTweet <- searchTweet search
664 liftIO $ myTweet `shouldBe` Right exampleTweet
666 it "returns document for query filter, cached" $ withTestEnv $ do
667 _ <- insertData
668 let filter = QueryFilter (TermQuery (Term "user" "bitemyapp") Nothing) False
669 search = mkSearch Nothing (Just filter)
670 myTweet <- searchTweet search
671 liftIO $ myTweet `shouldBe` Right exampleTweet
673 describe "Aggregation API" $ do
674 it "returns term aggregation results" $ withTestEnv $ do
675 _ <- insertData
676 let terms = TermsAgg $ mkTermsAggregation "user"
677 let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
678 searchExpectAggs search
679 searchValidBucketAgg search "users" toTerms
681 it "can give collection hint parameters to term aggregations" $ when' (atleast es13) $ withTestEnv $ do
682 _ <- insertData
683 let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
684 let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
685 searchExpectAggs search
686 searchValidBucketAgg search "users" toTerms
688 it "can give execution hint parameters to term aggregations" $ when' (atmost es11) $ withTestEnv $ do
689 _ <- insertData
690 searchTermsAggHint [Map, Ordinals]
692 it "can give execution hint parameters to term aggregations" $ when' (is es12) $ withTestEnv $ do
693 _ <- insertData
694 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map, Ordinals]
696 it "can give execution hint parameters to term aggregations" $ when' (atleast es12) $ withTestEnv $ do
697 _ <- insertData
698 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map]
701 it "can execute value_count aggregations" $ withTestEnv $ do
702 _ <- insertData
703 _ <- insertOther
704 let ags = mkAggregations "user_count" (ValueCountAgg (FieldValueCount (FieldName "user"))) <>
705 mkAggregations "bogus_count" (ValueCountAgg (FieldValueCount (FieldName "bogus")))
706 let search = mkAggregateSearch Nothing ags
707 let docCountPair k n = (k, object ["value" .= Number n])
708 res <- searchTweets search
709 liftIO $
710 fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "user_count" 2
711 , docCountPair "bogus_count" 0
712 ]))
714 it "can execute filter aggregations" $ withTestEnv $ do
715 _ <- insertData
716 _ <- insertOther
717 let ags = mkAggregations "bitemyapps" (FilterAgg (FilterAggregation (TermFilter (Term "user" "bitemyapp") defaultCache) Nothing)) <>
718 mkAggregations "notmyapps" (FilterAgg (FilterAggregation (TermFilter (Term "user" "notmyapp") defaultCache) Nothing))
719 let search = mkAggregateSearch Nothing ags
720 let docCountPair k n = (k, object ["doc_count" .= Number n])
721 res <- searchTweets search
722 liftIO $
723 fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "bitemyapps" 1
724 , docCountPair "notmyapps" 1
725 ]))
727 it "returns date histogram aggregation results" $ withTestEnv $ do
728 _ <- insertData
729 let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute
730 let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram)
731 searchExpectAggs search
732 searchValidBucketAgg search "byDate" toDateHistogram
734 it "returns date histogram using fractional date" $ withTestEnv $ do
735 _ <- insertData
736 let periods = [Year, Quarter, Month, Week, Day, Hour, Minute, Second]
737 let fractionals = map (FractionalInterval 1.5) [Weeks, Days, Hours, Minutes, Seconds]
738 let intervals = periods ++ fractionals
739 let histogram = mkDateHistogram (FieldName "postDate")
740 let search interval = mkAggregateSearch Nothing $ mkAggregations "byDate" $ DateHistogramAgg (histogram interval)
741 let expect interval = searchExpectAggs (search interval)
742 let valid interval = searchValidBucketAgg (search interval) "byDate" toDateHistogram
743 forM_ intervals expect
744 forM_ intervals valid
746 describe "Highlights API" $ do
748 it "returns highlight from query when there should be one" $ withTestEnv $ do
749 _ <- insertData
750 _ <- insertOther
751 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
752 let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
754 let search = mkHighlightSearch (Just query) testHighlight
755 myHighlight <- searchTweetHighlight search
756 liftIO $
757 myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use <em>haskell</em>!"])]))
759 it "doesn't return highlight from a query when it shouldn't" $ withTestEnv $ do
760 _ <- insertData
761 _ <- insertOther
762 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
763 let testHighlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]
765 let search = mkHighlightSearch (Just query) testHighlight
766 myHighlight <- searchTweetHighlight search
767 liftIO $
768 myHighlight `shouldBe` Right Nothing
770 describe "Source filtering" $ do
772 it "doesn't include source when sources are disabled" $ withTestEnv $ do
773 searchExpectSource
774 NoSource
775 (Left "Source was missing")
777 it "includes a source" $ withTestEnv $ do
778 searchExpectSource
779 (SourcePatterns (PopPattern (Pattern "message")))
780 (Right (Object (HM.fromList [("message", String "Use haskell!")])))
782 it "includes sources" $ withTestEnv $ do
783 searchExpectSource
784 (SourcePatterns (PopPatterns [Pattern "user", Pattern "message"]))
785 (Right (Object (HM.fromList [("user",String "bitemyapp"),("message", String "Use haskell!")])))
787 it "includes source patterns" $ withTestEnv $ do
788 searchExpectSource
789 (SourcePatterns (PopPattern (Pattern "*ge")))
790 (Right (Object (HM.fromList [("age", Number 10000),("message", String "Use haskell!")])))
792 it "excludes source patterns" $ withTestEnv $ do
793 searchExpectSource
794 (SourceIncludeExclude (Include []) (Exclude [Pattern "l*", Pattern "*ge", Pattern "postDate"]))
795 (Right (Object (HM.fromList [("user",String "bitemyapp")])))
797 describe "ToJSON RegexpFlags" $ do
798 it "generates the correct JSON for AllRegexpFlags" $
799 toJSON AllRegexpFlags `shouldBe` String "ALL"
801 it "generates the correct JSON for NoRegexpFlags" $
802 toJSON NoRegexpFlags `shouldBe` String "NONE"
804 it "generates the correct JSON for SomeRegexpFlags" $
805 let flags = AnyString :| [ Automaton
806 , Complement
807 , Empty
808 , Intersection
809 , Interval ]
810 in toJSON (SomeRegexpFlags flags) `shouldBe` String "ANYSTRING|AUTOMATON|COMPLEMENT|EMPTY|INTERSECTION|INTERVAL"
812 prop "removes duplicates from flags" $ \(flags :: RegexpFlags) ->
813 let String str = toJSON flags
814 flagStrs = T.splitOn "|" str
815 in noDuplicates flagStrs
817 describe "omitNulls" $ do
818 it "checks that omitNulls drops list elements when it should" $
819 let dropped = omitNulls $ [ "test1" .= (toJSON ([] :: [Int]))
820 , "test2" .= (toJSON ("some value" :: Text))]
821 in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")])
823 it "checks that omitNulls doesn't drop list elements when it shouldn't" $
824 let notDropped = omitNulls $ [ "test1" .= (toJSON ([1] :: [Int]))
825 , "test2" .= (toJSON ("some value" :: Text))]
826 in notDropped `shouldBe` Object (HM.fromList [ ("test1", Array (V.fromList [Number 1.0]))
827 , ("test2", String "some value")])
828 it "checks that omitNulls drops non list elements when it should" $
829 let dropped = omitNulls $ [ "test1" .= (toJSON Null)
830 , "test2" .= (toJSON ("some value" :: Text))]
831 in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")])
832 it "checks that omitNulls doesn't drop non list elements when it shouldn't" $
833 let notDropped = omitNulls $ [ "test1" .= (toJSON (1 :: Int))
834 , "test2" .= (toJSON ("some value" :: Text))]
835 in notDropped `shouldBe` Object (HM.fromList [ ("test1", Number 1.0)
836 , ("test2", String "some value")])
837 describe "Monoid (SearchHits a)" $ do
838 prop "abides the monoid laws" $ eq $
839 prop_Monoid (T :: T (SearchHits ()))
841 describe "mkDocVersion" $ do
842 prop "can never construct an out of range docVersion" $ \i ->
843 let res = mkDocVersion i
844 in case res of
845 Nothing -> property True
846 Just dv -> (dv >= minBound) .&&.
847 (dv <= maxBound) .&&.
848 docVersionNumber dv === i
850 describe "Enum DocVersion" $ do
851 it "follows the laws of Enum, Bounded" $ do
852 evaluate (succ maxBound :: DocVersion) `shouldThrow` anyErrorCall
853 evaluate (pred minBound :: DocVersion) `shouldThrow` anyErrorCall
854 evaluate (toEnum 0 :: DocVersion) `shouldThrow` anyErrorCall
855 evaluate (toEnum 9200000000000000001 :: DocVersion) `shouldThrow` anyErrorCall
856 enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
857 enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
858 enumFromThen minBound (pred maxBound :: DocVersion) `shouldBe` [minBound, pred maxBound]
860 describe "scan&scroll API" $ do
861 it "returns documents using the scan&scroll API" $ withTestEnv $ do
862 _ <- insertData
863 _ <- insertOther
864 let search = (mkSearch (Just $ MatchAllQuery Nothing) Nothing) { size = (Size 1) }
865 regular_search <- searchTweet search
866 scan_search' <- scanSearch testIndex testMapping search :: BH IO [Hit Tweet]
867 let scan_search = map hitSource scan_search'
868 liftIO $
869 regular_search `shouldBe` Right exampleTweet -- Check that the size restrtiction is being honored
870 liftIO $
871 scan_search `shouldMatchList` [Just exampleTweet, Just otherTweet]