-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.
module Wire.API.Error
  ( -- * Static and dynamic error types
    DynError (..),
    dynError,
    dynErrorToWai,
    StaticError (..),
    KnownError,
    MapError,
    errorToResponse,
    errorToWai,
    APIError (..),

    -- * Static errors and Servant
    CanThrow,
    CanThrowMany,
    DeclaredErrorEffects,
    addErrorResponseToSwagger,
    addStaticErrorToSwagger,
    IsSwaggerError (..),
    ErrorResponse,

    -- * Static errors and Polysemy
    ErrorEffect,
    ErrorS,
    throwS,
    noteS,
    mapErrorS,
    runErrorS,
    mapToRuntimeError,
    mapToDynamicError,
  )
where

import Control.Error (hush)
import Control.Lens (at, (%~), (.~), (?~))
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Aeson qualified as A
import Data.HashMap.Strict.InsOrd
import Data.Kind
import Data.Metrics.Servant
import Data.OpenApi qualified as S
import Data.Proxy
import Data.SOP
import Data.Schema
import Data.Text qualified as Text
import Data.Text.Lazy qualified as LT
import GHC.TypeLits
import Imports hiding (All)
import Network.HTTP.Types.Status qualified as HTTP
import Network.Wai.Utilities.Error qualified as Wai
import Network.Wai.Utilities.JSONResponse
import Polysemy
import Polysemy.Error
import Servant
import Servant.Client (HasClient (Client))
import Servant.Client.Core.HasClient (hoistClientMonad)
import Servant.Client.Streaming (HasClient (clientWithRoute))
import Servant.OpenApi
import Wire.API.Routes.MultiVerb
import Wire.API.Routes.Named (Named)
import Wire.API.Routes.Version

-- | Runtime representation of a statically-known error.
data DynError = DynError
  { DynError -> Natural
eCode :: Natural,
    DynError -> Text
eLabel :: Text,
    DynError -> Text
eMessage :: Text
  }

dynErrorToWai :: DynError -> Wai.Error
dynErrorToWai :: DynError -> Error
dynErrorToWai (DynError Natural
c Text
l Text
m) =
  Status -> LText -> LText -> Error
Wai.mkError (HttpStatusCode -> Status
forall a. Enum a => HttpStatusCode -> a
toEnum (Natural -> HttpStatusCode
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
c)) (Text -> LText
LT.fromStrict Text
l) (Text -> LText
LT.fromStrict Text
m)

instance ToJSON DynError where
  toJSON :: DynError -> Value
toJSON = (.value) (JSONResponse -> Value)
-> (DynError -> JSONResponse) -> DynError -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynError -> JSONResponse
forall e. APIError e => e -> JSONResponse
toResponse

dynErrorFromWai :: Wai.Error -> DynError
dynErrorFromWai :: Error -> DynError
dynErrorFromWai =
  Natural -> Text -> Text -> DynError
DynError
    (Natural -> Text -> Text -> DynError)
-> (Error -> Natural) -> Error -> Text -> Text -> DynError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HttpStatusCode -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HttpStatusCode -> Natural)
-> (Error -> HttpStatusCode) -> Error -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> HttpStatusCode
HTTP.statusCode (Status -> HttpStatusCode)
-> (Error -> Status) -> Error -> HttpStatusCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Status
Wai.code
    (Error -> Text -> Text -> DynError)
-> (Error -> Text) -> Error -> Text -> DynError
forall a b. (Error -> a -> b) -> (Error -> a) -> Error -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LText -> Text
LT.toStrict (LText -> Text) -> (Error -> LText) -> Error -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> LText
Wai.label
    (Error -> Text -> DynError) -> (Error -> Text) -> Error -> DynError
forall a b. (Error -> a -> b) -> (Error -> a) -> Error -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LText -> Text
LT.toStrict (LText -> Text) -> (Error -> LText) -> Error -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> LText
Wai.message

instance FromJSON DynError where
  parseJSON :: Value -> Parser DynError
parseJSON = (Error -> DynError) -> Parser Error -> Parser DynError
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Error -> DynError
dynErrorFromWai (Parser Error -> Parser DynError)
-> (Value -> Parser Error) -> Value -> Parser DynError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Error
forall a. FromJSON a => Value -> Parser a
parseJSON

-- | A statically-known error. This is meant to be used as a kind.
data StaticError = StaticError
  { StaticError -> Natural
seCode :: Nat,
    StaticError -> Symbol
seLabel :: Symbol,
    StaticError -> Symbol
seMessage :: Symbol
  }

