git.iko.soy/typeable/bloodhound
on 87d539d help sign in
typeable/bloodhound/tests/V5/tests.hs
1263 lines 56 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE DeriveGeneric #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE RecordWildCards #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TemplateHaskell #-}
11{-# LANGUAGE TypeOperators #-}
12{-# OPTIONS_GHC -fno-warn-orphans #-}
13#if __GLASGOW_HASKELL__ < 800
14{-# OPTIONS_GHC -fcontext-stack=100 #-}
15#endif
16#if __GLASGOW_HASKELL__ >= 802
17{-# LANGUAGE MonoLocalBinds #-}
18#endif
19module Main where
21import Test.Import
23import Control.Error hiding (Script)
24import qualified Data.HashMap.Strict as HM
25import Data.List (nub)
26import qualified Data.List as L
27import Data.List.NonEmpty (NonEmpty (..))
28import qualified Data.List.NonEmpty as NE
29import qualified Data.Map.Strict as M
30import Data.Text (Text)
31import qualified Data.Text as T
32import Data.Time.Calendar (Day (..), fromGregorian)
33import Data.Time.Clock (UTCTime (..),
34 secondsToDiffTime)
35import qualified Data.Vector as V
36import qualified Data.Version as Vers
37import qualified Database.V5.Bloodhound
38import qualified Lens.Micro.Aeson as LMA
39import qualified Network.HTTP.Types.Method as NHTM
40import qualified Network.HTTP.Types.Status as NHTS
41import qualified Network.URI as URI
42import Prelude hiding (filter)
44import qualified Test.JSON as JSON
46testServer :: Server
47testServer = Server "http://localhost:9200"
48testIndex :: IndexName
49testIndex = IndexName "bloodhound-tests-twitter-1"
50testMapping :: MappingName
51testMapping = MappingName "tweet"
53withTestEnv :: BH IO a -> IO a
54withTestEnv = withBH defaultManagerSettings testServer
56validateStatus :: Show body => Response body -> Int -> Expectation
57validateStatus resp expected =
58 if actual == expected
59 then return ()
60 else expectationFailure ("Expected " <> show expected <> " but got " <> show actual <> ": " <> show body)
61 where
62 actual = NHTS.statusCode (responseStatus resp)
63 body = responseBody resp
65createExampleIndex :: (MonadBH m) => m Reply
66createExampleIndex = createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) testIndex
67deleteExampleIndex :: (MonadBH m) => m Reply
68deleteExampleIndex = deleteIndex testIndex
70es13 :: Vers.Version
71es13 = Vers.Version [1, 3, 0] []
73es12 :: Vers.Version
74es12 = Vers.Version [1, 2, 0] []
76es11 :: Vers.Version
77es11 = Vers.Version [1, 1, 0] []
79es14 :: Vers.Version
80es14 = Vers.Version [1, 4, 0] []
82es15 :: Vers.Version
83es15 = Vers.Version [1, 5, 0] []
85es16 :: Vers.Version
86es16 = Vers.Version [1, 6, 0] []
88es20 :: Vers.Version
89es20 = Vers.Version [2, 0, 0] []
91es50 :: Vers.Version
92es50 = Vers.Version [5, 0, 0] []
94getServerVersion :: IO (Maybe Vers.Version)
95getServerVersion = fmap extractVersion <$> withTestEnv getStatus
96 where
97 extractVersion = versionNumber . number . version
99-- | Get configured repo paths for snapshotting. Note that by default
100-- this is not enabled and if we are over es 1.5, we won't be able to
101-- test snapshotting. Note that this can and should be part of the
102-- client functionality in a much less ad-hoc incarnation.
103getRepoPaths :: IO [FilePath]
104getRepoPaths = withTestEnv $ do
105 bhe <- getBHEnv
106 let Server s = bhServer bhe
107 let tUrl = s <> "/" <> "_nodes"
108 initReq <- parseRequest (URI.escapeURIString URI.isAllowedInURI (T.unpack tUrl))
109 let req = setRequestIgnoreStatus $ initReq { method = NHTM.methodGet }
110 Right (Object o) <- parseEsResponse =<< liftIO (httpLbs req (bhManager bhe))
111 return $ fromMaybe mempty $ do
112 Object nodes <- HM.lookup "nodes" o
113 Object firstNode <- snd <$> headMay (HM.toList nodes)
114 Object settings <- HM.lookup "settings" firstNode
115 Object path <- HM.lookup "path" settings
116 Array repo <- HM.lookup "repo" path
117 return [ T.unpack t | String t <- V.toList repo]
119-- | 1.5 and earlier don't care about repo paths
120canSnapshot :: IO Bool
121canSnapshot = do
122 caresAboutRepos <- atleast es16
123 repoPaths <- getRepoPaths
124 return (not caresAboutRepos || not (null (repoPaths)))
126atleast :: Vers.Version -> IO Bool
127atleast v = getServerVersion >>= \x -> return $ x >= Just v
129atmost :: Vers.Version -> IO Bool
130atmost v = getServerVersion >>= \x -> return $ x <= Just v
132is :: Vers.Version -> IO Bool
133is v = getServerVersion >>= \x -> return $ x == Just v
135when' :: Monad m => m Bool -> m () -> m ()
136when' b f = b >>= \x -> when x f
138data Location = Location { lat :: Double
139 , lon :: Double } deriving (Eq, Show)
141data Tweet = Tweet { user :: Text
142 , postDate :: UTCTime
143 , message :: Text
144 , age :: Int
145 , location :: Location
146 , extra :: Maybe Text }
147 deriving (Eq, Show)
149$(deriveJSON defaultOptions ''Location)
150$(deriveJSON defaultOptions ''Tweet)
152data ParentMapping = ParentMapping deriving (Eq, Show)
154instance ToJSON ParentMapping where
155 toJSON ParentMapping =
156 object ["properties" .=
157 object [ "user" .= object ["type" .= ("string" :: Text)
158 , "fielddata" .= True
159 ]
160 -- Serializing the date as a date is breaking other tests, mysteriously.
161 -- , "postDate" .= object [ "type" .= ("date" :: Text)
162 -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
163 , "message" .= object ["type" .= ("string" :: Text)]
164 , "age" .= object ["type" .= ("integer" :: Text)]
165 , "location" .= object ["type" .= ("geo_point" :: Text)]
166 , "extra" .= object ["type" .= ("keyword" :: Text)]
167 ]]
169data ChildMapping = ChildMapping deriving (Eq, Show)
171instance ToJSON ChildMapping where
172 toJSON ChildMapping =
173 object ["_parent" .= object ["type" .= ("parent" :: Text)]
174 , "properties" .=
175 object [ "user" .= object ["type" .= ("string" :: Text)
176 , "fielddata" .= True
177 ]
178 -- Serializing the date as a date is breaking other tests, mysteriously.
179 -- , "postDate" .= object [ "type" .= ("date" :: Text)
180 -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
181 , "message" .= object ["type" .= ("string" :: Text)]
182 , "age" .= object ["type" .= ("integer" :: Text)]
183 , "location" .= object ["type" .= ("geo_point" :: Text)]
184 , "extra" .= object ["type" .= ("keyword" :: Text)]
185 ]]
187data TweetMapping = TweetMapping deriving (Eq, Show)
189instance ToJSON TweetMapping where
190 toJSON TweetMapping =
191 object ["tweet" .=
192 object ["properties" .=
193 object [ "user" .= object [ "type" .= ("string" :: Text)
194 , "fielddata" .= True
195 ]
196 -- Serializing the date as a date is breaking other tests, mysteriously.
197 -- , "postDate" .= object [ "type" .= ("date" :: Text)
198 -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
199 , "message" .= object ["type" .= ("string" :: Text)]
200 , "age" .= object ["type" .= ("integer" :: Text)]
201 , "location" .= object ["type" .= ("geo_point" :: Text)]
202 , "extra" .= object ["type" .= ("keyword" :: Text)]
203 ]]]
205exampleTweet :: Tweet
206exampleTweet = Tweet { user = "bitemyapp"
207 , postDate = UTCTime
208 (ModifiedJulianDay 55000)
209 (secondsToDiffTime 10)
210 , message = "Use haskell!"
211 , age = 10000
212 , location = Location 40.12 (-71.34)
213 , extra = Nothing }
215tweetWithExtra :: Tweet
216tweetWithExtra = Tweet { user = "bitemyapp"
217 , postDate = UTCTime
218 (ModifiedJulianDay 55000)
219 (secondsToDiffTime 10)
220 , message = "Use haskell!"
221 , age = 10000
222 , location = Location 40.12 (-71.34)
223 , extra = Just "blah blah" }
225newAge :: Int
226newAge = 31337
228newUser :: Text
229newUser = "someotherapp"
231tweetPatch :: Value
232tweetPatch =
233 object [ "age" .= newAge
234 , "user" .= newUser
235 ]
237patchedTweet :: Tweet
238patchedTweet = exampleTweet{age = newAge, user = newUser}
240otherTweet :: Tweet
241otherTweet = Tweet { user = "notmyapp"
242 , postDate = UTCTime
243 (ModifiedJulianDay 55000)
244 (secondsToDiffTime 11)
245 , message = "Use haskell!"
246 , age = 1000
247 , location = Location 40.12 (-71.34)
248 , extra = Nothing }
250resetIndex :: BH IO ()
251resetIndex = do
252 _ <- deleteExampleIndex
253 _ <- createExampleIndex
254 _ <- putMapping testIndex testMapping TweetMapping
255 return ()
257insertData :: BH IO Reply
258insertData = do
259 resetIndex
260 insertData' defaultIndexDocumentSettings
262insertData' :: IndexDocumentSettings -> BH IO Reply
263insertData' ids = do
264 r <- indexDocument testIndex testMapping ids exampleTweet (DocId "1")
265 _ <- refreshIndex testIndex
266 return r
268updateData :: BH IO Reply
269updateData = do
270 r <- updateDocument testIndex testMapping defaultIndexDocumentSettings tweetPatch (DocId "1")
271 _ <- refreshIndex testIndex
272 return r
274insertOther :: BH IO ()
275insertOther = do
276 _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings otherTweet (DocId "2")
277 _ <- refreshIndex testIndex
278 return ()
280insertExtra :: BH IO ()
281insertExtra = do
282 _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings tweetWithExtra (DocId "4")
283 _ <- refreshIndex testIndex
284 return ()
286insertWithSpaceInId :: BH IO ()
287insertWithSpaceInId = do
288 _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "Hello World")
289 _ <- refreshIndex testIndex
290 return ()
292searchTweet :: Search -> BH IO (Either EsError Tweet)
293searchTweet search = do
294 result <- searchTweets search
295 let myTweet :: Either EsError Tweet
296 myTweet = grabFirst result
297 return myTweet
299searchTweets :: Search -> BH IO (Either EsError (SearchResult Tweet))
300searchTweets search = parseEsResponse =<< searchByIndex testIndex search
302searchExpectNoResults :: Search -> BH IO ()
303searchExpectNoResults search = do
304 result <- searchTweets search
305 let emptyHits = fmap (hits . searchHits) result
306 liftIO $
307 emptyHits `shouldBe` Right []
309searchExpectAggs :: Search -> BH IO ()
310searchExpectAggs search = do
311 reply <- searchByIndex testIndex search
312 let isEmpty x = return (M.null x)
313 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
314 liftIO $
315 (result >>= aggregations >>= isEmpty) `shouldBe` Just False
317searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) =>
318 Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH IO ()
319searchValidBucketAgg search aggKey extractor = do
320 reply <- searchByIndex testIndex search
321 let bucketDocs = docCount . head . buckets
322 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
323 let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x)
324 liftIO $
325 count `shouldBe` Just 1
327searchTermsAggHint :: [ExecutionHint] -> BH IO ()
328searchTermsAggHint hints = do
329 let terms hint = TermsAgg $ (mkTermsAggregation "user") { termExecutionHint = Just hint }
330 let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint
331 forM_ hints $ searchExpectAggs . search
332 forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
334searchTweetHighlight :: Search -> BH IO (Either EsError (Maybe HitHighlight))
335searchTweetHighlight search = do
336 result <- searchTweets search
337 let myHighlight = fmap (hitHighlight . head . hits . searchHits) result
338 return myHighlight
340searchExpectSource :: Source -> Either EsError Value -> BH IO ()
341searchExpectSource src expected = do
342 _ <- insertData
343 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
344 let search = (mkSearch (Just query) Nothing) { source = Just src }
345 reply <- searchByIndex testIndex search
346 result <- parseEsResponse reply
347 let value = grabFirst result
348 liftIO $
349 value `shouldBe` expected
351withSnapshotRepo
352 :: ( MonadMask m
353 , MonadBH m
354 )
355 => SnapshotRepoName
356 -> (GenericSnapshotRepo -> m a)
357 -> m a
358withSnapshotRepo srn@(SnapshotRepoName n) f = do
359 repoPaths <- liftIO getRepoPaths
360 -- we'll use the first repo path if available, otherwise system temp
361 -- dir. Note that this will fail on ES > 1.6, so be sure you use
362 -- @when' canSnapshot@.
363 case repoPaths of
364 (firstRepoPath:_) -> withTempDirectory firstRepoPath (T.unpack n) $ \dir -> bracket (alloc dir) free f
365 [] -> withSystemTempDirectory (T.unpack n) $ \dir -> bracket (alloc dir) free f
366 where
367 alloc dir = do
368 liftIO (setFileMode dir mode)
369 let repo = FsSnapshotRepo srn "bloodhound-tests-backups" True Nothing Nothing Nothing
370 resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings repo
371 liftIO (validateStatus resp 200)
372 return (toGSnapshotRepo repo)
373 mode = ownerModes `unionFileModes` groupModes `unionFileModes` otherModes
374 free GenericSnapshotRepo {..} = do
375 resp <- deleteSnapshotRepo gSnapshotRepoName
376 liftIO (validateStatus resp 200)
379withSnapshot
380 :: ( MonadMask m
381 , MonadBH m
382 )
383 => SnapshotRepoName
384 -> SnapshotName
385 -> m a
386 -> m a
387withSnapshot srn sn = bracket_ alloc free
388 where
389 alloc = do
390 resp <- createSnapshot srn sn createSettings
391 liftIO (validateStatus resp 200)
392 -- We'll make this synchronous for testing purposes
393 createSettings = defaultSnapshotCreateSettings { snapWaitForCompletion = True
394 , snapIndices = Just (IndexList (testIndex :| []))
395 -- We don't actually need to back up any data
396 }
397 free = do
398 deleteSnapshot srn sn
402newtype BulkTest =
403 BulkTest { name :: Text }
404 deriving (Eq, Show)
406instance ToJSON BulkTest where
407 toJSON (BulkTest name) =
408 object ["name" .= name]
410instance FromJSON BulkTest where
411 parseJSON = withObject "BulkTest" parse
412 where
413 parse o = do
414 t <- o .: "name"
415 BulkTest <$> parseJSON t
417noDuplicates :: Eq a => [a] -> Bool
418noDuplicates xs = nub xs == xs
421getSource :: EsResult a -> Maybe a
422getSource = fmap _source . foundResult
424grabFirst :: Either EsError (SearchResult a) -> Either EsError a
425grabFirst r =
426 case fmap (hitSource . head . hits . searchHits) r of
427 (Left e) -> Left e
428 (Right Nothing) -> Left (EsError 500 "Source was missing")
429 (Right (Just x)) -> Right x
431main :: IO ()
432main = hspec $ do
433 JSON.spec
434 describe "index create/delete API" $ do
435 it "creates and then deletes the requested index" $ withTestEnv $ do
436 -- priming state.
437 _ <- deleteExampleIndex
438 resp <- createExampleIndex
439 deleteResp <- deleteExampleIndex
440 liftIO $ do
441 validateStatus resp 200
442 validateStatus deleteResp 200
444 describe "error parsing" $ do
445 it "can parse EsErrors for < 2.0" $ when' (atmost es16) $ withTestEnv $ do
446 res <- getDocument (IndexName "bogus") (MappingName "also_bogus") (DocId "bogus_as_well")
447 let errorResp = eitherDecode (responseBody res)
448 liftIO (errorResp `shouldBe` Right (EsError 404 "IndexMissingException[[bogus] missing]"))
450 it "can parse EsErrors for >= 2.0" $ when' (atleast es20) $ withTestEnv $ do
451 res <- getDocument (IndexName "bogus") (MappingName "also_bogus") (DocId "bogus_as_well")
452 let errorResp = eitherDecode (responseBody res)
453 liftIO (errorResp `shouldBe` Right (EsError 404 "no such index"))
455 describe "document API" $ do
456 it "indexes, updates, gets, and then deletes the generated document" $ withTestEnv $ do
457 _ <- insertData
458 _ <- updateData
459 docInserted <- getDocument testIndex testMapping (DocId "1")
460 let newTweet = eitherDecode
461 (responseBody docInserted) :: Either String (EsResult Tweet)
462 liftIO $ (fmap getSource newTweet `shouldBe` Right (Just patchedTweet))
464 it "indexes, gets, and then deletes the generated document with a DocId containing a space" $ withTestEnv $ do
465 _ <- insertWithSpaceInId
466 docInserted <- getDocument testIndex testMapping (DocId "Hello World")
467 let newTweet = eitherDecode
468 (responseBody docInserted) :: Either String (EsResult Tweet)
469 liftIO $ (fmap getSource newTweet `shouldBe` Right (Just exampleTweet))
471 it "produces a parseable result when looking up a bogus document" $ withTestEnv $ do
472 doc <- getDocument testIndex testMapping (DocId "bogus")
473 let noTweet = eitherDecode
474 (responseBody doc) :: Either String (EsResult Tweet)
475 liftIO $ fmap foundResult noTweet `shouldBe` Right Nothing
477 it "can use optimistic concurrency control" $ withTestEnv $ do
478 let ev = ExternalDocVersion minBound
479 let cfg = defaultIndexDocumentSettings { idsVersionControl = ExternalGT ev }
480 resetIndex
481 res <- insertData' cfg
482 liftIO $ isCreated res `shouldBe` True
483 res' <- insertData' cfg
484 liftIO $ isVersionConflict res' `shouldBe` True
486 it "indexes two documents in a parent/child relationship and checks that the child exists" $ withTestEnv $ do
487 resetIndex
488 _ <- putMapping testIndex (MappingName "child") ChildMapping
489 _ <- putMapping testIndex (MappingName "parent") ParentMapping
490 _ <- indexDocument testIndex (MappingName "parent") defaultIndexDocumentSettings exampleTweet (DocId "1")
491 let parent = (Just . DocumentParent . DocId) "1"
492 ids = IndexDocumentSettings NoVersionControl parent
493 _ <- indexDocument testIndex (MappingName "child") ids otherTweet (DocId "2")
494 _ <- refreshIndex testIndex
495 exists <- documentExists testIndex (MappingName "child") parent (DocId "2")
496 liftIO $ exists `shouldBe` True
498 describe "template API" $ do
499 it "can create a template" $ withTestEnv $ do
500 let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
501 resp <- putTemplate idxTpl (TemplateName "tweet-tpl")
502 liftIO $ validateStatus resp 200
504 it "can detect if a template exists" $ withTestEnv $ do
505 exists <- templateExists (TemplateName "tweet-tpl")
506 liftIO $ exists `shouldBe` True
508 it "can delete a template" $ withTestEnv $ do
509 resp <- deleteTemplate (TemplateName "tweet-tpl")
510 liftIO $ validateStatus resp 200
512 it "can detect if a template doesn't exist" $ withTestEnv $ do
513 exists <- templateExists (TemplateName "tweet-tpl")
514 liftIO $ exists `shouldBe` False
516 describe "bulk API" $ do
517 it "inserts all documents we request" $ withTestEnv $ do
518 _ <- insertData
519 let firstTest = BulkTest "blah"
520 let secondTest = BulkTest "bloo"
521 let thirdTest = BulkTest "graffle"
522 let fourthTest = BulkTest "garabadoo"
523 let fifthTest = BulkTest "serenity"
524 let firstDoc = BulkIndex testIndex
525 testMapping (DocId "2") (toJSON firstTest)
526 let secondDoc = BulkCreate testIndex
527 testMapping (DocId "3") (toJSON secondTest)
528 let thirdDoc = BulkCreateEncoding testIndex
529 testMapping (DocId "4") (toEncoding thirdTest)
530 let fourthDoc = BulkIndexAuto testIndex
531 testMapping (toJSON fourthTest)
532 let fifthDoc = BulkIndexEncodingAuto testIndex
533 testMapping (toEncoding fifthTest)
534 let stream = V.fromList [firstDoc, secondDoc, thirdDoc, fourthDoc, fifthDoc]
535 _ <- bulk stream
536 -- liftIO $ pPrint bulkResp
537 _ <- refreshIndex testIndex
538 -- liftIO $ pPrint refreshResp
539 fDoc <- getDocument testIndex testMapping (DocId "2")
540 sDoc <- getDocument testIndex testMapping (DocId "3")
541 tDoc <- getDocument testIndex testMapping (DocId "4")
542 -- note that we cannot query for fourthDoc and fifthDoc since we
543 -- do not know their autogenerated ids.
544 let maybeFirst =
545 eitherDecode
546 $ responseBody fDoc
547 :: Either String (EsResult BulkTest)
548 let maybeSecond =
549 eitherDecode
550 $ responseBody sDoc
551 :: Either String (EsResult BulkTest)
552 let maybeThird =
553 eitherDecode
554 $ responseBody tDoc
555 :: Either String (EsResult BulkTest)
556 -- liftIO $ pPrint [maybeFirst, maybeSecond, maybeThird]
557 liftIO $ do
558 fmap getSource maybeFirst `shouldBe` Right (Just firstTest)
559 fmap getSource maybeSecond `shouldBe` Right (Just secondTest)
560 fmap getSource maybeThird `shouldBe` Right (Just thirdTest)
561 -- Since we can't get the docs by doc id, we check for their existence in
562 -- a match all query.
563 let query = MatchAllQuery Nothing
564 let search = mkSearch (Just query) Nothing
565 resp <- searchByIndex testIndex search
566 parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Value))
567 case parsed of
568 Left e ->
569 liftIO $ expectationFailure ("Expected a script-transformed result but got: " <> show e)
570 (Right sr) -> do
571 liftIO $
572 hitsTotal (searchHits sr) `shouldBe` 6
573 let nameList :: [Text]
574 nameList =
575 (hits (searchHits sr))
576 ^.. traverse
577 . to hitSource
578 . _Just
579 . LMA.key "name"
580 . _String
581 liftIO $
582 nameList
583 `shouldBe` ["blah","bloo","graffle","garabadoo","serenity"]
586 describe "query API" $ do
587 it "returns document for term query and identity filter" $ withTestEnv $ do
588 _ <- insertData
589 let query = TermQuery (Term "user" "bitemyapp") Nothing
590 let filter = Filter $ MatchAllQuery Nothing
591 let search = mkSearch (Just query) (Just filter)
592 myTweet <- searchTweet search
593 liftIO $
594 myTweet `shouldBe` Right exampleTweet
596 it "handles constant score queries" $ withTestEnv $ do
597 _ <- insertData
598 let query = TermsQuery "user" ("bitemyapp" :| [])
599 let cfQuery = ConstantScoreQuery query (Boost 1.0)
600 let filter = Filter $ MatchAllQuery Nothing
601 let search = mkSearch (Just cfQuery) (Just filter)
602 myTweet <- searchTweet search
603 liftIO $
604 myTweet `shouldBe` Right exampleTweet
606 it "returns document for terms query and identity filter" $ withTestEnv $ do
607 _ <- insertData
608 let query = TermsQuery "user" ("bitemyapp" :| [])
609 let filter = Filter $ MatchAllQuery Nothing
610 let search = mkSearch (Just query) (Just filter)
611 myTweet <- searchTweet search
612 liftIO $
613 myTweet `shouldBe` Right exampleTweet
615 it "returns document for match query" $ withTestEnv $ do
616 _ <- insertData
617 let query = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
618 let search = mkSearch (Just query) Nothing
619 myTweet <- searchTweet search
620 liftIO $
621 myTweet `shouldBe` Right exampleTweet
623 it "returns document for multi-match query" $ withTestEnv $ do
624 _ <- insertData
625 let flds = [FieldName "user", FieldName "message"]
626 let query = QueryMultiMatchQuery $ mkMultiMatchQuery flds (QueryString "bitemyapp")
627 let search = mkSearch (Just query) Nothing
628 myTweet <- searchTweet search
629 liftIO $
630 myTweet `shouldBe` Right exampleTweet
632 it "returns document for multi-match query with a custom tiebreaker" $ withTestEnv $ do
633 _ <- insertData
634 let tiebreaker = Just $ Tiebreaker 0.3
635 flds = [FieldName "user", FieldName "message"]
636 multiQuery' = mkMultiMatchQuery flds (QueryString "bitemyapp")
637 query = QueryMultiMatchQuery $ multiQuery' { multiMatchQueryTiebreaker = tiebreaker }
638 search = mkSearch (Just query) Nothing
639 myTweet <- searchTweet search
640 liftIO $
641 myTweet `shouldBe` Right exampleTweet
643 it "returns document for bool query" $ withTestEnv $ do
644 _ <- insertData
645 let innerQuery = QueryMatchQuery $
646 mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
647 let query = QueryBoolQuery $
648 mkBoolQuery [innerQuery] [] [] []
649 let search = mkSearch (Just query) Nothing
650 myTweet <- searchTweet search
651 liftIO $
652 myTweet `shouldBe` Right exampleTweet
654 it "returns document for boosting query" $ withTestEnv $ do
655 _ <- insertData
656 let posQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
657 let negQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "notmyapp")
658 let query = QueryBoostingQuery $ BoostingQuery posQuery negQuery (Boost 0.2)
659 let search = mkSearch (Just query) Nothing
660 myTweet <- searchTweet search
661 liftIO $
662 myTweet `shouldBe` Right exampleTweet
664 it "returns document for common terms query" $ withTestEnv $ do
665 _ <- insertData
666 let query = QueryCommonTermsQuery $
667 CommonTermsQuery (FieldName "user")
668 (QueryString "bitemyapp")
669 (CutoffFrequency 0.0001)
670 Or Or Nothing Nothing Nothing Nothing
671 let search = mkSearch (Just query) Nothing
672 myTweet <- searchTweet search
673 liftIO $
674 myTweet `shouldBe` Right exampleTweet
676 it "returns document for for inline template query" $ withTestEnv $ do
677 _ <- insertData
678 let innerQuery = QueryMatchQuery $
679 mkMatchQuery (FieldName "{{userKey}}")
680 (QueryString "{{bitemyappKey}}")
681 templateParams = TemplateQueryKeyValuePairs $ HM.fromList
682 [ ("userKey", "user")
683 , ("bitemyappKey", "bitemyapp")
684 ]
685 templateQuery = QueryTemplateQueryInline $
686 TemplateQueryInline innerQuery templateParams
687 search = mkSearch (Just templateQuery) Nothing
688 myTweet <- searchTweet search
689 liftIO $ myTweet `shouldBe` Right exampleTweet
692 describe "sorting" $ do
693 it "returns documents in the right order" $ withTestEnv $ do
694 _ <- insertData
695 _ <- insertOther
696 let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
697 let search = Search Nothing
698 Nothing (Just [sortSpec]) Nothing Nothing
699 False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
700 Nothing Nothing
701 result <- searchTweets search
702 let myTweet = grabFirst result
703 liftIO $
704 myTweet `shouldBe` Right otherTweet
706 describe "Aggregation API" $ do
707 it "returns term aggregation results" $ withTestEnv $ do
708 _ <- insertData
709 let terms = TermsAgg $ mkTermsAggregation "user"
710 let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
711 searchExpectAggs search
712 searchValidBucketAgg search "users" toTerms
714 it "return sub-aggregation results" $ withTestEnv $ do
715 _ <- insertData
716 let subaggs = mkAggregations "age_agg" . TermsAgg $ mkTermsAggregation "age"
717 agg = TermsAgg $ (mkTermsAggregation "user") { termAggs = Just subaggs}
718 search = mkAggregateSearch Nothing $ mkAggregations "users" agg
719 reply <- searchByIndex testIndex search
720 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
721 usersAggResults = result >>= aggregations >>= toTerms "users"
722 subAggResults = usersAggResults >>= (listToMaybe . buckets) >>= termsAggs >>= toTerms "age_agg"
723 subAddResultsExists = isJust subAggResults
724 liftIO $ (subAddResultsExists) `shouldBe` True
726 it "returns cardinality aggregation results" $ withTestEnv $ do
727 _ <- insertData
728 let cardinality = CardinalityAgg $ mkCardinalityAggregation $ FieldName "user"
729 let search = mkAggregateSearch Nothing $ mkAggregations "users" cardinality
730 let search' = search { Database.V5.Bloodhound.from = From 0, size = Size 0 }
731 searchExpectAggs search'
732 let docCountPair k n = (k, object ["value" .= Number n])
733 res <- searchTweets search'
734 liftIO $
735 fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "users" 1]))
737 it "returns stats aggregation results" $ withTestEnv $ do
738 _ <- insertData
739 let stats = StatsAgg $ mkStatsAggregation $ FieldName "age"
740 let search = mkAggregateSearch Nothing $ mkAggregations "users" stats
741 let search' = search { Database.V5.Bloodhound.from = From 0, size = Size 0 }
742 searchExpectAggs search'
743 let statsAggRes k n = (k, object [ "max" .= Number n
744 , "avg" .= Number n
745 , "count" .= Number 1
746 , "min" .= Number n
747 , "sum" .= Number n])
748 res <- searchTweets search'
749 liftIO $
750 fmap aggregations res `shouldBe` Right (Just (M.fromList [ statsAggRes "users" 10000]))
752 it "can give collection hint parameters to term aggregations" $ when' (atleast es13) $ withTestEnv $ do
753 _ <- insertData
754 let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
755 let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
756 searchExpectAggs search
757 searchValidBucketAgg search "users" toTerms
759 -- One of these fails with 1.7.3
760 it "can give execution hint parameters to term aggregations" $ when' (atmost es11) $ withTestEnv $ do
761 _ <- insertData
762 searchTermsAggHint [Map, Ordinals]
764 it "can give execution hint parameters to term aggregations" $ when' (is es12) $ withTestEnv $ do
765 _ <- insertData
766 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map, Ordinals]
768 it "can give execution hint parameters to term aggregations" $ when' (atleast es12) $ withTestEnv $ do
769 _ <- insertData
770 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map]
771 -- One of the above.
773 it "can execute value_count aggregations" $ withTestEnv $ do
774 _ <- insertData
775 _ <- insertOther
776 let ags = mkAggregations "user_count" (ValueCountAgg (FieldValueCount (FieldName "user"))) <>
777 mkAggregations "bogus_count" (ValueCountAgg (FieldValueCount (FieldName "bogus")))
778 let search = mkAggregateSearch Nothing ags
779 let docCountPair k n = (k, object ["value" .= Number n])
780 res <- searchTweets search
781 liftIO $
782 fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "user_count" 2
783 , docCountPair "bogus_count" 0
784 ]))
786 it "can execute date_range aggregations" $ withTestEnv $ do
787 let now = fromGregorian 2015 3 14
788 let ltAMonthAgo = UTCTime (fromGregorian 2015 3 1) 0
789 let ltAWeekAgo = UTCTime (fromGregorian 2015 3 10) 0
790 let oldDoc = exampleTweet { postDate = ltAMonthAgo }
791 let newDoc = exampleTweet { postDate = ltAWeekAgo }
792 _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings oldDoc (DocId "1")
793 _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings newDoc (DocId "2")
794 _ <- refreshIndex testIndex
795 let thisMonth = DateRangeFrom (DateMathExpr (DMDate now) [SubtractTime 1 DMMonth])
796 let thisWeek = DateRangeFrom (DateMathExpr (DMDate now) [SubtractTime 1 DMWeek])
797 let agg = DateRangeAggregation (FieldName "postDate") Nothing (thisMonth :| [thisWeek])
798 let ags = mkAggregations "date_ranges" (DateRangeAgg agg)
799 let search = mkAggregateSearch Nothing ags
800 res <- searchTweets search
801 liftIO $ hitsTotal . searchHits <$> res `shouldBe` Right 2
802 let bucks = do magrs <- fmapL show (aggregations <$> res)
803 agrs <- note "no aggregations returned" magrs
804 rawBucks <- note "no date_ranges aggregation" $ M.lookup "date_ranges" agrs
805 parseEither parseJSON rawBucks
806 let fromMonthT = UTCTime (fromGregorian 2015 2 14) 0
807 let fromWeekT = UTCTime (fromGregorian 2015 3 7) 0
808 liftIO $ buckets <$> bucks `shouldBe` Right [ DateRangeResult "2015-02-14T00:00:00.000Z-*"
809 (Just fromMonthT)
810 (Just "2015-02-14T00:00:00.000Z")
811 Nothing
812 Nothing
813 2
814 Nothing
815 , DateRangeResult "2015-03-07T00:00:00.000Z-*"
816 (Just fromWeekT)
817 (Just "2015-03-07T00:00:00.000Z")
818 Nothing
819 Nothing
820 1
821 Nothing
822 ]
824 it "returns date histogram aggregation results" $ withTestEnv $ do
825 _ <- insertData
826 let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute
827 let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram)
828 searchExpectAggs search
829 searchValidBucketAgg search "byDate" toDateHistogram
831 it "can execute missing aggregations" $ withTestEnv $ do
832 _ <- insertData
833 _ <- insertExtra
834 let ags = mkAggregations "missing_agg" (MissingAgg (MissingAggregation "extra"))
835 let search = mkAggregateSearch Nothing ags
836 let docCountPair k n = (k, object ["doc_count" .= Number n])
837 res <- searchTweets search
838 liftIO $
839 fmap aggregations res `shouldBe` Right (Just (M.fromList [docCountPair "missing_agg" 1]))
841 describe "Highlights API" $ do
843 it "returns highlight from query when there should be one" $ withTestEnv $ do
844 _ <- insertData
845 _ <- insertOther
846 let query = QueryMatchQuery $ mkMatchQuery (FieldName "message") (QueryString "haskell")
847 let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
849 let search = mkHighlightSearch (Just query) testHighlight
850 myHighlight <- searchTweetHighlight search
851 liftIO $
852 myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use <em>haskell</em>!"])]))
854 it "doesn't return highlight from a query when it shouldn't" $ withTestEnv $ do
855 _ <- insertData
856 _ <- insertOther
857 let query = QueryMatchQuery $ mkMatchQuery (FieldName "message") (QueryString "haskell")
858 let testHighlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]
860 let search = mkHighlightSearch (Just query) testHighlight
861 myHighlight <- searchTweetHighlight search
862 liftIO $
863 myHighlight `shouldBe` Right Nothing
865 describe "Source filtering" $ do
867 it "doesn't include source when sources are disabled" $ withTestEnv $ do
868 searchExpectSource
869 NoSource
870 (Left (EsError 500 "Source was missing"))
872 it "includes a source" $ withTestEnv $ do
873 searchExpectSource
874 (SourcePatterns (PopPattern (Pattern "message")))
875 (Right (Object (HM.fromList [("message", String "Use haskell!")])))
877 it "includes sources" $ withTestEnv $ do
878 searchExpectSource
879 (SourcePatterns (PopPatterns [Pattern "user", Pattern "message"]))
880 (Right (Object (HM.fromList [("user",String "bitemyapp"),("message", String "Use haskell!")])))
882 it "includes source patterns" $ withTestEnv $ do
883 searchExpectSource
884 (SourcePatterns (PopPattern (Pattern "*ge")))
885 (Right (Object (HM.fromList [("age", Number 10000),("message", String "Use haskell!")])))
887 it "excludes source patterns" $ withTestEnv $ do
888 searchExpectSource
889 (SourceIncludeExclude (Include [])
890 (Exclude [Pattern "l*", Pattern "*ge", Pattern "postDate", Pattern "extra"]))
891 (Right (Object (HM.fromList [("user",String "bitemyapp")])))
893 describe "ToJSON RegexpFlags" $ do
894 it "generates the correct JSON for AllRegexpFlags" $
895 toJSON AllRegexpFlags `shouldBe` String "ALL"
897 it "generates the correct JSON for NoRegexpFlags" $
898 toJSON NoRegexpFlags `shouldBe` String "NONE"
900 it "generates the correct JSON for SomeRegexpFlags" $
901 let flags = AnyString :| [ Automaton
902 , Complement
903 , Empty
904 , Intersection
905 , Interval ]
906 in toJSON (SomeRegexpFlags flags) `shouldBe` String "ANYSTRING|AUTOMATON|COMPLEMENT|EMPTY|INTERSECTION|INTERVAL"
908 prop "removes duplicates from flags" $ \(flags :: RegexpFlags) ->
909 let String str = toJSON flags
910 flagStrs = T.splitOn "|" str
911 in noDuplicates flagStrs
913 describe "omitNulls" $ do
914 it "checks that omitNulls drops list elements when it should" $
915 let dropped = omitNulls $ [ "test1" .= (toJSON ([] :: [Int]))
916 , "test2" .= (toJSON ("some value" :: Text))]
917 in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")])
919 it "checks that omitNulls doesn't drop list elements when it shouldn't" $
920 let notDropped = omitNulls $ [ "test1" .= (toJSON ([1] :: [Int]))
921 , "test2" .= (toJSON ("some value" :: Text))]
922 in notDropped `shouldBe` Object (HM.fromList [ ("test1", Array (V.fromList [Number 1.0]))
923 , ("test2", String "some value")])
924 it "checks that omitNulls drops non list elements when it should" $
925 let dropped = omitNulls $ [ "test1" .= (toJSON Null)
926 , "test2" .= (toJSON ("some value" :: Text))]
927 in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")])
928 it "checks that omitNulls doesn't drop non list elements when it shouldn't" $
929 let notDropped = omitNulls $ [ "test1" .= (toJSON (1 :: Int))
930 , "test2" .= (toJSON ("some value" :: Text))]
931 in notDropped `shouldBe` Object (HM.fromList [ ("test1", Number 1.0)
932 , ("test2", String "some value")])
933 describe "Monoid (SearchHits a)" $ do
934 prop "abides the monoid laws" $ eq $
935 prop_Monoid (T :: T (SearchHits ()))
937 describe "mkDocVersion" $ do
938 prop "can never construct an out of range docVersion" $ \i ->
939 let res = mkDocVersion i
940 in case res of
941 Nothing -> property True
942 Just dv -> (dv >= minBound) .&&.
943 (dv <= maxBound) .&&.
944 docVersionNumber dv === i
946 describe "FsSnapshotRepo" $ do
947 prop "SnapshotRepo laws" $ \fsr ->
948 fromGSnapshotRepo (toGSnapshotRepo fsr) === Right (fsr :: FsSnapshotRepo)
950 describe "snapshot repos" $ do
951 it "always parses all snapshot repos API" $ when' canSnapshot $ withTestEnv $ do
952 res <- getSnapshotRepos AllSnapshotRepos
953 liftIO $ case res of
954 Left e -> expectationFailure ("Expected a right but got Left " <> show e)
955 Right _ -> return ()
957 it "finds an existing list of repos" $ when' canSnapshot $ withTestEnv $ do
958 let r1n = SnapshotRepoName "bloodhound-repo1"
959 let r2n = SnapshotRepoName "bloodhound-repo2"
960 withSnapshotRepo r1n $ \r1 ->
961 withSnapshotRepo r2n $ \r2 -> do
962 repos <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| [ExactRepo r2n]))
963 liftIO $ case repos of
964 Right xs -> do
965 let srt = L.sortBy (comparing gSnapshotRepoName)
966 srt xs `shouldBe` srt [r1, r2]
967 Left e -> expectationFailure (show e)
969 it "creates and updates with updateSnapshotRepo" $ when' canSnapshot $ withTestEnv $ do
970 let r1n = SnapshotRepoName "bloodhound-repo1"
971 withSnapshotRepo r1n $ \r1 -> do
972 let Just (String dir) = HM.lookup "location" (gSnapshotRepoSettingsObject (gSnapshotRepoSettings r1))
973 let noCompression = FsSnapshotRepo r1n (T.unpack dir) False Nothing Nothing Nothing
974 resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings noCompression
975 liftIO (validateStatus resp 200)
976 Right [roundtrippedNoCompression] <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| []))
977 liftIO (roundtrippedNoCompression `shouldBe` toGSnapshotRepo noCompression)
979 -- verify came around in 1.4 it seems
980 it "can verify existing repos" $ when' canSnapshot $ when' (atleast es14) $ withTestEnv $ do
981 let r1n = SnapshotRepoName "bloodhound-repo1"
982 withSnapshotRepo r1n $ \_ -> do
983 res <- verifySnapshotRepo r1n
984 liftIO $ case res of
985 Right (SnapshotVerification vs)
986 | null vs -> expectationFailure "Expected nonempty set of verifying nodes"
987 | otherwise -> return ()
988 Left e -> expectationFailure (show e)
990 describe "snapshots" $ do
991 it "always parses all snapshots API" $ when' canSnapshot $ withTestEnv $ do
992 let r1n = SnapshotRepoName "bloodhound-repo1"
993 withSnapshotRepo r1n $ \_ -> do
994 res <- getSnapshots r1n AllSnapshots
995 liftIO $ case res of
996 Left e -> expectationFailure ("Expected a right but got Left " <> show e)
997 Right _ -> return ()
999 it "can parse a snapshot that it created" $ when' canSnapshot $ withTestEnv $ do
1000 let r1n = SnapshotRepoName "bloodhound-repo1"
1001 withSnapshotRepo r1n $ \_ -> do
1002 let s1n = SnapshotName "example-snapshot"
1003 withSnapshot r1n s1n $ do
1004 res <- getSnapshots r1n (SnapshotList (ExactSnap s1n :| []))
1005 liftIO $ case res of
1006 Right [snap]
1007 | snapInfoState snap == SnapshotSuccess &&
1008 snapInfoName snap == s1n -> return ()
1009 | otherwise -> expectationFailure (show snap)
1010 Right [] -> expectationFailure "There were no snapshots"
1011 Right snaps -> expectationFailure ("Expected 1 snapshot but got" <> show (length snaps))
1012 Left e -> expectationFailure (show e)
1014 describe "snapshot restore" $ do
1015 it "can restore a snapshot that we create" $ when' canSnapshot $ withTestEnv $ do
1016 let r1n = SnapshotRepoName "bloodhound-repo1"
1017 withSnapshotRepo r1n $ \_ -> do
1018 let s1n = SnapshotName "example-snapshot"
1019 withSnapshot r1n s1n $ do
1020 let settings = defaultSnapshotRestoreSettings { snapRestoreWaitForCompletion = True }
1021 -- have to close an index to restore it
1022 resp1 <- closeIndex testIndex
1023 liftIO (validateStatus resp1 200)
1024 resp2 <- restoreSnapshot r1n s1n settings
1025 liftIO (validateStatus resp2 200)
1027 it "can restore and rename" $ when' canSnapshot $ withTestEnv $ do
1028 let r1n = SnapshotRepoName "bloodhound-repo1"
1029 withSnapshotRepo r1n $ \_ -> do
1030 let s1n = SnapshotName "example-snapshot"
1031 withSnapshot r1n s1n $ do
1032 let pat = RestoreRenamePattern "bloodhound-tests-twitter-(\\d+)"
1033 let replace = RRTLit "restored-" :| [RRSubWholeMatch]
1034 let expectedIndex = IndexName "restored-bloodhound-tests-twitter-1"
1035 oldEnoughForOverrides <- liftIO (atleast es15)
1036 let overrides = RestoreIndexSettings { restoreOverrideReplicas = Just (ReplicaCount 0) }
1037 let settings = defaultSnapshotRestoreSettings { snapRestoreWaitForCompletion = True
1038 , snapRestoreRenamePattern = Just pat
1039 , snapRestoreRenameReplacement = Just replace
1040 , snapRestoreIndexSettingsOverrides = if oldEnoughForOverrides
1041 then Just overrides
1042 else Nothing
1044 -- have to close an index to restore it
1045 let go = do
1046 resp <- restoreSnapshot r1n s1n settings
1047 liftIO (validateStatus resp 200)
1048 exists <- indexExists expectedIndex
1049 liftIO (exists `shouldBe` True)
1050 go `finally` deleteIndex expectedIndex
1052 describe "getNodesInfo" $ do
1053 it "fetches the responding node when LocalNode is used" $ withTestEnv $ do
1054 res <- getNodesInfo LocalNode
1055 liftIO $ case res of
1056 -- This is really just a smoke test for response
1057 -- parsing. Node info is so variable, there's not much I can
1058 -- assert here.
1059 Right NodesInfo {..} -> length nodesInfo `shouldBe` 1
1060 Left e -> expectationFailure ("Expected NodesInfo but got " <> show e)
1062 describe "getNodesStats" $ do
1063 it "fetches the responding node when LocalNode is used" $ withTestEnv $ do
1064 res <- getNodesStats LocalNode
1065 liftIO $ case res of
1066 -- This is really just a smoke test for response
1067 -- parsing. Node stats is so variable, there's not much I can
1068 -- assert here.
1069 Right NodesStats {..} -> length nodesStats `shouldBe` 1
1070 Left e -> expectationFailure ("Expected NodesStats but got " <> show e)
1072 describe "Enum DocVersion" $ do
1073 it "follows the laws of Enum, Bounded" $ do
1074 evaluate (succ maxBound :: DocVersion) `shouldThrow` anyErrorCall
1075 evaluate (pred minBound :: DocVersion) `shouldThrow` anyErrorCall
1076 evaluate (toEnum 0 :: DocVersion) `shouldThrow` anyErrorCall
1077 evaluate (toEnum 9200000000000000001 :: DocVersion) `shouldThrow` anyErrorCall
1078 enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
1079 enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
1080 enumFromThen minBound (pred maxBound :: DocVersion) `shouldBe` [minBound, pred maxBound]
1082 describe "scan&scroll API" $ do
1083 it "returns documents using the scan&scroll API" $ withTestEnv $ do
1084 _ <- insertData
1085 _ <- insertOther
1086 let search = (mkSearch (Just $ MatchAllQuery Nothing) Nothing) { size = (Size 1) }
1087 regular_search <- searchTweet search
1088 scan_search' <- scanSearch testIndex testMapping search :: BH IO [Hit Tweet]
1089 let scan_search = map hitSource scan_search'
1090 liftIO $
1091 regular_search `shouldBe` Right exampleTweet -- Check that the size restrtiction is being honored
1092 liftIO $
1093 scan_search `shouldMatchList` [Just exampleTweet, Just otherTweet]
1095 describe "index aliases" $ do
1096 let aname = IndexAliasName (IndexName "bloodhound-tests-twitter-1-alias")
1097 let alias = IndexAlias (testIndex) aname
1098 let create = IndexAliasCreate Nothing Nothing
1099 let action = AddAlias alias create
1100 it "handles the simple case of aliasing an existing index" $ do
1101 withTestEnv $ do
1102 resetIndex
1103 resp <- updateIndexAliases (action :| [])
1104 liftIO $ validateStatus resp 200
1105 let cleanup = withTestEnv (updateIndexAliases (RemoveAlias alias :| []))
1106 (do aliases <- withTestEnv getIndexAliases
1107 let expected = IndexAliasSummary alias create
1108 case aliases of
1109 Right (IndexAliasesSummary summs) ->
1110 L.find ((== alias) . indexAliasSummaryAlias) summs `shouldBe` Just expected
1111 Left e -> expectationFailure ("Expected an IndexAliasesSummary but got " <> show e)) `finally` cleanup
1112 it "allows alias deletion" $ do
1113 aliases <- withTestEnv $ do
1114 resetIndex
1115 resp <- updateIndexAliases (action :| [])
1116 liftIO $ validateStatus resp 200
1117 _ <- deleteIndexAlias aname
1118 getIndexAliases
1119 -- let expected = IndexAliasSummary alias create
1120 case aliases of
1121 Right (IndexAliasesSummary summs) ->
1122 L.find ( (== aname)
1123 . indexAlias
1124 . indexAliasSummaryAlias
1125 ) summs
1126 `shouldBe` Nothing
1127 Left e -> expectationFailure ("Expected an IndexAliasesSummary but got " <> show e)
1129 describe "Index Listing" $ do
1130 it "returns a list of index names" $ withTestEnv $ do
1131 _ <- createExampleIndex
1132 ixns <- listIndices
1133 liftIO (ixns `shouldContain` [testIndex])
1135 describe "Index Settings" $ do
1136 it "persists settings" $ withTestEnv $ do
1137 _ <- deleteExampleIndex
1138 _ <- createExampleIndex
1139 let updates = BlocksWrite False :| []
1140 updateResp <- updateIndexSettings updates testIndex
1141 liftIO $ validateStatus updateResp 200
1142 getResp <- getIndexSettings testIndex
1143 liftIO $
1144 getResp `shouldBe` Right (IndexSettingsSummary
1145 testIndex
1146 (IndexSettings (ShardCount 1) (ReplicaCount 0))
1147 (NE.toList updates))
1149 it "allows total fields to be set" $ when' (atleast es50) $ withTestEnv $ do
1150 _ <- deleteExampleIndex
1151 _ <- createExampleIndex
1152 let updates = MappingTotalFieldsLimit 2500 :| []
1153 updateResp <- updateIndexSettings updates testIndex
1154 liftIO $ validateStatus updateResp 200
1155 getResp <- getIndexSettings testIndex
1156 liftIO $
1157 getResp `shouldBe` Right (IndexSettingsSummary
1158 testIndex
1159 (IndexSettings (ShardCount 1) (ReplicaCount 0))
1160 (NE.toList updates))
1162 it "accepts customer analyzers" $ when' (atleast es50) $ withTestEnv $ do
1163 _ <- deleteExampleIndex
1164 let analysis = Analysis
1165 (M.singleton "ex_analyzer"
1166 ( AnalyzerDefinition
1167 (Just (Tokenizer "ex_tokenizer"))
1168 (map TokenFilter
1169 [ "ex_filter_lowercase","ex_filter_uppercase","ex_filter_apostrophe"
1170 , "ex_filter_reverse","ex_filter_snowball"
1171 , "ex_filter_shingle"
1176 (M.singleton "ex_tokenizer"
1177 ( TokenizerDefinitionNgram
1178 ( Ngram 3 4 [TokenLetter,TokenDigit])
1181 (M.fromList
1182 [ ("ex_filter_lowercase",TokenFilterDefinitionLowercase (Just Greek))
1183 , ("ex_filter_uppercase",TokenFilterDefinitionUppercase Nothing)
1184 , ("ex_filter_apostrophe",TokenFilterDefinitionApostrophe)
1185 , ("ex_filter_reverse",TokenFilterDefinitionReverse)
1186 , ("ex_filter_snowball",TokenFilterDefinitionSnowball English)
1187 , ("ex_filter_shingle",TokenFilterDefinitionShingle (Shingle 3 3 True False " " "_"))
1190 updates = [AnalysisSetting analysis]
1191 createResp <- createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex
1192 liftIO $ validateStatus createResp 200
1193 getResp <- getIndexSettings testIndex
1194 liftIO $
1195 getResp `shouldBe` Right (IndexSettingsSummary
1196 testIndex
1197 (IndexSettings (ShardCount 1) (ReplicaCount 0))
1198 updates
1201 it "accepts default compression codec" $ when' (atleast es50) $ withTestEnv $ do
1202 _ <- deleteExampleIndex
1203 let updates = [CompressionSetting CompressionDefault]
1204 createResp <- createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex
1205 liftIO $ validateStatus createResp 200
1206 getResp <- getIndexSettings testIndex
1207 liftIO $ getResp `shouldBe` Right
1208 (IndexSettingsSummary testIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) updates)
1210 it "accepts best compression codec" $ when' (atleast es50) $ withTestEnv $ do
1211 _ <- deleteExampleIndex
1212 let updates = [CompressionSetting CompressionBest]
1213 createResp <- createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex
1214 liftIO $ validateStatus createResp 200
1215 getResp <- getIndexSettings testIndex
1216 liftIO $ getResp `shouldBe` Right
1217 (IndexSettingsSummary testIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) updates)
1220 describe "Index Optimization" $ do
1221 it "returns a successful response upon completion" $ withTestEnv $ do
1222 _ <- createExampleIndex
1223 resp <- forceMergeIndex (IndexList (testIndex :| [])) defaultForceMergeIndexSettings
1224 liftIO $ validateStatus resp 200
1226 describe "Suggest" $ do
1227 it "returns a search suggestion using the phrase suggester" $ withTestEnv $ do
1228 _ <- insertData
1229 let query = QueryMatchNoneQuery
1230 phraseSuggester = mkPhraseSuggester (FieldName "message")
1231 namedSuggester = Suggest "Use haskel" "suggest_name" (SuggestTypePhraseSuggester phraseSuggester)
1232 search' = mkSearch (Just query) Nothing
1233 search = search' { suggestBody = Just namedSuggester }
1234 expectedText = Just "use haskell"
1235 resp <- searchByIndex testIndex search
1236 parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Tweet))
1237 case parsed of
1238 Left e -> liftIO $ expectationFailure ("Expected an search suggestion but got " <> show e)
1239 Right sr -> liftIO $ (suggestOptionsText . head . suggestResponseOptions . head . nsrResponses <$> suggest sr) `shouldBe` expectedText
1241 describe "Script" $ do
1242 it "returns a transformed document based on the script field" $ withTestEnv $ do
1243 _ <- insertData
1244 let query = MatchAllQuery Nothing
1245 sfv = toJSON $
1246 Script
1247 (Just (ScriptLanguage "painless"))
1248 (Just (ScriptInline "doc['age'].value * 2"))
1249 Nothing
1250 Nothing
1251 sf = ScriptFields $
1252 HM.fromList [("test1", sfv)]
1253 search' = mkSearch (Just query) Nothing
1254 search = search' { scriptFields = Just sf }
1255 resp <- searchByIndex testIndex search
1256 parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Value))
1257 case parsed of
1258 Left e ->
1259 liftIO $ expectationFailure ("Expected a script-transformed result but got: " <> show e)
1260 Right sr -> do
1261 let Just results =
1262 hitFields (head (hits (searchHits sr)))
1263 liftIO $ results `shouldBe` (HitFields (M.fromList [("test1", [Number 20000.0])]))