Fix bugs with constant score filter/queries

src/Database/Bloodhound/Client.hs

@@ -57,6 +57,7 @@ module Database.Bloodhound.Client
        , isVersionConflict
        , isSuccess
        , isCreated
+       , parseEsResponse
        )
        where
 
@@ -287,15 +288,16 @@ parseEsResponse :: (MonadBH m, MonadThrow m, FromJSON a) => Reply
 parseEsResponse reply
   | respIsTwoHunna reply = case eitherDecode body of
                              Right a -> return (Right a)
-                             Left _ -> case eitherDecode body of
-                                         Right e -> return (Left e)
-                                         -- this case should not be possible
-                                         Left _ -> explode
-  | otherwise = explode
+                             Left _ -> tryParseError
+  | otherwise = tryParseError
   where body = responseBody reply
         stat = responseStatus reply
         hdrs = responseHeaders reply
         cookies = responseCookieJar reply
+        tryParseError = case eitherDecode body of
+                          Right e -> return (Left e)
+                          -- this case should not be possible
+                          Left _ -> explode
         explode = throwM (StatusCodeException stat hdrs cookies)
 
 -- | 'indexExists' enables you to check if an index exists. Returns 'Bool'

src/Database/Bloodhound/Types.hs

@@ -1825,12 +1825,12 @@ instance ToJSON Query where
     object [ "common" .= commonTermsQuery ]
 
   toJSON (ConstantScoreFilter csFilter boost) =
-    object ["filter" .= object ["constant_score" .= csFilter]
-           , "boost" .= boost]
+    object ["constant_score" .= object ["filter" .= csFilter
+                                       , "boost" .= boost]]
 
   toJSON (ConstantScoreQuery query boost) =
-    object ["query" .= object ["constant_score" .= query]
-           , "boost" .= boost]
+    object ["constant_score" .= object ["query" .= query
+                                       , "boost" .= boost]]
 
   toJSON (QueryDisMaxQuery disMaxQuery) =
     object [ "dis_max" .= disMaxQuery ]
@@ -1891,8 +1891,8 @@ instance FromJSON Query where
                 <|> queryBoolQuery `taggedWith` "bool"
                 <|> queryBoostingQuery `taggedWith` "boosting"
                 <|> queryCommonTermsQuery `taggedWith` "common"
-                <|> constantScoreFilter o
-                <|> constantScoreQuery o
+                <|> constantScoreFilter `taggedWith` "constant_score"
+                <|> constantScoreQuery `taggedWith` "constant_score"
                 <|> queryDisMaxQuery `taggedWith` "dis_max"
                 <|> queryFilteredQuery `taggedWith` "filtered"
                 <|> queryFuzzyLikeThisQuery `taggedWith` "fuzzy_like_this"
@@ -1926,15 +1926,14 @@ instance FromJSON Query where
           queryBoolQuery = pure . QueryBoolQuery
           queryBoostingQuery = pure . QueryBoostingQuery
           queryCommonTermsQuery = pure . QueryCommonTermsQuery
-          --FIXME: these are ambiguous
           constantScoreFilter o = case HM.lookup "filter" o of
