{-|
Module      : PostgREST.Error
Description : PostgREST error HTTP responses
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances #-}

module PostgREST.Error (
  errorResponseFor
, ApiRequestError(..)
, PgError(..)
, SimpleError(..)
, errorPayload
, checkIsFatal
, singularityError
) where

import qualified Data.Aeson                as JSON
import qualified Data.Text                 as T
import qualified Hasql.Pool                as P
import qualified Hasql.Session             as H
import qualified Network.HTTP.Types.Status as HT

import Data.Aeson  ((.=))
import Network.Wai (Response, responseLBS)

import Network.HTTP.Types.Header

import PostgREST.Types
import Protolude       hiding (toS)
import Protolude.Conv  (toS)


class (JSON.ToJSON a) => PgrstError a where
  status   :: a -> HT.Status
  headers  :: a -> [Header]

  errorPayload :: a -> LByteString
  errorPayload = JSON.encode

  errorResponseFor :: a -> Response
  errorResponseFor err = responseLBS (status err) (headers err) $ errorPayload err



data ApiRequestError
  = ActionInappropriate
  | InvalidRange
  | InvalidBody ByteString
  | ParseRequestError Text Text
  | NoRelBetween Text Text
  | AmbiguousRelBetween Text Text [Relation]
  | InvalidFilters
  | UnacceptableSchema [Text]
  | UnknownRelation                -- Unreachable?
  | UnsupportedVerb                -- Unreachable?
  deriving (Show, Eq)

instance PgrstError ApiRequestError where
  status InvalidRange            = HT.status416
  status InvalidFilters          = HT.status405
  status (InvalidBody _)         = HT.status400
  status UnsupportedVerb         = HT.status405
  status UnknownRelation         = HT.status404
  status ActionInappropriate     = HT.status405
  status (ParseRequestError _ _) = HT.status400
  status (NoRelBetween _ _)      = HT.status400
  status AmbiguousRelBetween{}   = HT.status300
  status (UnacceptableSchema _)  = HT.status406

  headers _ = [toHeader CTApplicationJSON]

instance JSON.ToJSON ApiRequestError where
  toJSON (ParseRequestError message details) = JSON.object [
    "message" .= message, "details" .= details]
  toJSON ActionInappropriate = JSON.object [
    "message" .= ("Bad Request" :: Text)]
  toJSON (InvalidBody errorMessage) = JSON.object [
    "message" .= (toS errorMessage :: Text)]
  toJSON InvalidRange = JSON.object [
    "message" .= ("HTTP Range error" :: Text)]
  toJSON UnknownRelation = JSON.object [
    "message" .= ("Unknown relation" :: Text)]
  toJSON (NoRelBetween parent child) = JSON.object [
    "message" .= ("Could not find foreign keys between these entities. No relationship found between " <> parent <> " and " <> child :: Text)]
  toJSON (AmbiguousRelBetween parent child rels) = JSON.object [
    "hint"    .= ("By following the 'details' key, disambiguate the request by changing the url to /origin?select=relationship(*) or /origin?select=target!relationship(*)" :: Text),
    "message" .= ("More than one relationship was found for " <> parent <> " and " <> child :: Text),
    "details" .= (compressedRel <$> rels) ]
  toJSON UnsupportedVerb = JSON.object [
    "message" .= ("Unsupported HTTP verb" :: Text)]
  toJSON InvalidFilters = JSON.object [
    "message" .= ("Filters must include all and only primary key columns with 'eq' operators" :: Text)]
  toJSON (UnacceptableSchema schemas) = JSON.object [
    "message" .= ("The schema must be one of the following: " <> T.intercalate ", " schemas)]

compressedRel :: Relation -> JSON.Value
compressedRel rel =
  let
    fmtTbl tbl = tableSchema tbl <> "." <> tableName tbl
    fmtEls els = "[" <> T.intercalate ", " els <> "]"
  in
  JSON.object $ [
    "origin"      .= fmtTbl (relTable rel)
  , "target"      .= fmtTbl (relFTable rel)
  , "cardinality" .= (show $ relType rel :: Text)
  ] ++
  case (relType rel, relJunction rel, relConstraint rel) of
    (M2M, Just (Junction jt (Just const1) _ (Just const2) _), _) -> [
      "relationship" .= (fmtTbl jt <> fmtEls [const1] <> fmtEls [const2])
      ]
    (_, _, Just relCon) -> [
      "relationship" .= (relCon <> fmtEls (colName <$> relColumns rel) <> fmtEls (colName <$> relFColumns rel))
      ]
    (_, _, _) ->
      mempty

data PgError = PgError Authenticated P.UsageError
type Authenticated = Bool

instance PgrstError PgError where
  status (PgError authed usageError) = pgErrorStatus authed usageError

  headers err =
    if status err == HT.status401
       then [toHeader CTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header]
       else [toHeader CTApplicationJSON]

instance JSON.ToJSON PgError where
  toJSON (PgError _ usageError) = JSON.toJSON usageError

instance JSON.ToJSON P.UsageError where
  toJSON (P.ConnectionError e) = JSON.object [
    "code"    .= ("" :: Text),
    "message" .= ("Database connection error" :: Text),
    "details" .= (toS $ fromMaybe "" e :: Text)]
  toJSON (P.SessionError e) = JSON.toJSON e -- H.Error

instance JSON.ToJSON H.QueryError where
  toJSON (H.QueryError _ _ e) = JSON.toJSON e

instance JSON.ToJSON H.CommandError where
  toJSON (H.ResultError (H.ServerError c m d h)) = case toS c of
    'P':'T':_ -> JSON.object [
        "details" .= (fmap toS d :: Maybe Text),
        "hint"    .= (fmap toS h :: Maybe Text)]

    _         -> JSON.object [
        "code"    .= (toS c      :: Text),
        "message" .= (toS m      :: Text),
        "details" .= (fmap toS d :: Maybe Text),
        "hint"    .= (fmap toS h :: Maybe Text)]

  toJSON (H.ResultError (H.UnexpectedResult m)) = JSON.object [
    "message" .= (m :: Text)]
  toJSON (H.ResultError (H.RowError i H.EndOfInput)) = JSON.object [
    "message" .= ("Row error: end of input" :: Text),
    "details" .= ("Attempt to parse more columns than there are in the result" :: Text),
    "hint"    .= (("Row number " <> show i) :: Text)]
  toJSON (H.ResultError (H.RowError i H.UnexpectedNull)) = JSON.object [
    "message" .= ("Row error: unexpected null" :: Text),
    "details" .= ("Attempt to parse a NULL as some value." :: Text),
    "hint"    .= (("Row number " <> show i) :: Text)]
  toJSON (H.ResultError (H.RowError i (H.ValueError d))) = JSON.object [
    "message" .= ("Row error: Wrong value parser used" :: Text),
    "details" .= d,
    "hint"    .= (("Row number " <> show i) :: Text)]
  toJSON (H.ResultError (H.UnexpectedAmountOfRows i)) = JSON.object [
    "message" .= ("Unexpected amount of rows" :: Text),
    "details" .= i]
  toJSON (H.ClientError d) = JSON.object [
    "message" .= ("Database client error" :: Text),
    "details" .= (fmap toS d :: Maybe Text)]

pgErrorStatus :: Bool -> P.UsageError -> HT.Status
pgErrorStatus _      (P.ConnectionError _)                                      = HT.status503
pgErrorStatus _      (P.SessionError (H.QueryError _ _ (H.ClientError _)))      = HT.status503
pgErrorStatus authed (P.SessionError (H.QueryError _ _ (H.ResultError rError))) =
  case rError of
    (H.ServerError c m _ _) ->
      case toS c of
        '0':'8':_ -> HT.status503 -- pg connection err
        '0':'9':_ -> HT.status500 -- triggered action exception
        '0':'L':_ -> HT.status403 -- invalid grantor
        '0':'P':_ -> HT.status403 -- invalid role specification
        "23503"   -> HT.status409 -- foreign_key_violation
        "23505"   -> HT.status409 -- unique_violation
        '2':'5':_ -> HT.status500 -- invalid tx state
        '2':'8':_ -> HT.status403 -- invalid auth specification
        '2':'D':_ -> HT.status500 -- invalid tx termination
        '3':'8':_ -> HT.status500 -- external routine exception
        '3':'9':_ -> HT.status500 -- external routine invocation
        '3':'B':_ -> HT.status500 -- savepoint exception
        '4':'0':_ -> HT.status500 -- tx rollback
        '5':'3':_ -> HT.status503 -- insufficient resources
        '5':'4':_ -> HT.status413 -- too complex
        '5':'5':_ -> HT.status500 -- obj not on prereq state
        '5':'7':_ -> HT.status500 -- operator intervention
        '5':'8':_ -> HT.status500 -- system error
        'F':'0':_ -> HT.status500 -- conf file error
        'H':'V':_ -> HT.status500 -- foreign data wrapper error
        "P0001"   -> HT.status400 -- default code for "raise"
        'P':'0':_ -> HT.status500 -- PL/pgSQL Error
        'X':'X':_ -> HT.status500 -- internal Error
        "42883"   -> HT.status404 -- undefined function
        "42P01"   -> HT.status404 -- undefined table
        "42501"   -> if authed then HT.status403 else HT.status401 -- insufficient privilege
        'P':'T':n -> fromMaybe HT.status500 (HT.mkStatus <$> readMaybe n <*> pure m)
        _         -> HT.status400

    _                       -> HT.status500

checkIsFatal :: PgError -> Maybe Text
checkIsFatal (PgError _ (P.ConnectionError e))
  | isAuthFailureMessage = Just $ toS failureMessage
  | otherwise = Nothing
  where isAuthFailureMessage = "FATAL:  password authentication failed" `isPrefixOf` toS failureMessage
        failureMessage = fromMaybe "" e
checkIsFatal _ = Nothing


data SimpleError
  = GucHeadersError
  | BinaryFieldError ContentType
  | ConnectionLostError
  | PutMatchingPkError
  | PutRangeNotAllowedError
  | JwtTokenMissing
  | JwtTokenInvalid Text
  | SingularityError Integer
  | ContentTypeError [ByteString]
  deriving (Show, Eq)

instance PgrstError SimpleError where
  status GucHeadersError         = HT.status500
  status (BinaryFieldError _)    = HT.status406
  status ConnectionLostError     = HT.status503
  status PutMatchingPkError      = HT.status400
  status PutRangeNotAllowedError = HT.status400
  status JwtTokenMissing         = HT.status500
  status (JwtTokenInvalid _)     = HT.unauthorized401
  status (SingularityError _)    = HT.status406
  status (ContentTypeError _)    = HT.status415

  headers (SingularityError _)     = [toHeader CTSingularJSON]
  headers (JwtTokenInvalid m)      = [toHeader CTApplicationJSON, invalidTokenHeader m]
  headers _                        = [toHeader CTApplicationJSON]

instance JSON.ToJSON SimpleError where
  toJSON GucHeadersError           = JSON.object [
    "message" .= ("response.headers guc must be a JSON array composed of objects with a single key and a string value" :: Text)]
  toJSON (BinaryFieldError ct)          = JSON.object [
    "message" .= ((toS (toMime ct) <> " requested but more than one column was selected") :: Text)]
  toJSON ConnectionLostError       = JSON.object [
    "message" .= ("Database connection lost, retrying the connection." :: Text)]

  toJSON PutRangeNotAllowedError   = JSON.object [
    "message" .= ("Range header and limit/offset querystring parameters are not allowed for PUT" :: Text)]
  toJSON PutMatchingPkError        = JSON.object [
    "message" .= ("Payload values do not match URL in primary key column(s)" :: Text)]

  toJSON (ContentTypeError cts)    = JSON.object [
    "message" .= ("None of these Content-Types are available: " <> (toS . intercalate ", " . map toS) cts :: Text)]
  toJSON (SingularityError n)      = JSON.object [
    "message" .= ("JSON object requested, multiple (or no) rows returned" :: Text),
    "details" .= T.unwords ["Results contain", show n, "rows,", toS (toMime CTSingularJSON), "requires 1 row"]]

  toJSON JwtTokenMissing           = JSON.object [
    "message" .= ("Server lacks JWT secret" :: Text)]
  toJSON (JwtTokenInvalid message) = JSON.object [
    "message" .= (message :: Text)]

invalidTokenHeader :: Text -> Header
invalidTokenHeader m =
  ("WWW-Authenticate", "Bearer error=\"invalid_token\", " <> "error_description=" <> encodeUtf8 (show m))

singularityError :: (Integral a) => a -> SimpleError
singularityError = SingularityError . toInteger