-- | The singleton corresponding to 'StaticError'. This is hand-written,
-- because the singletons library has problems with promoted natural numbers.
data SStaticError e where
  SStaticError ::
    (KnownNat c, KnownSymbol l, KnownSymbol msg) =>
    Proxy c ->
    Proxy l ->
    Proxy msg ->
    SStaticError ('StaticError c l msg)
  deriving (Value -> Parser [SStaticError e]
Value -> Parser (SStaticError e)
(Value -> Parser (SStaticError e))
-> (Value -> Parser [SStaticError e]) -> FromJSON (SStaticError e)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
forall (e :: StaticError).
KnownError e =>
Value -> Parser [SStaticError e]
forall (e :: StaticError).
KnownError e =>
Value -> Parser (SStaticError e)
$cparseJSON :: forall (e :: StaticError).
KnownError e =>
Value -> Parser (SStaticError e)
parseJSON :: Value -> Parser (SStaticError e)
$cparseJSONList :: forall (e :: StaticError).
KnownError e =>
Value -> Parser [SStaticError e]
parseJSONList :: Value -> Parser [SStaticError e]
A.FromJSON, [SStaticError e] -> Value
[SStaticError e] -> Encoding
SStaticError e -> Value
SStaticError e -> Encoding
(SStaticError e -> Value)
-> (SStaticError e -> Encoding)
-> ([SStaticError e] -> Value)
-> ([SStaticError e] -> Encoding)
-> ToJSON (SStaticError e)
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
forall (e :: StaticError).
KnownError e =>
[SStaticError e] -> Value
forall (e :: StaticError).
KnownError e =>
[SStaticError e] -> Encoding
forall (e :: StaticError). KnownError e => SStaticError e -> Value
forall (e :: StaticError).
KnownError e =>
SStaticError e -> Encoding
$ctoJSON :: forall (e :: StaticError). KnownError e => SStaticError e -> Value
toJSON :: SStaticError e -> Value
$ctoEncoding :: forall (e :: StaticError).
KnownError e =>
SStaticError e -> Encoding
toEncoding :: SStaticError e -> Encoding
$ctoJSONList :: forall (e :: StaticError).
KnownError e =>
[SStaticError e] -> Value
toJSONList :: [SStaticError e] -> Value
$ctoEncodingList :: forall (e :: StaticError).
KnownError e =>
[SStaticError e] -> Encoding
toEncodingList :: [SStaticError e] -> Encoding
A.ToJSON, Typeable (SStaticError e)
Typeable (SStaticError e) =>
(Proxy (SStaticError e)
 -> Declare (Definitions Schema) NamedSchema)
-> ToSchema (SStaticError e)
Proxy (SStaticError e) -> Declare (Definitions Schema) NamedSchema
forall a.
Typeable a =>
(Proxy a -> Declare (Definitions Schema) NamedSchema) -> ToSchema a
forall (e :: StaticError).
(Typeable e, KnownError e) =>
Typeable (SStaticError e)
forall (e :: StaticError).
(Typeable e, KnownError e) =>
Proxy (SStaticError e) -> Declare (Definitions Schema) NamedSchema
$cdeclareNamedSchema :: forall (e :: StaticError).
(Typeable e, KnownError e) =>
Proxy (SStaticError e) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema :: Proxy (SStaticError e) -> Declare (Definitions Schema) NamedSchema
S.ToSchema) via Schema (SStaticError e)

class KnownError (e :: StaticError) where
  seSing :: SStaticError e

instance (KnownNat c, KnownSymbol l, KnownSymbol msg) => KnownError ('StaticError c l msg) where
  seSing :: SStaticError ('StaticError c l msg)
seSing = Proxy c
-> Proxy l -> Proxy msg -> SStaticError ('StaticError c l msg)
forall (c :: Natural) (l :: Symbol) (msg :: Symbol).
(KnownNat c, KnownSymbol l, KnownSymbol msg) =>
Proxy c
-> Proxy l -> Proxy msg -> SStaticError ('StaticError c l msg)
SStaticError Proxy c
forall {k} (t :: k). Proxy t
Proxy Proxy l
forall {k} (t :: k). Proxy t
Proxy Proxy msg
forall {k} (t :: k). Proxy t
Proxy

dynError' :: SStaticError e -> DynError
dynError' :: forall (e :: StaticError). SStaticError e -> DynError
dynError' (SStaticError Proxy c
c Proxy l
l Proxy msg
msg) = Proxy c -> Proxy l -> Proxy msg -> DynError
forall (c :: Natural) (l :: Symbol) (msg :: Symbol).
(KnownNat c, KnownSymbol l, KnownSymbol msg) =>
Proxy c -> Proxy l -> Proxy msg -> DynError
mkDynError Proxy c
c Proxy l
l Proxy msg
msg

mkDynError ::
  (KnownNat c, KnownSymbol l, KnownSymbol msg) =>
  Proxy c ->
  Proxy l ->
  Proxy msg ->
  DynError
mkDynError :: forall (c :: Natural) (l :: Symbol) (msg :: Symbol).
(KnownNat c, KnownSymbol l, KnownSymbol msg) =>
Proxy c -> Proxy l -> Proxy msg -> DynError
mkDynError Proxy c
c Proxy l
l Proxy msg
msg =
  Natural -> Text -> Text -> DynError
DynError
    (HttpStatusCode -> Natural
forall a. Enum a => HttpStatusCode -> a
toEnum (Integer -> HttpStatusCode
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy c -> Integer
forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Integer
natVal Proxy c
c)))
    (String -> Text
Text.pack (Proxy l -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy l
l))
    (String -> Text
Text.pack (Proxy msg -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy msg
msg))

dynError :: forall e. (KnownError e) => DynError
dynError :: forall (e :: StaticError). KnownError e => DynError
dynError = SStaticError e -> DynError
forall (e :: StaticError). SStaticError e -> DynError
dynError' (SStaticError e -> DynError) -> SStaticError e -> DynError
forall a b. (a -> b) -> a -> b
$ forall (e :: StaticError). KnownError e => SStaticError e
seSing @e

staticErrorSchema :: SStaticError e -> ValueSchema NamedSwaggerDoc (SStaticError e)
staticErrorSchema :: forall (e :: StaticError).
SStaticError e -> ValueSchema NamedSwaggerDoc (SStaticError e)
staticErrorSchema e :: SStaticError e
e@(SStaticError Proxy c
c Proxy l
l Proxy msg
m) =
  Text
-> (NamedSwaggerDoc -> NamedSwaggerDoc)
-> ObjectSchema SwaggerDoc (SStaticError e)
-> ValueSchema NamedSwaggerDoc (SStaticError e)
forall doc doc' a.
HasObject doc doc' =>
Text -> (doc' -> doc') -> ObjectSchema doc a -> ValueSchema doc' a
objectWithDocModifier Text
"Error" NamedSwaggerDoc -> NamedSwaggerDoc
addExample (ObjectSchema SwaggerDoc (SStaticError e)
 -> ValueSchema NamedSwaggerDoc (SStaticError e))
-> ObjectSchema SwaggerDoc (SStaticError e)
-> ValueSchema NamedSwaggerDoc (SStaticError e)
forall a b. (a -> b) -> a -> b
$
    Proxy c -> Proxy l -> Proxy msg -> SStaticError e
Proxy c
-> Proxy l -> Proxy msg -> SStaticError ('StaticError c l msg)
forall (c :: Natural) (l :: Symbol) (msg :: Symbol).
(KnownNat c, KnownSymbol l, KnownSymbol msg) =>
Proxy c
-> Proxy l -> Proxy msg -> SStaticError ('StaticError c l msg)
SStaticError
      (Proxy c -> Proxy l -> Proxy msg -> SStaticError e)
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) (Proxy c)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     (SStaticError e)
     (Proxy l -> Proxy msg -> SStaticError e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Proxy c
c Proxy c
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) Natural
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) (Proxy c)
forall a b.
a
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) b
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Natural -> SStaticError e -> Natural
forall a b. a -> b -> a
const Natural
code (SStaticError e -> Natural)
-> SchemaP SwaggerDoc Object [Pair] Natural Natural
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) Natural
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP SwaggerDoc Value Value Natural Natural
-> SchemaP SwaggerDoc Object [Pair] Natural Natural
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"code" SchemaP SwaggerDoc Value Value Natural Natural
codeSchema))
      SchemaP
  SwaggerDoc
  Object
  [Pair]
  (SStaticError e)
  (Proxy l -> Proxy msg -> SStaticError e)
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) (Proxy l)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     (SStaticError e)
     (Proxy msg -> SStaticError e)
