module Servant.Util.Combinators.ErrorResponses
( ErrorDesc (..)
, ErrorPartialDesc (..)
, ErrorResponses
, type (#:)
, type ($)
, ExceptionalResponses
) where
import Universum
import Control.Lens (at, (<>~), (?~))
import qualified Data.Swagger as S
import Data.Swagger.Declare (runDeclare)
import GHC.TypeLits (KnownSymbol, Symbol)
import Servant (HasServer (..), (:>))
import Servant.Client (HasClient (..))
import Servant.Swagger (HasSwagger (..))
import Servant.Util.Combinators.Logging
import Servant.Util.Common
data ErrorDesc = ErrorDesc
{ ErrorDesc -> Nat
erCode :: Nat
, ErrorDesc -> *
erException :: Type
, ErrorDesc -> Symbol
erDesc :: Symbol
}
data ErrorPartialDesc = ErrorPartialDesc
{ ErrorPartialDesc -> Nat
epdCode :: Nat
, ErrorPartialDesc -> Symbol
epdDesc :: Symbol
}
data ErrorResponses (errs :: [ErrorDesc])
type family ExceptionDesc err (codes :: [ErrorPartialDesc]) :: [ErrorDesc] where
ExceptionDesc e '[] = '[]
ExceptionDesc e ('ErrorPartialDesc code desc ': cs) =
'ErrorDesc code e desc ': ExceptionDesc e cs
instance HasServer subApi ctx => HasServer (ErrorResponses errors :> subApi) ctx where
type ServerT (ErrorResponses errors :> subApi) m = ServerT subApi m
route :: Proxy (ErrorResponses errors :> subApi)
-> Context ctx
-> Delayed env (Server (ErrorResponses errors :> subApi))
-> Router env
route Proxy (ErrorResponses errors :> subApi)
_ = Proxy subApi
-> Context ctx -> Delayed env (Server subApi) -> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy subApi
forall k (t :: k). Proxy t
Proxy @subApi)
hoistServerWithContext :: Proxy (ErrorResponses errors :> subApi)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (ErrorResponses errors :> subApi) m
-> ServerT (ErrorResponses errors :> subApi) n
hoistServerWithContext Proxy (ErrorResponses errors :> subApi)
_ = Proxy subApi
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT subApi m
-> ServerT subApi n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy subApi
forall k (t :: k). Proxy t
Proxy @subApi)
instance HasClient m subApi => HasClient m (ErrorResponses errors :> subApi) where
type Client m (ErrorResponses errors :> subApi) = Client m subApi
clientWithRoute :: Proxy m
-> Proxy (ErrorResponses errors :> subApi)
-> Request
-> Client m (ErrorResponses errors :> subApi)
clientWithRoute Proxy m
pm Proxy (ErrorResponses errors :> subApi)
_ = Proxy m -> Proxy subApi -> Request -> Client m subApi
forall (m :: * -> *) api.
HasClient m api =>
Proxy m -> Proxy api -> Request -> Client m api
clientWithRoute Proxy m
pm (Proxy subApi
forall k (t :: k). Proxy t
Proxy @subApi)
hoistClientMonad :: Proxy m
-> Proxy (ErrorResponses errors :> subApi)
-> (forall x. mon x -> mon' x)
-> Client mon (ErrorResponses errors :> subApi)
-> Client mon' (ErrorResponses errors :> subApi)
hoistClientMonad Proxy m
pm Proxy (ErrorResponses errors :> subApi)
_ forall x. mon x -> mon' x
hst = Proxy m
-> Proxy subApi
-> (forall x. mon x -> mon' x)
-> Client mon subApi
-> Client mon' subApi
forall (m :: * -> *) api (mon :: * -> *) (mon' :: * -> *).
HasClient m api =>
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
hoistClientMonad Proxy m
pm (Proxy subApi
forall k (t :: k). Proxy t
Proxy @subApi) forall x. mon x -> mon' x
hst
instance HasLoggingServer config lcontext subApi ctx =>
HasLoggingServer config lcontext (ErrorResponses errors :> subApi) ctx where
routeWithLog :: Proxy
(LoggingApiRec config lcontext (ErrorResponses errors :> subApi))
-> Context ctx
-> Delayed
env
(Server
(LoggingApiRec config lcontext (ErrorResponses errors :> subApi)))
-> Router env
routeWithLog = (Proxy
(ErrorResponses errors :> LoggingApiRec config lcontext subApi)
-> Context ctx
-> Delayed
env
(Server
(ErrorResponses errors :> LoggingApiRec config lcontext subApi))
-> Router env)
-> (Server
(LoggingApiRec config lcontext (ErrorResponses errors :> subApi))
-> Server
(ErrorResponses errors :> LoggingApiRec config lcontext subApi))
-> Proxy
(LoggingApiRec config lcontext (ErrorResponses errors :> subApi))
-> Context ctx
-> Delayed
env
(Server
(LoggingApiRec config lcontext (ErrorResponses errors :> subApi)))
-> Router env
forall api api' (ctx :: [*]) env.
(Proxy api
-> Context ctx -> Delayed env (Server api) -> Router env)
-> (Server api' -> Server api)
-> Proxy api'
-> Context ctx
-> Delayed env (Server api')
-> Router env
inRouteServer @(ErrorResponses errors :> LoggingApiRec config lcontext subApi) Proxy
(ErrorResponses errors :> LoggingApiRec config lcontext subApi)
-> Context ctx
-> Delayed
env
(Server
(ErrorResponses errors :> LoggingApiRec config lcontext subApi))
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route Server
(LoggingApiRec config lcontext (ErrorResponses errors :> subApi))
-> Server
(ErrorResponses errors :> LoggingApiRec config lcontext subApi)
forall a. a -> a
id
class KnownErrorCodes (errors :: [ErrorDesc]) where
errorCodesToSwagger :: S.Swagger -> S.Swagger
instance KnownErrorCodes '[] where
errorCodesToSwagger :: Swagger -> Swagger
errorCodesToSwagger = Swagger -> Swagger
forall a. a -> a
id
instance (KnownNat code, KnownSymbol desc, S.ToSchema exc, KnownErrorCodes es) =>
KnownErrorCodes ('ErrorDesc code exc desc ': es) where
errorCodesToSwagger :: Swagger -> Swagger
errorCodesToSwagger Swagger
swagger = Swagger
swagger
Swagger -> (Swagger -> Swagger) -> Swagger
forall a b. a -> (a -> b) -> b
& (Operation -> Identity Operation) -> Swagger -> Identity Swagger
Traversal' Swagger Operation
S.allOperations ((Operation -> Identity Operation) -> Swagger -> Identity Swagger)
-> ((Maybe (Referenced Response)
-> Identity (Maybe (Referenced Response)))
-> Operation -> Identity Operation)
-> (Maybe (Referenced Response)
-> Identity (Maybe (Referenced Response)))
-> Swagger
-> Identity Swagger
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Responses -> Identity Responses)
-> Operation -> Identity Operation
forall s a. HasResponses s a => Lens' s a
S.responses ((Responses -> Identity Responses)
-> Operation -> Identity Operation)
-> ((Maybe (Referenced Response)
-> Identity (Maybe (Referenced Response)))
-> Responses -> Identity Responses)
-> (Maybe (Referenced Response)
-> Identity (Maybe (Referenced Response)))
-> Operation
-> Identity Operation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InsOrdHashMap HttpStatusCode (Referenced Response)
-> Identity (InsOrdHashMap HttpStatusCode (Referenced Response)))
-> Responses -> Identity Responses
forall s a. HasResponses s a => Lens' s a
S.responses ((InsOrdHashMap HttpStatusCode (Referenced Response)
-> Identity (InsOrdHashMap HttpStatusCode (Referenced Response)))
-> Responses -> Identity Responses)
-> ((Maybe (Referenced Response)
-> Identity (Maybe (Referenced Response)))
-> InsOrdHashMap HttpStatusCode (Referenced Response)
-> Identity (InsOrdHashMap HttpStatusCode (Referenced Response)))
-> (Maybe (Referenced Response)
-> Identity (Maybe (Referenced Response)))
-> Responses
-> Identity Responses
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap HttpStatusCode (Referenced Response))
-> Lens'
(InsOrdHashMap HttpStatusCode (Referenced Response))
(Maybe
(IxValue (InsOrdHashMap HttpStatusCode (Referenced Response))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at HttpStatusCode
Index (InsOrdHashMap HttpStatusCode (Referenced Response))
code ((Maybe (Referenced Response)
-> Identity (Maybe (Referenced Response)))
-> Swagger -> Identity Swagger)
-> Referenced Response -> Swagger -> Swagger
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Response -> Referenced Response
forall a. a -> Referenced a
S.Inline Response
response
Swagger -> (Swagger -> Swagger) -> Swagger
forall a b. a -> (a -> b) -> b
& (Definitions Schema -> Identity (Definitions Schema))
-> Swagger -> Identity Swagger
forall s a. HasDefinitions s a => Lens' s a
S.definitions ((Definitions Schema -> Identity (Definitions Schema))
-> Swagger -> Identity Swagger)
-> Definitions Schema -> Swagger -> Swagger
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ Definitions Schema
defs
Swagger -> (Swagger -> Swagger) -> Swagger
forall a b. a -> (a -> b) -> b
& KnownErrorCodes es => Swagger -> Swagger
forall (errors :: [ErrorDesc]).
KnownErrorCodes errors =>
Swagger -> Swagger
errorCodesToSwagger @es
where
code :: HttpStatusCode
code = Natural -> HttpStatusCode
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy code -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal @code Proxy code
forall k (t :: k). Proxy t
Proxy)
desc :: Text
desc = KnownSymbol desc => Text
forall (s :: Symbol). KnownSymbol s => Text
symbolValT @desc
(Definitions Schema
defs, Referenced Schema
excSchema) = Declare (Definitions Schema) (Referenced Schema)
-> Definitions Schema -> (Definitions Schema, Referenced Schema)
forall d a. Declare d a -> d -> (d, a)
runDeclare (Proxy exc -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
S.declareSchemaRef (Proxy exc
forall k (t :: k). Proxy t
Proxy @exc)) Definitions Schema
forall a. Monoid a => a
mempty
response :: Response
response = Response
forall a. Monoid a => a
mempty
Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> Response -> Identity Response
forall s a. HasDescription s a => Lens' s a
S.description ((Text -> Identity Text) -> Response -> Identity Response)
-> Text -> Response -> Response
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
desc
Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& (Maybe (Referenced Schema) -> Identity (Maybe (Referenced Schema)))
-> Response -> Identity Response
forall s a. HasSchema s a => Lens' s a
S.schema ((Maybe (Referenced Schema)
-> Identity (Maybe (Referenced Schema)))
-> Response -> Identity Response)
-> Referenced Schema -> Response -> Response
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema
excSchema
instance ( HasSwagger subApi
, KnownErrorCodes errors
) => HasSwagger (ErrorResponses errors :> subApi) where
toSwagger :: Proxy (ErrorResponses errors :> subApi) -> Swagger
toSwagger Proxy (ErrorResponses errors :> subApi)
_ = Proxy subApi -> Swagger
forall k (api :: k). HasSwagger api => Proxy api -> Swagger
toSwagger (Proxy subApi
forall k (t :: k). Proxy t
Proxy @subApi) Swagger -> (Swagger -> Swagger) -> Swagger
forall a b. a -> (a -> b) -> b
& KnownErrorCodes errors => Swagger -> Swagger
forall (errors :: [ErrorDesc]).
KnownErrorCodes errors =>
Swagger -> Swagger
errorCodesToSwagger @errors
type (#!) = 'ErrorDesc
type ExceptionalResponses err codes = ErrorResponses $ ExceptionDesc err codes
type (#:) = 'ErrorPartialDesc
data MyBackendException
type Sample1 = ExceptionalResponses MyBackendException
'[ 404 #: "Not found"
, 403 #: "Operation is not permitted"
]
_sample1 :: Sample1
_sample1 :: Sample1
_sample1 = Text
-> ErrorResponses
'[ 'ErrorDesc 404 MyBackendException "Not found",
'ErrorDesc 403 MyBackendException "Operation is not permitted"]
forall a. HasCallStack => Text -> a
error Text
"Just checked that kind of Sample1 is *"
type Sample2 =
ErrorResponses
'[ 404 #! MyBackendException $
"Not found"
, 403 #! Int $
"Operation is not permitted"
]
_sample2 :: Sample2
_sample2 :: Sample2
_sample2 = Text -> Sample2
forall a. HasCallStack => Text -> a
error Text
"Just checked that kind of Sample2 is *"