1{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE ScopedTypeVariables #-}
6import Control.Applicative
9import Data.HashMap.Strict (fromList)
11import Data.List.NonEmpty (NonEmpty (..))
12import qualified Data.Map.Strict as M
13import Data.Text (Text)
14import qualified Data.Text as T
15import Data.Time.Calendar (Day (..))
16import Data.Time.Clock (UTCTime (..), secondsToDiffTime)
17import qualified Data.Vector as V
18import Database.Bloodhound
19import GHC.Generics (Generic)
20import Network.HTTP.Client
21import qualified Network.HTTP.Types.Status as NHTS
22import Prelude hiding (filter, putStrLn)
25import Test.Hspec.QuickCheck (prop)
29testServer = Server "http://localhost:9200"
31testIndex = IndexName "bloodhound-tests-twitter-1"
32testMapping :: MappingName
33testMapping = MappingName "tweet"
35validateStatus :: Response body -> Int -> Expectation
36validateStatus resp expected =
37 (NHTS.statusCode $ responseStatus resp)
38 `shouldBe` (expected :: Int)
40createExampleIndex :: IO Reply
41createExampleIndex = createIndex testServer defaultIndexSettings testIndex
42deleteExampleIndex :: IO Reply
43deleteExampleIndex = deleteIndex testServer testIndex
45data ServerVersion = ServerVersion Int Int Int deriving (Show, Eq, Ord)
48es14 = ServerVersion 1 4 0
51es13 = ServerVersion 1 3 0
54es12 = ServerVersion 1 2 0
57es11 = ServerVersion 1 1 0
60es10 = ServerVersion 1 0 0
62serverBranch :: ServerVersion -> ServerVersion
63serverBranch (ServerVersion majorVer minorVer patchVer) =
64 ServerVersion majorVer minorVer patchVer
66mkServerVersion :: [Int] -> Maybe ServerVersion
67mkServerVersion [majorVer, minorVer, patchVer] =
68 Just (ServerVersion majorVer minorVer patchVer)
69mkServerVersion _ = Nothing
71getServerVersion :: Server -> IO (Maybe ServerVersion)
72getServerVersion s = liftM extractVersion (getStatus s)
74 version' = T.splitOn "." . number . version
75 toInt = read . T.unpack
76 parseVersion v = map toInt (version' v)
77 extractVersion = join . liftM (mkServerVersion . parseVersion)
81testServerBranch :: IO (Maybe ServerVersion)
82testServerBranch = getServerVersion testServer >>= \v -> return $ liftM serverBranch v
84atleast :: ServerVersion -> IO Bool
85atleast v = testServerBranch >>= \x -> return $ x >= Just (serverBranch v)
87atmost :: ServerVersion -> IO Bool
88atmost v = testServerBranch >>= \x -> return $ x <= Just (serverBranch v)
90is :: ServerVersion -> IO Bool
91is v = testServerBranch >>= \x -> return $ x == Just (serverBranch v)
93when' :: Monad m => m Bool -> m () -> m ()
94when' b f = b >>= \x -> when x f
96data Location = Location { lat :: Double
97 , lon :: Double } deriving (Eq, Generic, Show)
99data Tweet = Tweet { user :: Text
100 , postDate :: UTCTime
103 , location :: Location }
104 deriving (Eq, Generic, Show)
107instance FromJSON Tweet
108instance ToJSON Location
109instance FromJSON Location
111data TweetMapping = TweetMapping deriving (Eq, Show)
113instance ToJSON TweetMapping where
114 toJSON TweetMapping =
116 object ["properties" .=
117 object ["location" .= object ["type" .= ("geo_point" :: Text)]]]]
120exampleTweet = Tweet { user = "bitemyapp"
122 (ModifiedJulianDay 55000)
123 (secondsToDiffTime 10)
124 , message = "Use haskell!"
126 , location = Location 40.12 (-71.34) }
129otherTweet = Tweet { user = "notmyapp"
131 (ModifiedJulianDay 55000)
132 (secondsToDiffTime 11)
133 , message = "Use haskell!"
135 , location = Location 40.12 (-71.34) }
139 _ <- deleteExampleIndex
140 _ <- createExampleIndex
141 _ <- putMapping testServer testIndex testMapping TweetMapping
142 _ <- indexDocument testServer testIndex testMapping exampleTweet (DocId "1")
143 _ <- refreshIndex testServer testIndex
148 _ <- indexDocument testServer testIndex testMapping otherTweet (DocId "2")
149 _ <- refreshIndex testServer testIndex
152searchTweet :: Search -> IO (Either String Tweet)
153searchTweet search = do
154 reply <- searchByIndex testServer testIndex search
155 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
156 let myTweet = fmap (hitSource . head . hits . searchHits) result
159searchExpectNoResults :: Search -> IO ()
160searchExpectNoResults search = do
161 reply <- searchByIndex testServer testIndex search
162 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
163 let emptyHits = fmap (hits . searchHits) result
164 emptyHits `shouldBe` Right []
166searchExpectAggs :: Search -> IO ()
167searchExpectAggs search = do
168 reply <- searchAll testServer search
169 let isEmpty x = return (M.null x)
170 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
171 (result >>= aggregations >>= isEmpty) `shouldBe` Just False
173searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) => Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> IO ()
174searchValidBucketAgg search aggKey extractor = do
175 reply <- searchAll testServer search
176 let bucketDocs = docCount . head . buckets
177 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
178 let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x)
179 count `shouldBe` Just 1
181searchTermsAggHint :: [ExecutionHint] -> IO ()
182searchTermsAggHint hints = do
183 let terms hint = TermsAgg $ (mkTermsAggregation "user") { termExecutionHint = Just hint }
184 let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint
185 forM_ hints $ searchExpectAggs . search
186 forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
188searchTweetHighlight :: Search -> IO (Either String (Maybe HitHighlight))
189searchTweetHighlight search = do
190 reply <- searchByIndex testServer testIndex search
191 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
192 let myHighlight = fmap (hitHighlight . head . hits . searchHits) result
195data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
196instance FromJSON BulkTest
197instance ToJSON BulkTest
199noDuplicates :: Eq a => [a] -> Bool
200noDuplicates xs = nub xs == xs
202instance Arbitrary RegexpFlags where
203 arbitrary = oneof [ pure AllRegexpFlags
205 , SomeRegexpFlags <$> arbitrary
208instance Arbitrary a => Arbitrary (NonEmpty a) where
209 arbitrary = liftA2 (:|) arbitrary arbitrary
211instance Arbitrary RegexpFlag where
212 arbitrary = oneof [ pure AnyString
223 describe "index create/delete API" $ do
224 it "creates and then deletes the requested index" $ do
226 _ <- deleteExampleIndex
227 resp <- createExampleIndex
228 deleteResp <- deleteExampleIndex
229 validateStatus resp 200
230 validateStatus deleteResp 200
233 describe "document API" $ do
234 it "indexes, gets, and then deletes the generated document" $ do
236 docInserted <- getDocument testServer testIndex testMapping (DocId "1")
237 let newTweet = eitherDecode
238 (responseBody docInserted) :: Either String (EsResult Tweet)
239 fmap _source newTweet `shouldBe` Right exampleTweet
242 describe "bulk API" $ do
243 it "inserts all documents we request" $ do
245 let firstTest = BulkTest "blah"
246 let secondTest = BulkTest "bloo"
247 let firstDoc = BulkIndex testIndex
248 testMapping (DocId "2") (toJSON firstTest)
249 let secondDoc = BulkCreate testIndex
250 testMapping (DocId "3") (toJSON secondTest)
251 let stream = V.fromList [firstDoc, secondDoc]
252 _ <- bulk testServer stream
253 _ <- refreshIndex testServer testIndex
254 fDoc <- getDocument testServer testIndex testMapping (DocId "2")
255 sDoc <- getDocument testServer testIndex testMapping (DocId "3")
256 let maybeFirst = eitherDecode $ responseBody fDoc :: Either String (EsResult BulkTest)
257 let maybeSecond = eitherDecode $ responseBody sDoc :: Either String (EsResult BulkTest)
258 fmap _source maybeFirst `shouldBe` Right firstTest
259 fmap _source maybeSecond `shouldBe` Right secondTest
262 describe "query API" $ do
263 it "returns document for term query and identity filter" $ do
265 let query = TermQuery (Term "user" "bitemyapp") Nothing
266 let filter = IdentityFilter <&&> IdentityFilter
267 let search = mkSearch (Just query) (Just filter)
268 myTweet <- searchTweet search
269 myTweet `shouldBe` Right exampleTweet
271 it "returns document for match query" $ do
273 let query = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
274 let search = mkSearch (Just query) Nothing
275 myTweet <- searchTweet search
276 myTweet `shouldBe` Right exampleTweet
278 it "returns document for multi-match query" $ do
280 let fields = [FieldName "user", FieldName "message"]
281 let query = QueryMultiMatchQuery $ mkMultiMatchQuery fields (QueryString "bitemyapp")
282 let search = mkSearch (Just query) Nothing
283 myTweet <- searchTweet search
284 myTweet `shouldBe` Right exampleTweet
286 it "returns document for bool query" $ do
288 let innerQuery = QueryMatchQuery $
289 mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
290 let query = QueryBoolQuery $
291 mkBoolQuery [innerQuery] [] []
292 let search = mkSearch (Just query) Nothing
293 myTweet <- searchTweet search
294 myTweet `shouldBe` Right exampleTweet
296 it "returns document for boosting query" $ do
298 let posQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
299 let negQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "notmyapp")
300 let query = QueryBoostingQuery $ BoostingQuery posQuery negQuery (Boost 0.2)
301 let search = mkSearch (Just query) Nothing
302 myTweet <- searchTweet search
303 myTweet `shouldBe` Right exampleTweet
305 it "returns document for common terms query" $ do
307 let query = QueryCommonTermsQuery $
308 CommonTermsQuery (FieldName "user")
309 (QueryString "bitemyapp")
310 (CutoffFrequency 0.0001)
311 Or Or Nothing Nothing Nothing Nothing
312 let search = mkSearch (Just query) Nothing
313 myTweet <- searchTweet search
314 myTweet `shouldBe` Right exampleTweet
317 describe "sorting" $ do
318 it "returns documents in the right order" $ do
321 let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
322 let search = Search Nothing
323 (Just IdentityFilter) (Just [sortSpec]) Nothing Nothing
325 reply <- searchByIndex testServer testIndex search
326 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
327 let myTweet = fmap (hitSource . head . hits . searchHits) result
328 myTweet `shouldBe` Right otherTweet
331 describe "filtering API" $ do
332 it "returns document for composed boolmatch and identity" $ do
334 let queryFilter = BoolFilter (MustMatch (Term "user" "bitemyapp") False)
336 let search = mkSearch Nothing (Just queryFilter)
337 myTweet <- searchTweet search
338 myTweet `shouldBe` Right exampleTweet
340 it "returns document for term filter" $ do
342 let termFilter = TermFilter (Term "user" "bitemyapp") False
343 let search = mkSearch Nothing (Just termFilter)
344 myTweet <- searchTweet search
345 myTweet `shouldBe` Right exampleTweet
347 it "returns document for existential filter" $ do
349 let search = mkSearch Nothing (Just (ExistsFilter (FieldName "user")))
350 myTweet <- searchTweet search
351 myTweet `shouldBe` Right exampleTweet
353 it "returns document for geo boundingbox filter" $ do
355 let box = GeoBoundingBox (LatLon 40.73 (-74.1)) (LatLon 40.10 (-71.12))
356 let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False GeoFilterMemory
357 let geoFilter = GeoBoundingBoxFilter bbConstraint
358 let search = mkSearch Nothing (Just geoFilter)
359 myTweet <- searchTweet search
360 myTweet `shouldBe` Right exampleTweet
362 it "doesn't return document for nonsensical boundingbox filter" $ do
364 let box = GeoBoundingBox (LatLon 0.73 (-4.1)) (LatLon 0.10 (-1.12))
365 let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False GeoFilterMemory
366 let geoFilter = GeoBoundingBoxFilter bbConstraint
367 let search = mkSearch Nothing (Just geoFilter)
368 searchExpectNoResults search
370 it "returns document for geo distance filter" $ do
372 let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
373 let distance = Distance 10.0 Miles
374 let optimizeBbox = OptimizeGeoFilterType GeoFilterMemory
375 let geoFilter = GeoDistanceFilter geoPoint distance SloppyArc optimizeBbox False
376 let search = mkSearch Nothing (Just geoFilter)
377 myTweet <- searchTweet search
378 myTweet `shouldBe` Right exampleTweet
380 it "returns document for geo distance range filter" $ do
382 let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
383 let distanceRange = DistanceRange (Distance 0.0 Miles) (Distance 10.0 Miles)
384 let geoFilter = GeoDistanceRangeFilter geoPoint distanceRange
385 let search = mkSearch Nothing (Just geoFilter)
386 myTweet <- searchTweet search
387 myTweet `shouldBe` Right exampleTweet
389 it "doesn't return document for wild geo distance range filter" $ do
391 let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
392 let distanceRange = DistanceRange (Distance 100.0 Miles) (Distance 1000.0 Miles)
393 let geoFilter = GeoDistanceRangeFilter geoPoint distanceRange
394 let search = mkSearch Nothing (Just geoFilter)
395 searchExpectNoResults search
397 it "returns document for geo polygon filter" $ do
399 let points = [LatLon 40.0 (-70.00),
400 LatLon 40.0 (-72.00),
401 LatLon 41.0 (-70.00),
402 LatLon 41.0 (-72.00)]
403 let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points
404 let search = mkSearch Nothing (Just geoFilter)
405 myTweet <- searchTweet search
406 myTweet `shouldBe` Right exampleTweet
408 it "doesn't return document for bad geo polygon filter" $ do
410 let points = [LatLon 40.0 (-70.00),
411 LatLon 40.0 (-71.00),
412 LatLon 41.0 (-70.00),
413 LatLon 41.0 (-71.00)]
414 let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points
415 let search = mkSearch Nothing (Just geoFilter)
416 searchExpectNoResults search
418 it "returns document for ids filter" $ do
420 let filter = IdsFilter (MappingName "tweet") [DocId "1"]
421 let search = mkSearch Nothing (Just filter)
422 myTweet <- searchTweet search
423 myTweet `shouldBe` Right exampleTweet
425 it "returns document for range filter" $ do
427 let filter = RangeFilter (FieldName "age")
428 (Right (RangeLtGt (LessThan 100000.0) (GreaterThan 1000.0)))
429 RangeExecutionIndex False
430 let search = mkSearch Nothing (Just filter)
431 myTweet <- searchTweet search
432 myTweet `shouldBe` Right exampleTweet
434 it "returns document for regexp filter" $ do
436 let filter = RegexpFilter (FieldName "user") (Regexp "bite.*app")
437 AllRegexpFlags (CacheName "test") False (CacheKey "key")
438 let search = mkSearch Nothing (Just filter)
439 myTweet <- searchTweet search
440 myTweet `shouldBe` Right exampleTweet
442 it "doesn't return document for non-matching regexp filter" $ do
444 let filter = RegexpFilter (FieldName "user")
445 (Regexp "boy") AllRegexpFlags
446 (CacheName "test") False (CacheKey "key")
447 let search = mkSearch Nothing (Just filter)
448 searchExpectNoResults search
450 describe "Aggregation API" $ do
451 it "returns term aggregation results" $ do
453 let terms = TermsAgg $ mkTermsAggregation "user"
454 let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
455 searchExpectAggs search
456 searchValidBucketAgg search "users" toTerms
458 it "can give collection hint parameters to term aggregations" $ when' (atleast es13) $ do
460 let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
461 let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
462 searchExpectAggs search
463 searchValidBucketAgg search "users" toTerms
465 it "can give execution hint paramters to term aggregations" $ when' (atmost es11) $ do
467 searchTermsAggHint [Map, Ordinals]
469 it "can give execution hint paramters to term aggregations" $ when' (is es12) $ do
471 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map, Ordinals]
473 it "can give execution hint paramters to term aggregations" $ when' (atleast es12) $ do
475 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map]
477 it "returns date histogram aggregation results" $ do
479 let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute
480 let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram)
481 searchExpectAggs search
482 searchValidBucketAgg search "byDate" toDateHistogram
484 it "returns date histogram using fractional date" $ do
486 let periods = [Year, Quarter, Month, Week, Day, Hour, Minute, Second]
487 let fractionals = map (FractionalInterval 1.5) [Weeks, Days, Hours, Minutes, Seconds]
488 let intervals = periods ++ fractionals
489 let histogram = mkDateHistogram (FieldName "postDate")
490 let search interval = mkAggregateSearch Nothing $ mkAggregations "byDate" $ DateHistogramAgg (histogram interval)
491 let expect interval = searchExpectAggs (search interval)
492 let valid interval = searchValidBucketAgg (search interval) "byDate" toDateHistogram
493 forM_ intervals expect
494 forM_ intervals valid
496 describe "Highlights API" $ do
498 it "returns highlight from query when there should be one" $ do
501 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
502 let highlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
504 let search = mkHighlightSearch (Just query) highlight
505 myHighlight <- searchTweetHighlight search
506 myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use <em>haskell</em>!"])]))
508 it "doesn't return highlight from a query when it shouldn't" $ do
511 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
512 let highlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]
514 let search = mkHighlightSearch (Just query) highlight
515 myHighlight <- searchTweetHighlight search
516 myHighlight `shouldBe` Right Nothing
520 describe "ToJSON RegexpFlags" $ do
521 it "generates the correct JSON for AllRegexpFlags" $
522 toJSON AllRegexpFlags `shouldBe` String "ALL"
524 it "generates the correct JSON for NoRegexpFlags" $
525 toJSON NoRegexpFlags `shouldBe` String "NONE"
527 it "generates the correct JSON for SomeRegexpFlags" $
528 let flags = AnyString :| [ Automaton
533 in toJSON (SomeRegexpFlags flags) `shouldBe` String "ANYSTRING|AUTOMATON|COMPLEMENT|EMPTY|INTERSECTION|INTERVAL"
535 prop "removes duplicates from flags" $ \(flags :: RegexpFlags) ->
536 let String str = toJSON flags
537 flagStrs = T.splitOn "|" str
538 in noDuplicates flagStrs
540 describe "omitNulls" $ do
541 it "checks that omitNulls drops list elements when it should" $
542 let dropped = omitNulls $ [ "test1" .= (toJSON ([] :: [Int]))
543 , "test2" .= (toJSON ("some value" :: Text))]
544 in dropped `shouldBe` Object (fromList [("test2", String "some value")])
546 it "checks that omitNulls doesn't drop list elements when it shouldn't" $
547 let notDropped = omitNulls $ [ "test1" .= (toJSON ([1] :: [Int]))
548 , "test2" .= (toJSON ("some value" :: Text))]
549 in notDropped `shouldBe` Object (fromList [ ("test1", Array (V.fromList [Number 1.0]))
550 , ("test2", String "some value")])
551 it "checks that omitNulls drops non list elements when it should" $
552 let dropped = omitNulls $ [ "test1" .= (toJSON Null)
553 , "test2" .= (toJSON ("some value" :: Text))]
554 in dropped `shouldBe` Object (fromList [("test2", String "some value")])
555 it "checks that omitNulls doesn't drop non list elements when it shouldn't" $
556 let notDropped = omitNulls $ [ "test1" .= (toJSON (1 :: Int))
557 , "test2" .= (toJSON ("some value" :: Text))]
558 in notDropped `shouldBe` Object (fromList [ ("test1", Number 1.0)
559 , ("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