content: {-# LANGUAGE
      DeriveDataTypeable
    , DeriveFoldable
    , DeriveFunctor
    , DeriveGeneric
    , DeriveTraversable
    , GADTs
    , NoImplicitPrelude
    , ScopedTypeVariables
    , StandaloneDeriving
    #-}
  module Rest.Types.Error
    ( DataError (..)
    , DomainReason (..)
    , Status (..)
    , fromEither
    , toEither
    , Reason_
    , Reason (..)
    , SomeReason (..)
    , ToResponseCode (..)
    ) where
  
  import Prelude.Compat
  
  import Control.Monad (ap)
  import Data.Aeson hiding (Success)
  import Data.JSON.Schema (JSONSchema (..), gSchema)
  import Data.Typeable
  import GHC.Generics
  import Generics.Generic.Aeson
  import Generics.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
  
  import Rest.Types.Void
  
  -- Error utilities.
  
  data DataError
    = ParseError        String
    | PrintError        String
    | MissingField      String
    | UnsupportedFormat String
    deriving (Eq, Generic, Show)
  
  newtype DomainReason a = DomainReason { reason :: a }
    deriving (Eq, Generic, Functor, Foldable, Show, Traversable)
  
  instance XmlPickler a => XmlPickler (DomainReason a) where
    xpickle = xpWrap (DomainReason, reason) xpickle
  
  instance ToJSON a => ToJSON (DomainReason a) where
    toJSON (DomainReason e) = toJSON e
  instance FromJSON a => FromJSON (DomainReason a) where
    parseJSON = fmap DomainReason . 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)
  
  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 Void
  
  data Reason a
    -- Thrown in the router.
    = UnsupportedRoute
    | UnsupportedMethod
    | UnsupportedVersion
  
    -- Thrown during generic IO.
    | IdentError   DataError
    | HeaderError  DataError
    | ParamError   DataError
    | InputError   DataError
    | OutputError  DataError
  
    -- Generic errors thrown in specific handlers.
    | NotFound
    | NotAllowed
    | AuthenticationFailed
    | Busy
    | Gone
  
    -- Custom domain reasons.
    | CustomReason (DomainReason a)
    deriving (Eq, Generic, Show, Typeable, Functor, Foldable, Traversable)
  
  instance Applicative Reason where
    pure = return
    (<*>) = ap
  
  instance Monad Reason where
    return a = CustomReason (DomainReason a)
    r >>= f = case r of
      CustomReason (DomainReason a) -> f a
      UnsupportedRoute              -> UnsupportedRoute
      UnsupportedMethod             -> UnsupportedMethod
      UnsupportedVersion            -> UnsupportedVersion
      IdentError   e                -> IdentError   e
      HeaderError  e                -> HeaderError  e
      ParamError   e                -> ParamError   e
      InputError   e                -> InputError   e
      OutputError  e                -> OutputError  e
      NotFound                      -> NotFound
      NotAllowed                    -> NotAllowed
      AuthenticationFailed          -> AuthenticationFailed
      Busy                          -> Busy
      Gone                          -> Gone
  
  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
  
  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
  
  -- | The response code that should be given for a type.
  -- This is currently only used for errors.
  class ToResponseCode a where
    toResponseCode :: a -> Int
  
  instance ToResponseCode Void where
    toResponseCode = magic
  
  instance ToResponseCode a => ToResponseCode (Reason a) where
    toResponseCode e =
      case e of
        NotFound                          -> 404
        UnsupportedRoute                  -> 404
        UnsupportedMethod                 -> 405
        UnsupportedVersion                -> 404
        NotAllowed                        -> 403
        AuthenticationFailed              -> 401
        Busy                              -> 503
        Gone                              -> 410
        OutputError (UnsupportedFormat _) -> 406
        InputError  _                     -> 400
        OutputError _                     -> 500
        IdentError  _                     -> 400
        HeaderError _                     -> 400
        ParamError  _                     -> 400
        CustomReason (DomainReason a)     -> toResponseCode a
  