forall a b.
SchemaP SwaggerDoc Object [Pair] (SStaticError e) (a -> b)
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) a
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Proxy l
l Proxy l
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) Text
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) (Proxy l)
forall a b.
a
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) b
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Text -> SStaticError e -> Text
forall a b. a -> b -> a
const Text
label (SStaticError e -> Text)
-> SchemaP SwaggerDoc Object [Pair] Text Text
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) Text
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP SwaggerDoc Value Value Text Text
-> SchemaP SwaggerDoc Object [Pair] Text Text
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"label" SchemaP SwaggerDoc Value Value Text Text
labelSchema))
      SchemaP
  SwaggerDoc
  Object
  [Pair]
  (SStaticError e)
  (Proxy msg -> SStaticError e)
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) (Proxy msg)
-> ObjectSchema SwaggerDoc (SStaticError e)
forall a b.
SchemaP SwaggerDoc Object [Pair] (SStaticError e) (a -> b)
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) a
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Proxy msg
m Proxy msg
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) Text
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) (Proxy msg)
forall a b.
a
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) b
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Text -> SStaticError e -> Text
forall a b. a -> b -> a
const Text
message (SStaticError e -> Text)
-> SchemaP SwaggerDoc Object [Pair] Text Text
-> SchemaP SwaggerDoc Object [Pair] (SStaticError e) Text
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP NamedSwaggerDoc Value Value Text Text
-> SchemaP SwaggerDoc Object [Pair] Text Text
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"message" SchemaP NamedSwaggerDoc Value Value Text Text
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema))
  where
    err :: DynError
err = SStaticError e -> DynError
forall (e :: StaticError). SStaticError e -> DynError
dynError' SStaticError e
e
    label :: Text
label = DynError -> Text
eLabel DynError
err
    code :: Natural
