{- |
   Module      : PostgREST.Response
   Description : Generate HTTP Response
-}
{-# LANGUAGE NamedFieldPuns  #-}
{-# LANGUAGE RecordWildCards #-}
module PostgREST.Response
  ( actionResponse
  , PgrstResponse(..)
  ) where

import qualified Data.Aeson                as JSON
import qualified Data.ByteString.Char8     as BS
import qualified Data.ByteString.Lazy      as LBS
import qualified Data.HashMap.Strict       as HM
import           Data.Maybe                (fromJust)
import           Data.Text.Read            (decimal)
import qualified Network.HTTP.Types.Header as HTTP
import qualified Network.HTTP.Types.Status as HTTP
import qualified Network.HTTP.Types.URI    as HTTP

import qualified PostgREST.Error            as Error
import qualified PostgREST.MediaType        as MediaType
import qualified PostgREST.RangeQuery       as RangeQuery
import qualified PostgREST.Response.OpenAPI as OpenAPI

import PostgREST.ApiRequest              (ApiRequest (..))
import PostgREST.ApiRequest.Preferences  (PreferRepresentation (..),
                                          PreferResolution (..),
                                          Preferences (..),
                                          prefAppliedHeader,
                                          shouldCount)
import PostgREST.ApiRequest.QueryParams  (QueryParams (..))
import PostgREST.ApiRequest.Types        (InvokeMethod (..),
                                          Mutation (..))
import PostgREST.Config                  (AppConfig (..))
import PostgREST.MainTx                  (DbResult (..),
                                          ResultSet (..))
import PostgREST.MediaType               (MediaType (..))
import PostgREST.Plan                    (CrudPlan (..),
                                          InfoPlan (..),
                                          InspectPlan (..))
import PostgREST.Plan.MutatePlan         (MutatePlan (..))
import PostgREST.Response.GucHeader      (GucHeader, unwrapGucHeader)
import PostgREST.SchemaCache             (SchemaCache (..))
import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..),
                                          Schema)
import PostgREST.SchemaCache.Routine     (FuncVolatility (..),
                                          Routine (..))
import PostgREST.SchemaCache.Table       (Table (..))

import qualified PostgREST.SchemaCache.Routine as Routine

import Protolude      hiding (Handler, toS)
import Protolude.Conv (toS)

data PgrstResponse = PgrstResponse {
  pgrstStatus  :: HTTP.Status
, pgrstHeaders :: [HTTP.Header]
, pgrstBody    :: LBS.ByteString
}

actionResponse :: DbResult -> ApiRequest -> (Text, Text) -> AppConfig -> SchemaCache -> Schema -> Bool -> Either Error.Error PgrstResponse

