-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2020 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 (Int -> ScimErrorType -> ShowS
[ScimErrorType] -> ShowS
ScimErrorType -> String
(Int -> ScimErrorType -> ShowS)
-> (ScimErrorType -> String)
-> ([ScimErrorType] -> ShowS)
-> Show ScimErrorType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScimErrorType] -> ShowS
$cshowList :: [ScimErrorType] -> ShowS
show :: ScimErrorType -> String
$cshow :: ScimErrorType -> String
showsPrec :: Int -> ScimErrorType -> ShowS
$cshowsPrec :: Int -> ScimErrorType -> ShowS
Show, ScimErrorType -> ScimErrorType -> Bool
(ScimErrorType -> ScimErrorType -> Bool)
-> (ScimErrorType -> ScimErrorType -> Bool) -> Eq ScimErrorType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScimErrorType -> ScimErrorType -> Bool
$c/= :: ScimErrorType -> ScimErrorType -> Bool
== :: ScimErrorType -> ScimErrorType -> Bool
$c== :: ScimErrorType -> ScimErrorType -> Bool
Eq, (forall x. ScimErrorType -> Rep ScimErrorType x)
-> (forall x. Rep ScimErrorType x -> ScimErrorType)
-> Generic ScimErrorType
forall x. Rep ScimErrorType x -> ScimErrorType
forall x. ScimErrorType -> Rep ScimErrorType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ScimErrorType x -> ScimErrorType
$cfrom :: forall x. ScimErrorType -> Rep ScimErrorType x
Generic)

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

-- wrapped in a newtype because SCIM wants strings for status codes
newtype Status = Status {Status -> Int
unStatus :: Int}
  deriving (Int -> Status -> ShowS
[Status] -> ShowS
Status -> String
(Int -> Status -> ShowS)
-> (Status -> String) -> ([Status] -> ShowS) -> Show Status
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Status] -> ShowS
$cshowList :: [Status] -> ShowS
show :: Status -> String
$cshow :: Status -> String
showsPrec :: Int -> Status -> ShowS
$cshowsPrec :: Int -> Status -> ShowS
Show, Status -> Status -> Bool
(Status -> Status -> Bool)
-> (Status -> Status -> Bool) -> Eq Status
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c== :: Status -> Status -> Bool
Eq, (forall x. Status -> Rep Status x)
-> (forall x. Rep Status x -> Status) -> Generic Status
forall x. Rep Status x -> Status
forall x. Status -> Rep Status x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Status x -> Status
$cfrom :: forall x. Status -> Rep Status x
Generic)

instance ToJSON Status where
  toJSON :: Status -> Value
toJSON (Status Int
stat) = Text -> Value
String (Text -> Value) -> (Int -> Text) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Value) -> Int -> Value
forall a b. (a -> b) -> a -> b
$ Int
stat

data ScimError = ScimError
  { ScimError -> [Schema]
schemas :: [Schema],
    ScimError -> Status
status :: Status,
    ScimError -> Maybe ScimErrorType
scimType :: Maybe ScimErrorType,
    ScimError -> Maybe Text
detail :: Maybe Text
  }
  deriving (Int -> ScimError -> ShowS
[ScimError] -> ShowS
ScimError -> String
(Int -> ScimError -> ShowS)
-> (ScimError -> String)
-> ([ScimError] -> ShowS)
-> Show ScimError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScimError] -> ShowS
$cshowList :: [ScimError] -> ShowS
show :: ScimError -> String
$cshow :: ScimError -> String
showsPrec :: Int -> ScimError -> ShowS
$cshowsPrec :: Int -> ScimError -> ShowS
Show, ScimError -> ScimError -> Bool
(ScimError -> ScimError -> Bool)
-> (ScimError -> ScimError -> Bool) -> Eq ScimError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScimError -> ScimError -> Bool
$c/= :: ScimError -> ScimError -> Bool
== :: ScimError -> ScimError -> Bool
$c== :: ScimError -> ScimError -> Bool
Eq, (forall x. ScimError -> Rep ScimError x)
-> (forall x. Rep ScimError x -> ScimError) -> Generic ScimError
forall x. Rep ScimError x -> ScimError
forall x. ScimError -> Rep ScimError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ScimError x -> ScimError
$cfrom :: forall x. ScimError -> Rep ScimError x
Generic)

instance ToJSON ScimError where
  toJSON :: ScimError -> Value
