chore: upgrade to bloodhound 0.26.0.0

cabal-override.project

@@ -53,7 +53,7 @@ constraints: any.Diff ==0.4.1,
              any.blaze-builder ==0.4.2.3,
              any.blaze-html ==0.9.2.0,
              any.blaze-markup ==0.8.3.0,
-             any.bloodhound ==0.19.1.0,
+             any.bloodhound ==0.26.0.0,
              any.boring ==0.2.2,
              any.bsb-http-chunked ==0.0.0.4,
              any.bugzilla-redhat ==1.0.1.1,
@@ -360,7 +360,7 @@ constraints: any.Diff ==0.4.1,
              any.yaml ==0.11.11.2,
              any.zigzag ==0.0.1.0,
              any.zlib ==0.6.3.0
-index-state: hackage.haskell.org 2025-01-06T16:40:37Z
+index-state: hackage.haskell.org 2025-10-19T21:24:34Z
 package proto3-suite
   flags: -swagger -large-records
 

monocle.cabal

@@ -125,7 +125,7 @@ library
                      , blaze-markup               >= 0.8.2.8
                      , blaze-html                 >= 0.9.1.2
                      , binary                     >= 0.8
-                     , bloodhound                 ^>= 0.19
+                     , bloodhound                 ^>= 0.26
                      , bugzilla-redhat            ^>= 1.0
                      , byteslice                  >= 0.2
                      , bytestring                 >= 0.10

nix/default.nix

@@ -118,11 +118,18 @@ let
     serialise = pkgs.haskell.lib.doJailbreak
       (pkgs.haskell.lib.dontCheck hpPrev.serialise);
 
-    # upgrade to bloodhound 0.20 needs some work
-    bloodhound = pkgs.haskell.lib.overrideCabal hpPrev.bloodhound {
-      version = "0.19.1.0";
-      sha256 = "sha256-QEN1wOLLUEsDKAbgz8ex0wfK/duNytvRYclwkBj/1G0=";
-    };
+    bloodhound = let
+      src = pkgs.fetchFromGitHub {
+        owner = "bitemyapp";
+        repo = "bloodhound";
+        rev = "601301754bc0c8d8002b1d3d7016530b357ee0c8"; # v0.26.0.0
+        sha256 = "sha256-Q5oVzHMp9OBCd2S+HlSDsSFGcqX7dFNVF/dpHKEspIc=";
+      };
+      pkg = hpPrev.callCabal2nix "bloodhound" src { };
+    in pkgs.lib.pipe pkg [
+      pkgs.haskell.lib.compose.doJailbreak
+      pkgs.haskell.lib.compose.dontCheck
+    ];
 
     # relax bound for doctest, ghc-prim, primitive, template-haskell, text and transformers
     proto3-wire = pkgs.haskell.lib.doJailbreak hpPrev.proto3-wire;

src/Database/Bloodhound/Raw.hs

@@ -13,54 +13,31 @@ module Database.Bloodhound.Raw (
   aggWithDocValues,
   mkAgg,
   mkTermsCompositeAgg,
-) where
+)
+where
 
 import Control.Monad.Catch (MonadThrow, throwM)
 import Data.Aeson
 import Data.Aeson qualified as Aeson
 import Data.Aeson.Casing.Internal qualified as AesonCasing
-import Data.Aeson.KeyMap qualified as KM
-import Data.Aeson.Types qualified as Aeson
-import Data.Text qualified as Text
+import Data.Map qualified as Map
+import Data.Text qualified as T
 import Data.Vector qualified as V
 import Database.Bloodhound qualified as BH
+import Database.Bloodhound.Common.Requests qualified as Query
 import Json.Extras qualified as Json
 import Monocle.Prelude
 import Network.HTTP.Client qualified as HTTP
 import Network.HTTP.Types.Method qualified as HTTP
+import Network.HTTP.Types.Status qualified as HTTP
 
 data ScrollRequest = NoScroll | GetScroll ByteString
 
-type QS = [(ByteString, Maybe ByteString)]
-
-dispatch ::
-  BH.MonadBH m =>
-  HTTP.Method ->
-  Text ->
-  LByteString ->
-  QS ->
-  m BH.Reply
-dispatch method url body qs = do
-  initReq <- liftIO $ HTTP.parseRequest (from url)
-  let request =
-        initReq
-          { HTTP.method = method
-          , HTTP.requestHeaders =
-              ("Content-Type", "application/json") : HTTP.requestHeaders initReq
-          , HTTP.requestBody = HTTP.RequestBodyLBS body
-          }
-  manager <- BH.bhManager <$> BH.getBHEnv
-  liftIO $ HTTP.httpLbs (setQs request) manager
- where
-  setQs = case qs of
-    [] -> id
-    xs -> HTTP.setQueryString xs
-
 -- | Utility function to advance in scroll result. We can use the BH library
 --   because we no longer need to support a custom raw body once we have a scroll.