code = DynError -> Natural
eCode DynError
err
    message :: Text
message = DynError -> Text
eMessage DynError
err

    addExample :: NamedSwaggerDoc -> NamedSwaggerDoc
addExample = (Schema -> Identity Schema)
-> NamedSwaggerDoc -> Identity NamedSwaggerDoc
forall s a. HasSchema s a => Lens' s a
Lens' NamedSwaggerDoc Schema
S.schema ((Schema -> Identity Schema)
 -> NamedSwaggerDoc -> Identity NamedSwaggerDoc)
-> ((Maybe Value -> Identity (Maybe Value))
    -> Schema -> Identity Schema)
-> (Maybe Value -> Identity (Maybe Value))
-> NamedSwaggerDoc
-> Identity NamedSwaggerDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Value -> Identity (Maybe Value))
-> Schema -> Identity Schema
forall s a. HasExample s a => Lens' s a
Lens' Schema (Maybe Value)
S.example ((Maybe Value -> Identity (Maybe Value))
 -> NamedSwaggerDoc -> Identity NamedSwaggerDoc)
-> Value -> NamedSwaggerDoc -> NamedSwaggerDoc
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SStaticError e -> Value
forall a. ToJSON a => a -> Value
A.toJSON SStaticError e
e
    labelSchema :: ValueSchema SwaggerDoc Text
    labelSchema :: SchemaP SwaggerDoc Value Value Text Text
labelSchema = SchemaP NamedSwaggerDoc Value Value Text Text
-> SchemaP SwaggerDoc Value Value Text Text
forall doc doc' v m a b.
HasObject doc doc' =>
SchemaP doc' v m a b -> SchemaP doc v m a b
unnamed (SchemaP NamedSwaggerDoc Value Value Text Text
 -> SchemaP SwaggerDoc Value Value Text Text)
-> SchemaP NamedSwaggerDoc Value Value Text Text
-> SchemaP SwaggerDoc Value Value Text Text
forall a b. (a -> b) -> a -> b
$ forall v doc a b.
(With v, HasEnum v doc) =>
Text
-> SchemaP [Value] v (Alt Maybe v) a b
-> SchemaP doc Value Value a b
enum @Text Text
"Label" (Text -> Text -> SchemaP [Value] Text (Alt Maybe Text) Text Text
forall a b.
(ToJSON a, Eq a, Eq b) =>
a -> b -> SchemaP [Value] a (Alt Maybe a) b b
element Text
label Text
label)
    codeSchema :: ValueSchema SwaggerDoc Natural
    codeSchema :: SchemaP SwaggerDoc Value Value Natural Natural
codeSchema = SchemaP NamedSwaggerDoc Value Value Natural Natural
-> SchemaP SwaggerDoc Value Value Natural Natural
forall doc doc' v m a b.
HasObject doc doc' =>
SchemaP doc' v m a b -> SchemaP doc v m a b
unnamed (SchemaP NamedSwaggerDoc Value Value Natural Natural
 -> SchemaP SwaggerDoc Value Value Natural Natural)
-> SchemaP NamedSwaggerDoc Value Value Natural Natural
-> SchemaP SwaggerDoc Value Value Natural Natural
forall a b. (a -> b) -> a -> b
$ forall v doc a b.
(With v, HasEnum v doc) =>
Text
-> SchemaP [Value] v (Alt Maybe v) a b
-> SchemaP doc Value Value a b
enum @Natural Text
"Status" (Natural
-> Natural
-> SchemaP [Value] Natural (Alt Maybe Natural) Natural Natural
forall a b.
(ToJSON a, Eq a, Eq b) =>
a -> b -> SchemaP [Value] a (Alt Maybe a) b b
element Natural
code Natural
code)

instance (KnownError e) => ToSchema (SStaticError e) where
  schema :: ValueSchema NamedSwaggerDoc (SStaticError e)
schema = SStaticError e -> ValueSchema NamedSwaggerDoc (SStaticError e)
forall (e :: StaticError).
SStaticError e -> ValueSchema NamedSwaggerDoc (SStaticError e)
staticErrorSchema SStaticError e
forall (e :: StaticError). KnownError e => SStaticError e
seSing

data CanThrow e

data CanThrowMany (es :: [k])

instance (RoutesToPaths api) => RoutesToPaths (CanThrow err :> api) where
  getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @api

instance (RoutesToPaths api) => RoutesToPaths (CanThrowMany errs :> api) where
  getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @api

type instance
  SpecialiseToVersion v (CanThrow e :> api) =
    CanThrow e :> SpecialiseToVersion v api

instance (HasServer api ctx) => HasServer (CanThrow e :> api) ctx where
  type ServerT (CanThrow e :> api) m = ServerT api m

  route :: forall env.