-            Just (Object o') -> ConstantScoreFilter <$> o' .: "constant_score"
-                                                    <*> o .: "boost"
+            Just x -> ConstantScoreFilter <$> parseJSON x
+                                          <*> o .: "boost"
             _ -> fail "Does not appear to be a ConstantScoreFilter"
           constantScoreQuery o = case HM.lookup "query" o of
-            Just (Object o') -> ConstantScoreQuery <$> o' .: "constant_score"
-                                                   <*> o .: "boost"
-            _ -> fail "Does not appear to be a ConstantScoreFilter"
+            Just x -> ConstantScoreQuery <$> parseJSON x
+                                         <*> o .: "boost"
+            _ -> fail "Does not appear to be a ConstantScoreQuery"
           queryDisMaxQuery = pure . QueryDisMaxQuery
           queryFilteredQuery = pure . QueryFilteredQuery
           queryFuzzyLikeThisQuery = pure . QueryFuzzyLikeThisQuery

tests/tests.hs

@@ -211,15 +211,15 @@ insertWithSpaceInId = do
   _ <- refreshIndex testIndex
   return ()
 
-searchTweet :: Search -> BH IO (Either String Tweet)
+searchTweet :: Search -> BH IO (Either EsError Tweet)
 searchTweet search = do
   result <- searchTweets search
-  let myTweet :: Either String Tweet
+  let myTweet :: Either EsError Tweet
       myTweet = grabFirst result
   return myTweet
 
-searchTweets :: Search -> BH IO (Either String (SearchResult Tweet))
-searchTweets search = eitherDecode . responseBody <$> searchByIndex testIndex search
+searchTweets :: Search -> BH IO (Either EsError (SearchResult Tweet))
+searchTweets search = parseEsResponse =<< searchByIndex testIndex search
 
 searchExpectNoResults :: Search -> BH IO ()
 searchExpectNoResults search = do
@@ -253,19 +253,19 @@ searchTermsAggHint hints = do
       forM_ hints $ searchExpectAggs . search
       forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
 
-searchTweetHighlight :: Search -> BH IO (Either String (Maybe HitHighlight))
+searchTweetHighlight :: Search -> BH IO (Either EsError (Maybe HitHighlight))
 searchTweetHighlight search = do
   result <- searchTweets search
   let myHighlight = fmap (hitHighlight . head . hits . searchHits) result
   return myHighlight
 
-searchExpectSource :: Source -> Either String Value -> BH IO ()
+searchExpectSource :: Source -> Either EsError Value -> BH IO ()
 searchExpectSource src expected = do
   _ <- insertData
   let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
   let search = (mkSearch (Just query) Nothing) { source = Just src }
   reply <- searchAll search
-  let result = eitherDecode (responseBody reply) :: Either String (SearchResult Value)
+  result <- parseEsResponse reply--  :: Either EsError (SearchResult Value)
   let value = grabFirst result
   liftIO $
     value `shouldBe` expected
@@ -307,11 +307,11 @@ reduceSize f = sized $ \n -> resize (n `div` 2) f
 getSource :: EsResult a -> Maybe a
 getSource = fmap _source . foundResult
 
-grabFirst :: Either String (SearchResult a) -> Either String a
+grabFirst :: Either EsError (SearchResult a) -> Either EsError a
 grabFirst r =
   case fmap (hitSource . head . hits . searchHits) r of
     (Left e) -> Left e
-    (Right Nothing) -> Left "Source was missing"
+    (Right Nothing) -> Left (EsError 500 "Source was missing")
     (Right (Just x)) -> Right x
 
 -------------------------------------------------------------------------------
@@ -611,6 +611,26 @@ main = hspec $ do
       liftIO $
         myTweet `shouldBe` Right exampleTweet
 
+    it "handles constant score queries" $ withTestEnv $ do
+      _ <- insertData
+      let query = TermsQuery "user" ("bitemyapp" :| [])
+      let cfQuery = ConstantScoreQuery query (Boost 1.0)
+      let filter = IdentityFilter
+      let search = mkSearch (Just cfQuery) (Just filter)
+      myTweet <- searchTweet search
+      liftIO $
+        myTweet `shouldBe` Right exampleTweet
+    it "handles constant score filters" $ withTestEnv $ do
+      _ <- insertData
+      let query = TermsQuery "user" ("bitemyapp" :| [])
+      let cfFilter = ConstantScoreFilter IdentityFilter (Boost 1.0)
+      let boolQuery = mkBoolQuery [query, cfFilter] [] []
+      let search = mkSearch (Just (QueryBoolQuery boolQuery)) Nothing
+      myTweet <- searchTweet search
+      liftIO $
+        myTweet `shouldBe` Right exampleTweet
+
+
     it "returns document for terms query and identity filter" $ withTestEnv $ do
       _ <- insertData
       let query = TermsQuery "user" ("bitemyapp" :| [])
@@ -946,7 +966,7 @@ main = hspec $ do
     it "doesn't include source when sources are disabled" $ withTestEnv $ do
       searchExpectSource
         NoSource
-        (Left "Source was missing")
+        (Left (EsError 500 "Source was missing"))
 
     it "includes a source" $ withTestEnv $ do
       searchExpectSource