{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
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"
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