Proxy (CanThrow e :> api)
-> Context ctx
-> Delayed env (Server (CanThrow e :> api))
-> Router env
route Proxy (CanThrow e :> api)
_ = Proxy api
-> Context ctx
-> Delayed env (Server api)
-> Router' env RoutingApplication
forall env.
Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api)
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (CanThrow e :> api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (CanThrow e :> api) m
-> ServerT (CanThrow e :> api) n
hoistServerWithContext Proxy (CanThrow e :> api)
_ = Proxy api
-> Proxy ctx
-> (forall {x}. m x -> n x)
-> ServerT api m
-> ServerT api 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
forall (m :: * -> *) (n :: * -> *).
Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api)

instance (HasServer api ctx) => HasServer (CanThrowMany es :> api) ctx where
  type ServerT (CanThrowMany es :> api) m = ServerT api m

  route :: forall env.
Proxy (CanThrowMany es :> api)
-> Context ctx
-> Delayed env (Server (CanThrowMany es :> api))
-> Router env
route Proxy (CanThrowMany es :> api)
_ = Proxy api
-> Context ctx
-> Delayed env (Server api)
-> Router' env RoutingApplication
forall env.
Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api)
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (CanThrowMany es :> api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (CanThrowMany es :> api) m
-> ServerT (CanThrowMany es :> api) n
hoistServerWithContext Proxy (CanThrowMany es :> api)
_ = Proxy api
-> Proxy ctx
-> (forall {x}. m x -> n x)
-> ServerT api m
-> ServerT api 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
forall (m :: * -> *) (n :: * -> *).
Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api)

instance
  (HasOpenApi api, IsSwaggerError e) =>
  HasOpenApi (CanThrow e :> api)
  where
  toOpenApi :: Proxy (CanThrow e :> api) -> OpenApi
toOpenApi Proxy (CanThrow e :> api)
_ = forall (e :: k). IsSwaggerError e => OpenApi -> OpenApi
forall {k} (e :: k). IsSwaggerError e => OpenApi -> OpenApi
addToOpenApi @e (Proxy api -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api))

instance (HasClient m api) => HasClient m (CanThrow e :> api) where
  type Client m (CanThrow e :> api) = Client m api
  clientWithRoute :: Proxy m
