Requests.hs

{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-deprecations #-}

module Database.Bloodhound.Internal.Utils.Requests where

import Data.Aeson (FromJSON, eitherDecode)
import Data.ByteString.Lazy.Char8 qualified as L
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Text.Encoding.Error (lenientDecode)
import Database.Bloodhound.Internal.Client.BHRequest
import Database.Bloodhound.Internal.Utils.Imports (showText)
import Network.HTTP.Client (responseBody, responseStatus)
import Network.HTTP.Types.Method qualified as NHTM
import Network.HTTP.Types.Status qualified as NHTS
import Prelude hiding (filter, head)

delete ::
  (ParseBHResponse contextualized, FromJSON body) =>
  Endpoint ->
  BHRequest contextualized body
delete = mkSimpleRequest NHTM.methodDelete

deleteWithBody ::
  (ParseBHResponse contextualized, FromJSON body) =>
  Endpoint ->
  L.ByteString ->
  BHRequest contextualized body
deleteWithBody = mkFullRequest NHTM.methodDelete

get ::
  (ParseBHResponse contextualized, FromJSON body) =>
  Endpoint ->
  BHRequest contextualized body
get = mkSimpleRequest NHTM.methodGet

-- | 'getWithBody' is a GET request that carries a request body. Most
-- Elasticsearch endpoints use GET without a body (and 'get' for
-- those), but a handful — notably @GET /_render/template@ and
-- @GET /_render/template\/{id}@ — require the request parameters to
-- be sent in a body even though the method is GET. Use 'get' for
-- body-less GETs and 'getWithBody' for these body-bearing GETs; for
-- symmetry with the other verb helpers it is a thin specialisation of
-- 'mkFullRequest'.
getWithBody ::
  (ParseBHResponse contextualized, FromJSON body) =>
  Endpoint ->
  L.ByteString ->
  BHRequest contextualized body
getWithBody = mkFullRequest NHTM.methodGet

head' ::
  (ParseBHResponse contextualized, FromJSON body) =>
  Endpoint ->
  BHRequest contextualized body
head' = mkSimpleRequest NHTM.methodHead

put ::
  (ParseBHResponse contextualized, FromJSON body) =>
  Endpoint ->
  L.ByteString ->
  BHRequest contextualized body
put = mkFullRequest NHTM.methodPut

post ::
  (ParseBHResponse contextualized, FromJSON body) =>
  Endpoint ->
  L.ByteString ->
  BHRequest contextualized body
post = mkFullRequest NHTM.methodPost

-- | 'postNoBody' is a POST request that carries no request body. Most
-- Elasticsearch\/OpenSearch POST endpoints expect a body (and 'post' for
-- those), but a handful — notably the Alerting plugin
-- @POST /_plugins/_alerting/monitors/{monitor_id}/_execute@ — take their
-- arguments as query-string parameters and document an empty body. Use
-- 'post' for body-bearing POSTs and 'postNoBody' for these; for
-- symmetry with the other verb helpers it is a thin specialisation of
-- 'mkSimpleRequest'.
postNoBody ::
  (ParseBHResponse contextualized, FromJSON body) =>
  Endpoint ->
  BHRequest contextualized body
postNoBody = mkSimpleRequest NHTM.methodPost

-- | Like 'get', but for endpoints that return a non-JSON, plain-text body
-- (e.g. @GET /_nodes/hot_threads@). The response body is decoded as
-- UTF-8 'Text'. Unlike 'get', this helper is pinned to 'StatusDependant'
-- because the parser branches on the HTTP status code. On non-2xx
-- responses, the body is first parsed as a JSON 'EsError' (ES error
-- format); if that also fails, a synthetic 'EsError' is produced
-- carrying the HTTP status code and the (length-bounded) raw body.
getText ::
  Endpoint ->
  BHRequest StatusDependant Text
getText endpoint =
  BHRequest
    { bhRequestMethod = NHTM.methodGet,
      bhRequestEndpoint = endpoint,
      bhRequestBody = Nothing,
      bhRequestQueryStrings = [],
      bhRequestParser = parseTextBody
    }

-- | Parser used by 'getText'. Decodes the raw body as UTF-8 'Text' on
-- success (leniently — invalid byte sequences become U+FFFD rather
-- than throwing, since the body is a diagnostic report) and routes
-- non-2xx responses through the standard 'EsError' path, falling back
-- to a status-only error carrying a bounded prefix of the raw body
-- when the body is not JSON.
parseTextBody ::
  BHResponse parsingContext Text ->
  Either EsProtocolException (ParsedEsResponse Text)
parseTextBody resp
  | isSuccess resp =
      Right (Right (TE.decodeUtf8With lenientDecode strictBody))
  | otherwise =
      case eitherDecode body of
        Right e -> Right (Left e)
        Left aesonErr ->
          Right $
            Left $
              EsError
                { errorStatus = Just statusCode,
                  errorMessage =
                    "Non-2xx ("
                      <> showText statusCode
                      <> ") with non-JSON body (aeson: "
                      <> T.pack aesonErr
                      <> "): "
                      <> T.take maxErrorBodyPrefix (TE.decodeUtf8With lenientDecode strictBody)
                }
  where
    body = responseBody (getResponse resp)
    strictBody = L.toStrict body
    statusCode = NHTS.statusCode (responseStatus (getResponse resp))
    maxErrorBodyPrefix = 512

-- | Like 'getWithBody', but for endpoints whose success response body
-- is /binary/ rather than JSON — notably
-- @GET \/{index}\/_mvt\/{field}\/{zoom}\/{x}\/{y}@, which returns a
-- Mapbox Vector Tile encoded as a Google Protobuf (PBF). The success
-- body is returned verbatim as a lazy 'L.ByteString'; non-2xx
-- responses are routed through the standard 'EsError' path (the server
-- returns JSON errors), falling back to a status-only error carrying a
-- bounded prefix of the raw body when the body is not JSON. Pinned to
-- 'StatusDependant' for the same reason as 'getText'.
getByteStringWithBody ::
  Endpoint ->
  L.ByteString ->
  BHRequest StatusDependant L.ByteString
getByteStringWithBody endpoint body =
  BHRequest
    { bhRequestMethod = NHTM.methodGet,
      bhRequestEndpoint = endpoint,
      bhRequestBody = Just body,
      bhRequestQueryStrings = [],
      bhRequestParser = parseByteStringBody
    }

-- | Like 'getByteStringWithBody', but a POST. The success response body is
-- returned verbatim as a lazy 'L.ByteString'; non-2xx responses are routed
-- through the standard 'EsError' path via 'parseByteStringBody'. Used by
-- endpoints whose success body is a non-JSON stream — notably the inference
-- streaming endpoints (@POST \/_inference\/...\/_stream@), which emit an
-- opaque @_types.StreamResult@ stream that callers parse themselves.
postRaw ::
  Endpoint ->
  L.ByteString ->
  BHRequest StatusDependant L.ByteString
postRaw endpoint body =
  BHRequest
    { bhRequestMethod = NHTM.methodPost,
      bhRequestEndpoint = endpoint,
      bhRequestBody = Just body,
      bhRequestQueryStrings = [],
      bhRequestParser = parseByteStringBody
    }

-- | Parser used by 'getByteStringWithBody'. Returns the raw response
-- body on 2xx; on non-2xx, attempts to decode the body as a JSON
-- 'EsError' (the server's standard error shape), falling back to a
-- synthetic 'EsError' carrying the HTTP status and a bounded prefix of
-- the raw body when the body is not JSON.
parseByteStringBody ::
  BHResponse parsingContext L.ByteString ->
  Either EsProtocolException (ParsedEsResponse L.ByteString)
parseByteStringBody resp
  | isSuccess resp = Right (Right body)
  | otherwise =
      case eitherDecode body of
        Right e -> Right (Left e)
        Left aesonErr ->
          Right $
            Left $
              EsError
                { errorStatus = Just statusCode,
                  errorMessage =
                    "Non-2xx ("
                      <> showText statusCode
                      <> ") with non-JSON body (aeson: "
                      <> T.pack aesonErr
                      <> "): "
                      <> T.take maxErrorBodyPrefix (TE.decodeUtf8With lenientDecode strictBody)
                }
  where
    body = responseBody (getResponse resp)
    strictBody = L.toStrict body
    statusCode = NHTS.statusCode (responseStatus (getResponse resp))
    maxErrorBodyPrefix = 512