{-# LANGUAGE CPP                       #-}
{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE PolyKinds                 #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE UndecidableInstances      #-}

-- | Annotate APIs with error types they might 'Throw'. This allows for type
-- level guided exception handling in servers, clients and can be used by for
-- generating error documentation.
--
-- See https://github.com/ch1bo/servant-exceptions/blob/master/example/Main.hs
-- for a working example.
module Servant.Exception
  ( Throws,
    ToServantErr (..),
    ServantException,
    toServantException,
    fromServantException,
    Exception (..),
    mapException
  )
where

import Control.Monad.Catch      (Exception (..), MonadCatch, SomeException, catch, throwM)
import Data.Aeson               (ToJSON (..), encode, object, (.=))
import Data.Kind                (Type)
import Data.String              (fromString)
import Data.Text                (Text)
import Data.Typeable            (Typeable, cast, typeOf)
import Network.HTTP.Types       (Header, Status (..))
import Servant.API.ContentTypes (JSON, MimeRender (..), PlainText)

-- | Declare that an API might throw errors of given type 'e'.
data Throws (e :: Type)

-- | Type class to convert an 'e' to servant's error types, e.g. 'ServerError'
-- on the server side. Thus, servers use methods of this class, along with
-- 'Typeable' and 'Show' allow convenient definition of how error responses
-- should look like.
class (Typeable e, Show e) => ToServantErr e where
  -- | HTTP status code to return
  status :: e -> Status

  -- | A human-readable message to include. Default implementation uses 'Show'.
  message :: e -> Text
  message = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> (e -> String) -> e -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
forall a. Show a => a -> String
show

  -- | Additional headers to include in the response. Content-type headers are
  -- created by default.
  headers :: e -> [Header]
  headers e
_ = []

-- * Exception utilities

-- | A root exception type (see 'Control.Exception') to provide a common
-- rendering format via 'MimeRender' for builtin content types 'JSON' and
-- 'PlainText'.
data ServantException = forall e. (Exception e, ToJSON e, ToServantErr e) => ServantException e
  deriving (Typeable)

instance Show ServantException where
  show :: ServantException -> String
show (ServantException e
e) = e -> String
forall a. Show a => a -> String
show e
e

instance Exception ServantException

instance MimeRender JSON ServantException where
  mimeRender :: Proxy JSON -> ServantException -> ByteString
mimeRender Proxy JSON
_ (ServantException e
e) =
    Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$
      [Pair] -> Value
object
        [ Text
"type" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
errorType,
          Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= e -> Text
forall e. ToServantErr e => e -> Text
message e
e,
          Text
"error" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= e -> Value
forall a. ToJSON a => a -> Value
toJSON e
e
        ]
    where
      errorType :: String
errorType = TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ e -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf e
e

instance MimeRender PlainText ServantException where
  mimeRender :: Proxy PlainText -> ServantException -> ByteString
mimeRender Proxy PlainText
ct = Proxy PlainText -> String -> ByteString
forall k (ctype :: k) a.
MimeRender ctype a =>
Proxy ctype -> a -> ByteString
mimeRender Proxy PlainText
ct (String -> ByteString)
-> (ServantException -> String) -> ServantException -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServantException -> String
forall e. Exception e => e -> String
displayException

instance ToServantErr ServantException where
  status :: ServantException -> Status
status (ServantException e
e) = e -> Status
forall e. ToServantErr e => e -> Status
status e
e
  message :: ServantException -> Text
message (ServantException e
e) = e -> Text
forall e. ToServantErr e => e -> Text
message e
e

toServantException :: (Exception e, ToJSON e, ToServantErr e) => e -> SomeException
toServantException :: e -> SomeException
toServantException = ServantException -> SomeException
forall e. Exception e => e -> SomeException
toException (ServantException -> SomeException)
-> (e -> ServantException) -> e -> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ServantException
forall e.
(Exception e, ToJSON e, ToServantErr e) =>
e -> ServantException
ServantException

fromServantException :: Exception e => SomeException -> Maybe e
fromServantException :: SomeException -> Maybe e
fromServantException SomeException
x = SomeException -> Maybe ServantException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x Maybe ServantException -> (ServantException -> Maybe e) -> Maybe e
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(ServantException e
e) -> e -> Maybe e
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e

-- | Catch and rethrow using mapping function 'f'.
mapException :: (Exception e1, Exception e2, MonadCatch m) => (e1 -> e2) -> m a -> m a
mapException :: (e1 -> e2) -> m a -> m a
mapException e1 -> e2
f m a
a = m a
a m a -> (e1 -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (e2 -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (e2 -> m a) -> (e1 -> e2) -> e1 -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e1 -> e2
f)