diff --git a/bloodhound.cabal b/bloodhound.cabal --- a/bloodhound.cabal +++ b/bloodhound.cabal @@ -1,7 +1,7 @@ cabal-version: 3.4 name: bloodhound -version: 0.25.0.0 +version: 0.26.0.0 synopsis: Elasticsearch client library for Haskell description: Elasticsearch made awesome for Haskell hackers category: Database, Search diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,14 @@ +0.26.0.0 +======== +- @blackheaven + - breaking: change `DateHistogramAggregation.dateInterval` from `Interval` to `Maybe Interval` + - breaking: change `mkDateHistogram` signature from `FieldName -> Interval -> DateHistogramAggregation` to `FieldName -> DateHistogramAggregation` + - breaking: replace `TermsAggregation.term` from `Either Text Text` to `TermsAggregationTarget` + - breaking: change `mkTermsAggregation` signature from `Text -> TermsAggregation` to `FieldName -> TermsAggregation` + - feat: add `IntervalFixed` constructor to `Interval` sum type + - feat: add `bhResponseHook` to `BHEnv` for post-response debugging/processing + - feat: add `TermsAggregationTarget` sum type with `TermsAggregationTargetField` and `TermsAggregationTargetScript` constructors + 0.25.0.0 ======== - @blackheaven diff --git a/src/Database/Bloodhound/Client/Cluster.hs b/src/Database/Bloodhound/Client/Cluster.hs --- a/src/Database/Bloodhound/Client/Cluster.hs +++ b/src/Database/Bloodhound/Client/Cluster.hs @@ -50,7 +50,9 @@ { bhServer :: Server, bhManager :: HTTP.Manager, -- | Low-level hook that is run before every request is sent. Used to implement custom authentication strategies. Defaults to 'return' with 'mkBHEnv'. - bhRequestHook :: HTTP.Request -> IO HTTP.Request + bhRequestHook :: HTTP.Request -> IO HTTP.Request, + -- | Low-level hook that is run after every response is received. Used to debug. Defaults to 'return' with 'mkBHEnv'. + bhResponseHook :: HTTP.Response L.ByteString -> IO (HTTP.Response L.ByteString) } -- | All API calls to Elasticsearch operate within @@ -86,7 +88,7 @@ -- -- >> (mkBHEnv myServer myManager) { bhRequestHook = customHook } mkBHEnv :: Server -> HTTP.Manager -> BHEnv -mkBHEnv s m = BHEnv s m return +mkBHEnv s m = BHEnv s m return return -- | Basic BH implementation newtype BH m a = BH @@ -121,28 +123,26 @@ type Backend (BH m) = 'Dynamic dispatch request = BH $ do env <- ask @BHEnv - let url = getEndpoint (bhServer env) (bhRequestEndpoint request) - initReq <- liftIO $ parseUrl' url - let reqHook = bhRequestHook env - let reqBody = HTTP.RequestBodyLBS $ fromMaybe emptyBody $ bhRequestBody request - let setQueryStrings = - case bhRequestQueryStrings request of - [] -> id - xs -> HTTP.setQueryString xs - req <- - liftIO $ - reqHook $ + liftIO $ do + initReq <- parseUrl' $ getEndpoint (bhServer env) (bhRequestEndpoint request) + let setQueryStrings = + case bhRequestQueryStrings request of + [] -> id + xs -> HTTP.setQueryString xs + req <- + bhRequestHook env $ HTTP.setRequestIgnoreStatus $ setQueryStrings $ initReq { HTTP.method = bhRequestMethod request, HTTP.requestHeaders = ("Content-Type", "application/json") : HTTP.requestHeaders initReq, - HTTP.requestBody = reqBody + HTTP.requestBody = HTTP.RequestBodyLBS $ fromMaybe emptyBody $ bhRequestBody request } - let mgr = bhManager env - BHResponse <$> liftIO (HTTP.httpLbs req mgr) + let mgr = bhManager env + rawResp <- HTTP.httpLbs req mgr + BHResponse <$> bhResponseHook env rawResp tryEsError = try throwEsError = throwM diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Aggregation.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Aggregation.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Aggregation.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Aggregation.hs @@ -147,7 +147,7 @@ omitNulls [ "terms" .= omitNulls - [ toJSON' term, + [ mkTarget term, "include" .= include, "exclude" .= exclude, "order" .= order, @@ -160,7 +160,9 @@ "aggs" .= termAggs ] where - toJSON' x = case x of Left y -> "field" .= y; Right y -> "script" .= y + mkTarget x = case x of + TermsAggregationTargetField fn -> "field" .= fn + TermsAggregationTargetScript scr -> "script" .= scr toJSON (CardinalityAgg (CardinalityAggregation field precisionThreshold missing)) = object [ "cardinality" @@ -270,7 +272,7 @@ topHitsAggregationSortLens :: Lens' TopHitsAggregation (Maybe Sort) topHitsAggregationSortLens = lens taSort (\x y -> x {taSort = y}) -data MissingAggregation = MissingAggregation +newtype MissingAggregation = MissingAggregation { maField :: Text } deriving stock (Eq, Show) @@ -279,7 +281,7 @@ missingAggregationFieldLens = lens maField (\x y -> x {maField = y}) data TermsAggregation = TermsAggregation - { term :: Either Text Text, + { term :: TermsAggregationTarget, termInclude :: Maybe TermInclusion, termExclude :: Maybe TermInclusion, termOrder :: Maybe TermOrder, @@ -292,7 +294,7 @@ } deriving stock (Eq, Show) -termAggregationTermLens :: Lens' TermsAggregation (Either Text Text) +termAggregationTermLens :: Lens' TermsAggregation TermsAggregationTarget termAggregationTermLens = lens term (\x y -> x {term = y}) termAggregationIncludeLens :: Lens' TermsAggregation (Maybe TermInclusion) @@ -322,6 +324,27 @@ termAggregationAggsLens :: Lens' TermsAggregation (Maybe Aggregations) termAggregationAggsLens = lens termAggs (\x y -> x {termAggs = y}) +data TermsAggregationTarget + = TermsAggregationTargetField FieldName + | TermsAggregationTargetScript Text + deriving stock (Eq, Show) + +termsAggregationTargetTermsAggregationTargetFieldPrism :: Prism' TermsAggregationTarget FieldName +termsAggregationTargetTermsAggregationTargetFieldPrism = prism TermsAggregationTargetField extract + where + extract s = + case s of + TermsAggregationTargetField x -> Right x + _ -> Left s + +termsAggregationTargetTermsAggregationTargetScriptPrism :: Prism' TermsAggregationTarget Text +termsAggregationTargetTermsAggregationTargetScriptPrism = prism TermsAggregationTargetScript extract + where + extract s = + case s of + TermsAggregationTargetScript x -> Right x + _ -> Left s + data CardinalityAggregation = CardinalityAggregation { cardinalityField :: FieldName, cardinalityPrecisionThreshold :: Maybe PrecisionThreshold, @@ -340,7 +363,7 @@ data DateHistogramAggregation = DateHistogramAggregation { dateField :: FieldName, - dateInterval :: Interval, + dateInterval :: Maybe Interval, dateFormat :: Maybe Text, -- pre and post deprecated in 1.5 datePreZone :: Maybe Text, @@ -362,7 +385,7 @@ dateHistogramAggregationFieldLens :: Lens' DateHistogramAggregation FieldName dateHistogramAggregationFieldLens = lens dateField (\x y -> x {dateField = y}) -dateHistogramAggregationIntervalLens :: Lens' DateHistogramAggregation Interval +dateHistogramAggregationIntervalLens :: Lens' DateHistogramAggregation (Maybe Interval) dateHistogramAggregationIntervalLens = lens dateInterval (\x y -> x {dateInterval = y}) dateHistogramAggregationFormatLens :: Lens' DateHistogramAggregation (Maybe Text) @@ -529,10 +552,10 @@ medianAbsoluteDeviationAggregationMissingLens :: Lens' MedianAbsoluteDeviationAggregation (Maybe Missing) medianAbsoluteDeviationAggregationMissingLens = lens medianAbsoluteDeviationAggregationMissing (\x y -> x {medianAbsoluteDeviationAggregationMissing = y}) -mkTermsAggregation :: Text -> TermsAggregation +mkTermsAggregation :: FieldName -> TermsAggregation mkTermsAggregation t = TermsAggregation - (Left t) + (TermsAggregationTargetField t) Nothing Nothing Nothing @@ -544,10 +567,10 @@ Nothing mkTermsScriptAggregation :: Text -> TermsAggregation -mkTermsScriptAggregation t = TermsAggregation (Right t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing +mkTermsScriptAggregation t = TermsAggregation (TermsAggregationTargetScript t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing -mkDateHistogram :: FieldName -> Interval -> DateHistogramAggregation -mkDateHistogram t i = DateHistogramAggregation t i Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing +mkDateHistogram :: FieldName -> DateHistogramAggregation +mkDateHistogram t = DateHistogramAggregation t Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing mkCardinalityAggregation :: FieldName -> CardinalityAggregation mkCardinalityAggregation t = CardinalityAggregation t Nothing Nothing diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Script.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Script.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Script.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Script.hs @@ -156,9 +156,9 @@ singleScript `taggedWith` "script_score" <|> singleRandom - `taggedWith` "random_score" + `taggedWith` "random_score" <|> singleFieldValueFactor - `taggedWith` "field_value_factor" + `taggedWith` "field_value_factor" where taggedWith parser k = parser =<< o .: k singleScript = pure . FunctionScoreFunctionScript diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Units.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Units.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Units.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Units.hs @@ -87,17 +87,21 @@ | Hour | Minute | Second + | IntervalFixed FixedInterval deriving stock (Eq, Show) instance ToJSON Interval where - toJSON Year = "year" - toJSON Quarter = "quarter" - toJSON Month = "month" - toJSON Week = "week" - toJSON Day = "day" - toJSON Hour = "hour" - toJSON Minute = "minute" - toJSON Second = "second" + toJSON x = + case x of + Year -> "year" + Quarter -> "quarter" + Month -> "month" + Week -> "week" + Day -> "day" + Hour -> "hour" + Minute -> "minute" + Second -> "second" + IntervalFixed i -> toJSON i parseStringInterval :: (Monad m, MonadFail m) => String -> m NominalDiffTime parseStringInterval s = case span isNumber s of diff --git a/tests/Test/AggregationSpec.hs b/tests/Test/AggregationSpec.hs --- a/tests/Test/AggregationSpec.hs +++ b/tests/Test/AggregationSpec.hs @@ -14,7 +14,7 @@ it "returns term aggregation results" $ withTestEnv $ do _ <- insertData - let terms = TermsAgg $ mkTermsAggregation "user" + let terms = TermsAgg $ mkTermsAggregation $ FieldName "user" let search = mkAggregateSearch Nothing $ mkAggregations "users" terms searchExpectAggs search searchValidBucketAgg search "users" toTerms @@ -22,8 +22,8 @@ it "return sub-aggregation results" $ withTestEnv $ do _ <- insertData - let subaggs = mkAggregations "age_agg" . TermsAgg $ mkTermsAggregation "age" - agg = TermsAgg $ (mkTermsAggregation "user") {termAggs = Just subaggs} + let subaggs = mkAggregations "age_agg" . TermsAgg $ mkTermsAggregation $ FieldName "age" + agg = TermsAgg $ (mkTermsAggregation $ FieldName "user") {termAggs = Just subaggs} search = mkAggregateSearch Nothing $ mkAggregations "users" agg result <- performBHRequest $ searchByIndex @Tweet testIndex search let usersAggResults = aggregations result >>= toTerms "users" @@ -67,7 +67,7 @@ it "can give collection hint parameters to term aggregations" $ withTestEnv $ do _ <- insertData - let terms = TermsAgg $ (mkTermsAggregation "user") {termCollectMode = Just BreadthFirst} + let terms = TermsAgg $ (mkTermsAggregation $ FieldName "user") {termCollectMode = Just BreadthFirst} let search = mkAggregateSearch Nothing $ mkAggregations "users" terms searchExpectAggs search searchValidBucketAgg search "users" toTerms @@ -124,30 +124,31 @@ let fromMonthT = UTCTime (fromGregorian 2015 2 14) 0 let fromWeekT = UTCTime (fromGregorian 2015 3 7) 0 liftIO $ - buckets <$> bucks - `shouldBe` Right - [ DateRangeResult - "2015-02-14T00:00:00.000Z-*" - (Just fromMonthT) - (Just "2015-02-14T00:00:00.000Z") - Nothing - Nothing - 2 - Nothing, - DateRangeResult - "2015-03-07T00:00:00.000Z-*" - (Just fromWeekT) - (Just "2015-03-07T00:00:00.000Z") - Nothing - Nothing - 1 - Nothing - ] + buckets + <$> bucks + `shouldBe` Right + [ DateRangeResult + "2015-02-14T00:00:00.000Z-*" + (Just fromMonthT) + (Just "2015-02-14T00:00:00.000Z") + Nothing + Nothing + 2 + Nothing, + DateRangeResult + "2015-03-07T00:00:00.000Z-*" + (Just fromWeekT) + (Just "2015-03-07T00:00:00.000Z") + Nothing + Nothing + 1 + Nothing + ] it "returns date histogram aggregation results" $ withTestEnv $ do _ <- insertData - let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute + let histogram = DateHistogramAgg (mkDateHistogram (FieldName "postDate")) {dateInterval = Just Minute} let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram) searchExpectAggs search searchValidBucketAgg search "byDate" toDateHistogram diff --git a/tests/TestsUtils/Common.hs b/tests/TestsUtils/Common.hs --- a/tests/TestsUtils/Common.hs +++ b/tests/TestsUtils/Common.hs @@ -278,7 +278,7 @@ searchTermsAggHint :: [ExecutionHint] -> BH IO () searchTermsAggHint hints = do - let terms hint = TermsAgg $ (mkTermsAggregation "user.keyword") {termExecutionHint = Just hint} + let terms hint = TermsAgg $ (mkTermsAggregation $ FieldName "user.keyword") {termExecutionHint = Just hint} let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint forM_ hints $ searchExpectAggs . search