-advance :: (MonadBH m, MonadThrow m, FromJSON resp) => BH.ScrollId -> m (BH.SearchResult resp)
+advance :: (MonadBH m, FromJSON resp) => BH.ScrollId -> m (BH.SearchResult resp)
 advance scroll = do
-  resp <- BH.advanceScroll scroll 60
+  resp <- BH.tryEsError $ BH.advanceScroll scroll 60
   case resp of
     Left err -> throwEsError "advance" err
     Right x -> pure x
@@ -69,22 +46,14 @@ throwEsError :: MonadThrow m => LByteString -> BH.EsError -> m a
 throwEsError resp err = throwM $ BH.EsProtocolException err.errorMessage resp
 
 settings :: (MonadBH m, ToJSON body) => BH.IndexName -> body -> m ()
-settings (BH.IndexName index) body = do
-  BH.Server s <- BH.bhServer <$> BH.getBHEnv
-  let url = Text.intercalate "/" [s, index, "_settings"]
+settings index body = do
+  let endpoint = BH.mkEndpoint [BH.unIndexName index, "_settings"]
       method = HTTP.methodPut
-  resp <- dispatch method url (Aeson.encode body) []
-  case HTTP.responseBody resp of
-    "{\"acknowledged\":true}" -> pure ()
+  resp <- BH.performBHRequest @_ @BH.StatusIndependant $ BH.mkFullRequest method endpoint (Aeson.encode body)
+  case resp of
+    BH.Acknowledged True -> pure ()
     _ -> error $ "Settings apply failed: " <> show resp
 
-search' :: (MonadBH m, ToJSON body) => BH.IndexName -> body -> QS -> m BH.Reply
-search' (BH.IndexName index) body qs = do
-  BH.Server s <- BH.bhServer <$> BH.getBHEnv
-  let url = Text.intercalate "/" [s, index, "_search"]
-      method = HTTP.methodPost
-  dispatch method url (Aeson.encode body) qs
-
 -- | Manual aeson casing implementation to create the search _source attribute
 --
 -- >>> aesonCasing "echangeCommitCount"
@@ -93,34 +62,26 @@ aesonCasing :: String -> String
 aesonCasing = AesonCasing.snakeCase . AesonCasing.dropFPrefix
 
 search ::
-  forall resp m body.
-  (MonadBH m, MonadThrow m) =>
-  (Aeson.ToJSON body, FromJSONField resp) =>
+  forall resp m.
+  MonadBH m =>
+  FromJSONField resp =>
   BH.IndexName ->
-  body ->
+  BH.Search ->
   ScrollRequest ->
   m (BH.SearchResult resp)
-search index body scrollRequest = do
-  rawResp <- search' index newBody qs
-  resp <- BH.parseEsResponse rawResp
+search index payload scrollRequest = do
+  let query = (Query.searchByIndex index payload {BH.source = Just fields}) {BH.bhRequestQueryStrings = qs}
+  resp <- BH.tryEsError $ BH.performBHRequest query
   case resp of
     Left err -> throwEsError "search" err
     Right x -> pure x
  where
-  newBody = case (fields, toJSON body) of
-    -- The results has fields, and the body is an object
-    (xs@(_ : _), Aeson.Object obj) -> Aeson.Object $ addSourceFields xs obj
-    -- Otherwise we don't change the body
-    (_, bodyValue) -> bodyValue
-
-  addSourceFields xs = KM.insert "_source" (Aeson.Array $ fromList $ map toSourceElem xs)
-
-  toSourceElem :: String -> Value
-  toSourceElem = Aeson.String . from . aesonCasing
+  toSourceElem :: String -> String
+  toSourceElem = from . aesonCasing
 
   -- The fields of the result data types.
-  fields :: [String]
-  fields = selectors (Proxy :: Proxy (Rep resp))
+  fields :: BH.Source
+  fields = BH.SourcePatterns $ BH.PopPatterns $ BH.Pattern . T.pack . toSourceElem <$> selectors (Proxy :: Proxy (Rep resp))
 
   qs = case scrollRequest of
     NoScroll -> []
@@ -129,77 +90,74 @@ search index body scrollRequest = do
 -- | A special purpose search implementation that uses the faster json-syntax
 searchHit ::
   MonadBH m =>
-  Aeson.ToJSON body =>
+  (Json.Value -> Either Text a) ->
   BH.IndexName ->
