@@ -18,428 +18,40 @@
1818#endif
1919module Main where
2020
21+import Test.Common
2122import Test.Import
2223
23−import Control.Error hiding (Script)
24−import qualified Data.HashMap.Strict as HM
25−import Data.List (nub)
26−import qualified Data.List as L
27−import Data.List.NonEmpty (NonEmpty (..))
28−import qualified Data.List.NonEmpty as NE
29−import qualified Data.Map.Strict as M
30−import Data.Text (Text)
31−import qualified Data.Text as T
32−import Data.Time.Calendar (Day (..), fromGregorian)
33−import Data.Time.Clock (UTCTime (..),
34− secondsToDiffTime)
35−import qualified Data.Vector as V
36−import qualified Data.Version as Vers
37−import qualified Database.V5.Bloodhound
38−import qualified Lens.Micro.Aeson as LMA
39−import qualified Network.HTTP.Types.Method as NHTM
40−import qualified Network.HTTP.Types.Status as NHTS
41−import qualified Network.URI as URI
4224import Prelude hiding (filter)
4325
26+import qualified Test.Aggregation as Aggregation
27+import qualified Test.BulkAPI as Bulk
28+import qualified Test.Documents as Documents
29+import qualified Test.Highlights as Highlights
30+import qualified Test.Indices as Indices
4431import qualified Test.JSON as JSON
45−
46−testServer :: Server
47−testServer = Server "http://localhost:9200"
48−testIndex :: IndexName
49−testIndex = IndexName "bloodhound-tests-twitter-1"
50−testMapping :: MappingName
51−testMapping = MappingName "tweet"
52−
53−withTestEnv :: BH IO a -> IO a
54−withTestEnv = withBH defaultManagerSettings testServer
55−
56−validateStatus :: Show body => Response body -> Int -> Expectation
57−validateStatus 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
64−
65−createExampleIndex :: (MonadBH m) => m Reply
66−createExampleIndex = createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) testIndex
67−deleteExampleIndex :: (MonadBH m) => m Reply
68−deleteExampleIndex = deleteIndex testIndex
69−
70−es13 :: Vers.Version
71−es13 = Vers.Version [1, 3, 0] []
72−
73−es12 :: Vers.Version
74−es12 = Vers.Version [1, 2, 0] []
75−
76−es11 :: Vers.Version
77−es11 = Vers.Version [1, 1, 0] []
78−
79−es14 :: Vers.Version
80−es14 = Vers.Version [1, 4, 0] []
81−
82−es15 :: Vers.Version
83−es15 = Vers.Version [1, 5, 0] []
84−
85−es16 :: Vers.Version
86−es16 = Vers.Version [1, 6, 0] []
87−
88−es20 :: Vers.Version
89−es20 = Vers.Version [2, 0, 0] []
90−
91−es50 :: Vers.Version
92−es50 = Vers.Version [5, 0, 0] []
93−
94−getServerVersion :: IO (Maybe Vers.Version)
95−getServerVersion = fmap extractVersion <$> withTestEnv getStatus
96− where
97− extractVersion = versionNumber . number . version
98−
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.
103−getRepoPaths :: IO [FilePath]
104−getRepoPaths = 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]
118−
119−-- | 1.5 and earlier don't care about repo paths
120−canSnapshot :: IO Bool
121−canSnapshot = do
122− caresAboutRepos <- atleast es16
123− repoPaths <- getRepoPaths
124− return (not caresAboutRepos || not (null (repoPaths)))
125−
126−atleast :: Vers.Version -> IO Bool
127−atleast v = getServerVersion >>= \x -> return $ x >= Just v
128−
129−atmost :: Vers.Version -> IO Bool
130−atmost v = getServerVersion >>= \x -> return $ x <= Just v
131−
132−is :: Vers.Version -> IO Bool
133−is v = getServerVersion >>= \x -> return $ x == Just v
134−
135−when' :: Monad m => m Bool -> m () -> m ()
136−when' b f = b >>= \x -> when x f
137−
138−data Location = Location { lat :: Double
139− , lon :: Double } deriving (Eq, Show)
140−
141−data Tweet = Tweet { user :: Text
142− , postDate :: UTCTime
143− , message :: Text
144− , age :: Int
145− , location :: Location
146− , extra :: Maybe Text }
147− deriving (Eq, Show)
148−
149−$(deriveJSON defaultOptions ''Location)
150−$(deriveJSON defaultOptions ''Tweet)
151−
152−data ParentMapping = ParentMapping deriving (Eq, Show)
153−
154−instance 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− ]]
168−
169−data ChildMapping = ChildMapping deriving (Eq, Show)
170−
171−instance 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− ]]
186−
187−data TweetMapping = TweetMapping deriving (Eq, Show)
188−
189−instance 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− ]]]
204−
205−exampleTweet :: Tweet
206−exampleTweet = 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 }
214−
215−tweetWithExtra :: Tweet
216−tweetWithExtra = 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" }
224−
225−newAge :: Int
226−newAge = 31337
227−
228−newUser :: Text
229−newUser = "someotherapp"
230−
231−tweetPatch :: Value
232−tweetPatch =
233− object [ "age" .= newAge
234− , "user" .= newUser
235− ]
236−
237−patchedTweet :: Tweet
238−patchedTweet = exampleTweet{age = newAge, user = newUser}
239−
240−otherTweet :: Tweet
241−otherTweet = 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 }
249−
250−resetIndex :: BH IO ()
251−resetIndex = do
252− _ <- deleteExampleIndex
253− _ <- createExampleIndex
254− _ <- putMapping testIndex testMapping TweetMapping
255− return ()
256−
257−insertData :: BH IO Reply
258−insertData = do
259− resetIndex
260− insertData' defaultIndexDocumentSettings
261−
262−insertData' :: IndexDocumentSettings -> BH IO Reply
263−insertData' ids = do
264− r <- indexDocument testIndex testMapping ids exampleTweet (DocId "1")
265− _ <- refreshIndex testIndex
266− return r
267−
268−updateData :: BH IO Reply
269−updateData = do
270− r <- updateDocument testIndex testMapping defaultIndexDocumentSettings tweetPatch (DocId "1")
271− _ <- refreshIndex testIndex
272− return r
273−
274−insertOther :: BH IO ()
275−insertOther = do
276− _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings otherTweet (DocId "2")
277− _ <- refreshIndex testIndex
278− return ()
279−
280−insertExtra :: BH IO ()
281−insertExtra = do
282− _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings tweetWithExtra (DocId "4")
283− _ <- refreshIndex testIndex
284− return ()
285−
286−insertWithSpaceInId :: BH IO ()
287−insertWithSpaceInId = do
288− _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "Hello World")
289− _ <- refreshIndex testIndex
290− return ()
291−
292−searchTweet :: Search -> BH IO (Either EsError Tweet)
293−searchTweet search = do
294− result <- searchTweets search
295− let myTweet :: Either EsError Tweet
296− myTweet = grabFirst result
297− return myTweet
298−
299−searchTweets :: Search -> BH IO (Either EsError (SearchResult Tweet))
300−searchTweets search = parseEsResponse =<< searchByIndex testIndex search
301−
302−searchExpectNoResults :: Search -> BH IO ()
303−searchExpectNoResults search = do
304− result <- searchTweets search
305− let emptyHits = fmap (hits . searchHits) result
306− liftIO $
307− emptyHits `shouldBe` Right []
308−
309−searchExpectAggs :: Search -> BH IO ()
310−searchExpectAggs 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
316−
317−searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) =>
318− Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH IO ()
319−searchValidBucketAgg 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
326−
327−searchTermsAggHint :: [ExecutionHint] -> BH IO ()
328−searchTermsAggHint 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)
333−
334−searchTweetHighlight :: Search -> BH IO (Either EsError (Maybe HitHighlight))
335−searchTweetHighlight search = do
336− result <- searchTweets search
337− let myHighlight = fmap (hitHighlight . head . hits . searchHits) result
338− return myHighlight
339−
340−searchExpectSource :: Source -> Either EsError Value -> BH IO ()
341−searchExpectSource 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
350−
351−withSnapshotRepo
352− :: ( MonadMask m
353− , MonadBH m
354− )
355− => SnapshotRepoName
356− -> (GenericSnapshotRepo -> m a)
357− -> m a
358−withSnapshotRepo 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)
377−
378−
379−withSnapshot
380− :: ( MonadMask m
381− , MonadBH m
382− )
383− => SnapshotRepoName
384− -> SnapshotName
385− -> m a
386− -> m a
387−withSnapshot 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
399−
400−
401−
402−newtype BulkTest =
403− BulkTest { name :: Text }
404− deriving (Eq, Show)
405−
406−instance ToJSON BulkTest where
407− toJSON (BulkTest name) =
408− object ["name" .= name]
409−
410−instance FromJSON BulkTest where
411− parseJSON = withObject "BulkTest" parse
412− where
413− parse o = do
414− t <- o .: "name"
415− BulkTest <$> parseJSON t
416−
417−noDuplicates :: Eq a => [a] -> Bool
418−noDuplicates xs = nub xs == xs
419−
420−
421−getSource :: EsResult a -> Maybe a
422−getSource = fmap _source . foundResult
423−
424−grabFirst :: Either EsError (SearchResult a) -> Either EsError a
425−grabFirst 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
32+import qualified Test.Query as Query
33+import qualified Test.Script as Script
34+import qualified Test.Snapshots as Snapshots
35+import qualified Test.Sorting as Sorting
36+import qualified Test.SourceFiltering as SourceFiltering
37+import qualified Test.Suggest as Suggest
38+import qualified Test.Templates as Templates
43039
43140main :: IO ()
43241main = hspec $ do
42+ Aggregation.spec
43+ Bulk.spec
44+ Documents.spec
45+ Highlights.spec
46+ Indices.spec
43347 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
48+ Query.spec
49+ Script.spec
50+ Snapshots.spec
51+ Sorting.spec
52+ SourceFiltering.spec
53+ Suggest.spec
54+ Templates.spec
44355
44456 describe "error parsing" $ do
44557 it "can parse EsErrors for < 2.0" $ when' (atmost es16) $ withTestEnv $ do
@@ -452,484 +64,6 @@ main = hspec $ do
45264 let errorResp = eitherDecode (responseBody res)
45365 liftIO (errorResp `shouldBe` Right (EsError 404 "no such index"))
45466
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))
463−
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))
470−
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
476−
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
485−
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
497−
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
503−
504− it "can detect if a template exists" $ withTestEnv $ do
505− exists <- templateExists (TemplateName "tweet-tpl")
506− liftIO $ exists `shouldBe` True
507−
508− it "can delete a template" $ withTestEnv $ do
509− resp <- deleteTemplate (TemplateName "tweet-tpl")
510− liftIO $ validateStatus resp 200
511−
512− it "can detect if a template doesn't exist" $ withTestEnv $ do
513− exists <- templateExists (TemplateName "tweet-tpl")
514− liftIO $ exists `shouldBe` False
515−
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"]
584−
585−
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
595−
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
605−
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
614−
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
622−
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
631−
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
642−
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
653−
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
663−
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
675−
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
690−
691−
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
705−
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
713−
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
725−
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]))
736−
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]))
751−
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
758−
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]
763−
764− it "can give execution hint parameters to term aggregations" $ when' (is es12) $ withTestEnv $ do
765− _ <- insertData
766− searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map, Ordinals]
767−
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.
772−
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− ]))
785−
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− ]
823−
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
830−
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]))
840−
841− describe "Highlights API" $ do
842−
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]
848−
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>!"])]))
853−
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]
859−
860− let search = mkHighlightSearch (Just query) testHighlight
861− myHighlight <- searchTweetHighlight search
862− liftIO $
863− myHighlight `shouldBe` Right Nothing
864−
865− describe "Source filtering" $ do
866−
867− it "doesn't include source when sources are disabled" $ withTestEnv $ do
868− searchExpectSource
869− NoSource
870− (Left (EsError 500 "Source was missing"))
871−
872− it "includes a source" $ withTestEnv $ do
873− searchExpectSource
874− (SourcePatterns (PopPattern (Pattern "message")))
875− (Right (Object (HM.fromList [("message", String "Use haskell!")])))
876−
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!")])))
881−
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!")])))
886−
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")])))
892−
893− describe "ToJSON RegexpFlags" $ do
894− it "generates the correct JSON for AllRegexpFlags" $
895− toJSON AllRegexpFlags `shouldBe` String "ALL"
896−
897− it "generates the correct JSON for NoRegexpFlags" $
898− toJSON NoRegexpFlags `shouldBe` String "NONE"
899−
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"
907−
908− prop "removes duplicates from flags" $ \(flags :: RegexpFlags) ->
909− let String str = toJSON flags
910− flagStrs = T.splitOn "|" str
911− in noDuplicates flagStrs
912−
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")])
918−
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")])
93367 describe "Monoid (SearchHits a)" $ do
93468 prop "abides the monoid laws" $ eq $
93569 prop_Monoid (T :: T (SearchHits ()))
@@ -943,112 +77,6 @@ main = hspec $ do
94377 (dv <= maxBound) .&&.
94478 docVersionNumber dv === i
94579
946− describe "FsSnapshotRepo" $ do
947− prop "SnapshotRepo laws" $ \fsr ->
948− fromGSnapshotRepo (toGSnapshotRepo fsr) === Right (fsr :: FsSnapshotRepo)
949−
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 ()
956−
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)
968−
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)
978−
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)
989−
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 ()
998−
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)
1013−
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)
1026−
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
1043− }
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
1051−
105280 describe "getNodesInfo" $ do
105381 it "fetches the responding node when LocalNode is used" $ withTestEnv $ do
105482 res <- getNodesInfo LocalNode
@@ -1079,7 +107,7 @@ main = hspec $ do
1079107 enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
1080108 enumFromThen minBound (pred maxBound :: DocVersion) `shouldBe` [minBound, pred maxBound]
1081109
1082− describe "scan&scroll API" $ do
110+ describe "Scan & Scroll API" $ do
1083111 it "returns documents using the scan&scroll API" $ withTestEnv $ do
1084112 _ <- insertData
1085113 _ <- insertOther
@@ -1091,173 +119,3 @@ main = hspec $ do
1091119 regular_search `shouldBe` Right exampleTweet -- Check that the size restrtiction is being honored
1092120 liftIO $
1093121 scan_search `shouldMatchList` [Just exampleTweet, Just otherTweet]
1094−
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)
1128−
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])
1134−
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))
1148−
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))
1161−
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"
1172− ]
1173− )
1174− )
1175− )
1176− (M.singleton "ex_tokenizer"
1177− ( TokenizerDefinitionNgram
1178− ( Ngram 3 4 [TokenLetter,TokenDigit])
1179− )
1180− )
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 " " "_"))
1188− ]
1189− )
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
1199− )
1200−
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)
1209−
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)
1218−
1219−
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
1225−
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
1240−
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])]))