BHRequest.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-deprecations #-}

-- |
-- Module : Database.Bloodhound.Client
-- Copyright : (C) 2014, 2018 Chris Allen
-- License : BSD-style (see the file LICENSE)
-- Maintainer : Chris Allen <cma@bitemyapp.com>
-- Stability : provisional
-- Portability : GHC
--
-- Client side abstractions to interact with Elasticsearch servers.
module Database.Bloodhound.Internal.Client.BHRequest
  ( -- * Request
    BHRequest (..),
    StatusIndependant,
    StatusDependant,
    mkFullRequest,
    mkSimpleRequest,
    ParsedEsResponse,
    ParseBHResponse (..),
    Server (..),
    Endpoint (..),
    mkEndpoint,
    withQueries,
    getEndpoint,
    withBHResponse,
    withBHResponse_,
    withBHResponseParsedEsResponse,
    keepBHResponse,
    joinBHResponse,

    -- * Response
    BHResponse (..),

    -- * Response interpretation
    decodeResponse,
    eitherDecodeResponse,
    parseEsResponse,
    parseEsResponseWith,
    isVersionConflict,
    isSuccess,
    isCreated,
    statusCodeIs,

    -- * Response handling
    EsProtocolException (..),
    EsResult (..),
    EsResultFound (..),
    esResultFoundSeqNoLens,
    esResultFoundPrimaryTermLens,
    esResultFoundRoutingLens,
    EsError (..),

    -- * Common results
    Acknowledged (..),
    Accepted (..),
    IgnoredBody (..),
  )
where

