{-# 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)

-- These are needed due to overlapping instances. See: https://github.com/haskell-servant/servant/issues/1431
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

-- | Inside `TypedHandler` we can throw two different kinds of errors:
-- Either a ServerError, via `throwServantError` or a custom error via `throwTyped`
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)

-- | This function is subtly different to `runTypedHandler` in that it can be used to
-- instantiate a function `f :: MonadError e m => m a` to `Handler (Union '[WithStatus200 a, WithStatus500 e])`.
-- Any calls to `throwError` in `f` will get turned to `throwTyped` in `liftTypedError f`.
-- In case you also want to throw a `ServantError`, use `runTypedHandler` instead.
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