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


-- | Type-level information about an error response.
data ErrorDesc = ErrorDesc
    { ErrorDesc -> Nat
erCode      :: Nat
    , ErrorDesc -> *
erException :: Type
    , ErrorDesc -> Symbol
erDesc      :: Symbol
    }

-- | Like 'ErrorDesc', but without exception type yet.
data ErrorPartialDesc = ErrorPartialDesc
    { ErrorPartialDesc -> Nat
epdCode :: Nat
    , ErrorPartialDesc -> Symbol
epdDesc :: Symbol
    }

{- | This combinator adds description of error response to swagger specification.

You have two ways to define this combinator:

* General:

@
ErrorResponses
   '[ 404 #! MyBackendException $
        "Not found"
    , 403 #! Int $
        "Operation is not permitted"
    ]
@

* When only one exception type is used:

@
ExceptionalResponses MyBackendException
   '[ 404 #: "Not found"
    , 403 #: "Operation is not permitted"
    ]
@

Note that if an error code was already defined further in endpoint definition,
it will be overwriten. For instance, 'Capture's define 400 error code (invalid
format); but in endpoint like @ErrorResponses (400 ...) :> Capture ... :> ...@
description for 400-error case provided by 'Capture' will be overwritten.

This combinator is transparent for server implementation.
-}
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

---------------------------------------------------------------------------
-- Helpers
---------------------------------------------------------------------------

-- | A convenient alias for use with 'ErrorResponse'.
type (#!) = 'ErrorDesc

-- | An alias for 'ErrorResponse' which allows to mention an exception type
-- just once across all errors specification.
type ExceptionalResponses err codes = ErrorResponses $ ExceptionDesc err codes

-- | A convenient alias for use with 'ExceptionalResponse'.
type (#:) = 'ErrorPartialDesc

---------------------------------------------------------------------------
-- Test samples
---------------------------------------------------------------------------

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 *"