{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Servant.Typed.Error
( GetTypedError,
PostTypedError,
DeleteTypedError,
PutTypedError,
WithError,
TypedHandler (..),
throwTypedError,
throwServantError,
runTypedHandler,
liftTypedError,
TypedClientM,
typedClient,
runTypedClientM,
)
where
import Control.Monad.Except (ExceptT (..), MonadError (..), runExceptT)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Reader (ReaderT (..))
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Bifunctor (Bifunctor (..))
import Data.SOP (I (I))
import Data.SOP.BasicFunctors (unI)
import Servant (Union, WithStatus (..), (:<|>) (..))
import Servant.API (Capture, HasStatus (..), JSON, ReqBody, StdMethod (DELETE, GET, POST, PUT), UVerb, Union, WithStatus (..), (:<|>) (..), (:>))
import Servant.API.UVerb (eject, inject)
import Servant.Client (ClientEnv, ClientError, runClientM)
import Servant.Client.Internal.HttpClient (ClientM (..))
import Servant.Server (Handler (..), ServerError, respond)
newtype WithStatus200 a = WithStatus200 (WithStatus 200 a)
newtype WithStatus500 a = WithStatus500 (WithStatus 500 a)
instance ToJSON a => ToJSON (WithStatus200 a) where
toJSON :: WithStatus200 a -> Value
toJSON (WithStatus200 (WithStatus a
a)) = forall a. ToJSON a => a -> Value
toJSON a
a
instance FromJSON a => FromJSON (WithStatus200 a) where
parseJSON :: Value -> Parser (WithStatus200 a)
parseJSON Value
o = (forall a. WithStatus 200 a -> WithStatus200 a
WithStatus200 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (k :: Nat) a. a -> WithStatus k a
WithStatus) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
o
instance ToJSON a => ToJSON (WithStatus500 a) where
toJSON :: WithStatus500 a -> Value
toJSON (WithStatus500 (WithStatus a
a)) = forall a. ToJSON a => a -> Value
toJSON a
a
instance FromJSON a => FromJSON (WithStatus500 a) where
parseJSON :: Value -> Parser (WithStatus500 a)
parseJSON Value
o = (forall a. WithStatus 500 a -> WithStatus500 a
WithStatus500 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (k :: Nat) a. a -> WithStatus k a
WithStatus) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
o
instance HasStatus (WithStatus200 a) where
type StatusOf (WithStatus200 a) = 200
instance HasStatus (WithStatus500 a) where
type StatusOf (WithStatus500 a) = 500
type WithError err ty = '[WithStatus200 ty, WithStatus500 err]
type GetTypedError resp ty err = UVerb 'GET resp '[WithStatus200 ty, WithStatus500 err]
type PostTypedError resp ty err = UVerb 'POST resp '[WithStatus200 ty, WithStatus500 err]
type DeleteTypedError resp ty err = UVerb 'DELETE resp '[WithStatus200 ty, WithStatus500 err]
type PutTypedError resp ty err = UVerb 'PUT resp '[WithStatus200 ty, WithStatus500 err]
newtype TypedHandler e a = TypedHandler {forall e a. TypedHandler e a -> ExceptT (Either ServerError e) IO a
unTypedHandler :: ExceptT (Either ServerError e) IO a}
deriving newtype (forall a b. a -> TypedHandler e b -> TypedHandler e a
forall a b. (a -> b) -> TypedHandler e a -> TypedHandler e b
forall e a b. a -> TypedHandler e b -> TypedHandler e a
forall e a b. (a -> b) -> TypedHandler e a -> TypedHandler e b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> TypedHandler e b -> TypedHandler e a
$c<$ :: forall e a b. a -> TypedHandler e b -> TypedHandler e a
fmap :: forall a b. (a -> b) -> TypedHandler e a -> TypedHandler e b
$cfmap :: forall e a b. (a -> b) -> TypedHandler e a -> TypedHandler e b
Functor, forall e. Functor (TypedHandler e)
forall a. a -> TypedHandler e a
forall e a. a -> TypedHandler e a
forall a b.
TypedHandler e a -> TypedHandler e b -> TypedHandler e a
forall a b.
TypedHandler e a -> TypedHandler e b -> TypedHandler e b
forall a b.
TypedHandler e (a -> b) -> TypedHandler e a -> TypedHandler e b
forall e a b.
TypedHandler e a -> TypedHandler e b -> TypedHandler e a
forall e a b.
TypedHandler e a -> TypedHandler e b -> TypedHandler e b
forall e a b.
TypedHandler e (a -> b) -> TypedHandler e a -> TypedHandler e b
forall a b c.
(a -> b -> c)
-> TypedHandler e a -> TypedHandler e b -> TypedHandler e c
forall e a b c.
(a -> b -> c)
-> TypedHandler e a -> TypedHandler e b -> TypedHandler e c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b.
TypedHandler e a -> TypedHandler e b -> TypedHandler e a
$c<* :: forall e a b.
TypedHandler e a -> TypedHandler e b -> TypedHandler e a
*> :: forall a b.
TypedHandler e a -> TypedHandler e b -> TypedHandler e b
$c*> :: forall e a b.
TypedHandler e a -> TypedHandler e b -> TypedHandler e b
liftA2 :: forall a b c.
(a -> b -> c)
-> TypedHandler e a -> TypedHandler e b -> TypedHandler e c
$cliftA2 :: forall e a b c.
(a -> b -> c)
-> TypedHandler e a -> TypedHandler e b -> TypedHandler e c
<*> :: forall a b.
TypedHandler e (a -> b) -> TypedHandler e a -> TypedHandler e b
$c<*> :: forall e a b.
TypedHandler e (a -> b) -> TypedHandler e a -> TypedHandler e b
pure :: forall a. a -> TypedHandler e a
$cpure :: forall e a. a -> TypedHandler e a
Applicative, forall e. Applicative (TypedHandler e)
forall a. a -> TypedHandler e a
forall e a. a -> TypedHandler e a
forall a b.
TypedHandler e a -> TypedHandler e b -> TypedHandler e b
forall a b.
TypedHandler e a -> (a -> TypedHandler e b) -> TypedHandler e b
forall e a b.
TypedHandler e a -> TypedHandler e b -> TypedHandler e b
forall e a b.
TypedHandler e a -> (a -> TypedHandler e b) -> TypedHandler e b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> TypedHandler e a
$creturn :: forall e a. a -> TypedHandler e a
>> :: forall a b.
TypedHandler e a -> TypedHandler e b -> TypedHandler e b
$c>> :: forall e a b.
TypedHandler e a -> TypedHandler e b -> TypedHandler e b
>>= :: forall a b.
TypedHandler e a -> (a -> TypedHandler e b) -> TypedHandler e b
$c>>= :: forall e a b.
TypedHandler e a -> (a -> TypedHandler e b) -> TypedHandler e b
Monad, MonadError (Either ServerError e))
throwTypedError :: e -> TypedHandler e a
throwTypedError :: forall e a. e -> TypedHandler e a
throwTypedError = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right
throwServantError :: ServerError -> TypedHandler e a
throwServantError :: forall e a. ServerError -> TypedHandler e a
throwServantError = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left
runTypedHandler :: TypedHandler e a -> Handler (Union '[WithStatus200 a, WithStatus500 e])
runTypedHandler :: forall e a.
TypedHandler e a
-> Handler (Union '[WithStatus200 a, WithStatus500 e])
runTypedHandler (TypedHandler ExceptT (Either ServerError e) IO a
m) =
forall a. ExceptT ServerError IO a -> Handler a
Handler forall a b. (a -> b) -> a -> b
$
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (x :: k) (xs :: [k]) (f :: k -> *).
UElem x xs =>
f x -> NS f xs
inject forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> I a
I forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WithStatus 500 a -> WithStatus500 a
WithStatus500 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (k :: Nat) a. a -> WithStatus k a
WithStatus))
(forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (x :: k) (xs :: [k]) (f :: k -> *).
UElem x xs =>
f x -> NS f xs
inject forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> I a
I forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WithStatus 200 a -> WithStatus200 a
WithStatus200 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (k :: Nat) a. a -> WithStatus k a
WithStatus)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT (Either ServerError e) IO a
m)
liftTypedError :: Functor m => ExceptT e m a -> m (Union '[WithStatus200 a, WithStatus500 e])
liftTypedError :: forall (m :: * -> *) e a.
Functor m =>
ExceptT e m a -> m (Union '[WithStatus200 a, WithStatus500 e])
liftTypedError ExceptT e m a
m =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall {k} (x :: k) (xs :: [k]) (f :: k -> *).
UElem x xs =>
f x -> NS f xs
inject forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> I a
I forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WithStatus 500 a -> WithStatus500 a
WithStatus500 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (k :: Nat) a. a -> WithStatus k a
WithStatus) (forall {k} (x :: k) (xs :: [k]) (f :: k -> *).
UElem x xs =>
f x -> NS f xs
inject forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> I a
I forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WithStatus 200 a -> WithStatus200 a
WithStatus200 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (k :: Nat) a. a -> WithStatus k a
WithStatus)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e m a
m
newtype TypedClientM e a = TypedClientM {forall e a.
TypedClientM e a
-> ReaderT ClientEnv (ExceptT (Either ClientError e) IO) a
unTypedClientM :: ReaderT ClientEnv (ExceptT (Either ClientError e) IO) a}
class TypedClient a b where
typedClient :: a -> b
instance (TypedClient a b, TypedClient a' b') => TypedClient (a :<|> a') (b :<|> b') where
typedClient :: (a :<|> a') -> b :<|> b'
typedClient = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a b. TypedClient a b => a -> b
typedClient forall a b. TypedClient a b => a -> b
typedClient
instance (TypedClient a' b', TypedClient b a) => TypedClient (a -> a') (b -> b') where
typedClient :: (a -> a') -> b -> b'
typedClient a -> a'
f = forall a b. TypedClient a b => a -> b
typedClient forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a'
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. TypedClient a b => a -> b
typedClient
instance TypedClient a a where
typedClient :: a -> a
typedClient = forall a. a -> a
id
instance TypedClient (ClientM (Union '[WithStatus200 a, WithStatus500 e])) (TypedClientM e a) where
typedClient :: ClientM (Union '[WithStatus200 a, WithStatus500 e])
-> TypedClientM e a
typedClient (ClientM (ReaderT ClientEnv
-> ExceptT
ClientError IO (Union '[WithStatus200 a, WithStatus500 e])
m)) = forall e a.
ReaderT ClientEnv (ExceptT (Either ClientError e) IO) a
-> TypedClientM e a
TypedClientM forall a b. (a -> b) -> a -> b
$
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \ClientEnv
env ->
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ClientEnv
-> ExceptT
ClientError IO (Union '[WithStatus200 a, WithStatus500 e])
m ClientEnv
env)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
Left ClientError
servantErr -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ClientError
servantErr
Right Union '[WithStatus200 a, WithStatus500 e]
u ->
case forall a. I a -> a
unI forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (x :: k) (xs :: [k]) (f :: k -> *).
UElem x xs =>
NS f xs -> Maybe (f x)
eject Union '[WithStatus200 a, WithStatus500 e]
u of
Just (WithStatus500 (WithStatus e
err)) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right e
err
Maybe (WithStatus500 e)
_ -> case forall a. I a -> a
unI forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (x :: k) (xs :: [k]) (f :: k -> *).
UElem x xs =>
NS f xs -> Maybe (f x)
eject Union '[WithStatus200 a, WithStatus500 e]
u of
Just (WithStatus200 (WithStatus a
a)) -> forall a b. b -> Either a b
Right a
a
Maybe (WithStatus200 a)
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Didn't match on either response"
runTypedClientM :: TypedClientM e a -> ClientEnv -> IO (Either (Either ClientError e) a)
runTypedClientM :: forall e a.
TypedClientM e a
-> ClientEnv -> IO (Either (Either ClientError e) a)
runTypedClientM TypedClientM e a
cm ClientEnv
env = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ClientEnv
env forall a b. (a -> b) -> a -> b
$ forall e a.
TypedClientM e a
-> ReaderT ClientEnv (ExceptT (Either ClientError e) IO) a
unTypedClientM TypedClientM e a
cm