import Blaze.ByteString.Builder qualified as BB
import Control.Applicative as A
import Control.Monad
import Control.Monad.Catch
import Data.Aeson
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL
import Data.Ix
import Data.Monoid
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Database.Bloodhound.Internal.Client.Doc
import Database.Bloodhound.Internal.Utils.Imports (Lens', lens)
import GHC.Exts
import Network.HTTP.Client
import Network.HTTP.Types.Method qualified as NHTM
import Network.HTTP.Types.Status qualified as NHTS
import Network.HTTP.Types.URI qualified as NHTU
import Prelude hiding (filter, head)

-- | 'Server' is used with the client functions to point at the ES instance
newtype Server = Server Text
  deriving stock (Eq, Show)
  deriving newtype (FromJSON)

-- | 'Endpoint' represents an url before being built
data Endpoint = Endpoint
  { getRawEndpoint :: [Text],
    getRawEndpointQueries :: [(Text, Maybe Text)]
  }
  deriving stock (Eq, Show)

instance IsList Endpoint where
  type Item Endpoint = Text
  toList = getRawEndpoint
  fromList = mkEndpoint

-- | Create an 'Endpoint' from a list of url parts
mkEndpoint :: [Text] -> Endpoint
mkEndpoint urlParts = Endpoint urlParts mempty

-- | Generate the raw URL
getEndpoint :: Server -> Endpoint -> Text
getEndpoint (Server serverRoot) endpoint =
  T.intercalate "/" (serverRoot : getRawEndpoint endpoint) <> queries
  where
    queries = T.decodeUtf8 $ BB.toByteString $ NHTU.renderQueryText prependQuestionMark $ getRawEndpointQueries endpoint
    prependQuestionMark = True

-- | Severely dumbed down query renderer. Assumes your data doesn't
-- need any encoding
withQueries :: Endpoint -> [(Text, Maybe Text)] -> Endpoint
withQueries endpoint queries = endpoint {getRawEndpointQueries = getRawEndpointQueries endpoint <> queries}

-- | 'Request' upon Elasticsearch's server.
--
-- @parsingContext@ is a phantom type for the expected status-dependancy
-- @responseBody@ is a phantom type for the expected result
data BHRequest parsingContext responseBody = BHRequest
  { bhRequestMethod :: NHTM.Method,
    bhRequestEndpoint :: Endpoint,
    bhRequestBody :: Maybe BL.ByteString,
    bhRequestQueryStrings :: [(BS.ByteString, Maybe BS.ByteString)],
    bhRequestParser :: BHResponse parsingContext responseBody -> Either EsProtocolException (ParsedEsResponse responseBody)
  }

instance Functor (BHRequest parsingContext) where
  fmap f req =
    req
      { bhRequestParser =
          \BHResponse {..} -> fmap (fmap f) $ bhRequestParser req $ BHResponse {..}
      }

-- | 'BHResponse' body-parsing does not depend on 'statusCode'
data StatusIndependant

-- | 'BHResponse' body-parsing may depend on 'statusCode'
data StatusDependant

-- | 'BHRequest' with a body
mkFullRequest :: (ParseBHResponse parsingContext, FromJSON responseBody) => NHTM.Method -> Endpoint -> BL.ByteString -> BHRequest parsingContext responseBody
mkFullRequest method' endpoint body =
  BHRequest
    { bhRequestMethod = method',
      bhRequestEndpoint = endpoint,
      bhRequestBody = Just body,
      bhRequestQueryStrings = [],
      bhRequestParser = parseBHResponse
    }

-- | 'BHRequest' without a body
mkSimpleRequest :: (ParseBHResponse parsingContext, FromJSON responseBody) => NHTM.Method -> Endpoint -> BHRequest parsingContext responseBody
mkSimpleRequest method' endpoint =
  BHRequest
    { bhRequestMethod = method',
      bhRequestEndpoint = endpoint,
      bhRequestBody = Nothing,
      bhRequestQueryStrings = [],
      bhRequestParser = parseBHResponse
    }

class ParseBHResponse parsingContext where
  parseBHResponse ::
    (FromJSON a) =>
    BHResponse parsingContext a ->
    Either EsProtocolException (ParsedEsResponse a)

instance ParseBHResponse StatusDependant where
  parseBHResponse = parseEsResponse

instance ParseBHResponse StatusIndependant where
  parseBHResponse r =
    return $
      case eitherDecodeResponse r of
        Right d -> Right d
        Left e ->
          Left $
            EsError
              { errorStatus = Just $ NHTS.statusCode (responseStatus $ getResponse r),
                errorMessage = "Unable to parse body: " <> T.pack e
              }

-- | Work with the full 'BHResponse'
withBHResponse ::
  forall a parsingContext b.
  (Either EsProtocolException (ParsedEsResponse a) -> BHResponse StatusDependant a -> b) ->
  BHRequest parsingContext a ->
  BHRequest StatusDependant b
withBHResponse f req =
  req
    { bhRequestParser = \resp ->
        liftResponse $ f (bhRequestParser req $ castResponse @_ @_ @parsingContext @a resp) $ castResponse @_ @_ @StatusDependant @a resp
    }
  where
    liftResponse :: b -> Either EsProtocolException (ParsedEsResponse b)
    liftResponse = return . return

-- | Internal only
castResponse :: BHResponse parsingContext0 responseBody0 -> BHResponse parsingContext1 responseBody1
castResponse BHResponse {..} = BHResponse {..}

-- | Work with the full 'BHResponse'
withBHResponse_ ::
  forall a parsingContext b.
  (BHResponse StatusDependant a -> b) ->
  BHRequest parsingContext a ->
  BHRequest StatusDependant b
withBHResponse_ f = withBHResponse $ const f

-- | Enable working with 'ParsedEsResponse'
withBHResponseParsedEsResponse ::
  forall a parsingContext.
  BHRequest parsingContext a ->
  BHRequest StatusDependant (ParsedEsResponse a)
withBHResponseParsedEsResponse req =
  req
    { bhRequestParser = \BHResponse {..} -> return <$> bhRequestParser req BHResponse {..}
    }

-- | Keep with the full 'BHResponse'
keepBHResponse ::
  forall a parsingContext.
  BHRequest parsingContext a ->
  BHRequest StatusDependant (BHResponse StatusDependant a, a)
keepBHResponse = joinBHResponse . withBHResponse (\parsed resp -> fmap (fmap ((,) resp)) parsed)

joinBHResponse ::
  forall a parsingContext.
  BHRequest parsingContext (Either EsProtocolException (ParsedEsResponse a)) ->
  BHRequest parsingContext a
joinBHResponse req =
  req
    { bhRequestParser = \resp ->
        case bhRequestParser req $ castResponse resp of
          Left e -> Left e
          Right (Right a) -> a
          Right (Left e) -> Right (Left e)
    }

-- | Result of a 'BHRequest'
newtype BHResponse parsingContext body = BHResponse
  { getResponse :: Network.HTTP.Client.Response BL.ByteString
  }
  deriving stock (Show)

-- | Result of a 'parseEsResponse'
type ParsedEsResponse a = Either EsError a

-- | Tries to parse a response body as the expected type @body@ and
-- failing that tries to parse it as an EsError. All well-formed, JSON
-- responses from elasticsearch should fall into these two
-- categories. If they don't, a 'EsProtocolException' will be
-- thrown. If you encounter this, please report the full body it
-- reports along with your Elasticsearch version.
--
-- /Empty-body 2xx handling/: some cluster endpoints (verified:
-- @/_cluster/voting_config_exclusions@ POST and DELETE on ES 7.17)
-- return HTTP 200 with a genuinely empty body (Content-Length: 0)
-- rather than the @{\"acknowledged\":true}@ envelope their declared
-- 'Acknowledged' return type implies. To tolerate that wire shape,
-- an empty body on a 2xx response is normalised to the JSON value
-- @null@ before the decoder is invoked. Only types whose 'FromJSON'
-- instance accepts @null@ are affected — in practice just
-- 'Acknowledged', whose instance maps @null@ to 'Acknowledged'
-- @True@ (a 200 OK with no body IS the acknowledgement per the
-- server's documented semantics). All other types keep the
-- historical behaviour: their strict 'FromJSON' instances reject
-- @null@, so the empty body surfaces as an 'EsProtocolException' as
-- before.
--
-- Note: the OpenSearch k-NN\/Neural warmup and clear-cache endpoints
-- were /suspected/ to need this handling but turn out to have
-- separate response-shape bugs (wrong method, wrong response type)
-- tracked by the pending live tests in @Test.KnnWarmupSpec@,
-- @Test.KnnClearCacheSpec@, @Test.NeuralWarmupSpec@, and
-- @Test.NeuralClearCacheSpec@. They do not return empty-body 200 and
-- are not covered by this normalisation.
parseEsResponse ::
  (FromJSON body) =>
  BHResponse parsingContext body ->
  Either EsProtocolException (ParsedEsResponse body)
parseEsResponse response
  | isSuccess response = case eitherDecode normalisedBody of
      Right a -> return (Right a)
      Left err ->
        tryParseError err
  | otherwise = tryParseError "Non-200 status code"
  where
    body = responseBody $ getResponse response
    -- Normalise a genuinely empty body to the literal JSON @null@
    -- before decoding. Only affects types whose 'FromJSON' accepts
    -- @null@ (e.g. 'Acknowledged'); strict types still reject it and
    -- surface the original parse failure below. Error envelopes always
    -- carry content, so 'tryParseError' decodes the raw 'body' rather
    -- than 'normalisedBody' — a hypothetical empty 4xx body would just
    -- fail to decode as 'EsError' and fall through to the original
    -- error in 'explode'.
    normalisedBody = if BL.null body then "null" else body
    tryParseError originalError =
      case eitherDecode body of
        Right e -> return (Left e)
        -- Failed to parse the error message.
        Left err -> explode ("Original error was: " <> originalError <> " Error parse failure was: " <> err)
    explode errorMsg = Left $ EsProtocolException (T.pack errorMsg) body

-- | Parse 'BHResponse' with an arbitrary parser
parseEsResponseWith ::
  ( MonadThrow m,
    FromJSON body
  ) =>
  (body -> Either String parsed) ->
  BHResponse parsingContext body ->
  m parsed
parseEsResponseWith parser response =
  case eitherDecode body of
    Left e -> explode e
    Right parsed ->
      case parser parsed of
        Right a -> return a
        Left e -> explode e
  where
    body = responseBody $ getResponse response
    explode errorMsg = throwM $ EsProtocolException (T.pack errorMsg) body

-- | Helper around 'aeson' 'decode'
decodeResponse ::
  (FromJSON a) =>
  BHResponse StatusIndependant a ->
  Maybe a
decodeResponse = decode . responseBody . getResponse

-- | Helper around 'aeson' 'eitherDecode'
eitherDecodeResponse ::
  (FromJSON a) =>
  BHResponse StatusIndependant a ->
  Either String a
eitherDecodeResponse = eitherDecode . responseBody . getResponse

-- | Was there an optimistic concurrency control conflict when
-- indexing a document? (Check '409' status code.)
isVersionConflict :: BHResponse parsingContext a -> Bool
isVersionConflict = statusCheck (== 409)

-- | Check '2xx' status codes
isSuccess :: BHResponse parsingContext a -> Bool
isSuccess = statusCodeIs (200, 299)

-- | Check '201' status code
isCreated :: BHResponse parsingContext a -> Bool
isCreated = statusCheck (== 201)

-- | Check status code
statusCheck :: (Int -> Bool) -> BHResponse parsingContext a -> Bool
statusCheck prd = prd . NHTS.statusCode . responseStatus . getResponse

-- | Check status code in range
statusCodeIs :: (Int, Int) -> BHResponse parsingContext body -> Bool
statusCodeIs r resp = inRange r $ NHTS.statusCode (responseStatus $ getResponse resp)

-- | 'EsResult' describes the standard wrapper JSON document that you see in
--   successful Elasticsearch lookups or lookups that couldn't find the document.
data EsResult a = EsResult
  { _index :: Text,
    _type :: Maybe Text,
    _id :: Text,
    foundResult :: Maybe (EsResultFound a)
  }
  deriving stock (Eq, Show)

{-# DEPRECATED _type "deprecated since ElasticSearch 6.0" #-}

-- | 'EsResultFound' contains the document and its metadata inside of an
--   'EsResult' when the document was successfully found.
--
--   @_seq_no@, @_primary_term@, and @_routing@ are 'Maybe' because they
--   are not always present in every response shape Bloodhound parses as
--   an 'EsResultFound' (e.g. test fixtures, the @_source=false@ case,
--   older protocol variants). Real ES7+\/OpenSearch @GET _doc@ responses
--   always include @_seq_no@ and @_primary_term@ on found documents.
data EsResultFound a = EsResultFound
  { _version :: DocVersion,
    _source :: a,
    _seq_no :: Maybe Int,
    _primary_term :: Maybe Int,
    _routing :: Maybe Text
  }
  deriving stock (Eq, Show)

instance (FromJSON a) => FromJSON (EsResult a) where
  parseJSON jsonVal@(Object v) = do
    found <- v .:? "found" .!= False
    fr <-
      if found
        -- 'optional' swallows ANY parse failure of 'EsResultFound',
        -- not just the missing @_source@ case. The primary trigger is
        -- the caller sending @_source=false@ (or the equivalent
        -- per-document filter in mget), which causes the @_source@ key
        -- to be absent from the response. In that case the document
        -- /was/ found but no source is available, so 'foundResult' is
        -- 'Nothing'. If the caller's 'FromJSON' instance is malformed
        -- or a future ES version drops @_version@, the parse failure
        -- is also swallowed here — a deliberate tradeoff for keeping
        -- @'_source' :: a@ non-'Maybe' in 'EsResultFound'.
        then A.optional (parseJSON jsonVal)
        else return Nothing
    EsResult
      <$> v
        .: "_index"
      <*> v
        .:? "_type"
      <*> v
        .: "_id"
      <*> pure fr
  parseJSON _ = empty

instance (FromJSON a) => FromJSON (EsResultFound a) where
  parseJSON (Object v) =
    EsResultFound
      <$> v
        .: "_version"
      <*> v
        .: "_source"
      <*> v
        .:? "_seq_no"
      <*> v
        .:? "_primary_term"
      <*> v
        .:? "_routing"
  parseJSON _ = empty

esResultFoundSeqNoLens :: Lens' (EsResultFound a) (Maybe Int)
esResultFoundSeqNoLens = lens _seq_no (\x y -> x {_seq_no = y})

esResultFoundPrimaryTermLens :: Lens' (EsResultFound a) (Maybe Int)
esResultFoundPrimaryTermLens = lens _primary_term (\x y -> x {_primary_term = y})

esResultFoundRoutingLens :: Lens' (EsResultFound a) (Maybe Text)
esResultFoundRoutingLens = lens _routing (\x y -> x {_routing = y})

-- | 'EsError' is the generic type that will be returned when there was a
--   problem. If you can't parse the expected response, its a good idea to
--   try parsing this.
data EsError = EsError
  { errorStatus :: Maybe Int,
    errorMessage :: Text
  }
  deriving stock (Eq, Show)

{-# DEPRECATED errorStatus "deprecated since ElasticSearch 6.0" #-}

instance Exception EsError

instance Semigroup EsError where
  _ <> x = x

instance Monoid EsError where
  mempty = EsError Nothing "Monoid value, shouldn't happen"

instance FromJSON EsError where
  parseJSON (Object v) = p1 <|> p2 <|> p3 <|> p4
    where
      -- Shape: {"status": <int>, "error": "<string>"}
      p1 =
        EsError
          <$> v .:? "status"
          <*> v .: "error"
      -- Shape: {"status": <int>, "error": {"reason": ..., "type": ...}}
      -- The reason field is fetched loosely because some servers (e.g.
      -- OpenSearch 1.3 on @GET /_script_language@) emit a 500 with
      -- @reason: null@ for an internal null_pointer_exception; we fall
      -- back to @type@, then a placeholder, so the decode yields a
      -- proper 'EsError' rather than an 'EsProtocolException'.
      p2 = do
        status <- v .:? "status"
        err <- v .: "error"
        reason <- err .:? "reason"
        typ <- err .:? "type"
        return $ EsError status $ case (reason, typ) of
          (Just r, _) -> r
          (Nothing, Just t) -> t
          _ -> "unknown error"
      -- Shape: {"failures": [{"status": <int>, "cause": {...}}]}
      -- Same null-tolerant treatment of @cause.reason@, falling back
      -- to @cause.type@.
      p3 = do
        failures <- v .: "failures"
        -- This is a bit imprecise: We're only using the first error, ignoring
        -- all others.
        case failures of
          (failure : _) -> do
            status <- failure .:? "status"
            cause <- failure .: "cause"
            reason <- cause .:? "reason"
            typ <- cause .:? "type"
            return $ EsError status $ case (reason, typ) of
              (Just r, _) -> r
              (Nothing, Just t) -> t
              _ -> "unknown failure"
          [] -> fail "could not find field `failure`"
      -- Catch-all so that future/unknown error shapes still surface as
      -- a proper 'EsError' rather than bubbling up as an
      -- 'EsProtocolException' from 'parseEsResponse'.
      p4 = EsError <$> v .:? "status" <*> pure "unrecognised error body"
  parseJSON _ = empty

-- | 'EsProtocolException' will be thrown if Bloodhound cannot parse a response
-- returned by the Elasticsearch server. If you encounter this error, please
-- verify that your domain data types and FromJSON instances are working properly
-- (for example, the 'a' of '[Hit a]' in 'SearchResult.searchHits.hits'). If you're
-- sure that your mappings are correct, then this error may be an indication of an
-- incompatibility between Bloodhound and Elasticsearch. Please open a bug report
-- and be sure to include the exception body.
data EsProtocolException = EsProtocolException
  { esProtoExMessage :: !Text,
    esProtoExResponse :: !BL.ByteString
  }
  deriving stock (Eq, Show)

instance Exception EsProtocolException

newtype Acknowledged = Acknowledged {isAcknowledged :: Bool}
  deriving stock (Eq, Show)

-- | Decodes @{"acknowledged": <bool>}@ as usual. Also accepts the
-- JSON value @null@, mapping it to 'Acknowledged' @True@: the ES
-- @/_cluster/voting_config_exclusions@ POST and DELETE endpoints
-- (at least on ES 7.17; see bead @bloodhound-vvj@) return HTTP 200
-- with an empty body for their 'Acknowledged'-typed responses, and
-- 'parseEsResponse' normalises such empty bodies to @null@ before
-- invoking this instance. A 200 OK with no body IS the
-- acknowledgement per the server's documented semantics; treating
-- @null@ as @True@ matches that wire shape without affecting the
-- well-formed @{"acknowledged": <bool>}@ path.
instance FromJSON Acknowledged where
  parseJSON Null = return (Acknowledged True)
  parseJSON v = withObject "Acknowledged" (fmap Acknowledged . (.: "acknowledged")) v

newtype Accepted = Accepted {isAccepted :: Bool}
  deriving stock (Eq, Show)

instance FromJSON Accepted where
  parseJSON =
    withObject "Accepted" $
      fmap Accepted . (.: "accepted")

data IgnoredBody = IgnoredBody
  deriving stock (Eq, Show)

instance FromJSON IgnoredBody where
  parseJSON _ = return IgnoredBody