1{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE ScopedTypeVariables #-}
7import Control.Applicative
10import qualified Data.HashMap.Strict as HM
12import Data.List.NonEmpty (NonEmpty (..))
13import qualified Data.List.NonEmpty as NE
14import qualified Data.Map.Strict as M
15import Data.Text (Text)
16import qualified Data.Text as T
17import Data.Time.Calendar (Day (..))
18import Data.Time.Clock (UTCTime (..), secondsToDiffTime)
19import qualified Data.Vector as V
20import Database.Bloodhound
21import GHC.Generics (Generic)
22import Network.HTTP.Client
23import qualified Network.HTTP.Types.Status as NHTS
24import Prelude hiding (filter, putStrLn)
27import Test.Hspec.QuickCheck (prop)
31testServer = Server "http://localhost:9200"
33testIndex = IndexName "bloodhound-tests-twitter-1"
34testMapping :: MappingName
35testMapping = MappingName "tweet"
37validateStatus :: Response body -> Int -> Expectation
38validateStatus resp expected =
39 (NHTS.statusCode $ responseStatus resp)
40 `shouldBe` (expected :: Int)
42createExampleIndex :: IO Reply
43createExampleIndex = createIndex testServer defaultIndexSettings testIndex
44deleteExampleIndex :: IO Reply
45deleteExampleIndex = deleteIndex testServer testIndex
47data ServerVersion = ServerVersion Int Int Int deriving (Show, Eq, Ord)
50es14 = ServerVersion 1 4 0
53es13 = ServerVersion 1 3 0
56es12 = ServerVersion 1 2 0
59es11 = ServerVersion 1 1 0
62es10 = ServerVersion 1 0 0
64serverBranch :: ServerVersion -> ServerVersion
65serverBranch (ServerVersion majorVer minorVer patchVer) =
66 ServerVersion majorVer minorVer patchVer
68mkServerVersion :: [Int] -> Maybe ServerVersion
69mkServerVersion [majorVer, minorVer, patchVer] =
70 Just (ServerVersion majorVer minorVer patchVer)
71mkServerVersion _ = Nothing
73getServerVersion :: Server -> IO (Maybe ServerVersion)
74getServerVersion s = liftM extractVersion (getStatus s)
76 version' = T.splitOn "." . number . version
77 toInt = read . T.unpack
78 parseVersion v = map toInt (version' v)
79 extractVersion = join . liftM (mkServerVersion . parseVersion)
83testServerBranch :: IO (Maybe ServerVersion)
84testServerBranch = getServerVersion testServer >>= \v -> return $ liftM serverBranch v
86atleast :: ServerVersion -> IO Bool
87atleast v = testServerBranch >>= \x -> return $ x >= Just (serverBranch v)
89atmost :: ServerVersion -> IO Bool
90atmost v = testServerBranch >>= \x -> return $ x <= Just (serverBranch v)
92is :: ServerVersion -> IO Bool
93is v = testServerBranch >>= \x -> return $ x == Just (serverBranch v)
95when' :: Monad m => m Bool -> m () -> m ()
96when' b f = b >>= \x -> when x f
98data Location = Location { lat :: Double
99 , lon :: Double } deriving (Eq, Generic, Show)
101data Tweet = Tweet { user :: Text
102 , postDate :: UTCTime
105 , location :: Location }
106 deriving (Eq, Generic, Show)
109instance FromJSON Tweet
110instance ToJSON Location
111instance FromJSON Location
113data TweetMapping = TweetMapping deriving (Eq, Show)
115instance ToJSON TweetMapping where
116 toJSON TweetMapping =
118 object ["properties" .=
119 object ["location" .= object ["type" .= ("geo_point" :: Text)]]]]
122exampleTweet = Tweet { user = "bitemyapp"
124 (ModifiedJulianDay 55000)
125 (secondsToDiffTime 10)
126 , message = "Use haskell!"
128 , location = Location 40.12 (-71.34) }
131otherTweet = Tweet { user = "notmyapp"
133 (ModifiedJulianDay 55000)
134 (secondsToDiffTime 11)
135 , message = "Use haskell!"
137 , location = Location 40.12 (-71.34) }
141 _ <- deleteExampleIndex
142 _ <- createExampleIndex
143 _ <- putMapping testServer testIndex testMapping TweetMapping
144 _ <- indexDocument testServer testIndex testMapping exampleTweet (DocId "1")
145 _ <- refreshIndex testServer testIndex
150 _ <- indexDocument testServer testIndex testMapping otherTweet (DocId "2")
151 _ <- refreshIndex testServer testIndex
154searchTweet :: Search -> IO (Either String Tweet)
155searchTweet search = do
156 reply <- searchByIndex testServer testIndex search
157 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
158 let myTweet = fmap (hitSource . head . hits . searchHits) result
161searchExpectNoResults :: Search -> IO ()
162searchExpectNoResults search = do
163 reply <- searchByIndex testServer testIndex search
164 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
165 let emptyHits = fmap (hits . searchHits) result
166 emptyHits `shouldBe` Right []
168searchExpectAggs :: Search -> IO ()
169searchExpectAggs search = do
170 reply <- searchAll testServer search
171 let isEmpty x = return (M.null x)
172 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
173 (result >>= aggregations >>= isEmpty) `shouldBe` Just False
175searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) => Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> IO ()
176searchValidBucketAgg search aggKey extractor = do
177 reply <- searchAll testServer search
178 let bucketDocs = docCount . head . buckets
179 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
180 let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x)
181 count `shouldBe` Just 1
183searchTermsAggHint :: [ExecutionHint] -> IO ()
184searchTermsAggHint hints = do
185 let terms hint = TermsAgg $ (mkTermsAggregation "user") { termExecutionHint = Just hint }
186 let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint
187 forM_ hints $ searchExpectAggs . search
188 forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
190searchTweetHighlight :: Search -> IO (Either String (Maybe HitHighlight))
191searchTweetHighlight search = do
192 reply <- searchByIndex testServer testIndex search
193 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
194 let myHighlight = fmap (hitHighlight . head . hits . searchHits) result
197data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
198instance FromJSON BulkTest
199instance ToJSON BulkTest
201noDuplicates :: Eq a => [a] -> Bool
202noDuplicates xs = nub xs == xs
204instance Arbitrary RegexpFlags where
205 arbitrary = oneof [ pure AllRegexpFlags
207 , SomeRegexpFlags <$> arbitrary
210instance Arbitrary a => Arbitrary (NonEmpty a) where
211 arbitrary = liftA2 (:|) arbitrary arbitrary
213instance Arbitrary RegexpFlag where
214 arbitrary = oneof [ pure AnyString
225 describe "index create/delete API" $ do
226 it "creates and then deletes the requested index" $ do
228 _ <- deleteExampleIndex
229 resp <- createExampleIndex
230 deleteResp <- deleteExampleIndex
231 validateStatus resp 200
232 validateStatus deleteResp 200
235 describe "document API" $ do
236 it "indexes, gets, and then deletes the generated document" $ do
238 docInserted <- getDocument testServer testIndex testMapping (DocId "1")
239 let newTweet = eitherDecode
240 (responseBody docInserted) :: Either String (EsResult Tweet)
241 fmap _source newTweet `shouldBe` Right exampleTweet
244 describe "bulk API" $ do
245 it "inserts all documents we request" $ do
247 let firstTest = BulkTest "blah"
248 let secondTest = BulkTest "bloo"
249 let firstDoc = BulkIndex testIndex
250 testMapping (DocId "2") (toJSON firstTest)
251 let secondDoc = BulkCreate testIndex
252 testMapping (DocId "3") (toJSON secondTest)
253 let stream = V.fromList [firstDoc, secondDoc]
254 _ <- bulk testServer stream
255 _ <- refreshIndex testServer testIndex
256 fDoc <- getDocument testServer testIndex testMapping (DocId "2")
257 sDoc <- getDocument testServer testIndex testMapping (DocId "3")
258 let maybeFirst = eitherDecode $ responseBody fDoc :: Either String (EsResult BulkTest)
259 let maybeSecond = eitherDecode $ responseBody sDoc :: Either String (EsResult BulkTest)
260 fmap _source maybeFirst `shouldBe` Right firstTest
261 fmap _source maybeSecond `shouldBe` Right secondTest
264 describe "query API" $ do
265 it "returns document for term query and identity filter" $ do
267 let query = TermQuery (Term "user" "bitemyapp") Nothing
268 let filter = IdentityFilter <&&> IdentityFilter
269 let search = mkSearch (Just query) (Just filter)
270 myTweet <- searchTweet search
271 myTweet `shouldBe` Right exampleTweet
273 it "returns document for terms query and identity filter" $ do
275 let query = TermsQuery (NE.fromList [(Term "user" "bitemyapp")])
276 let filter = IdentityFilter <&&> IdentityFilter
277 let search = mkSearch (Just query) (Just filter)
278 myTweet <- searchTweet search
279 myTweet `shouldBe` Right exampleTweet
281 it "returns document for match query" $ do
283 let query = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
284 let search = mkSearch (Just query) Nothing
285 myTweet <- searchTweet search
286 myTweet `shouldBe` Right exampleTweet
288 it "returns document for multi-match query" $ do
290 let fields = [FieldName "user", FieldName "message"]
291 let query = QueryMultiMatchQuery $ mkMultiMatchQuery fields (QueryString "bitemyapp")
292 let search = mkSearch (Just query) Nothing
293 myTweet <- searchTweet search
294 myTweet `shouldBe` Right exampleTweet
296 it "returns document for bool query" $ do
298 let innerQuery = QueryMatchQuery $
299 mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
300 let query = QueryBoolQuery $
301 mkBoolQuery [innerQuery] [] []
302 let search = mkSearch (Just query) Nothing
303 myTweet <- searchTweet search
304 myTweet `shouldBe` Right exampleTweet
306 it "returns document for boosting query" $ do
308 let posQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
309 let negQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "notmyapp")
310 let query = QueryBoostingQuery $ BoostingQuery posQuery negQuery (Boost 0.2)
311 let search = mkSearch (Just query) Nothing
312 myTweet <- searchTweet search
313 myTweet `shouldBe` Right exampleTweet
315 it "returns document for common terms query" $ do
317 let query = QueryCommonTermsQuery $
318 CommonTermsQuery (FieldName "user")
319 (QueryString "bitemyapp")
320 (CutoffFrequency 0.0001)
321 Or Or Nothing Nothing Nothing Nothing
322 let search = mkSearch (Just query) Nothing
323 myTweet <- searchTweet search
324 myTweet `shouldBe` Right exampleTweet
327 describe "sorting" $ do
328 it "returns documents in the right order" $ do
331 let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
332 let search = Search Nothing
333 (Just IdentityFilter) (Just [sortSpec]) Nothing Nothing
335 reply <- searchByIndex testServer testIndex search
336 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
337 let myTweet = fmap (hitSource . head . hits . searchHits) result
338 myTweet `shouldBe` Right otherTweet
341 describe "filtering API" $ do
342 it "returns document for composed boolmatch and identity" $ do
344 let queryFilter = BoolFilter (MustMatch (Term "user" "bitemyapp") False)
346 let search = mkSearch Nothing (Just queryFilter)
347 myTweet <- searchTweet search
348 myTweet `shouldBe` Right exampleTweet
350 it "returns document for term filter" $ do
352 let termFilter = TermFilter (Term "user" "bitemyapp") False
353 let search = mkSearch Nothing (Just termFilter)
354 myTweet <- searchTweet search
355 myTweet `shouldBe` Right exampleTweet
357 it "returns document for existential filter" $ do
359 let search = mkSearch Nothing (Just (ExistsFilter (FieldName "user")))
360 myTweet <- searchTweet search
361 myTweet `shouldBe` Right exampleTweet
363 it "returns document for geo boundingbox filter" $ do
365 let box = GeoBoundingBox (LatLon 40.73 (-74.1)) (LatLon 40.10 (-71.12))
366 let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False GeoFilterMemory
367 let geoFilter = GeoBoundingBoxFilter bbConstraint
368 let search = mkSearch Nothing (Just geoFilter)
369 myTweet <- searchTweet search
370 myTweet `shouldBe` Right exampleTweet
372 it "doesn't return document for nonsensical boundingbox filter" $ do
374 let box = GeoBoundingBox (LatLon 0.73 (-4.1)) (LatLon 0.10 (-1.12))
375 let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False GeoFilterMemory
376 let geoFilter = GeoBoundingBoxFilter bbConstraint
377 let search = mkSearch Nothing (Just geoFilter)
378 searchExpectNoResults search
380 it "returns document for geo distance filter" $ do
382 let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
383 let distance = Distance 10.0 Miles
384 let optimizeBbox = OptimizeGeoFilterType GeoFilterMemory
385 let geoFilter = GeoDistanceFilter geoPoint distance SloppyArc optimizeBbox False
386 let search = mkSearch Nothing (Just geoFilter)
387 myTweet <- searchTweet search
388 myTweet `shouldBe` Right exampleTweet
390 it "returns document for geo distance range filter" $ do
392 let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
393 let distanceRange = DistanceRange (Distance 0.0 Miles) (Distance 10.0 Miles)
394 let geoFilter = GeoDistanceRangeFilter geoPoint distanceRange
395 let search = mkSearch Nothing (Just geoFilter)
396 myTweet <- searchTweet search
397 myTweet `shouldBe` Right exampleTweet
399 it "doesn't return document for wild geo distance range filter" $ do
401 let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
402 let distanceRange = DistanceRange (Distance 100.0 Miles) (Distance 1000.0 Miles)
403 let geoFilter = GeoDistanceRangeFilter geoPoint distanceRange
404 let search = mkSearch Nothing (Just geoFilter)
405 searchExpectNoResults search
407 it "returns document for geo polygon filter" $ do
409 let points = [LatLon 40.0 (-70.00),
410 LatLon 40.0 (-72.00),
411 LatLon 41.0 (-70.00),
412 LatLon 41.0 (-72.00)]
413 let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points
414 let search = mkSearch Nothing (Just geoFilter)
415 myTweet <- searchTweet search
416 myTweet `shouldBe` Right exampleTweet
418 it "doesn't return document for bad geo polygon filter" $ do
420 let points = [LatLon 40.0 (-70.00),
421 LatLon 40.0 (-71.00),
422 LatLon 41.0 (-70.00),
423 LatLon 41.0 (-71.00)]
424 let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points
425 let search = mkSearch Nothing (Just geoFilter)
426 searchExpectNoResults search
428 it "returns document for ids filter" $ do
430 let filter = IdsFilter (MappingName "tweet") [DocId "1"]
431 let search = mkSearch Nothing (Just filter)
432 myTweet <- searchTweet search
433 myTweet `shouldBe` Right exampleTweet
435 it "returns document for range filter" $ do
437 let filter = RangeFilter (FieldName "age")
438 (Right (RangeLtGt (LessThan 100000.0) (GreaterThan 1000.0)))
439 RangeExecutionIndex False
440 let search = mkSearch Nothing (Just filter)
441 myTweet <- searchTweet search
442 myTweet `shouldBe` Right exampleTweet
444 it "returns document for regexp filter" $ do
446 let filter = RegexpFilter (FieldName "user") (Regexp "bite.*app")
447 AllRegexpFlags (CacheName "test") False (CacheKey "key")
448 let search = mkSearch Nothing (Just filter)
449 myTweet <- searchTweet search
450 myTweet `shouldBe` Right exampleTweet
452 it "doesn't return document for non-matching regexp filter" $ do
454 let filter = RegexpFilter (FieldName "user")
455 (Regexp "boy") AllRegexpFlags
456 (CacheName "test") False (CacheKey "key")
457 let search = mkSearch Nothing (Just filter)
458 searchExpectNoResults search
460 describe "Aggregation API" $ do
461 it "returns term aggregation results" $ do
463 let terms = TermsAgg $ mkTermsAggregation "user"
464 let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
465 searchExpectAggs search
466 searchValidBucketAgg search "users" toTerms
468 it "can give collection hint parameters to term aggregations" $ when' (atleast es13) $ do
470 let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
471 let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
472 searchExpectAggs search
473 searchValidBucketAgg search "users" toTerms
475 it "can give execution hint paramters to term aggregations" $ when' (atmost es11) $ do
477 searchTermsAggHint [Map, Ordinals]
479 it "can give execution hint paramters to term aggregations" $ when' (is es12) $ do
481 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map, Ordinals]
483 it "can give execution hint paramters to term aggregations" $ when' (atleast es12) $ do
485 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map]
487 it "returns date histogram aggregation results" $ do
489 let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute
490 let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram)
491 searchExpectAggs search
492 searchValidBucketAgg search "byDate" toDateHistogram
494 it "returns date histogram using fractional date" $ do
496 let periods = [Year, Quarter, Month, Week, Day, Hour, Minute, Second]
497 let fractionals = map (FractionalInterval 1.5) [Weeks, Days, Hours, Minutes, Seconds]
498 let intervals = periods ++ fractionals
499 let histogram = mkDateHistogram (FieldName "postDate")
500 let search interval = mkAggregateSearch Nothing $ mkAggregations "byDate" $ DateHistogramAgg (histogram interval)
501 let expect interval = searchExpectAggs (search interval)
502 let valid interval = searchValidBucketAgg (search interval) "byDate" toDateHistogram
503 forM_ intervals expect
504 forM_ intervals valid
506 describe "Highlights API" $ do
508 it "returns highlight from query when there should be one" $ do
511 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
512 let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
514 let search = mkHighlightSearch (Just query) testHighlight
515 myHighlight <- searchTweetHighlight search
516 myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use <em>haskell</em>!"])]))
518 it "doesn't return highlight from a query when it shouldn't" $ do
521 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
522 let testHighlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]
524 let search = mkHighlightSearch (Just query) testHighlight
525 myHighlight <- searchTweetHighlight search
526 myHighlight `shouldBe` Right Nothing
530 describe "ToJSON RegexpFlags" $ do
531 it "generates the correct JSON for AllRegexpFlags" $
532 toJSON AllRegexpFlags `shouldBe` String "ALL"
534 it "generates the correct JSON for NoRegexpFlags" $
535 toJSON NoRegexpFlags `shouldBe` String "NONE"
537 it "generates the correct JSON for SomeRegexpFlags" $
538 let flags = AnyString :| [ Automaton
543 in toJSON (SomeRegexpFlags flags) `shouldBe` String "ANYSTRING|AUTOMATON|COMPLEMENT|EMPTY|INTERSECTION|INTERVAL"
545 prop "removes duplicates from flags" $ \(flags :: RegexpFlags) ->
546 let String str = toJSON flags
547 flagStrs = T.splitOn "|" str
548 in noDuplicates flagStrs
550 describe "omitNulls" $ do
551 it "checks that omitNulls drops list elements when it should" $
552 let dropped = omitNulls $ [ "test1" .= (toJSON ([] :: [Int]))
553 , "test2" .= (toJSON ("some value" :: Text))]
554 in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")])
556 it "checks that omitNulls doesn't drop list elements when it shouldn't" $
557 let notDropped = omitNulls $ [ "test1" .= (toJSON ([1] :: [Int]))
558 , "test2" .= (toJSON ("some value" :: Text))]
559 in notDropped `shouldBe` Object (HM.fromList [ ("test1", Array (V.fromList [Number 1.0]))
560 , ("test2", String "some value")])
561 it "checks that omitNulls drops non list elements when it should" $
562 let dropped = omitNulls $ [ "test1" .= (toJSON Null)
563 , "test2" .= (toJSON ("some value" :: Text))]
564 in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")])
565 it "checks that omitNulls doesn't drop non list elements when it shouldn't" $
566 let notDropped = omitNulls $ [ "test1" .= (toJSON (1 :: Int))
567 , "test2" .= (toJSON ("some value" :: Text))]
568 in notDropped `shouldBe` Object (HM.fromList [ ("test1", Number 1.0)
569 , ("test2", String "some value")])
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list