-> Proxy (CanThrow e :> api)
-> Request
-> Client m (CanThrow e :> api)
clientWithRoute Proxy m
pm Proxy (CanThrow e :> api)
_ = Proxy m -> Proxy api -> Request -> Client m api
forall (m :: * -> *) api.
HasClient m api =>
Proxy m -> Proxy api -> Request -> Client m api
clientWithRoute Proxy m
pm (Proxy api -> Request -> Client m api)
-> Proxy api -> Request -> Client m api
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api
  hoistClientMonad :: forall (mon :: * -> *) (mon' :: * -> *).
Proxy m
-> Proxy (CanThrow e :> api)
-> (forall x. mon x -> mon' x)
-> Client mon (CanThrow e :> api)
-> Client mon' (CanThrow e :> api)
hoistClientMonad Proxy m
pm Proxy (CanThrow e :> api)
_ = Proxy m
-> Proxy api
-> (forall {x}. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (m :: * -> *) api (mon :: * -> *) (mon' :: * -> *).
HasClient m api =>
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (mon :: * -> *) (mon' :: * -> *).
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
hoistClientMonad Proxy m
pm (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api)

type instance
  SpecialiseToVersion v (CanThrowMany es :> api) =
    CanThrowMany es :> SpecialiseToVersion v api

instance (HasOpenApi api) => HasOpenApi (CanThrowMany '[] :> api) where
  toOpenApi :: Proxy (CanThrowMany '[] :> api) -> OpenApi
toOpenApi Proxy (CanThrowMany '[] :> api)
_ = Proxy api -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api)

instance
  (HasOpenApi (CanThrowMany es :> api), IsSwaggerError e) =>
  HasOpenApi (CanThrowMany (e : es) :> api)
  where
  toOpenApi :: Proxy (CanThrowMany (e : es) :> api) -> OpenApi
toOpenApi Proxy (CanThrowMany (e : es) :> api)
_ = forall (e :: k). IsSwaggerError e => OpenApi -> OpenApi
forall {k} (e :: k). IsSwaggerError e => OpenApi -> OpenApi
addToOpenApi @e (Proxy (CanThrowMany es :> api) -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(CanThrowMany es :> api)))

type family DeclaredErrorEffects api :: EffectRow where
  DeclaredErrorEffects (CanThrow e :> api) = (ErrorEffect e ': DeclaredErrorEffects api)
  DeclaredErrorEffects (CanThrowMany (e : es) :> api) =
    DeclaredErrorEffects (CanThrow e :> CanThrowMany es :> api)
  DeclaredErrorEffects (x :> api) = DeclaredErrorEffects api
  DeclaredErrorEffects (Named n api) = DeclaredErrorEffects api
  DeclaredErrorEffects api = '[]

errorResponseSwagger :: forall e. (Typeable e, KnownError e) => S.Response
errorResponseSwagger :: forall (e :: StaticError). (Typeable e, KnownError e) => Response
errorResponseSwagger =
  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
Lens' Response Text
S.description ((Text -> Identity Text) -> Response -> Identity Response)
-> Text -> Response -> Response
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (DynError -> Text
eMessage DynError
err Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (label: `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> DynError -> Text
eLabel DynError
err Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`)")
    -- Defaulting this to JSON, as openapi3 needs something to map a schema against.
    -- This _should_ be overridden with the actual media types once we are at the
    -- point of rendering out the schemas for MultiVerb.
    -- Check the instance of `S.HasOpenApi (MultiVerb method (cs :: [Type]) as r)`
    Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap MediaType MediaTypeObject
 -> Identity (InsOrdHashMap MediaType MediaTypeObject))
-> Response -> Identity Response
forall s a. HasContent s a => Lens' s a
Lens' Response (InsOrdHashMap MediaType MediaTypeObject)
S.content ((InsOrdHashMap MediaType MediaTypeObject
  -> Identity (InsOrdHashMap MediaType MediaTypeObject))
 -> Response -> Identity Response)
-> InsOrdHashMap MediaType MediaTypeObject -> Response -> Response
forall s t a b. ASetter s t a b -> b -> s -> t
.~ MediaType
-> MediaTypeObject -> InsOrdHashMap MediaType MediaTypeObject
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
singleton MediaType
mediaType MediaTypeObject
mediaTypeObject
  where
    err :: DynError
err = forall (e :: StaticError). KnownError e => DynError
dynError @e
    mediaType :: MediaType
mediaType = Proxy JSON -> MediaType
forall {k} (ctype :: k). Accept ctype => Proxy ctype -> MediaType
contentType (Proxy JSON -> MediaType) -> Proxy JSON -> MediaType
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @JSON
    mediaTypeObject :: MediaTypeObject
mediaTypeObject =
      MediaTypeObject
forall a. Monoid a => a
mempty
        MediaTypeObject
-> (MediaTypeObject -> MediaTypeObject) -> MediaTypeObject
forall a b. a -> (a -> b) -> b
& (Maybe (Referenced Schema) -> Identity (Maybe (Referenced Schema)))
-> MediaTypeObject -> Identity MediaTypeObject
forall s a. HasSchema s a => Lens' s a
Lens' MediaTypeObject (Maybe (Referenced Schema))
S.schema ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> MediaTypeObject -> Identity MediaTypeObject)
-> Referenced Schema -> MediaTypeObject -> MediaTypeObject
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Schema -> Referenced Schema
forall a. a -> Referenced a
S.Inline (Proxy (SStaticError e) -> Schema
forall a. ToSchema a => Proxy a -> Schema
S.toSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(SStaticError e)))

addErrorResponseToSwagger :: Int -> S.Response -> S.OpenApi -> S.OpenApi
addErrorResponseToSwagger :: HttpStatusCode -> Response -> OpenApi -> OpenApi
addErrorResponseToSwagger HttpStatusCode
code Response
resp =
  (Operation -> Identity Operation) -> OpenApi -> Identity OpenApi
Traversal' OpenApi Operation
S.allOperations
    ((Operation -> Identity Operation) -> OpenApi -> Identity OpenApi)
-> ((Maybe (Referenced Response)
     -> Identity (Maybe (Referenced Response)))
    -> Operation -> Identity Operation)
-> (Maybe (Referenced Response)
    -> Identity (Maybe (Referenced Response)))
-> OpenApi
-> Identity OpenApi
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
Lens' Operation Responses
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
Lens'
  Responses (InsOrdHashMap HttpStatusCode (Referenced Response))
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)))
 -> OpenApi -> Identity OpenApi)
-> (Maybe (Referenced Response) -> Maybe (Referenced Response))
-> OpenApi
-> OpenApi
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Referenced Response -> Maybe (Referenced Response)
forall a. a -> Maybe a
Just
      (Referenced Response -> Maybe (Referenced Response))
-> (Maybe (Referenced Response) -> Referenced Response)
-> Maybe (Referenced Response)
-> Maybe (Referenced Response)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Referenced Response) -> Referenced Response
addRef
  where
    addRef :: Maybe (S.Referenced S.Response) -> S.Referenced S.Response
    addRef :: Maybe (Referenced Response) -> Referenced Response
addRef Maybe (Referenced Response)
Nothing = Response -> Referenced Response
forall a. a -> Referenced a
S.Inline Response
resp
    addRef (Just (S.Inline Response
resp1)) = Response -> Referenced Response
forall a. a -> Referenced a
S.Inline (Response -> Response -> Response
combineResponseSwagger Response
resp1 Response
resp)
    addRef (Just r :: Referenced Response
r@(S.Ref Reference
_)) = Referenced Response
r

addStaticErrorToSwagger :: forall e. (Typeable e, KnownError e) => S.OpenApi -> S.OpenApi
addStaticErrorToSwagger :: forall (e :: StaticError).
(Typeable e, KnownError e) =>
OpenApi -> OpenApi
addStaticErrorToSwagger =
  HttpStatusCode -> Response -> OpenApi -> OpenApi
