{- |
   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 WrappedReadPlan{pMedia, wrHdrsOnly=headersOnly, crudQi=identifier} RSStandard{..}) ctxApiRequest@ApiRequest{iPreferences=Preferences{..},..} _ _ _ _ _ = do
  let
    (status, contentRange) = RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal rsTableTotal
    cLHeader = if headersOnly then mempty else [contentLengthHeaderStrict rsBody]
    prefHeader = maybeToList . prefAppliedHeader $ Preferences Nothing Nothing preferCount preferTransaction Nothing preferHandling preferTimezone Nothing []
    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 MutateReadPlan{mrMutation=MutationCreate, mrMutatePlan, pMedia, crudQi=QualifiedIdentifier{..}} RSStandard{..}) ctxApiRequest@ApiRequest{iPreferences=Preferences{..}, ..} _ _ _ _ _ = do
  let
    pkCols = case mrMutatePlan of { Insert{insPkCols} -> insPkCols; _ -> mempty;}
    prefHeader = prefAppliedHeader $
      Preferences (if null pkCols && isNothing (qsOnConflict iQueryParams) then Nothing else preferResolution)
      preferRepresentation preferCount preferTransaction preferMissing preferHandling preferTimezone Nothing []
    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 then Just rsQueryTotal else Nothing
        , Just $ contentLengthHeaderStrict rsBody
        , prefHeader ]

    isInsertIfGTZero i =
        if i <= 0 && preferResolution == Just MergeDuplicates then
          HTTP.status200
        else
          HTTP.status201
    status = maybe HTTP.status200 isInsertIfGTZero rsInserted
    (headers', bod) = case preferRepresentation 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 headers'

  Right $ PgrstResponse ovStatus ovHeaders bod

actionResponse (DbCrudResult MutateReadPlan{mrMutation=MutationUpdate, pMedia} RSStandard{..}) ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} _ _ _ _ _ = do
  let
    contentRangeHeader =
      Just . RangeQuery.contentRangeH 0 (rsQueryTotal - 1) $
        if shouldCount preferCount then Just rsQueryTotal else Nothing
    prefHeader = prefAppliedHeader $ Preferences Nothing preferRepresentation preferCount preferTransaction preferMissing preferHandling preferTimezone preferMaxAffected []
    headers = catMaybes [contentRangeHeader, prefHeader]

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

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

  Right $ PgrstResponse ovStatus ovHeaders body

actionResponse (DbCrudResult MutateReadPlan{mrMutation=MutationSingleUpsert, pMedia} RSStandard{..}) ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} _ _ _ _ _ = do
  let
    prefHeader = maybeToList . prefAppliedHeader $ Preferences Nothing preferRepresentation preferCount preferTransaction Nothing preferHandling preferTimezone Nothing []
    cLHeader = [contentLengthHeaderStrict rsBody]
    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 of
          Just Full -> (upsertStatus, cLHeader ++ cTHeader ++ prefHeader, LBS.fromStrict rsBody)
          Just None -> (HTTP.status204,  prefHeader, mempty)
          _ -> (HTTP.status204, prefHeader, mempty)
  (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers

  Right $ PgrstResponse ovStatus ovHeaders body

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

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

  Right $ PgrstResponse ovStatus ovHeaders body

actionResponse (DbCrudResult CallReadPlan{pMedia, crInvMthd=invMethod, crProc=proc} RSStandard {..}) ctxApiRequest@ApiRequest{iPreferences=Preferences{..},..} _ _ _ _ _ = 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 $ Preferences Nothing Nothing preferCount preferTransaction Nothing preferHandling preferTimezone preferMaxAffected []
    cLHeader = if isHeadMethod then mempty else [contentLengthHeaderLazy 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 _ _ _ _ _ =
  Right $ PgrstResponse HTTP.status200 (contentLengthHeaderStrict plan : contentTypeHeaders media ctxApiRequest) $ LBS.fromStrict plan

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 [contentLengthHeaderLazy rsBody]
  in
  Right $ PgrstResponse HTTP.status200 (MediaType.toContentType MTOpenAPI : cLHeader ++ maybeToList (profileHeader schema negotiatedByProfile)) rsBody

actionResponse (NoDbResult (RelInfoPlan qi@QualifiedIdentifier{..})) _ _ _ SchemaCache{dbTables} _ _ =
  case HM.lookup qi dbTables of
    Just tbl -> respondInfo $ allowH tbl
    Nothing  -> Left $ Error.SchemaCacheErr $ Error.TableNotFound qiSchema qiName (HM.elems dbTables)
  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 [contentLengthHeaderStrict 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 :: Show b => (a -> b) -> a -> HTTP.Header
contentLengthHeader lenFn body = ("Content-Length", show (lenFn body))

contentLengthHeaderStrict :: BS.ByteString -> HTTP.Header
contentLengthHeaderStrict = contentLengthHeader BS.length

contentLengthHeaderLazy :: LBS.ByteString -> HTTP.Header
contentLengthHeaderLazy = contentLengthHeader LBS.length

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