module Rest.Types.Error
( DataError(..)
, DomainReason(..)
, Status(..)
, fromEither
, toEither
, Reason_
, Reason(..)
, SomeReason(..)
) where
import Control.Monad.Error
import Data.Aeson hiding (Success)
import Data.Foldable (Foldable)
import Data.JSON.Schema (JSONSchema (..), gSchema)
import Data.Traversable (Traversable)
import Data.Typeable
import GHC.Generics
import Generics.Generic.Aeson
import Generics.Regular (PF, deriveAll)
import Generics.Regular.XmlPickler (gxpickle)
import Text.XML.HXT.Arrow.Pickle
import Text.XML.HXT.Arrow.Pickle.Schema
import Text.XML.HXT.Arrow.Pickle.Xml
import qualified Data.JSON.Schema as JSONSchema
data DataError
= ParseError String
| PrintError String
| MissingField String
| UnsupportedFormat String
deriving (Eq, Generic, Show)
data DomainReason a = DomainReason { responseCode :: Int, reason :: a }
deriving (Eq, Generic, Functor, Foldable, Traversable)
instance Show a => Show (DomainReason a) where
showsPrec a (DomainReason _ e) = showParen (a >= 11) (showString "Domain " . showsPrec 11 e)
instance XmlPickler a => XmlPickler (DomainReason a) where
xpickle = xpWrap (DomainReason (error "No error function defined for DomainReason parsed from JSON"), reason) xpickle
instance ToJSON a => ToJSON (DomainReason a) where
toJSON (DomainReason _ e) = toJSON e
instance FromJSON a => FromJSON (DomainReason a) where
parseJSON = fmap (DomainReason (error "No error function defined for DomainReason parsed from JSON")) . parseJSON
instance JSONSchema a => JSONSchema (DomainReason a) where
schema = schema . fmap reason
data Status a b = Failure a | Success b
deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable)
$(deriveAll ''Status "PFStatus")
type instance PF (Status a b) = PFStatus a b
instance (XmlPickler a, XmlPickler b) => XmlPickler (Status a b) where
xpickle = gxpickle
instance (ToJSON a, ToJSON b) => ToJSON (Status a b) where toJSON = gtoJson
instance (FromJSON a, FromJSON b) => FromJSON (Status a b) where parseJSON = gparseJson
instance (JSONSchema a, JSONSchema b) => JSONSchema (Status a b) where
schema = gSchema
fromEither :: Either a b -> Status a b
fromEither = either Failure Success
toEither :: Status a b -> Either a b
toEither (Success x) = Right x
toEither (Failure y) = Left y
type Reason_ = Reason ()
data Reason a
= UnsupportedRoute
| UnsupportedMethod
| UnsupportedVersion
| IdentError DataError
| HeaderError DataError
| ParamError DataError
| InputError DataError
| OutputError DataError
| NotFound
| NotAllowed
| AuthenticationFailed
| Busy
| Gone
| CustomReason (DomainReason a)
deriving (Eq, Generic, Show, Typeable, Functor, Foldable, Traversable)
instance Error DataError
instance Error (Reason e)
$(deriveAll ''DataError "PFDataError")
$(deriveAll ''Reason "PFReason")
type instance PF DataError = PFDataError
type instance PF (Reason e) = PFReason e
instance XmlPickler DataError where xpickle = gxpickle
instance XmlPickler e => XmlPickler (Reason e) where xpickle = gxpickle
instance ToJSON DataError where toJSON = gtoJson
instance FromJSON DataError where parseJSON = gparseJson
instance ToJSON e => ToJSON (Reason e) where toJSON = gtoJson
instance FromJSON e => FromJSON (Reason e) where parseJSON = gparseJson
instance JSONSchema DataError where schema = gSchema
instance JSONSchema e => JSONSchema (Reason e) where schema = gSchema
data SomeReason where
SomeReason :: (XmlPickler e, JSONSchema e, ToJSON e) => Reason e -> SomeReason
instance Error SomeReason
deriving instance Typeable SomeReason
instance XmlPickler SomeReason where
xpickle = PU
(\(SomeReason e) st -> appPickle xpickle e st)
(throwMsg "Cannot unpickle SomeReason.")
Any
instance ToJSON SomeReason where toJSON (SomeReason r) = toJSON r
instance JSONSchema SomeReason where
schema _ = JSONSchema.Any