toJSON = Options -> ScimError -> Value
forall a.
(Generic a, GToJSON Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
serializeOptions

instance Exception ScimError

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

badRequest ::
  -- | Error type
  ScimErrorType ->
  -- | Error details
  Maybe Text ->
  ScimError
badRequest :: ScimErrorType -> Maybe Text -> ScimError
badRequest ScimErrorType
typ Maybe Text
mbDetail =
  ScimError :: [Schema]
-> Status -> Maybe ScimErrorType -> Maybe Text -> ScimError
ScimError
    { schemas :: [Schema]
schemas = [Schema
Error20],
      status :: Status
status = Int -> Status
Status Int
400,
      scimType :: Maybe ScimErrorType
scimType = ScimErrorType -> Maybe ScimErrorType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScimErrorType
typ,
      detail :: Maybe Text
detail = Maybe Text
mbDetail
    }

unauthorized ::
  -- | Error details
  Text ->
  ScimError
unauthorized :: Text -> ScimError
unauthorized Text
details =
  ScimError :: [Schema]
-> Status -> Maybe ScimErrorType -> Maybe Text -> ScimError
ScimError
    { schemas :: [Schema]
schemas = [Schema
Error20],
      status :: Status
status = Int -> Status
Status Int
401,
      scimType :: Maybe ScimErrorType
scimType = Maybe ScimErrorType
forall a. Maybe a
Nothing,
      detail :: Maybe Text
detail = Text -> Maybe Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"authorization failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
details
    }

forbidden ::
  -- | Error details
  Text ->
  ScimError
forbidden :: Text -> ScimError
forbidden Text
details =
  ScimError :: [Schema]
-> Status -> Maybe ScimErrorType -> Maybe Text -> ScimError
ScimError
    { schemas :: [Schema]
schemas = [Schema
Error20],
      status :: Status
status = Int -> Status
Status Int
403,
      scimType :: Maybe ScimErrorType
scimType = Maybe ScimErrorType
forall a. Maybe a
Nothing,
      detail :: Maybe Text
detail = Text -> Maybe Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"forbidden: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
details
    }

notFound ::
  -- | Resource type
  Text ->
  -- | Resource ID
  Text ->
  ScimError
notFound :: Text -> Text -> ScimError
notFound Text
resourceType Text
resourceId =
  ScimError :: [Schema]
-> Status -> Maybe ScimErrorType -> Maybe Text -> ScimError
ScimError
    { schemas :: [Schema]
schemas = [Schema
Error20],
      status :: Status
status = Int -> Status
Status Int
404,
      scimType :: Maybe ScimErrorType
scimType = Maybe ScimErrorType
forall a. Maybe a
Nothing,
      detail :: Maybe Text
detail = Text -> Maybe Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
resourceType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
resourceId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not found"
    }

conflict :: ScimError
conflict :: ScimError
conflict =
  ScimError :: [Schema]
-> Status -> Maybe ScimErrorType -> Maybe Text -> ScimError
ScimError
    { schemas :: [Schema]
schemas = [Schema
Error20],
      status :: Status
status = Int -> Status
Status Int
409,
      scimType :: Maybe ScimErrorType
scimType = ScimErrorType -> Maybe ScimErrorType
forall a. a -> Maybe a
Just ScimErrorType
Uniqueness,
      detail :: Maybe Text
detail = Maybe Text
forall a. Maybe a
Nothing
    }

serverError ::
  -- | Error details
  Text ->
  ScimError
serverError :: Text -> ScimError
serverError Text
details =
  ScimError :: [Schema]
-> Status -> Maybe ScimErrorType -> Maybe Text -> ScimError
ScimError
    { schemas :: [Schema]
schemas = [Schema
Error20],
      status :: Status
status = Int -> Status
Status Int
500,
      scimType :: Maybe ScimErrorType
scimType = Maybe ScimErrorType
forall a. Maybe a
Nothing,
      detail :: Maybe Text
detail = Text -> Maybe Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
details
    }

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

-- | Convert a SCIM 'Error' to a Servant one by encoding it with the
-- appropriate headers.
scimToServerError :: ScimError -> ServerError
scimToServerError :: ScimError -> ServerError
scimToServerError ScimError
err =
  ServerError :: Int -> String -> ByteString -> [Header] -> ServerError
ServerError
    { errHTTPCode :: Int
errHTTPCode = Status -> Int
unStatus (ScimError -> Status
status ScimError
err),
      errReasonPhrase :: String
errReasonPhrase = Status -> String
reasonPhrase (ScimError -> Status
status ScimError
err),
      errBody :: ByteString
errBody = ScimError -> ByteString
forall a. ToJSON a => a -> ByteString
encode ScimError
err,
      errHeaders :: [Header]
errHeaders = [(HeaderName
"Content-Type", ByteString
"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 :: Status -> String
reasonPhrase = \case
  Status Int
400 -> String
"Bad Request"
  Status Int
401 -> String
"Unauthorized"
  Status Int
402 -> String
"Payment Required"
  Status Int
403 -> String
"Forbidden"
  Status Int
404 -> String
"Not Found"
  Status Int
405 -> String
"Method Not Allowed"
  Status Int
406 -> String
"Not Acceptable"
  Status Int
407 -> String
"Proxy Authentication Required"
  Status Int
408 -> String
"Request Time-out"
  Status Int
409 -> String
"Conflict"
  Status Int
410 -> String
"Gone"
  Status Int
411 -> String
"Length Required"
  Status Int
412 -> String
"Precondition Failed"
  Status Int
413 -> String
"Request Entity Too Large"
  Status Int
414 -> String
"Request-URI Too Large"
  Status Int
415 -> String
"Unsupported Media Type"
  Status Int
416 -> String
"Range Not Satisfiable"
  Status Int
417 -> String
"Expectation Failed"
  Status Int
422 -> String
"Unprocessable Entity"
  Status Int
500 -> String
"Internal Server Error"
  Status Int
501 -> String
"Not Implemented"
  Status Int
502 -> String
"Bad Gateway"
  Status Int
503 -> String
"Service Unavailable"
  Status Int
504 -> String
"Gateway Time-out"
  Status Int
505 -> String
"HTTP Version not supported"
  Status
other -> Status -> String
forall a. Show a => a -> String
show Status
other