{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
module Monad.Rail.Error
( ErrorSeverity (..),
PublicErrorInfo (..),
InternalErrorInfo (..),
SomeErrorDetails (..),
HasErrorInfo (..),
publicErrorInfo,
internalErrorInfo,
SomeError (..),
UnhandledException (..),
Failure (..),
)
where
import qualified Control.Exception as E
import Data.Aeson (ToJSON (..), object, (.=))
import Data.Data (Data, toConstr)
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable (Typeable)
import GHC.Stack (CallStack, prettyCallStack)
data ErrorSeverity
=
Error
|
Critical
deriving (ErrorSeverity -> ErrorSeverity -> Bool
(ErrorSeverity -> ErrorSeverity -> Bool)
-> (ErrorSeverity -> ErrorSeverity -> Bool) -> Eq ErrorSeverity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrorSeverity -> ErrorSeverity -> Bool
== :: ErrorSeverity -> ErrorSeverity -> Bool
$c/= :: ErrorSeverity -> ErrorSeverity -> Bool
/= :: ErrorSeverity -> ErrorSeverity -> Bool
Eq, Int -> ErrorSeverity -> ShowS
[ErrorSeverity] -> ShowS
ErrorSeverity -> String
(Int -> ErrorSeverity -> ShowS)
-> (ErrorSeverity -> String)
-> ([ErrorSeverity] -> ShowS)
-> Show ErrorSeverity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrorSeverity -> ShowS
showsPrec :: Int -> ErrorSeverity -> ShowS
$cshow :: ErrorSeverity -> String
show :: ErrorSeverity -> String
$cshowList :: [ErrorSeverity] -> ShowS
showList :: [ErrorSeverity] -> ShowS
Show, Eq ErrorSeverity
Eq ErrorSeverity =>
(ErrorSeverity -> ErrorSeverity -> Ordering)
-> (ErrorSeverity -> ErrorSeverity -> Bool)
-> (ErrorSeverity -> ErrorSeverity -> Bool)
-> (ErrorSeverity -> ErrorSeverity -> Bool)
-> (ErrorSeverity -> ErrorSeverity -> Bool)
-> (ErrorSeverity -> ErrorSeverity -> ErrorSeverity)
-> (ErrorSeverity -> ErrorSeverity -> ErrorSeverity)
-> Ord ErrorSeverity
ErrorSeverity -> ErrorSeverity -> Bool
ErrorSeverity -> ErrorSeverity -> Ordering
ErrorSeverity -> ErrorSeverity -> ErrorSeverity
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ErrorSeverity -> ErrorSeverity -> Ordering
compare :: ErrorSeverity -> ErrorSeverity -> Ordering
$c< :: ErrorSeverity -> ErrorSeverity -> Bool
< :: ErrorSeverity -> ErrorSeverity -> Bool
$c<= :: ErrorSeverity -> ErrorSeverity -> Bool
<= :: ErrorSeverity -> ErrorSeverity -> Bool
$c> :: ErrorSeverity -> ErrorSeverity -> Bool
> :: ErrorSeverity -> ErrorSeverity -> Bool
$c>= :: ErrorSeverity -> ErrorSeverity -> Bool
>= :: ErrorSeverity -> ErrorSeverity -> Bool
$cmax :: ErrorSeverity -> ErrorSeverity -> ErrorSeverity
max :: ErrorSeverity -> ErrorSeverity -> ErrorSeverity
$cmin :: ErrorSeverity -> ErrorSeverity -> ErrorSeverity
min :: ErrorSeverity -> ErrorSeverity -> ErrorSeverity
Ord, Int -> ErrorSeverity
ErrorSeverity -> Int
ErrorSeverity -> [ErrorSeverity]
ErrorSeverity -> ErrorSeverity
ErrorSeverity -> ErrorSeverity -> [ErrorSeverity]
ErrorSeverity -> ErrorSeverity -> ErrorSeverity -> [ErrorSeverity]
(ErrorSeverity -> ErrorSeverity)
-> (ErrorSeverity -> ErrorSeverity)
-> (Int -> ErrorSeverity)
-> (ErrorSeverity -> Int)
-> (ErrorSeverity -> [ErrorSeverity])
-> (ErrorSeverity -> ErrorSeverity -> [ErrorSeverity])
-> (ErrorSeverity -> ErrorSeverity -> [ErrorSeverity])
-> (ErrorSeverity
-> ErrorSeverity -> ErrorSeverity -> [ErrorSeverity])
-> Enum ErrorSeverity
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: ErrorSeverity -> ErrorSeverity
succ :: ErrorSeverity -> ErrorSeverity
$cpred :: ErrorSeverity -> ErrorSeverity
pred :: ErrorSeverity -> ErrorSeverity
$ctoEnum :: Int -> ErrorSeverity
toEnum :: Int -> ErrorSeverity
$cfromEnum :: ErrorSeverity -> Int
fromEnum :: ErrorSeverity -> Int
$cenumFrom :: ErrorSeverity -> [ErrorSeverity]
enumFrom :: ErrorSeverity -> [ErrorSeverity]
$cenumFromThen :: ErrorSeverity -> ErrorSeverity -> [ErrorSeverity]
enumFromThen :: ErrorSeverity -> ErrorSeverity -> [ErrorSeverity]
$cenumFromTo :: ErrorSeverity -> ErrorSeverity -> [ErrorSeverity]
enumFromTo :: ErrorSeverity -> ErrorSeverity -> [ErrorSeverity]
$cenumFromThenTo :: ErrorSeverity -> ErrorSeverity -> ErrorSeverity -> [ErrorSeverity]
enumFromThenTo :: ErrorSeverity -> ErrorSeverity -> ErrorSeverity -> [ErrorSeverity]
Enum)
instance ToJSON ErrorSeverity where
toJSON :: ErrorSeverity -> Value
toJSON ErrorSeverity
Error = Value
"Error"
toJSON ErrorSeverity
Critical = Value
"Critical"
data SomeErrorDetails = forall a. (ToJSON a, Show a, Typeable a) => SomeErrorDetails a
instance Show SomeErrorDetails where
show :: SomeErrorDetails -> String
show (SomeErrorDetails a
a) = a -> String
forall a. Show a => a -> String
show a
a
instance ToJSON SomeErrorDetails where
toJSON :: SomeErrorDetails -> Value
toJSON (SomeErrorDetails a
a) = a -> Value
forall a. ToJSON a => a -> Value
toJSON a
a
data PublicErrorInfo = PublicErrorInfo
{
PublicErrorInfo -> Text
publicMessage :: Text,
PublicErrorInfo -> Text
code :: Text,
PublicErrorInfo -> Maybe SomeErrorDetails
details :: Maybe SomeErrorDetails
}
deriving (Int -> PublicErrorInfo -> ShowS
[PublicErrorInfo] -> ShowS
PublicErrorInfo -> String
(Int -> PublicErrorInfo -> ShowS)
-> (PublicErrorInfo -> String)
-> ([PublicErrorInfo] -> ShowS)
-> Show PublicErrorInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PublicErrorInfo -> ShowS
showsPrec :: Int -> PublicErrorInfo -> ShowS
$cshow :: PublicErrorInfo -> String
show :: PublicErrorInfo -> String
$cshowList :: [PublicErrorInfo] -> ShowS
showList :: [PublicErrorInfo] -> ShowS
Show)
instance ToJSON PublicErrorInfo where
toJSON :: PublicErrorInfo -> Value
toJSON PublicErrorInfo
pub =
[Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
[Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
[ Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"message" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PublicErrorInfo -> Text
publicMessage PublicErrorInfo
pub),
Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"code" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PublicErrorInfo -> Text
code PublicErrorInfo
pub),
(Key
"details" Key -> SomeErrorDetails -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (SomeErrorDetails -> Pair) -> Maybe SomeErrorDetails -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PublicErrorInfo -> Maybe SomeErrorDetails
details PublicErrorInfo
pub
]
data InternalErrorInfo = InternalErrorInfo
{
InternalErrorInfo -> Maybe Text
internalMessage :: Maybe Text,
InternalErrorInfo -> ErrorSeverity
severity :: ErrorSeverity,
InternalErrorInfo -> Maybe SomeException
exception :: Maybe E.SomeException,
InternalErrorInfo -> Maybe CallStack
callStack :: Maybe CallStack
}
deriving (Int -> InternalErrorInfo -> ShowS
[InternalErrorInfo] -> ShowS
InternalErrorInfo -> String
(Int -> InternalErrorInfo -> ShowS)
-> (InternalErrorInfo -> String)
-> ([InternalErrorInfo] -> ShowS)
-> Show InternalErrorInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InternalErrorInfo -> ShowS
showsPrec :: Int -> InternalErrorInfo -> ShowS
$cshow :: InternalErrorInfo -> String
show :: InternalErrorInfo -> String
$cshowList :: [InternalErrorInfo] -> ShowS
showList :: [InternalErrorInfo] -> ShowS
Show)
instance ToJSON InternalErrorInfo where
toJSON :: InternalErrorInfo -> Value
toJSON InternalErrorInfo
internal =
[Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
[Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
[ Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"severity" Key -> ErrorSeverity -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= InternalErrorInfo -> ErrorSeverity
severity InternalErrorInfo
internal),
(Key
"message" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (Text -> Pair) -> Maybe Text -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InternalErrorInfo -> Maybe Text
internalMessage InternalErrorInfo
internal,
(Key
"exception" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (Text -> Pair) -> (SomeException -> Text) -> SomeException -> Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (SomeException -> String) -> SomeException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall e. Exception e => e -> String
E.displayException (SomeException -> Pair) -> Maybe SomeException -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InternalErrorInfo -> Maybe SomeException
exception InternalErrorInfo
internal,
(Key
"callStack" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (Text -> Pair) -> (CallStack -> Text) -> CallStack -> Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (CallStack -> String) -> CallStack -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> String
prettyCallStack (CallStack -> Pair) -> Maybe CallStack -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InternalErrorInfo -> Maybe CallStack
callStack InternalErrorInfo
internal
]
class HasErrorInfo e where
errorPublicMessage :: e -> Text
errorCode :: e -> Text
default errorCode :: (Data e) => e -> Text
errorCode e
e = String -> Text
T.pack (Constr -> String
forall a. Show a => a -> String
show (e -> Constr
forall a. Data a => a -> Constr
toConstr e
e))
errorDetails :: e -> Maybe SomeErrorDetails
errorDetails e
_ = Maybe SomeErrorDetails
forall a. Maybe a
Nothing
errorSeverity :: e -> ErrorSeverity
errorSeverity e
_ = ErrorSeverity
Error
errorInternalMessage :: e -> Maybe Text
errorInternalMessage e
_ = Maybe Text
forall a. Maybe a
Nothing
errorException :: e -> Maybe E.SomeException
errorException e
_ = Maybe SomeException
forall a. Maybe a
Nothing
errorCallStack :: e -> Maybe CallStack
errorCallStack e
_ = Maybe CallStack
forall a. Maybe a
Nothing
publicErrorInfo :: (HasErrorInfo e) => e -> PublicErrorInfo
publicErrorInfo :: forall e. HasErrorInfo e => e -> PublicErrorInfo
publicErrorInfo e
e =
PublicErrorInfo
{ publicMessage :: Text
publicMessage = e -> Text
forall e. HasErrorInfo e => e -> Text
errorPublicMessage e
e,
code :: Text
code = e -> Text
forall e. HasErrorInfo e => e -> Text
errorCode e
e,
details :: Maybe SomeErrorDetails
details = e -> Maybe SomeErrorDetails
forall e. HasErrorInfo e => e -> Maybe SomeErrorDetails
errorDetails e
e
}
internalErrorInfo :: (HasErrorInfo e) => e -> InternalErrorInfo
internalErrorInfo :: forall e. HasErrorInfo e => e -> InternalErrorInfo
internalErrorInfo e
e =
InternalErrorInfo
{ internalMessage :: Maybe Text
internalMessage = e -> Maybe Text
forall e. HasErrorInfo e => e -> Maybe Text
errorInternalMessage e
e,
severity :: ErrorSeverity
severity = e -> ErrorSeverity
forall e. HasErrorInfo e => e -> ErrorSeverity
errorSeverity e
e,
exception :: Maybe SomeException
exception = e -> Maybe SomeException
forall e. HasErrorInfo e => e -> Maybe SomeException
errorException e
e,
callStack :: Maybe CallStack
callStack = e -> Maybe CallStack
forall e. HasErrorInfo e => e -> Maybe CallStack
errorCallStack e
e
}
data UnhandledException = UnhandledException
{
UnhandledException -> Maybe Text
unhandledCode :: Maybe Text,
UnhandledException -> SomeException
unhandledException :: E.SomeException,
UnhandledException -> Maybe CallStack
unhandledCallStack :: Maybe CallStack,
UnhandledException -> Maybe Text
unhandledMessage :: Maybe Text
}
instance Show UnhandledException where
show :: UnhandledException -> String
show UnhandledException
ue = String
"Unhandled exception: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall e. Exception e => e -> String
E.displayException (UnhandledException -> SomeException
unhandledException UnhandledException
ue)
instance HasErrorInfo UnhandledException where
errorPublicMessage :: UnhandledException -> Text
errorPublicMessage UnhandledException
ue = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"An unexpected error occurred" (UnhandledException -> Maybe Text
unhandledMessage UnhandledException
ue)
errorCode :: UnhandledException -> Text
errorCode UnhandledException
ue = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"UnhandledException" (UnhandledException -> Maybe Text
unhandledCode UnhandledException
ue)
errorSeverity :: UnhandledException -> ErrorSeverity
errorSeverity UnhandledException
_ = ErrorSeverity
Critical
errorInternalMessage :: UnhandledException -> Maybe Text
errorInternalMessage UnhandledException
ue = Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
T.pack (SomeException -> String
forall e. Exception e => e -> String
E.displayException (UnhandledException -> SomeException
unhandledException UnhandledException
ue)))
errorException :: UnhandledException -> Maybe SomeException
errorException UnhandledException
ue = SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just (UnhandledException -> SomeException
unhandledException UnhandledException
ue)
errorCallStack :: UnhandledException -> Maybe CallStack
errorCallStack UnhandledException
ue = UnhandledException -> Maybe CallStack
unhandledCallStack UnhandledException
ue
data SomeError
= forall e.
(HasErrorInfo e, Show e, Typeable e) =>
SomeError e
instance ToJSON SomeError where
toJSON :: SomeError -> Value
toJSON (SomeError e
e) = PublicErrorInfo -> Value
forall a. ToJSON a => a -> Value
toJSON (e -> PublicErrorInfo
forall e. HasErrorInfo e => e -> PublicErrorInfo
publicErrorInfo e
e)
instance Show SomeError where
show :: SomeError -> String
show (SomeError e
e) = e -> String
forall a. Show a => a -> String
show e
e
instance HasErrorInfo SomeError where
errorPublicMessage :: SomeError -> Text
errorPublicMessage (SomeError e
e) = e -> Text
forall e. HasErrorInfo e => e -> Text
errorPublicMessage e
e
errorCode :: SomeError -> Text
errorCode (SomeError e
e) = e -> Text
forall e. HasErrorInfo e => e -> Text
errorCode e
e
errorDetails :: SomeError -> Maybe SomeErrorDetails
errorDetails (SomeError e
e) = e -> Maybe SomeErrorDetails
forall e. HasErrorInfo e => e -> Maybe SomeErrorDetails
errorDetails e
e
errorSeverity :: SomeError -> ErrorSeverity
errorSeverity (SomeError e
e) = e -> ErrorSeverity
forall e. HasErrorInfo e => e -> ErrorSeverity
errorSeverity e
e
errorInternalMessage :: SomeError -> Maybe Text
errorInternalMessage (SomeError e
e) = e -> Maybe Text
forall e. HasErrorInfo e => e -> Maybe Text
errorInternalMessage e
e
errorException :: SomeError -> Maybe SomeException
errorException (SomeError e
e) = e -> Maybe SomeException
forall e. HasErrorInfo e => e -> Maybe SomeException
errorException e
e
errorCallStack :: SomeError -> Maybe CallStack
errorCallStack (SomeError e
e) = e -> Maybe CallStack
forall e. HasErrorInfo e => e -> Maybe CallStack
errorCallStack e
e
newtype Failure = Failure
{
Failure -> NonEmpty SomeError
getErrors :: NonEmpty SomeError
}
deriving (Int -> Failure -> ShowS
[Failure] -> ShowS
Failure -> String
(Int -> Failure -> ShowS)
-> (Failure -> String) -> ([Failure] -> ShowS) -> Show Failure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Failure -> ShowS
showsPrec :: Int -> Failure -> ShowS
$cshow :: Failure -> String
show :: Failure -> String
$cshowList :: [Failure] -> ShowS
showList :: [Failure] -> ShowS
Show)
instance Semigroup Failure where
(Failure NonEmpty SomeError
e1) <> :: Failure -> Failure -> Failure
<> (Failure NonEmpty SomeError
e2) = NonEmpty SomeError -> Failure
Failure (NonEmpty SomeError
e1 NonEmpty SomeError -> NonEmpty SomeError -> NonEmpty SomeError
forall a. Semigroup a => a -> a -> a
<> NonEmpty SomeError
e2)
instance ToJSON Failure where
toJSON :: Failure -> Value
toJSON = NonEmpty SomeError -> Value
forall a. ToJSON a => a -> Value
toJSON (NonEmpty SomeError -> Value)
-> (Failure -> NonEmpty SomeError) -> Failure -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failure -> NonEmpty SomeError
getErrors