content: {-# LANGUAGE GADTs #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TypeFamilies #-}
  
  -- |
  -- 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 (..),
      EsError (..),
  
      -- * Common results
      Acknowledged (..),
      Accepted (..),
      IgnoredBody (..),
    )
  where
  
  import qualified Blaze.ByteString.Builder as BB
  import Control.Applicative as A
  import Control.Monad
  import Control.Monad.Catch
  import Data.Aeson
  import qualified Data.ByteString as BS
  import qualified Data.ByteString.Lazy as BL
  import Data.Ix
  import Data.Monoid
  import Data.Text (Text)
  import qualified Data.Text as T
  import qualified Data.Text.Encoding as T
  import Data.Typeable
  import Database.Bloodhound.Internal.Client.Doc
  import GHC.Exts
  import Network.HTTP.Client
  import qualified Network.HTTP.Types.Method as NHTM
  import qualified Network.HTTP.Types.Status as NHTS
  import qualified Network.HTTP.Types.URI 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.
  parseEsResponse ::
    (FromJSON body) =>
    BHResponse parsingContext body ->
    Either EsProtocolException (ParsedEsResponse body)
  parseEsResponse response
    | isSuccess response = case eitherDecode body of
        Right a -> return (Right a)
        Left err ->
          tryParseError err
    | otherwise = tryParseError "Non-200 status code"
    where
      body = responseBody $ getResponse response
      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.
  data EsResultFound a = EsResultFound
    { _version :: DocVersion,
      _source :: a
    }
    deriving stock (Eq, Show)
  
  instance (FromJSON a) => FromJSON (EsResult a) where
    parseJSON jsonVal@(Object v) = do
      found <- v .:? "found" .!= False
      fr <-
        if found
          then 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"
    parseJSON _ = empty
  
  -- | '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, Typeable)
  
  {-# 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
      where
        p1 =
          EsError
            <$> v .:? "status"
            <*> v .: "error"
        p2 =
          EsError
            <$> v .:? "status"
            <*> (v .: "error" >>= (.: "reason"))
        p3 = do
          failures <- v .: "failures"
          -- This is a bit imprecise: We're only using the first error, ignoring
          -- all others.
          case failures of
            (failure : _) ->
              EsError
                <$> failure .:? "status"
                <*> (failure .: "cause" >>= (.: "reason"))
            [] -> fail "could not find field `failure`"
    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)
  
  instance FromJSON Acknowledged where
    parseJSON =
      withObject "Acknowledged" $
        fmap Acknowledged . (.: "acknowledged")
  
  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
  