addErrorResponseToSwagger
    (Natural -> HttpStatusCode
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DynError -> Natural
eCode (forall (e :: StaticError). KnownError e => DynError
dynError @e)))
    (forall (e :: StaticError). (Typeable e, KnownError e) => Response
errorResponseSwagger @e)

type family MapError (e :: k) :: StaticError

type family ErrorEffect (e :: k) :: Effect

class IsSwaggerError e where
  addToOpenApi :: S.OpenApi -> S.OpenApi

-- | An effect for a static error type with no data.
type ErrorS e = Error (Tagged e ())

throwS :: forall e r a. (Member (ErrorS e) r) => Sem r a
throwS :: forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS = Tagged e () -> Sem r a
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (forall (s :: k) b. b -> Tagged s b
forall {k} (s :: k) b. b -> Tagged s b
Tagged @e ())

noteS :: forall e r a. (Member (ErrorS e) r) => Maybe a -> Sem r a
noteS :: forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
noteS = Tagged e () -> Maybe a -> Sem r a
forall e (r :: EffectRow) a.
Member (Error e) r =>
e -> Maybe a -> Sem r a
note (forall (s :: k) b. b -> Tagged s b
forall {k} (s :: k) b. b -> Tagged s b
Tagged @e ())

runErrorS :: forall e r a. Sem (ErrorS e : r) a -> Sem r (Maybe a)
runErrorS :: forall {k} (e :: k) (r :: EffectRow) a.
Sem (ErrorS e : r) a -> Sem r (Maybe a)
runErrorS = (Either (Tagged e ()) a -> Maybe a)
-> Sem r (Either (Tagged e ()) a) -> Sem r (Maybe a)
forall a b. (a -> b) -> Sem r a -> Sem r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either (Tagged e ()) a -> Maybe a
forall a b. Either a b -> Maybe b
hush (Sem r (Either (Tagged e ()) a) -> Sem r (Maybe a))
-> (Sem (ErrorS e : r) a -> Sem r (Either (Tagged e ()) a))
-> Sem (ErrorS e : r) a
-> Sem r (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError @(Tagged e ())

mapErrorS ::
  forall e e' r a.
  (Member (ErrorS e') r) =>
  Sem (ErrorS e ': r) a ->
  Sem r a
mapErrorS :: forall {k} {k} (e :: k) (e' :: k) (r :: EffectRow) a.
Member (ErrorS e') r =>
Sem (ErrorS e : r) a -> Sem r a
mapErrorS = (Tagged e () -> Tagged e' ())
-> Sem (Error (Tagged e ()) : r) a -> Sem r a
forall e1 e2 (r :: EffectRow) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
mapError (forall (s :: k) b. b -> Tagged s b
forall {k} (s :: k) b. b -> Tagged s b
Tagged @e' (() -> Tagged e' ())
-> (Tagged e () -> ()) -> Tagged e () -> Tagged e' ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tagged e () -> ()
forall {k} (s :: k) b. Tagged s b -> b
unTagged)

mapToRuntimeError ::
  forall e e' r a. (Member (Error e') r) => e' -> Sem (ErrorS e ': r) a -> Sem r a
mapToRuntimeError :: forall {k} (e :: k) e' (r :: EffectRow) a.
Member (Error e') r =>
e' -> Sem (ErrorS e : r) a -> Sem r a
mapToRuntimeError e'
e' = (Tagged e () -> e') -> Sem (Error (Tagged e ()) : r) a -> Sem r a
forall e1 e2 (r :: EffectRow) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
mapError (e' -> Tagged e () -> e'
forall a b. a -> b -> a
const e'
e')

mapToDynamicError ::
  forall e r a.
  (Member (Error DynError) r, KnownError (MapError e)) =>
  Sem (ErrorS e ': r) a ->
  Sem r a
mapToDynamicError :: forall {k} (e :: k) (r :: EffectRow) a.
(Member (Error DynError) r, KnownError (MapError e)) =>
Sem (ErrorS e : r) a -> Sem r a
mapToDynamicError = DynError -> Sem (ErrorS e : r) a -> Sem r a
forall {k} (e :: k) e' (r :: EffectRow) a.
Member (Error e') r =>
e' -> Sem (ErrorS e : r) a -> Sem r a
mapToRuntimeError (forall (e :: StaticError). KnownError e => DynError
dynError @(MapError e))

errorToWai :: forall e. (KnownError (MapError e)) => Wai.Error
errorToWai :: forall {k} (e :: k). KnownError (MapError e) => Error
errorToWai = DynError -> Error
dynErrorToWai (forall (e :: StaticError). KnownError e => DynError
dynError @(MapError e))

errorToResponse :: forall e. (KnownError (MapError e)) => JSONResponse
errorToResponse :: forall {k} (e :: k). KnownError (MapError e) => JSONResponse
errorToResponse = DynError -> JSONResponse
forall e. APIError e => e -> JSONResponse
toResponse (forall (e :: StaticError). KnownError e => DynError
dynError @(MapError e))

class APIError e where
  toResponse :: e -> JSONResponse

instance APIError Wai.Error where
  toResponse :: Error -> JSONResponse
toResponse = Error -> JSONResponse
waiErrorToJSONResponse

instance APIError DynError where
  toResponse :: DynError -> JSONResponse
toResponse (DynError Natural
c Text
l Text
m) =
    Error -> JSONResponse
forall e. APIError e => e -> JSONResponse
toResponse (Error -> JSONResponse) -> Error -> JSONResponse
forall a b. (a -> b) -> a -> b
$
      Status -> LText -> LText -> Error
Wai.mkError (HttpStatusCode -> Status
forall a. Enum a => HttpStatusCode -> a
toEnum (Natural -> HttpStatusCode
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
c)) (Text -> LText
LT.fromStrict Text
l) (Text -> LText
LT.fromStrict Text
m)

instance APIError (SStaticError e) where
  toResponse :: SStaticError e -> JSONResponse
toResponse = DynError -> JSONResponse
forall e. APIError e => e -> JSONResponse
toResponse (DynError -> JSONResponse)
-> (SStaticError e -> DynError) -> SStaticError e -> JSONResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SStaticError e -> DynError
forall (e :: StaticError). SStaticError e -> DynError
dynError'

--------------------------------------------------------------------------------
-- MultiVerb support

type family RespondWithStaticError (s :: StaticError) :: Type where
  RespondWithStaticError ('StaticError s l m) = RespondAs JSON s m DynError

type family StaticErrorStatus (s :: StaticError) :: Nat where
  StaticErrorStatus ('StaticError s l m) = s

data ErrorResponse e

type instance ResponseType (ErrorResponse e) = DynError

instance
  ( ResponseBody (RespondWithStaticError (MapError e)) ~ LByteString,
    ResponseType (RespondWithStaticError (MapError e)) ~ DynError,
    IsResponse cs (RespondWithStaticError (MapError e))
  ) =>
  IsResponse cs (ErrorResponse e)
  where
  type ResponseStatus (ErrorResponse e) = StaticErrorStatus (MapError e)
  type ResponseBody (ErrorResponse e) = LByteString

  responseRender :: AcceptHeader
-> ResponseType (ErrorResponse e)
-> Maybe (ResponseF (ResponseBody (ErrorResponse e)))
responseRender = forall (cs :: k) a.
IsResponse cs a =>
AcceptHeader
-> ResponseType a -> Maybe (ResponseF (ResponseBody a))
forall {k} (cs :: k) a.
IsResponse cs a =>
AcceptHeader
-> ResponseType a -> Maybe (ResponseF (ResponseBody a))
responseRender @cs @(RespondWithStaticError (MapError e))
  responseUnrender :: MediaType
-> ResponseF (ResponseBody (ErrorResponse e))
-> UnrenderResult (ResponseType (ErrorResponse e))
responseUnrender = forall (cs :: k) a.
IsResponse cs a =>
MediaType
-> ResponseF (ResponseBody a) -> UnrenderResult (ResponseType a)
forall {k} (cs :: k) a.
IsResponse cs a =>
MediaType
-> ResponseF (ResponseBody a) -> UnrenderResult (ResponseType a)
responseUnrender @cs @(RespondWithStaticError (MapError e))

instance (KnownError (MapError e)) => AsConstructor '[] (ErrorResponse e) where
  toConstructor :: ResponseType (ErrorResponse e) -> NP I '[]
toConstructor ResponseType (ErrorResponse e)
_ = NP I '[]
forall {k} (a :: k -> *). NP a '[]
Nil
  fromConstructor :: NP I '[] -> ResponseType (ErrorResponse e)
fromConstructor NP I '[]
_ = forall (e :: StaticError). KnownError e => DynError
dynError @(MapError e)

instance (KnownError (MapError e), Typeable (MapError e)) => IsSwaggerResponse (ErrorResponse e) where
  responseSwagger :: Declare Response
responseSwagger = Response -> Declare Response
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> Declare Response) -> Response -> Declare Response
forall a b. (a -> b) -> a -> b
$ forall (e :: StaticError). (Typeable e, KnownError e) => Response
errorResponseSwagger @(MapError e)

instance
  (ResponseType r ~ a, KnownError (MapError e)) =>
  AsUnion '[ErrorResponse e, r] (Maybe a)
  where
  toUnion :: Maybe a -> Union (ResponseTypes '[ErrorResponse e, r])
toUnion Maybe a
Nothing = I DynError -> NS I '[DynError, a]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (DynError -> I DynError
forall a. a -> I a
I (forall (e :: StaticError). KnownError e => DynError
dynError @(MapError e)))
  toUnion (Just a
x) = NS I '[a] -> NS I '[DynError, a]
forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (I a -> NS I '[a]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (a -> I a
forall a. a -> I a
I a
x))
  fromUnion :: Union (ResponseTypes '[ErrorResponse e, r]) -> Maybe a
fromUnion (Z (I x
_)) = Maybe a
forall a. Maybe a
Nothing
  fromUnion (S (Z (I x
x))) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
x
  fromUnion (S (S NS I xs
x)) = case NS I xs
x of {}