Error.hs

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

-- | SCIM errors
module Web.Scim.Schema.Error
  ( -- * Types
    ScimErrorType (..),
    ScimError (..),
    Status (..),

    -- * Constructors
    notFound,
    badRequest,
    conflict,
    unauthorized,
    forbidden,
    serverError,

    -- * Servant interoperability
    scimToServerError,
  )
where

import Control.Exception
import Data.Aeson hiding (Error)
import Data.Text (Text, pack)
import GHC.Generics (Generic)
import Servant (ServerError (..))
import Web.Scim.Schema.Common
import Web.Scim.Schema.Schema

----------------------------------------------------------------------------
-- Types

-- | An ADT for error types in the SCIM specification. Not all possible SCIM
-- errors have a corresponding 'ScimErrorType' (for instance, authorization
-- is not covered by this type).
--
-- See <https://tools.ietf.org/html/rfc7644#page-69>
data ScimErrorType
  = InvalidFilter
  | TooMany
  | Uniqueness
  | Mutability
  | InvalidSyntax
  | InvalidPath
  | NoTarget
  | InvalidValue
  | InvalidVers
  | Sensitive
  deriving (Show, Eq, Generic)

instance ToJSON ScimErrorType where
  toJSON InvalidFilter = "invalidFilter"
  toJSON TooMany = "tooMany"
  toJSON Uniqueness = "uniqueness"
  toJSON Mutability = "mutability"
  toJSON InvalidSyntax = "invalidSyntax"
  toJSON InvalidPath = "invalidPath"
  toJSON NoTarget = "noTarget"
  toJSON InvalidValue = "invalidValue"
  toJSON InvalidVers = "invalidVers"
  toJSON Sensitive = "sensitive"

-- wrapped in a newtype because SCIM wants strings for status codes
newtype Status = Status {unStatus :: Int}
  deriving (Show, Eq, Generic)

instance ToJSON Status where
  toJSON (Status stat) = String . pack . show $ stat

data ScimError = ScimError
  { schemas :: [Schema],
    status :: Status,
    scimType :: Maybe ScimErrorType,
    detail :: Maybe Text
  }
  deriving (Show, Eq, Generic)

instance ToJSON ScimError where
  toJSON = genericToJSON serializeOptions

instance Exception ScimError

----------------------------------------------------------------------------
-- Constructors

badRequest ::
  -- | Error type
  ScimErrorType ->
  -- | Error details
  Maybe Text ->
  ScimError
badRequest typ mbDetail =
  ScimError
    { schemas = [Error20],
      status = Status 400,
      scimType = pure typ,
      detail = mbDetail
    }

unauthorized ::
  -- | Error details
  Text ->
  ScimError
unauthorized details =
  ScimError
    { schemas = [Error20],
      status = Status 401,
      scimType = Nothing,
      detail = pure $ "authorization failed: " <> details
    }

forbidden ::
  -- | Error details
  Text ->
  ScimError
forbidden details =
  ScimError
    { schemas = [Error20],
      status = Status 403,
      scimType = Nothing,
      detail = pure $ "forbidden: " <> details
    }

notFound ::
  -- | Resource type
  Text ->
  -- | Resource ID
  Text ->
  ScimError
notFound resourceType resourceId =
  ScimError
    { schemas = [Error20],
      status = Status 404,
      scimType = Nothing,
      detail = pure $ resourceType <> " " <> resourceId <> " not found"
    }

conflict :: ScimError
conflict =
  ScimError
    { schemas = [Error20],
      status = Status 409,
      scimType = Just Uniqueness,
      detail = Nothing
    }

serverError ::
  -- | Error details
  Text ->
  ScimError
serverError details =
  ScimError
    { schemas = [Error20],
      status = Status 500,
      scimType = Nothing,
      detail = pure details
    }

----------------------------------------------------------------------------
-- Servant

-- | Convert a SCIM 'Error' to a Servant one by encoding it with the
-- appropriate headers.
scimToServerError :: ScimError -> ServerError
scimToServerError err =
  ServerError
    { errHTTPCode = unStatus (status err),
      errReasonPhrase = reasonPhrase (status err),
      errBody = encode err,
      errHeaders = [("Content-Type", "application/scim+json;charset=utf-8")]
    }

-- | A mapping of error code "reason phrases" (e.g. "Method Not Allowed")
-- for all 4xx and 5xx errors.
reasonPhrase :: Status -> String
reasonPhrase = \case
  Status 400 -> "Bad Request"
  Status 401 -> "Unauthorized"
  Status 402 -> "Payment Required"
  Status 403 -> "Forbidden"
  Status 404 -> "Not Found"
  Status 405 -> "Method Not Allowed"
  Status 406 -> "Not Acceptable"
  Status 407 -> "Proxy Authentication Required"
  Status 408 -> "Request Time-out"
  Status 409 -> "Conflict"
  Status 410 -> "Gone"
  Status 411 -> "Length Required"
  Status 412 -> "Precondition Failed"
  Status 413 -> "Request Entity Too Large"
  Status 414 -> "Request-URI Too Large"
  Status 415 -> "Unsupported Media Type"
  Status 416 -> "Range Not Satisfiable"
  Status 417 -> "Expectation Failed"
  Status 422 -> "Unprocessable Entity"
  Status 500 -> "Internal Server Error"
  Status 501 -> "Not Implemented"
  Status 502 -> "Bad Gateway"
  Status 503 -> "Service Unavailable"
  Status 504 -> "Gateway Time-out"
  Status 505 -> "HTTP Version not supported"
  other -> show other