git.iko.soy/typeable/bloodhound
on extra-source-files help sign in
typeable/bloodhound/tests/tests.hs
839 lines 36 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 (prop_Monoid, eq, T(..))
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
115instance FromJSON Tweet
116instance ToJSON Location
117instance FromJSON Location
119data ParentMapping = ParentMapping deriving (Eq, Show)
121instance ToJSON ParentMapping where
122 toJSON ParentMapping =
123 object ["parent" .= Null ]
125data ChildMapping = ChildMapping deriving (Eq, Show)
127instance ToJSON ChildMapping where
128 toJSON ChildMapping =
129 object ["child" .=
130 object ["_parent" .= object ["type" .= ("parent" :: Text)]]
131 ]
133data TweetMapping = TweetMapping deriving (Eq, Show)
135instance ToJSON TweetMapping where
136 toJSON TweetMapping =
137 object ["tweet" .=
138 object ["properties" .=
139 object [ "user" .= object ["type" .= ("string" :: Text)]
140 -- Serializing the date as a date is breaking other tests, mysteriously.
141 -- , "postDate" .= object [ "type" .= ("date" :: Text)
142 -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
143 , "message" .= object ["type" .= ("string" :: Text)]
144 , "age" .= object ["type" .= ("integer" :: Text)]
145 , "location" .= object ["type" .= ("geo_point" :: Text)]
146 ]]]
148exampleTweet :: Tweet
149exampleTweet = Tweet { user = "bitemyapp"
150 , postDate = UTCTime
151 (ModifiedJulianDay 55000)
152 (secondsToDiffTime 10)
153 , message = "Use haskell!"
154 , age = 10000
155 , location = Location 40.12 (-71.34) }
157otherTweet :: Tweet
158otherTweet = Tweet { user = "notmyapp"
159 , postDate = UTCTime
160 (ModifiedJulianDay 55000)
161 (secondsToDiffTime 11)
162 , message = "Use haskell!"
163 , age = 1000
164 , location = Location 40.12 (-71.34) }
166resetIndex :: BH IO ()
167resetIndex = do
168 _ <- deleteExampleIndex
169 _ <- createExampleIndex
170 _ <- putMapping testIndex testMapping TweetMapping
171 return ()
173insertData :: BH IO Reply
174insertData = do
175 resetIndex
176 insertData' defaultIndexDocumentSettings
178insertData' :: IndexDocumentSettings -> BH IO Reply
179insertData' ids = do
180 r <- indexDocument testIndex testMapping ids exampleTweet (DocId "1")
181 _ <- refreshIndex testIndex
182 return r
184insertOther :: BH IO ()
185insertOther = do
186 _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings otherTweet (DocId "2")
187 _ <- refreshIndex testIndex
188 return ()
190searchTweet :: Search -> BH IO (Either String Tweet)
191searchTweet search = do
192 result <- searchTweets search
193 let myTweet = fmap (hitSource . head . hits . searchHits) result
194 return myTweet
196searchTweets :: Search -> BH IO (Either String (SearchResult Tweet))
197searchTweets search = eitherDecode . responseBody <$> searchByIndex testIndex search
199searchExpectNoResults :: Search -> BH IO ()
200searchExpectNoResults search = do
201 result <- searchTweets search
202 let emptyHits = fmap (hits . searchHits) result
203 liftIO $
204 emptyHits `shouldBe` Right []
206searchExpectAggs :: Search -> BH IO ()
207searchExpectAggs search = do
208 reply <- searchAll search
209 let isEmpty x = return (M.null x)
210 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
211 liftIO $
212 (result >>= aggregations >>= isEmpty) `shouldBe` Just False
214searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) =>
215 Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH IO ()
216searchValidBucketAgg search aggKey extractor = do
217 reply <- searchAll search
218 let bucketDocs = docCount . head . buckets
219 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
220 let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x)
221 liftIO $
222 count `shouldBe` Just 1
224searchTermsAggHint :: [ExecutionHint] -> BH IO ()
225searchTermsAggHint hints = do
226 let terms hint = TermsAgg $ (mkTermsAggregation "user") { termExecutionHint = Just hint }
227 let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint
228 forM_ hints $ searchExpectAggs . search
229 forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
231searchTweetHighlight :: Search -> BH IO (Either String (Maybe HitHighlight))
232searchTweetHighlight search = do
233 result <- searchTweets search
234 let myHighlight = fmap (hitHighlight . head . hits . searchHits) result
235 return myHighlight
237searchExpectSource :: Source -> Either String Value -> BH IO ()
238searchExpectSource src expected = do
239 _ <- insertData
240 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
241 let search = (mkSearch (Just query) Nothing) { source = Just src }
242 reply <- searchAll search
243 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Value)
244 let value = fmap (hitSource . head . hits . searchHits) result
245 liftIO $
246 value `shouldBe` expected
248data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
249instance FromJSON BulkTest
250instance ToJSON BulkTest
252noDuplicates :: Eq a => [a] -> Bool
253noDuplicates xs = nub xs == xs
255instance Arbitrary RegexpFlags where
256 arbitrary = oneof [ pure AllRegexpFlags
257 , pure NoRegexpFlags
258 , SomeRegexpFlags <$> arbitrary
259 ]
261instance Arbitrary a => Arbitrary (NonEmpty a) where
262 arbitrary = liftA2 (:|) arbitrary arbitrary
264instance Arbitrary RegexpFlag where
265 arbitrary = oneof [ pure AnyString
266 , pure Automaton
267 , pure Complement
268 , pure Empty
269 , pure Intersection
270 , pure Interval
271 ]
273arbitraryScore :: Gen Score
274arbitraryScore = fmap getPositive <$> arbitrary
276instance Arbitrary Text where
277 arbitrary = T.pack <$> arbitrary
279instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) where
280 arbitrary = M.fromList <$> arbitrary
282instance Arbitrary IndexName where
283 arbitrary = IndexName <$> arbitrary
285instance Arbitrary MappingName where
286 arbitrary = MappingName <$> arbitrary
288instance Arbitrary DocId where
289 arbitrary = DocId <$> arbitrary
291instance Arbitrary a => Arbitrary (Hit a) where
292 arbitrary = Hit <$> arbitrary
293 <*> arbitrary
294 <*> arbitrary
295 <*> arbitraryScore
296 <*> arbitrary
297 <*> arbitrary
300instance Arbitrary a => Arbitrary (SearchHits a) where
301 arbitrary = sized $ \n -> resize (n `div` 2) $ do
302 tot <- getPositive <$> arbitrary
303 score <- arbitraryScore
304 hs <- arbitrary
305 return $ SearchHits tot score hs
307getSource :: EsResult a -> Maybe a
308getSource = fmap _source . foundResult
310main :: IO ()
311main = hspec $ do
313 describe "index create/delete API" $ do
314 it "creates and then deletes the requested index" $ withTestEnv $ do
315 -- priming state.
316 _ <- deleteExampleIndex
317 resp <- createExampleIndex
318 deleteResp <- deleteExampleIndex
319 liftIO $ do
320 validateStatus resp 200
321 validateStatus deleteResp 200
324 describe "document API" $ do
325 it "indexes, gets, and then deletes the generated document" $ withTestEnv $ do
326 _ <- insertData
327 docInserted <- getDocument testIndex testMapping (DocId "1")
328 let newTweet = eitherDecode
329 (responseBody docInserted) :: Either String (EsResult Tweet)
330 liftIO $ (fmap getSource newTweet `shouldBe` Right (Just exampleTweet))
332 it "produces a parseable result when looking up a bogus document" $ withTestEnv $ do
333 doc <- getDocument testIndex testMapping (DocId "bogus")
334 let noTweet = eitherDecode
335 (responseBody doc) :: Either String (EsResult Tweet)
336 liftIO $ fmap foundResult noTweet `shouldBe` Right Nothing
338 it "can use optimistic concurrency control" $ withTestEnv $ do
339 let ev = ExternalDocVersion minBound
340 let cfg = defaultIndexDocumentSettings { idsVersionControl = ExternalGT ev }
341 resetIndex
342 res <- insertData' cfg
343 liftIO $ isCreated res `shouldBe` True
344 res' <- insertData' cfg
345 liftIO $ isVersionConflict res' `shouldBe` True
347 it "indexes two documents in a parent/child relationship and checks that the child exists" $ withTestEnv $ do
348 resetIndex
349 _ <- putMapping testIndex (MappingName "parent") ParentMapping
350 _ <- putMapping testIndex (MappingName "child") ChildMapping
351 _ <- indexDocument testIndex (MappingName "parent") defaultIndexDocumentSettings exampleTweet (DocId "1")
352 let parent = (Just . DocumentParent . DocId) "1"
353 ids = IndexDocumentSettings NoVersionControl parent
354 _ <- indexDocument testIndex (MappingName "child") ids otherTweet (DocId "2")
355 _ <- refreshIndex testIndex
356 exists <- documentExists testIndex (MappingName "child") parent (DocId "2")
357 liftIO $ exists `shouldBe` True
359 describe "template API" $ do
360 it "can create a template" $ withTestEnv $ do
361 let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
362 resp <- putTemplate idxTpl (TemplateName "tweet-tpl")
363 liftIO $ validateStatus resp 200
365 it "can detect if a template exists" $ withTestEnv $ do
366 exists <- templateExists (TemplateName "tweet-tpl")
367 liftIO $ exists `shouldBe` True
369 it "can delete a template" $ withTestEnv $ do
370 resp <- deleteTemplate (TemplateName "tweet-tpl")
371 liftIO $ validateStatus resp 200
373 it "can detect if a template doesn't exist" $ withTestEnv $ do
374 exists <- templateExists (TemplateName "tweet-tpl")
375 liftIO $ exists `shouldBe` False
377 describe "bulk API" $ do
378 it "inserts all documents we request" $ withTestEnv $ do
379 _ <- insertData
380 let firstTest = BulkTest "blah"
381 let secondTest = BulkTest "bloo"
382 let firstDoc = BulkIndex testIndex
383 testMapping (DocId "2") (toJSON firstTest)
384 let secondDoc = BulkCreate testIndex
385 testMapping (DocId "3") (toJSON secondTest)
386 let stream = V.fromList [firstDoc, secondDoc]
387 _ <- bulk stream
388 _ <- refreshIndex testIndex
389 fDoc <- getDocument testIndex testMapping (DocId "2")
390 sDoc <- getDocument testIndex testMapping (DocId "3")
391 let maybeFirst = eitherDecode $ responseBody fDoc :: Either String (EsResult BulkTest)
392 let maybeSecond = eitherDecode $ responseBody sDoc :: Either String (EsResult BulkTest)
393 liftIO $ do
394 fmap getSource maybeFirst `shouldBe` Right (Just firstTest)
395 fmap getSource maybeSecond `shouldBe` Right (Just secondTest)
398 describe "query API" $ do
399 it "returns document for term query and identity filter" $ withTestEnv $ do
400 _ <- insertData
401 let query = TermQuery (Term "user" "bitemyapp") Nothing
402 let filter = IdentityFilter <&&> IdentityFilter
403 let search = mkSearch (Just query) (Just filter)
404 myTweet <- searchTweet search
405 liftIO $
406 myTweet `shouldBe` Right exampleTweet
408 it "returns document for terms query and identity filter" $ withTestEnv $ do
409 _ <- insertData
410 let query = TermsQuery (NE.fromList [(Term "user" "bitemyapp")])
411 let filter = IdentityFilter <&&> IdentityFilter
412 let search = mkSearch (Just query) (Just filter)
413 myTweet <- searchTweet search
414 liftIO $
415 myTweet `shouldBe` Right exampleTweet
417 it "returns document for match query" $ withTestEnv $ do
418 _ <- insertData
419 let query = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
420 let search = mkSearch (Just query) Nothing
421 myTweet <- searchTweet search
422 liftIO $
423 myTweet `shouldBe` Right exampleTweet
425 it "returns document for multi-match query" $ withTestEnv $ do
426 _ <- insertData
427 let flds = [FieldName "user", FieldName "message"]
428 let query = QueryMultiMatchQuery $ mkMultiMatchQuery flds (QueryString "bitemyapp")
429 let search = mkSearch (Just query) Nothing
430 myTweet <- searchTweet search
431 liftIO $
432 myTweet `shouldBe` Right exampleTweet
434 it "returns document for bool query" $ withTestEnv $ do
435 _ <- insertData
436 let innerQuery = QueryMatchQuery $
437 mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
438 let query = QueryBoolQuery $
439 mkBoolQuery [innerQuery] [] []
440 let search = mkSearch (Just query) Nothing
441 myTweet <- searchTweet search
442 liftIO $
443 myTweet `shouldBe` Right exampleTweet
445 it "returns document for boosting query" $ withTestEnv $ do
446 _ <- insertData
447 let posQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
448 let negQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "notmyapp")
449 let query = QueryBoostingQuery $ BoostingQuery posQuery negQuery (Boost 0.2)
450 let search = mkSearch (Just query) Nothing
451 myTweet <- searchTweet search
452 liftIO $
453 myTweet `shouldBe` Right exampleTweet
455 it "returns document for common terms query" $ withTestEnv $ do
456 _ <- insertData
457 let query = QueryCommonTermsQuery $
458 CommonTermsQuery (FieldName "user")
459 (QueryString "bitemyapp")
460 (CutoffFrequency 0.0001)
461 Or Or Nothing Nothing Nothing Nothing
462 let search = mkSearch (Just query) Nothing
463 myTweet <- searchTweet search
464 liftIO $
465 myTweet `shouldBe` Right exampleTweet
468 describe "sorting" $ do
469 it "returns documents in the right order" $ withTestEnv $ do
470 _ <- insertData
471 _ <- insertOther
472 let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
473 let search = Search Nothing
474 (Just IdentityFilter) (Just [sortSpec]) Nothing Nothing
475 False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
476 result <- searchTweets search
477 let myTweet = fmap (hitSource . head . hits . searchHits) result
478 liftIO $
479 myTweet `shouldBe` Right otherTweet
482 describe "filtering API" $ do
483 it "returns document for composed boolmatch and identity" $ withTestEnv $ do
484 _ <- insertData
485 let queryFilter = BoolFilter (MustMatch (Term "user" "bitemyapp") False)
486 <&&> IdentityFilter
487 let search = mkSearch Nothing (Just queryFilter)
488 myTweet <- searchTweet search
489 liftIO $
490 myTweet `shouldBe` Right exampleTweet
492 it "returns document for term filter" $ withTestEnv $ do
493 _ <- insertData
494 let termFilter = TermFilter (Term "user" "bitemyapp") False
495 let search = mkSearch Nothing (Just termFilter)
496 myTweet <- searchTweet search
497 liftIO $
498 myTweet `shouldBe` Right exampleTweet
500 it "returns document for existential filter" $ withTestEnv $ do
501 _ <- insertData
502 let search = mkSearch Nothing (Just (ExistsFilter (FieldName "user")))
503 myTweet <- searchTweet search
504 liftIO $
505 myTweet `shouldBe` Right exampleTweet
507 it "returns document for geo boundingbox filter" $ withTestEnv $ do
508 _ <- insertData
509 let box = GeoBoundingBox (LatLon 40.73 (-74.1)) (LatLon 40.10 (-71.12))
510 let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False GeoFilterMemory
511 let geoFilter = GeoBoundingBoxFilter bbConstraint
512 let search = mkSearch Nothing (Just geoFilter)
513 myTweet <- searchTweet search
514 liftIO $
515 myTweet `shouldBe` Right exampleTweet
517 it "doesn't return document for nonsensical boundingbox filter" $ withTestEnv $ do
518 _ <- insertData
519 let box = GeoBoundingBox (LatLon 0.73 (-4.1)) (LatLon 0.10 (-1.12))
520 let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False GeoFilterMemory
521 let geoFilter = GeoBoundingBoxFilter bbConstraint
522 let search = mkSearch Nothing (Just geoFilter)
523 searchExpectNoResults search
525 it "returns document for geo distance filter" $ withTestEnv $ do
526 _ <- insertData
527 let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
528 let distance = Distance 10.0 Miles
529 let optimizeBbox = OptimizeGeoFilterType GeoFilterMemory
530 let geoFilter = GeoDistanceFilter geoPoint distance SloppyArc optimizeBbox False
531 let search = mkSearch Nothing (Just geoFilter)
532 myTweet <- searchTweet search
533 liftIO $
534 myTweet `shouldBe` Right exampleTweet
536 it "returns document for geo distance range filter" $ withTestEnv $ do
537 _ <- insertData
538 let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
539 let distanceRange = DistanceRange (Distance 0.0 Miles) (Distance 10.0 Miles)
540 let geoFilter = GeoDistanceRangeFilter geoPoint distanceRange
541 let search = mkSearch Nothing (Just geoFilter)
542 myTweet <- searchTweet search
543 liftIO $
544 myTweet `shouldBe` Right exampleTweet
546 it "doesn't return document for wild geo distance range filter" $ withTestEnv $ do
547 _ <- insertData
548 let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
549 let distanceRange = DistanceRange (Distance 100.0 Miles) (Distance 1000.0 Miles)
550 let geoFilter = GeoDistanceRangeFilter geoPoint distanceRange
551 let search = mkSearch Nothing (Just geoFilter)
552 searchExpectNoResults search
554 it "returns document for geo polygon filter" $ withTestEnv $ do
555 _ <- insertData
556 let points = [LatLon 40.0 (-70.00),
557 LatLon 40.0 (-72.00),
558 LatLon 41.0 (-70.00),
559 LatLon 41.0 (-72.00)]
560 let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points
561 let search = mkSearch Nothing (Just geoFilter)
562 myTweet <- searchTweet search
563 liftIO $
564 myTweet `shouldBe` Right exampleTweet
566 it "doesn't return document for bad geo polygon filter" $ withTestEnv $ do
567 _ <- insertData
568 let points = [LatLon 40.0 (-70.00),
569 LatLon 40.0 (-71.00),
570 LatLon 41.0 (-70.00),
571 LatLon 41.0 (-71.00)]
572 let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points
573 let search = mkSearch Nothing (Just geoFilter)
574 searchExpectNoResults search
576 it "returns document for ids filter" $ withTestEnv $ do
577 _ <- insertData
578 let filter = IdsFilter (MappingName "tweet") [DocId "1"]
579 let search = mkSearch Nothing (Just filter)
580 myTweet <- searchTweet search
581 liftIO $
582 myTweet `shouldBe` Right exampleTweet
584 it "returns document for Double range filter" $ withTestEnv $ do
585 _ <- insertData
586 let filter = RangeFilter (FieldName "age")
587 (RangeDoubleGtLt (GreaterThan 1000.0) (LessThan 100000.0))
588 RangeExecutionIndex False
589 let search = mkSearch Nothing (Just filter)
590 myTweet <- searchTweet search
591 liftIO $
592 myTweet `shouldBe` Right exampleTweet
594 it "returns document for UTCTime date filter" $ withTestEnv $ do
595 _ <- insertData
596 let filter = RangeFilter (FieldName "postDate")
597 (RangeDateGtLt
598 (GreaterThanD (UTCTime
599 (ModifiedJulianDay 54000)
600 (secondsToDiffTime 0)))
601 (LessThanD (UTCTime
602 (ModifiedJulianDay 55000)
603 (secondsToDiffTime 11))))
604 RangeExecutionIndex False
605 let search = mkSearch Nothing (Just filter)
606 myTweet <- searchTweet search
607 liftIO $
608 myTweet `shouldBe` Right exampleTweet
610 it "returns document for regexp filter" $ withTestEnv $ do
611 _ <- insertData
612 let filter = RegexpFilter (FieldName "user") (Regexp "bite.*app")
613 AllRegexpFlags (CacheName "test") False (CacheKey "key")
614 let search = mkSearch Nothing (Just filter)
615 myTweet <- searchTweet search
616 liftIO $
617 myTweet `shouldBe` Right exampleTweet
619 it "doesn't return document for non-matching regexp filter" $ withTestEnv $ do
620 _ <- insertData
621 let filter = RegexpFilter (FieldName "user")
622 (Regexp "boy") AllRegexpFlags
623 (CacheName "test") False (CacheKey "key")
624 let search = mkSearch Nothing (Just filter)
625 searchExpectNoResults search
627 it "returns document for query filter, uncached" $ withTestEnv $ do
628 _ <- insertData
629 let filter = QueryFilter (TermQuery (Term "user" "bitemyapp") Nothing) True
630 search = mkSearch Nothing (Just filter)
631 myTweet <- searchTweet search
632 liftIO $ myTweet `shouldBe` Right exampleTweet
634 it "returns document for query filter, cached" $ withTestEnv $ do
635 _ <- insertData
636 let filter = QueryFilter (TermQuery (Term "user" "bitemyapp") Nothing) False
637 search = mkSearch Nothing (Just filter)
638 myTweet <- searchTweet search
639 liftIO $ myTweet `shouldBe` Right exampleTweet
641 describe "Aggregation API" $ do
642 it "returns term aggregation results" $ withTestEnv $ do
643 _ <- insertData
644 let terms = TermsAgg $ mkTermsAggregation "user"
645 let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
646 searchExpectAggs search
647 searchValidBucketAgg search "users" toTerms
649 it "can give collection hint parameters to term aggregations" $ when' (atleast es13) $ withTestEnv $ do
650 _ <- insertData
651 let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
652 let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
653 searchExpectAggs search
654 searchValidBucketAgg search "users" toTerms
656 it "can give execution hint parameters to term aggregations" $ when' (atmost es11) $ withTestEnv $ do
657 _ <- insertData
658 searchTermsAggHint [Map, Ordinals]
660 it "can give execution hint parameters to term aggregations" $ when' (is es12) $ withTestEnv $ do
661 _ <- insertData
662 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map, Ordinals]
664 it "can give execution hint parameters to term aggregations" $ when' (atleast es12) $ withTestEnv $ do
665 _ <- insertData
666 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map]
669 it "can execute value_count aggregations" $ withTestEnv $ do
670 _ <- insertData
671 _ <- insertOther
672 let ags = mkAggregations "user_count" (ValueCountAgg (FieldValueCount (FieldName "user"))) <>
673 mkAggregations "bogus_count" (ValueCountAgg (FieldValueCount (FieldName "bogus")))
674 let search = mkAggregateSearch Nothing ags
675 let docCountPair k n = (k, object ["value" .= Number n])
676 res <- searchTweets search
677 liftIO $
678 fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "user_count" 2
679 , docCountPair "bogus_count" 0
680 ]))
682 it "can execute filter aggregations" $ withTestEnv $ do
683 _ <- insertData
684 _ <- insertOther
685 let ags = mkAggregations "bitemyapps" (FilterAgg (FilterAggregation (TermFilter (Term "user" "bitemyapp") defaultCache) Nothing)) <>
686 mkAggregations "notmyapps" (FilterAgg (FilterAggregation (TermFilter (Term "user" "notmyapp") defaultCache) Nothing))
687 let search = mkAggregateSearch Nothing ags
688 let docCountPair k n = (k, object ["doc_count" .= Number n])
689 res <- searchTweets search
690 liftIO $
691 fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "bitemyapps" 1
692 , docCountPair "notmyapps" 1
693 ]))
694 -- Interaction of date serialization and date histogram aggregation is broken.
695 -- it "returns date histogram aggregation results" $ withTestEnv $ do
696 -- _ <- insertData
697 -- let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute
698 -- let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram)
699 -- searchExpectAggs search
700 -- searchValidBucketAgg search "byDate" toDateHistogram
702 -- it "returns date histogram using fractional date" $ withTestEnv $ do
703 -- _ <- insertData
704 -- let periods = [Year, Quarter, Month, Week, Day, Hour, Minute, Second]
705 -- let fractionals = map (FractionalInterval 1.5) [Weeks, Days, Hours, Minutes, Seconds]
706 -- let intervals = periods ++ fractionals
707 -- let histogram = mkDateHistogram (FieldName "postDate")
708 -- let search interval = mkAggregateSearch Nothing $ mkAggregations "byDate" $ DateHistogramAgg (histogram interval)
709 -- let expect interval = searchExpectAggs (search interval)
710 -- let valid interval = searchValidBucketAgg (search interval) "byDate" toDateHistogram
711 -- forM_ intervals expect
712 -- forM_ intervals valid
714 describe "Highlights API" $ do
716 it "returns highlight from query when there should be one" $ withTestEnv $ do
717 _ <- insertData
718 _ <- insertOther
719 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
720 let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
722 let search = mkHighlightSearch (Just query) testHighlight
723 myHighlight <- searchTweetHighlight search
724 liftIO $
725 myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use <em>haskell</em>!"])]))
727 it "doesn't return highlight from a query when it shouldn't" $ withTestEnv $ do
728 _ <- insertData
729 _ <- insertOther
730 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
731 let testHighlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]
733 let search = mkHighlightSearch (Just query) testHighlight
734 myHighlight <- searchTweetHighlight search
735 liftIO $
736 myHighlight `shouldBe` Right Nothing
738 describe "Source filtering" $ do
740 it "doesn't include source when sources are disabled" $ withTestEnv $ do
741 searchExpectSource
742 NoSource
743 (Left "key \"_source\" not present")
745 it "includes a source" $ withTestEnv $ do
746 searchExpectSource
747 (SourcePatterns (PopPattern (Pattern "message")))
748 (Right (Object (HM.fromList [("message", String "Use haskell!")])))
750 it "includes sources" $ withTestEnv $ do
751 searchExpectSource
752 (SourcePatterns (PopPatterns [Pattern "user", Pattern "message"]))
753 (Right (Object (HM.fromList [("user",String "bitemyapp"),("message", String "Use haskell!")])))
755 it "includes source patterns" $ withTestEnv $ do
756 searchExpectSource
757 (SourcePatterns (PopPattern (Pattern "*ge")))
758 (Right (Object (HM.fromList [("age", Number 10000),("message", String "Use haskell!")])))
760 it "excludes source patterns" $ withTestEnv $ do
761 searchExpectSource
762 (SourceIncludeExclude (Include []) (Exclude [Pattern "l*", Pattern "*ge", Pattern "postDate"]))
763 (Right (Object (HM.fromList [("user",String "bitemyapp")])))
765 describe "ToJSON RegexpFlags" $ do
766 it "generates the correct JSON for AllRegexpFlags" $
767 toJSON AllRegexpFlags `shouldBe` String "ALL"
769 it "generates the correct JSON for NoRegexpFlags" $
770 toJSON NoRegexpFlags `shouldBe` String "NONE"
772 it "generates the correct JSON for SomeRegexpFlags" $
773 let flags = AnyString :| [ Automaton
774 , Complement
775 , Empty
776 , Intersection
777 , Interval ]
778 in toJSON (SomeRegexpFlags flags) `shouldBe` String "ANYSTRING|AUTOMATON|COMPLEMENT|EMPTY|INTERSECTION|INTERVAL"
780 prop "removes duplicates from flags" $ \(flags :: RegexpFlags) ->
781 let String str = toJSON flags
782 flagStrs = T.splitOn "|" str
783 in noDuplicates flagStrs
785 describe "omitNulls" $ do
786 it "checks that omitNulls drops list elements when it should" $
787 let dropped = omitNulls $ [ "test1" .= (toJSON ([] :: [Int]))
788 , "test2" .= (toJSON ("some value" :: Text))]
789 in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")])
791 it "checks that omitNulls doesn't drop list elements when it shouldn't" $
792 let notDropped = omitNulls $ [ "test1" .= (toJSON ([1] :: [Int]))
793 , "test2" .= (toJSON ("some value" :: Text))]
794 in notDropped `shouldBe` Object (HM.fromList [ ("test1", Array (V.fromList [Number 1.0]))
795 , ("test2", String "some value")])
796 it "checks that omitNulls drops non list elements when it should" $
797 let dropped = omitNulls $ [ "test1" .= (toJSON Null)
798 , "test2" .= (toJSON ("some value" :: Text))]
799 in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")])
800 it "checks that omitNulls doesn't drop non list elements when it shouldn't" $
801 let notDropped = omitNulls $ [ "test1" .= (toJSON (1 :: Int))
802 , "test2" .= (toJSON ("some value" :: Text))]
803 in notDropped `shouldBe` Object (HM.fromList [ ("test1", Number 1.0)
804 , ("test2", String "some value")])
805 describe "Monoid (SearchHits a)" $ do
806 prop "abides the monoid laws" $ eq $
807 prop_Monoid (T :: T (SearchHits ()))
809 describe "mkDocVersion" $ do
810 prop "can never construct an out of range docVersion" $ \i ->
811 let res = mkDocVersion i
812 in case res of
813 Nothing -> property True
814 Just dv -> (dv >= minBound) .&&.
815 (dv <= maxBound) .&&.
816 docVersionNumber dv === i
818 describe "Enum DocVersion" $ do
819 it "follows the laws of Enum, Bounded" $ do
820 evaluate (succ maxBound :: DocVersion) `shouldThrow` anyErrorCall
821 evaluate (pred minBound :: DocVersion) `shouldThrow` anyErrorCall
822 evaluate (toEnum 0 :: DocVersion) `shouldThrow` anyErrorCall
823 evaluate (toEnum 9200000000000000001 :: DocVersion) `shouldThrow` anyErrorCall
824 enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
825 enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
826 enumFromThen minBound (pred maxBound :: DocVersion) `shouldBe` [minBound, pred maxBound]
828 describe "scan&scroll API" $ do
829 it "returns documents using the scan&scroll API" $ withTestEnv $ do
830 _ <- insertData
831 _ <- insertOther
832 let search = (mkSearch (Just $ MatchAllQuery Nothing) Nothing) { size = (Size 1) }
833 regular_search <- searchTweet search
834 scan_search' <- scanSearch testIndex testMapping search :: BH IO [Hit Tweet]
835 let scan_search = map hitSource scan_search'
836 liftIO $
837 regular_search `shouldBe` Right exampleTweet -- Check that the size restrtiction is being honored
838 liftIO $
839 scan_search `shouldMatchList` [exampleTweet, otherTweet]