actionResponse (DbCrudResult plan@WrappedReadPlan{pMedia, wrHdrsOnly=headersOnly, crudQi=identifier} RSStandard{..}) ctxApiRequest@ApiRequest{..} _ _ _ _ _ = do
  let
    (status, contentRange) = RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal rsTableTotal
    cLHeader = if headersOnly then mempty else [ contentLengthHeader bod ]
    prefHeader = maybeToList . prefAppliedHeader $ responsePreferences plan ctxApiRequest

    headers =
      [ contentRange
      , ( "Content-Location"
        , "/"
            <> toUtf8 (qiName identifier)
            <> if BS.null (qsCanonical iQueryParams) then mempty else "?" <> qsCanonical iQueryParams
        )
      ]
      ++ cLHeader
      ++ contentTypeHeaders pMedia ctxApiRequest
      ++ prefHeader
    bod | status == HTTP.status416 = Error.errorPayload $ Error.ApiRequestError $ Error.InvalidRange $
                                     Error.OutOfBounds (show $ RangeQuery.rangeOffset iTopLevelRange) (maybe "0" show rsTableTotal)
        | headersOnly              = mempty
        | otherwise                = LBS.fromStrict rsBody

  (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers

  Right $ PgrstResponse ovStatus ovHeaders bod

actionResponse (DbCrudResult plan@MutateReadPlan{mrMutation=MutationCreate, pMedia, crudQi=QualifiedIdentifier{..}} RSStandard{..}) ctxApiRequest@ApiRequest{..} _ _ _ _ _ = do
  let
    prefHeader = prefAppliedHeader $ responsePreferences plan ctxApiRequest

    headers =
      catMaybes
        [ if null rsLocation then
            Nothing
          else
            Just
              ( HTTP.hLocation
              , "/"
                  <> toUtf8 qiName
                  <> HTTP.renderSimpleQuery True rsLocation
              )
        , Just . RangeQuery.contentRangeH 1 0 $
            if shouldCount (preferCount iPreferences) then Just rsQueryTotal else Nothing
        , prefHeader ]

    isInsertIfGTZero i =
        if i <= 0 && preferResolution iPreferences == Just MergeDuplicates then
          HTTP.status200
        else
          HTTP.status201
    status = maybe HTTP.status200 isInsertIfGTZero rsInserted
    (headers', bod) = case preferRepresentation iPreferences of
      Just Full -> (headers ++ contentTypeHeaders pMedia ctxApiRequest, LBS.fromStrict rsBody)
      Just None -> (headers, mempty)
      Just HeadersOnly -> (headers, mempty)
      Nothing -> (headers, mempty)

  (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status $ contentLengthHeader bod:headers'

  Right $ PgrstResponse ovStatus ovHeaders bod

actionResponse (DbCrudResult plan@MutateReadPlan{mrMutation=MutationUpdate, pMedia} RSStandard{..}) ctxApiRequest@ApiRequest{..} _ _ _ _ _ = do
  let
    contentRangeHeader =
      Just . RangeQuery.contentRangeH 0 (rsQueryTotal - 1) $
        if shouldCount (preferCount iPreferences) then Just rsQueryTotal else Nothing

    prefHeader = prefAppliedHeader $ responsePreferences plan ctxApiRequest

    headers = catMaybes [contentRangeHeader, prefHeader]
    lbsBody = LBS.fromStrict rsBody

  let (status, headers', body) =
        case preferRepresentation iPreferences of
          Just Full -> (HTTP.status200, headers ++ [contentLengthHeader lbsBody] ++ contentTypeHeaders pMedia ctxApiRequest, lbsBody)
          Just None -> (HTTP.status204, headers, mempty)
          _         -> (HTTP.status204, headers, mempty)

  (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers'

  Right $ PgrstResponse ovStatus ovHeaders body

actionResponse (DbCrudResult plan@MutateReadPlan{mrMutation=MutationSingleUpsert, pMedia} RSStandard{..}) ctxApiRequest@ApiRequest{..} _ _ _ _ _ = do
  let
    prefHeader = maybeToList . prefAppliedHeader $ responsePreferences plan ctxApiRequest
    lbsBody = LBS.fromStrict rsBody
    cLHeader = [contentLengthHeader lbsBody]
    cTHeader = contentTypeHeaders pMedia ctxApiRequest

  let isInsertIfGTZero i = if i > 0 then HTTP.status201 else HTTP.status200
      upsertStatus       = isInsertIfGTZero $ fromJust rsInserted
      (status, headers, body) =
        case preferRepresentation iPreferences of
          Just Full -> (upsertStatus, cLHeader ++ cTHeader ++ prefHeader, lbsBody)
          Just None -> (HTTP.status204,  prefHeader, mempty)
          _ -> (HTTP.status204, prefHeader, mempty)
  (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers

  Right $ PgrstResponse ovStatus ovHeaders body

actionResponse (DbCrudResult plan@MutateReadPlan{mrMutation=MutationDelete, pMedia} RSStandard{..}) ctxApiRequest@ApiRequest{..} _ _ _ _ _ = do
  let
    contentRangeHeader = RangeQuery.contentRangeH 1 0 $ if shouldCount (preferCount iPreferences) then Just rsQueryTotal else Nothing
    prefHeader = maybeToList . prefAppliedHeader $ responsePreferences plan ctxApiRequest
    headers = contentRangeHeader : prefHeader
    lbsBody = LBS.fromStrict rsBody
    (status, headers', body) =
        case preferRepresentation iPreferences of
            Just Full -> (HTTP.status200, headers ++ [contentLengthHeader lbsBody] ++ contentTypeHeaders pMedia ctxApiRequest, lbsBody)
            Just None -> (HTTP.status204, headers, mempty)
            _ -> (HTTP.status204, headers, mempty)

  (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers'

  Right $ PgrstResponse ovStatus ovHeaders body

actionResponse (DbCrudResult plan@CallReadPlan{pMedia, crInvMthd=invMethod, crProc=proc} RSStandard {..}) ctxApiRequest@ApiRequest{..} _ _ _ _ _ = do
  let
    (status, contentRange) =
      RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal rsTableTotal
    rsOrErrBody = if status == HTTP.status416
      then Error.errorPayload $ Error.ApiRequestError $ Error.InvalidRange
        $ Error.OutOfBounds (show $ RangeQuery.rangeOffset iTopLevelRange) (maybe "0" show rsTableTotal)
      else LBS.fromStrict rsBody
    isHeadMethod = invMethod == InvRead True
    prefHeader = maybeToList . prefAppliedHeader $ responsePreferences plan ctxApiRequest
    cLHeader = if isHeadMethod then mempty else [contentLengthHeader rsOrErrBody]
    headers = contentRange : prefHeader
    (status', headers', body) =
        if Routine.funcReturnsVoid proc then
            (HTTP.status204, headers, mempty)
          else
            (status,
              headers ++ cLHeader ++ contentTypeHeaders pMedia ctxApiRequest,
              if isHeadMethod then mempty else rsOrErrBody)

  (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status' headers'

  Right $ PgrstResponse ovStatus ovHeaders body

actionResponse (DbPlanResult media plan) ctxApiRequest _ _ _ _ _ =
  let body = LBS.fromStrict plan in
  Right $ PgrstResponse HTTP.status200 (contentLengthHeader body : contentTypeHeaders media ctxApiRequest) body

actionResponse (MaybeDbResult InspectPlan{ipHdrsOnly=headersOnly} body) _ versions conf sCache schema negotiatedByProfile =
  let
    rsBody = maybe mempty (\(x, y, z) -> if headersOnly then mempty else OpenAPI.encode versions conf sCache x y z) body
    cLHeader = if headersOnly then mempty else [contentLengthHeader rsBody]
  in
  Right $ PgrstResponse HTTP.status200 (MediaType.toContentType MTOpenAPI : cLHeader ++ maybeToList (profileHeader schema negotiatedByProfile)) rsBody

actionResponse (NoDbResult (RelInfoPlan qi@QualifiedIdentifier{..})) _ _ _ sc@SchemaCache{dbTables} _ _ =
  case HM.lookup qi dbTables of
    Just tbl -> respondInfo $ allowH tbl
    Nothing  -> Left $ Error.SchemaCacheErr $ Error.TableNotFound qiSchema qiName sc
  where
    allowH table =
      let hasPK = not . null $ tablePKCols table in
      BS.intercalate "," $
          ["OPTIONS,GET,HEAD"] ++
          ["POST" | tableInsertable table] ++
          ["PUT" | tableInsertable table && tableUpdatable table && hasPK] ++
          ["PATCH" | tableUpdatable table] ++
          ["DELETE" | tableDeletable table]

actionResponse (NoDbResult (RoutineInfoPlan proc)) _ _ _ _ _ _
  | pdVolatility proc == Volatile = respondInfo "OPTIONS,POST"
  | otherwise                     = respondInfo "OPTIONS,GET,HEAD,POST"

actionResponse (NoDbResult SchemaInfoPlan) _ _ _ _ _ _ = respondInfo "OPTIONS,GET,HEAD"

respondInfo :: ByteString -> Either Error.Error PgrstResponse
respondInfo allowHeader =
  let allOrigins = ("Access-Control-Allow-Origin", "*") in
  Right $ PgrstResponse HTTP.status200 [contentLengthHeader mempty, allOrigins, (HTTP.hAllow, allowHeader)] mempty

-- Status and headers can be overridden as per https://postgrest.org/en/stable/references/transactions.html#response-headers
overrideStatusHeaders :: Maybe Text -> Maybe BS.ByteString -> HTTP.Status -> [HTTP.Header]-> Either Error.Error (HTTP.Status, [HTTP.Header])
overrideStatusHeaders rsGucStatus rsGucHeaders pgrstStatus pgrstHeaders = do
  gucStatus <- decodeGucStatus rsGucStatus
  gucHeaders <- decodeGucHeaders rsGucHeaders
  Right (fromMaybe pgrstStatus gucStatus, addHeadersIfNotIncluded pgrstHeaders $ map unwrapGucHeader gucHeaders)

decodeGucHeaders :: Maybe BS.ByteString -> Either Error.Error [GucHeader]
decodeGucHeaders =
  maybe (Right []) $ first (const . Error.ApiRequestError $ Error.GucHeadersError) . JSON.eitherDecode . LBS.fromStrict

decodeGucStatus :: Maybe Text -> Either Error.Error (Maybe HTTP.Status)
decodeGucStatus =
  maybe (Right Nothing) $ first (const . Error.ApiRequestError $ Error.GucStatusError) . fmap (Just . toEnum . fst) . decimal

contentLengthHeader :: LBS.ByteString -> HTTP.Header
contentLengthHeader body = ("Content-Length", show (LBS.length body))

contentTypeHeaders :: MediaType -> ApiRequest -> [HTTP.Header]
contentTypeHeaders mediaType ApiRequest{..} =
  MediaType.toContentType mediaType : maybeToList (profileHeader iSchema iNegotiatedByProfile)

profileHeader :: Schema -> Bool -> Maybe HTTP.Header
profileHeader schema negotiatedByProfile =
  if negotiatedByProfile
    then Just $ (,) "Content-Profile" (toS schema)
  else
    Nothing

-- | Add headers not already included to allow the user to override them instead of duplicating them
addHeadersIfNotIncluded :: [HTTP.Header] -> [HTTP.Header] -> [HTTP.Header]
addHeadersIfNotIncluded newHeaders initialHeaders =
  filter (\(nk, _) -> isNothing $ find (\(ik, _) -> ik == nk) initialHeaders) newHeaders ++
  initialHeaders

-- | Get Preferences for Preference-Applied header per plan
responsePreferences :: CrudPlan -> ApiRequest -> Preferences
responsePreferences plan ApiRequest{iPreferences=Preferences{..}, iQueryParams=QueryParams{..}} =
  let
    -- Only returned on Inserts
    preferResolution' = case plan of
      MutateReadPlan{mrMutation=MutationCreate, mrMutatePlan} ->
        let pkCols = case mrMutatePlan of { Insert{insPkCols} -> insPkCols ; _ -> mempty; }
        in (if null pkCols && isNothing qsOnConflict then Nothing else preferResolution)
      _ -> Nothing

    preferRepresentation' = case plan of
      MutateReadPlan{} -> preferRepresentation
      _                -> Nothing

    preferMissing' = case plan of
      MutateReadPlan{mrMutation=MutationCreate} -> preferMissing
      MutateReadPlan{mrMutation=MutationUpdate} -> preferMissing
      _                                         -> Nothing

    preferMaxAffected' = case plan of
      MutateReadPlan{mrMutation=MutationUpdate} -> preferMaxAffected
      MutateReadPlan{mrMutation=MutationDelete} -> preferMaxAffected
      CallReadPlan{}                            -> preferMaxAffected
      _                                         -> Nothing

    in Preferences preferResolution' preferRepresentation' preferCount preferTransaction preferMissing' preferHandling preferTimezone preferMaxAffected' []
