{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}

-- 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/>.

module Network.Wai.Utilities.Error
  ( Error (..),
    ErrorData (..),
    mkError,
    (!>>),
  )
where

import Control.Error
import Data.Aeson hiding (Error)
import Data.Aeson.Types (Pair)
import Data.Domain
import Imports
import Network.HTTP.Types

data Error = Error
  { Error -> Status
code :: !Status,
    Error -> LText
label :: !LText,
    Error -> LText
message :: !LText,
    Error -> Maybe ErrorData
errorData :: Maybe ErrorData,
    Error -> Maybe Error
innerError :: Maybe Error
  }
  deriving (Error -> Error -> Bool
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
/= :: Error -> Error -> Bool
Eq, Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Error -> ShowS
showsPrec :: Int -> Error -> ShowS
$cshow :: Error -> String
show :: Error -> String
$cshowList :: [Error] -> ShowS
showList :: [Error] -> ShowS
Show, Typeable)

mkError :: Status -> LText -> LText -> Error
mkError :: Status -> LText -> LText -> Error
mkError Status
c LText
l LText
m = Status -> LText -> LText -> Maybe ErrorData -> Maybe Error -> Error
Error Status
c LText
l LText
m Maybe ErrorData
forall a. Maybe a
Nothing Maybe Error
forall a. Maybe a
Nothing

instance Exception Error

data ErrorData = FederationErrorData
  { ErrorData -> Domain
federrDomain :: !Domain,
    ErrorData -> Text
federrPath :: !Text
  }
  deriving (ErrorData -> ErrorData -> Bool
(ErrorData -> ErrorData -> Bool)
-> (ErrorData -> ErrorData -> Bool) -> Eq ErrorData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrorData -> ErrorData -> Bool
== :: ErrorData -> ErrorData -> Bool
$c/= :: ErrorData -> ErrorData -> Bool
/= :: ErrorData -> ErrorData -> Bool
Eq, Int -> ErrorData -> ShowS
[ErrorData] -> ShowS
ErrorData -> String
(Int -> ErrorData -> ShowS)
-> (ErrorData -> String)
-> ([ErrorData] -> ShowS)
-> Show ErrorData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrorData -> ShowS
showsPrec :: Int -> ErrorData -> ShowS
$cshow :: ErrorData -> String
show :: ErrorData -> String
$cshowList :: [ErrorData] -> ShowS
showList :: [ErrorData] -> ShowS
Show, Typeable)

instance ToJSON ErrorData where
  toJSON :: ErrorData -> Value
toJSON (FederationErrorData Domain
d Text
p) =
    [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
      [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= (Text
"federation" :: Text),
        Key
"domain" Key -> Domain -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Domain
d,
        Key
"path" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
p
      ]

instance FromJSON ErrorData where
  parseJSON :: Value -> Parser ErrorData
parseJSON = String -> (Object -> Parser ErrorData) -> Value -> Parser ErrorData
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ErrorData" ((Object -> Parser ErrorData) -> Value -> Parser ErrorData)
-> (Object -> Parser ErrorData) -> Value -> Parser ErrorData
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Domain -> Text -> ErrorData
FederationErrorData
      (Domain -> Text -> ErrorData)
-> Parser Domain -> Parser (Text -> ErrorData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Domain
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"domain"
      Parser (Text -> ErrorData) -> Parser Text -> Parser ErrorData
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"path"

instance ToJSON Error where
  toJSON :: Error -> Value
toJSON (Error Status
c LText
l LText
m Maybe ErrorData
md Maybe Error
inner) =
    [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
      [ Key
"code" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Status -> Int
statusCode Status
c,
        Key
"label" Key -> LText -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= LText
l,
        Key
"message" Key -> LText -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= LText
m
      ]
        [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair] -> (ErrorData -> [Pair]) -> Maybe ErrorData -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ErrorData -> [Pair]
dataFields Maybe ErrorData
md
        [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Key
"inner" Key -> Error -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Error
e | Error
e <- Maybe Error -> [Error]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe Error
inner]
    where
      dataFields :: ErrorData -> [Pair]
      dataFields :: ErrorData -> [Pair]
dataFields ErrorData
d = [Key
"data" Key -> ErrorData -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= ErrorData
d]

instance FromJSON Error where
  parseJSON :: Value -> Parser Error
parseJSON = String -> (Object -> Parser Error) -> Value -> Parser Error
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Error" ((Object -> Parser Error) -> Value -> Parser Error)
-> (Object -> Parser Error) -> Value -> Parser Error
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Status -> LText -> LText -> Maybe ErrorData -> Maybe Error -> Error
Error
      (Status
 -> LText -> LText -> Maybe ErrorData -> Maybe Error -> Error)
-> Parser Status
-> Parser
     (LText -> LText -> Maybe ErrorData -> Maybe Error -> Error)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Status
forall a. Enum a => Int -> a
toEnum (Int -> Status) -> Parser Int -> Parser Status
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"code")
      Parser (LText -> LText -> Maybe ErrorData -> Maybe Error -> Error)
-> Parser LText
-> Parser (LText -> Maybe ErrorData -> Maybe Error -> Error)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser LText
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"label"
      Parser (LText -> Maybe ErrorData -> Maybe Error -> Error)
-> Parser LText -> Parser (Maybe ErrorData -> Maybe Error -> Error)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser LText
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"message"
      Parser (Maybe ErrorData -> Maybe Error -> Error)
-> Parser (Maybe ErrorData) -> Parser (Maybe Error -> Error)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe ErrorData)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"data"
      Parser (Maybe Error -> Error)
-> Parser (Maybe Error) -> Parser Error
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Error)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"inner"

-- FIXME: This should not live here.
infixl 5 !>>

(!>>) :: (Monad m) => ExceptT a m r -> (a -> b) -> ExceptT b m r
!>> :: forall (m :: * -> *) a r b.
Monad m =>
ExceptT a m r -> (a -> b) -> ExceptT b m r
(!>>) = ((a -> b) -> ExceptT a m r -> ExceptT b m r)
-> ExceptT a m r -> (a -> b) -> ExceptT b m r
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> b) -> ExceptT a m r -> ExceptT b m r
forall (m :: * -> *) a b r.
Functor m =>
(a -> b) -> ExceptT a m r -> ExceptT b m r
fmapLT