-  body ->
-  m [Json.Value]
-searchHit index body = do
-  rawResp <- search' index body []
-  case decodeHits (Json.decodeThrow $ HTTP.responseBody rawResp) of
-    Just xs -> pure xs
-    Nothing -> error $ "Could not find hits in " <> show rawResp
- where
-  decodeHits :: Json.Value -> Maybe [Json.Value]
-  decodeHits value = do
-    hits <- Json.getAttr "hits" =<< Json.getAttr "hits" value
-    fmap getSource <$> Json.getArray hits
-  getSource value = case Json.getAttr "_source" value of
-    Nothing -> error $ "No source found in: " <> show value
-    Just v -> v
-
-aggWithDocValues :: [(Text, Value)] -> Maybe BH.Query -> Value
-aggWithDocValues agg = mkAgg agg (Just dv)
- where
-  dv =
-    Aeson.Array
-      ( V.fromList
-          [ Aeson.object
-              [ "field" .= Aeson.String "created_at"
-              , "format" .= Aeson.String "date_time"
-              ]
-          ]
-      )
+  BH.Search ->
+  m [a]
+searchHit parseHit index payload = do
+  let query = Query.searchByIndex @Value index payload
+  resp <-
+    BH.tryEsError
+      $ BH.performBHRequest @_ @BH.StatusIndependant
+        query
+          { BH.bhRequestParser = \(BH.BHResponse rawResp) ->
+              let
+                decodeHits :: Json.Value -> Maybe [Json.Value]
+                decodeHits value = do
+                  hits <- Json.getAttr "hits" =<< Json.getAttr "hits" value
+                  fmap getSource <$> Json.getArray hits
+                getSource value = case Json.getAttr "_source" value of
+                  Nothing -> error $ "No source found in: " <> show value
+                  Just v -> v
+               in
+                case decodeHits (Json.decodeThrow $ HTTP.responseBody rawResp) of
+                  Just xs -> pure $ first (BH.EsError $ Just $ HTTP.statusCode $ HTTP.responseStatus rawResp) $ traverse parseHit xs
+                  Nothing -> error $ "Could not find hits in " <> show rawResp
+          }
+  case resp of
+    Right xs -> pure xs
+    Left e -> throwEsError "Could not find hits" e
 
-toPair :: (Text, Value) -> Aeson.Pair
-toPair (k, v) = (from k, v)
+aggWithDocValues :: BH.Aggregations -> Maybe BH.Query -> BH.Search
+aggWithDocValues agg = mkAgg agg (Just [BH.DocvalueFieldNameAndFormat (BH.FieldName "created_at") "date_time"])
 
-mkAgg :: [(Text, Value)] -> Maybe Value -> Maybe BH.Query -> Value
+mkAgg :: BH.Aggregations -> Maybe [BH.DocvalueField] -> Maybe BH.Query -> BH.Search
 mkAgg agg docvalues query =
-  Aeson.object
-    $ [ "aggregations" .= Aeson.object (toPair <$> agg)
-      , "size" .= Aeson.Number 0
-      ]
-    <> case docvalues of
-      Just dv -> ["docvalue_fields" .= dv]
-      Nothing -> []
-    <> case query of
-      Just q -> ["query" .= Aeson.toJSON q]
-      Nothing -> []
-
-mkTermsCompositeAgg :: Text -> Maybe Value -> (Text, Value)
+  BH.Search
+    { trackSortScores = False
+    , suggestBody = Nothing
+    , sortBody = Nothing
+    , searchType = BH.SearchTypeQueryThenFetch
+    , searchAfterKey = Nothing
+    , scriptFields = Nothing
+    , docvalueFields = docvalues
+    , queryBody = query
+    , pointInTime = Nothing
+    , highlight = Nothing
+    , filterBody = Nothing
+    , aggBody = Just agg
+    , source = Nothing
+    , size = BH.Size 0
+    , fields = Nothing
+    , from = BH.From 0
+    }
+
+mkTermsCompositeAgg :: Text -> Maybe Value -> BH.Aggregations
 mkTermsCompositeAgg term afterM =
-  ( "agg1"
-  , Aeson.object
-      [ "composite"
-          .= Aeson.object
-            ( [ "sources" .= [agg]
-              , "size" .= Aeson.Number 1024
-              ]
-                <> after
-            )
-      ]
-  )
- where
-  after = case afterM of
-    Just v -> ["after" .= Aeson.object ["agg" .= v]]
-    Nothing -> []
-  agg =
-    Aeson.object
-      [ "agg"
-          .= Aeson.object
-            [ "terms" .= Aeson.object ["field" .= term]
-            ]
-      ]
+  Map.singleton
+    "agg1"
+    $ BH.CompositeAgg
+    $ BH.CompositeAggregation
+      { compositeAggregationSize = Just 1024
+      , compositeAggregationSources =
+          [ BH.CompositeAggregationSource
+              "agg"
+              $ BH.CompositeTermsAgg
+              $ BH.mkTermsAggregation
+              $ BH.FieldName term
+          ]
+      , compositeAggregationAfter = (\v -> Aeson.object ["agg" .= v]) <$> afterM
+      }
 
 -- Make Value a type parameter for TermsCompositeAggResult
 newtype TermsCompositeAggKey = TermsCompositeAggKey