{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE RecordWildCards #-}

-- 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.Routes.MultiVerb
  ( -- * MultiVerb types
    MultiVerb,
    MultiVerb1,
    Respond,
    RespondAs,
    RespondEmpty,
    RespondStreaming,
    WithHeaders,
    DescHeader,
    OptHeader,
    AsHeaders (..),
    AsUnion (..),
    eitherToUnion,
    eitherFromUnion,
    maybeToUnion,
    maybeFromUnion,
    AsConstructor (..),
    GenericAsConstructor (..),
    GenericAsUnion (..),
    ResponseType,
    IsResponse (..),
    IsSwaggerResponse (..),
    IsSwaggerResponseList (..),
    simpleResponseSwagger,
    combineResponseSwagger,
    ResponseTypes,
    IsResponseList (..),
    addContentType,
  )
where

import Control.Applicative
import Control.Lens hiding (Context, (<|))
import Data.ByteString.Builder
import Data.ByteString.Lazy qualified as LBS
import Data.CaseInsensitive qualified as CI
import Data.HashMap.Strict.InsOrd (InsOrdHashMap, unionWith)
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
import Data.Kind
import Data.Metrics.Servant
import Data.OpenApi hiding (HasServer, Response, contentType)
import Data.OpenApi qualified as S
import Data.OpenApi.Declare qualified as S
import Data.Proxy
import Data.SOP
import Data.Sequence (Seq, (<|), pattern (:<|))
import Data.Sequence qualified as Seq
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Typeable
import GHC.TypeLits
import Generics.SOP as GSOP
import Imports
import Network.HTTP.Media qualified as M
import Network.HTTP.Types (hContentType)
import Network.HTTP.Types qualified as HTTP
import Network.HTTP.Types.Status
import Network.Wai qualified as Wai
import Servant.API
import Servant.API.ContentTypes
import Servant.API.Status (KnownStatus (..))
import Servant.Client
import Servant.Client.Core hiding (addHeader)
import Servant.OpenApi as S
import Servant.OpenApi.Internal as S
import Servant.Server
import Servant.Server.Internal
import Servant.Types.SourceT

type Declare = S.Declare (S.Definitions S.Schema)

-- | A type to describe a 'MultiVerb' response.
--
-- Includes status code, description, and return type. The content type of the
-- response is determined dynamically using the accept header and the list of
-- supported content types specified in the containing 'MultiVerb' type.
data Respond (s :: Nat) (desc :: Symbol) (a :: Type)

-- | A type to describe a 'MultiVerb' response with a fixed content type.
--
-- Similar to 'Respond', but hardcodes the content type to be used for
-- generating the response.
data RespondAs ct (s :: Nat) (desc :: Symbol) (a :: Type)

-- | A type to describe a 'MultiVerb' response with an empty body.
--
-- Includes status code and description.
type RespondEmpty s desc = RespondAs '() s desc ()

-- | A type to describe a streaming 'MultiVerb' response.
--
-- Includes status code, description and content type. Note that the handler
-- return type is hardcoded to be 'SourceIO ByteString'.
data RespondStreaming (s :: Nat) (desc :: Symbol) (ct :: Type)

-- | The result of parsing a response as a union alternative of type 'a'.
--
-- 'StatusMismatch' indicates that the response does not refer to the given
-- alternative, because the status code does not match the one produced by that
-- alternative.
--
-- 'UnrenderError' and 'UnrenderSuccess' represent respectively a failing and
-- successful parse of the response body as a value of type 'a'.
--
-- The 'UnrenderResult' type constructor has monad and alternative instances
-- corresponding to those of 'Either (Maybe (Last String)) a'.
data UnrenderResult a = StatusMismatch | UnrenderError String | UnrenderSuccess a
  deriving (UnrenderResult a -> UnrenderResult a -> Bool
(UnrenderResult a -> UnrenderResult a -> Bool)
-> (UnrenderResult a -> UnrenderResult a -> Bool)
-> Eq (UnrenderResult a)
forall a. Eq a => UnrenderResult a -> UnrenderResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => UnrenderResult a -> UnrenderResult a -> Bool
== :: UnrenderResult a -> UnrenderResult a -> Bool
$c/= :: forall a. Eq a => UnrenderResult a -> UnrenderResult a -> Bool
/= :: UnrenderResult a -> UnrenderResult a -> Bool
Eq, Int -> UnrenderResult a -> ShowS
[UnrenderResult a] -> ShowS
UnrenderResult a -> String
(Int -> UnrenderResult a -> ShowS)
-> (UnrenderResult a -> String)
-> ([UnrenderResult a] -> ShowS)
-> Show (UnrenderResult a)
forall a. Show a => Int -> UnrenderResult a -> ShowS
forall a. Show a => [UnrenderResult a] -> ShowS
forall a. Show a => UnrenderResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> UnrenderResult a -> ShowS
showsPrec :: Int -> UnrenderResult a -> ShowS
$cshow :: forall a. Show a => UnrenderResult a -> String
show :: UnrenderResult a -> String
$cshowList :: forall a. Show a => [UnrenderResult a] -> ShowS
showList :: [UnrenderResult a] -> ShowS
Show, (forall a b. (a -> b) -> UnrenderResult a -> UnrenderResult b)
-> (forall a b. a -> UnrenderResult b -> UnrenderResult a)
-> Functor UnrenderResult
forall a b. a -> UnrenderResult b -> UnrenderResult a
forall a b. (a -> b) -> UnrenderResult a -> UnrenderResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> UnrenderResult a -> UnrenderResult b
fmap :: forall a b. (a -> b) -> UnrenderResult a -> UnrenderResult b
$c<$ :: forall a b. a -> UnrenderResult b -> UnrenderResult a
<$ :: forall a b. a -> UnrenderResult b -> UnrenderResult a
Functor)

instance Applicative UnrenderResult where
  pure :: forall a. a -> UnrenderResult a
pure = a -> UnrenderResult a
forall a. a -> UnrenderResult a
UnrenderSuccess
  <*> :: forall a b.
UnrenderResult (a -> b) -> UnrenderResult a -> UnrenderResult b
(<*>) = UnrenderResult (a -> b) -> UnrenderResult a -> UnrenderResult b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad UnrenderResult where
  return :: forall a. a -> UnrenderResult a
return = a -> UnrenderResult a
forall a. a -> UnrenderResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  UnrenderResult a
StatusMismatch >>= :: forall a b.
UnrenderResult a -> (a -> UnrenderResult b) -> UnrenderResult b
>>= a -> UnrenderResult b
_ = UnrenderResult b
forall a. UnrenderResult a
StatusMismatch
  UnrenderError String
e >>= a -> UnrenderResult b
_ = String -> UnrenderResult b
forall a. String -> UnrenderResult a
UnrenderError String
e
  UnrenderSuccess a
x >>= a -> UnrenderResult b
f = a -> UnrenderResult b
f a
x

instance Alternative UnrenderResult where
  empty :: forall a. UnrenderResult a
empty = UnrenderResult a
forall a. UnrenderResult a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  <|> :: forall a. UnrenderResult a -> UnrenderResult a -> UnrenderResult a
(<|>) = UnrenderResult a -> UnrenderResult a -> UnrenderResult a
forall a. UnrenderResult a -> UnrenderResult a -> UnrenderResult a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance MonadPlus UnrenderResult where
  mzero :: forall a. UnrenderResult a
mzero = UnrenderResult a
forall a. UnrenderResult a
StatusMismatch
  mplus :: forall a. UnrenderResult a -> UnrenderResult a -> UnrenderResult a
mplus UnrenderResult a
StatusMismatch UnrenderResult a
m = UnrenderResult a
m
  mplus (UnrenderError String
e) UnrenderResult a
StatusMismatch = String -> UnrenderResult a
forall a. String -> UnrenderResult a
UnrenderError String
e
  mplus (UnrenderError String
_) UnrenderResult a
m = UnrenderResult a
m
  mplus m :: UnrenderResult a
m@(UnrenderSuccess a
_) UnrenderResult a
_ = UnrenderResult a
m

class IsSwaggerResponse a where
  responseSwagger :: Declare S.Response

type family ResponseType a :: Type

class (IsWaiBody (ResponseBody a)) => IsResponse cs a where
  type ResponseStatus a :: Nat
  type ResponseBody a :: Type

  responseRender :: AcceptHeader -> ResponseType a -> Maybe (ResponseF (ResponseBody a))
  responseUnrender :: M.MediaType -> ResponseF (ResponseBody a) -> UnrenderResult (ResponseType a)

type instance ResponseType (Respond s desc a) = a

instance (AllMimeRender cs a, AllMimeUnrender cs a, KnownStatus s) => IsResponse cs (Respond s desc a) where
  type ResponseStatus (Respond s desc a) = s
  type ResponseBody (Respond s desc a) = LByteString

  -- Note: here it seems like we are rendering for all possible content types,
  -- only to choose the correct one afterwards. However, render results besides the
  -- one picked by 'M.mapAcceptMedia' are not evaluated, and therefore nor are the
  -- corresponding rendering functions.
  responseRender :: AcceptHeader
-> ResponseType (Respond s desc a)
-> Maybe (ResponseF (ResponseBody (Respond s desc a)))
responseRender (AcceptHeader ByteString
acc) ResponseType (Respond s desc a)
x =
    [(MediaType, Response)] -> ByteString -> Maybe Response
forall b. [(MediaType, b)] -> ByteString -> Maybe b
M.mapAcceptMedia (((MediaType, LByteString) -> (MediaType, Response))
-> [(MediaType, LByteString)] -> [(MediaType, Response)]
forall a b. (a -> b) -> [a] -> [b]
map ((MediaType -> LByteString -> (MediaType, Response))
-> (MediaType, LByteString) -> (MediaType, Response)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry MediaType -> LByteString -> (MediaType, Response)
mkRenderOutput) (Proxy cs -> a -> [(MediaType, LByteString)]
forall (list :: [*]) a.
AllMimeRender list a =>
Proxy list -> a -> [(MediaType, LByteString)]
allMimeRender (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @cs) a
ResponseType (Respond s desc a)
x)) ByteString
acc
    where
      mkRenderOutput :: M.MediaType -> LByteString -> (M.MediaType, Response)
      mkRenderOutput :: MediaType -> LByteString -> (MediaType, Response)
mkRenderOutput MediaType
c LByteString
body =
        (MediaType
c,) (Response -> (MediaType, Response))
-> (Response -> Response) -> Response -> (MediaType, Response)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MediaType -> Response -> Response
forall a. MediaType -> ResponseF a -> ResponseF a
addContentType' MediaType
c (Response -> (MediaType, Response))
-> Response -> (MediaType, Response)
forall a b. (a -> b) -> a -> b
$
          Response
            { responseStatusCode :: Status
responseStatusCode = Proxy s -> Status
forall (n :: Nat) (proxy :: Nat -> *).
KnownStatus n =>
proxy n -> Status
forall (proxy :: Nat -> *). proxy s -> Status
statusVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s),
              responseBody :: LByteString
responseBody = LByteString
body,
              responseHeaders :: Seq Header
responseHeaders = Seq Header
forall a. Monoid a => a
mempty,
              responseHttpVersion :: HttpVersion
responseHttpVersion = HttpVersion
HTTP.http11
            }

  responseUnrender :: MediaType
-> ResponseF (ResponseBody (Respond s desc a))
-> UnrenderResult (ResponseType (Respond s desc a))
responseUnrender MediaType
c ResponseF (ResponseBody (Respond s desc a))
output = do
    Bool -> UnrenderResult ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Response -> Status
forall a. ResponseF a -> Status
responseStatusCode Response
ResponseF (ResponseBody (Respond s desc a))
output Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy s -> Status
forall (n :: Nat) (proxy :: Nat -> *).
KnownStatus n =>
proxy n -> Status
forall (proxy :: Nat -> *). proxy s -> Status
statusVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s))
    let results :: [(MediaType, LByteString -> Either String a)]
results = Proxy cs -> [(MediaType, LByteString -> Either String a)]
forall (list :: [*]) a.
AllMimeUnrender list a =>
Proxy list -> [(MediaType, LByteString -> Either String a)]
allMimeUnrender (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @cs)
    case MediaType
-> [(MediaType, LByteString -> Either String a)]
-> Maybe (LByteString -> Either String a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup MediaType
c [(MediaType, LByteString -> Either String a)]
results of
      Maybe (LByteString -> Either String a)
Nothing -> UnrenderResult a
forall a. UnrenderResult a
forall (f :: * -> *) a. Alternative f => f a
empty
      Just LByteString -> Either String a
f -> (String -> UnrenderResult a)
-> (a -> UnrenderResult a) -> Either String a -> UnrenderResult a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> UnrenderResult a
forall a. String -> UnrenderResult a
UnrenderError a -> UnrenderResult a
forall a. a -> UnrenderResult a
UnrenderSuccess (LByteString -> Either String a
f (Response -> LByteString
forall a. ResponseF a -> a
responseBody Response
ResponseF (ResponseBody (Respond s desc a))
output))

simpleResponseSwagger :: forall a cs desc. (S.ToSchema a, KnownSymbol desc, AllMime cs) => Declare S.Response
simpleResponseSwagger :: forall a (cs :: [*]) (desc :: Symbol).
(ToSchema a, KnownSymbol desc, AllMime cs) =>
Declare Response
simpleResponseSwagger = do
  Referenced Schema
ref <- Proxy a -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
S.declareSchemaRef (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
  let resps :: InsOrdHashMap M.MediaType MediaTypeObject
      resps :: InsOrdHashMap MediaType MediaTypeObject
resps = [(MediaType, MediaTypeObject)]
-> InsOrdHashMap MediaType MediaTypeObject
forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
InsOrdHashMap.fromList ([(MediaType, MediaTypeObject)]
 -> InsOrdHashMap MediaType MediaTypeObject)
-> [(MediaType, MediaTypeObject)]
-> InsOrdHashMap MediaType MediaTypeObject
forall a b. (a -> b) -> a -> b
$ (,Maybe (Referenced Schema)
-> Maybe Value
-> InsOrdHashMap Text (Referenced Example)
-> InsOrdHashMap Text Encoding
-> MediaTypeObject
MediaTypeObject (Referenced Schema -> Maybe (Referenced Schema)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Referenced Schema
ref) Maybe Value
forall a. Maybe a
Nothing InsOrdHashMap Text (Referenced Example)
forall a. Monoid a => a
mempty InsOrdHashMap Text Encoding
forall a. Monoid a => a
mempty) (MediaType -> (MediaType, MediaTypeObject))
-> [MediaType] -> [(MediaType, MediaTypeObject)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MediaType]
cs
  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
$
    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
.~ String -> Text
Text.pack (Proxy desc -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @desc))
      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
.~ InsOrdHashMap MediaType MediaTypeObject
resps
  where
    cs :: [M.MediaType]
    cs :: [MediaType]
cs = Proxy cs -> [MediaType]
forall (list :: [*]). AllMime list => Proxy list -> [MediaType]
allMime (Proxy cs -> [MediaType]) -> Proxy cs -> [MediaType]
forall a b. (a -> b) -> a -> b
$ forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @cs

instance
  (KnownSymbol desc, S.ToSchema a) =>
  IsSwaggerResponse (Respond s desc a)
  where
  -- Defaulting this to JSON, as openapi3 needs something to map a schema against.
  responseSwagger :: Declare Response
responseSwagger = forall a (cs :: [*]) (desc :: Symbol).
(ToSchema a, KnownSymbol desc, AllMime cs) =>
Declare Response
simpleResponseSwagger @a @'[JSON] @desc

type instance ResponseType (RespondAs ct s desc a) = a

instance
  ( KnownStatus s,
    MimeRender ct a,
    MimeUnrender ct a
  ) =>
  IsResponse cs (RespondAs (ct :: Type) s desc a)
  where
  type ResponseStatus (RespondAs ct s desc a) = s
  type ResponseBody (RespondAs ct s desc a) = LByteString

  responseRender :: AcceptHeader
-> ResponseType (RespondAs ct s desc a)
-> Maybe (ResponseF (ResponseBody (RespondAs ct s desc a)))
responseRender AcceptHeader
_ ResponseType (RespondAs ct s desc a)
x =
    Response -> Maybe Response
Response
-> Maybe (ResponseF (ResponseBody (RespondAs ct s desc a)))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response
 -> Maybe (ResponseF (ResponseBody (RespondAs ct s desc a))))
-> (Response -> Response)
-> Response
-> Maybe (ResponseF (ResponseBody (RespondAs ct s desc a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (ct :: k) a. Accept ct => ResponseF a -> ResponseF a
forall ct a. Accept ct => ResponseF a -> ResponseF a
addContentType @ct (Response
 -> Maybe (ResponseF (ResponseBody (RespondAs ct s desc a))))
-> Response
-> Maybe (ResponseF (ResponseBody (RespondAs ct s desc a)))
forall a b. (a -> b) -> a -> b
$
      Response
        { responseStatusCode :: Status
responseStatusCode = Proxy s -> Status
forall (n :: Nat) (proxy :: Nat -> *).
KnownStatus n =>
proxy n -> Status
forall (proxy :: Nat -> *). proxy s -> Status
statusVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s),
          responseBody :: LByteString
responseBody = Proxy ct -> a -> LByteString
forall {k} (ctype :: k) a.
MimeRender ctype a =>
Proxy ctype -> a -> LByteString
mimeRender (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @ct) a
ResponseType (RespondAs ct s desc a)
x,
          responseHeaders :: Seq Header
responseHeaders = Seq Header
forall a. Monoid a => a
mempty,
          responseHttpVersion :: HttpVersion
responseHttpVersion = HttpVersion
HTTP.http11
        }

  responseUnrender :: MediaType
-> ResponseF (ResponseBody (RespondAs ct s desc a))
-> UnrenderResult (ResponseType (RespondAs ct s desc a))
responseUnrender MediaType
_ ResponseF (ResponseBody (RespondAs ct s desc a))
output = do
    Bool -> UnrenderResult ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Response -> Status
forall a. ResponseF a -> Status
responseStatusCode Response
ResponseF (ResponseBody (RespondAs ct s desc a))
output Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy s -> Status
forall (n :: Nat) (proxy :: Nat -> *).
KnownStatus n =>
proxy n -> Status
forall (proxy :: Nat -> *). proxy s -> Status
statusVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s))
    (String -> UnrenderResult a)
-> (a -> UnrenderResult a) -> Either String a -> UnrenderResult a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> UnrenderResult a
forall a. String -> UnrenderResult a
UnrenderError a -> UnrenderResult a
forall a. a -> UnrenderResult a
UnrenderSuccess (Either String a -> UnrenderResult a)
-> Either String a -> UnrenderResult a
forall a b. (a -> b) -> a -> b
$
      Proxy ct -> LByteString -> Either String a
forall {k} (ctype :: k) a.
MimeUnrender ctype a =>
Proxy ctype -> LByteString -> Either String a
mimeUnrender (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @ct) (Response -> LByteString
forall a. ResponseF a -> a
responseBody Response
ResponseF (ResponseBody (RespondAs ct s desc a))
output)

instance (KnownStatus s) => IsResponse cs (RespondAs '() s desc ()) where
  type ResponseStatus (RespondAs '() s desc ()) = s
  type ResponseBody (RespondAs '() s desc ()) = ()

  responseRender :: AcceptHeader
-> ResponseType (RespondAs '() s desc ())
-> Maybe (ResponseF (ResponseBody (RespondAs '() s desc ())))
responseRender AcceptHeader
_ ResponseType (RespondAs '() s desc ())
_ =
    ResponseF (ResponseBody (RespondAs '() s desc ()))
-> Maybe (ResponseF (ResponseBody (RespondAs '() s desc ())))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResponseF (ResponseBody (RespondAs '() s desc ()))
 -> Maybe (ResponseF (ResponseBody (RespondAs '() s desc ()))))
-> ResponseF (ResponseBody (RespondAs '() s desc ()))
-> Maybe (ResponseF (ResponseBody (RespondAs '() s desc ())))
forall a b. (a -> b) -> a -> b
$
      Response
        { responseStatusCode :: Status
responseStatusCode = Proxy s -> Status
forall (n :: Nat) (proxy :: Nat -> *).
KnownStatus n =>
proxy n -> Status
forall (proxy :: Nat -> *). proxy s -> Status
statusVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s),
          responseBody :: ()
responseBody = (),
          responseHeaders :: Seq Header
responseHeaders = Seq Header
forall a. Monoid a => a
mempty,
          responseHttpVersion :: HttpVersion
responseHttpVersion = HttpVersion
HTTP.http11
        }

  responseUnrender :: MediaType
-> ResponseF (ResponseBody (RespondAs '() s desc ()))
-> UnrenderResult (ResponseType (RespondAs '() s desc ()))
responseUnrender MediaType
_ ResponseF (ResponseBody (RespondAs '() s desc ()))
output =
    Bool -> UnrenderResult ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ResponseF () -> Status
forall a. ResponseF a -> Status
responseStatusCode ResponseF ()
ResponseF (ResponseBody (RespondAs '() s desc ()))
output Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy s -> Status
forall (n :: Nat) (proxy :: Nat -> *).
KnownStatus n =>
proxy n -> Status
forall (proxy :: Nat -> *). proxy s -> Status
statusVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s))

instance
  (KnownSymbol desc, S.ToSchema a, Accept ct) =>
  IsSwaggerResponse (RespondAs (ct :: Type) s desc a)
  where
  responseSwagger :: Declare Response
responseSwagger = forall a (cs :: [*]) (desc :: Symbol).
(ToSchema a, KnownSymbol desc, AllMime cs) =>
Declare Response
simpleResponseSwagger @a @'[ct] @desc

instance
  (KnownSymbol desc) =>
  IsSwaggerResponse (RespondEmpty s desc)
  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
$
      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
.~ String -> Text
Text.pack (Proxy desc -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @desc))

type instance ResponseType (RespondStreaming s desc ct) = SourceIO ByteString

instance
  (Accept ct, KnownStatus s) =>
  IsResponse cs (RespondStreaming s desc ct)
  where
  type ResponseStatus (RespondStreaming s desc ct) = s
  type ResponseBody (RespondStreaming s desc ct) = SourceIO ByteString
  responseRender :: AcceptHeader
-> ResponseType (RespondStreaming s desc ct)
-> Maybe (ResponseF (ResponseBody (RespondStreaming s desc ct)))
responseRender AcceptHeader
_ ResponseType (RespondStreaming s desc ct)
x =
    ResponseF (SourceIO ByteString)
-> Maybe (ResponseF (SourceIO ByteString))
ResponseF (SourceIO ByteString)
-> Maybe (ResponseF (ResponseBody (RespondStreaming s desc ct)))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResponseF (SourceIO ByteString)
 -> Maybe (ResponseF (ResponseBody (RespondStreaming s desc ct))))
-> (ResponseF (SourceIO ByteString)
    -> ResponseF (SourceIO ByteString))
-> ResponseF (SourceIO ByteString)
-> Maybe (ResponseF (ResponseBody (RespondStreaming s desc ct)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (ct :: k) a. Accept ct => ResponseF a -> ResponseF a
forall ct a. Accept ct => ResponseF a -> ResponseF a
addContentType @ct (ResponseF (SourceIO ByteString)
 -> Maybe (ResponseF (ResponseBody (RespondStreaming s desc ct))))
-> ResponseF (SourceIO ByteString)
-> Maybe (ResponseF (ResponseBody (RespondStreaming s desc ct)))
forall a b. (a -> b) -> a -> b
$
      Response
        { responseStatusCode :: Status
responseStatusCode = Proxy s -> Status
forall (n :: Nat) (proxy :: Nat -> *).
KnownStatus n =>
proxy n -> Status
forall (proxy :: Nat -> *). proxy s -> Status
statusVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s),
          responseBody :: SourceIO ByteString
responseBody = SourceIO ByteString
ResponseType (RespondStreaming s desc ct)
x,
          responseHeaders :: Seq Header
responseHeaders = Seq Header
forall a. Monoid a => a
mempty,
          responseHttpVersion :: HttpVersion
responseHttpVersion = HttpVersion
HTTP.http11
        }

  responseUnrender :: MediaType
-> ResponseF (ResponseBody (RespondStreaming s desc ct))
-> UnrenderResult (ResponseType (RespondStreaming s desc ct))
responseUnrender MediaType
_ ResponseF (ResponseBody (RespondStreaming s desc ct))
resp = do
    Bool -> UnrenderResult ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ResponseF (SourceIO ByteString) -> Status
forall a. ResponseF a -> Status
responseStatusCode ResponseF (SourceIO ByteString)
ResponseF (ResponseBody (RespondStreaming s desc ct))
resp Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy s -> Status
forall (n :: Nat) (proxy :: Nat -> *).
KnownStatus n =>
proxy n -> Status
forall (proxy :: Nat -> *). proxy s -> Status
statusVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s))
    pure $ ResponseF (SourceIO ByteString) -> SourceIO ByteString
forall a. ResponseF a -> a
responseBody ResponseF (SourceIO ByteString)
ResponseF (ResponseBody (RespondStreaming s desc ct))
resp

instance (KnownSymbol desc) => IsSwaggerResponse (RespondStreaming s desc ct) 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
$
      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
.~ String -> Text
Text.pack (Proxy desc -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @desc))

-- | This type adds response headers to a 'MultiVerb' response.
--
-- Type variables:
--  * @hs@: type-level list of headers
--  * @a@: return type (with headers)
--  * @r@: underlying response (without headers)
data WithHeaders (hs :: [Type]) (a :: Type) (r :: Type)

-- | This is used to convert a response containing headers to a custom type
-- including the information in the headers.
class AsHeaders xs a b where
  fromHeaders :: (NP I xs, a) -> b
  toHeaders :: b -> (NP I xs, a)

-- single-header empty response
instance AsHeaders '[a] () a where
  toHeaders :: a -> (NP I '[a], ())
toHeaders a
a = (a -> I a
forall a. a -> I a
I a
a I a -> NP I '[] -> NP I '[a]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP I '[]
forall {k} (a :: k -> *). NP a '[]
Nil, ())
  fromHeaders :: (NP I '[a], ()) -> a
fromHeaders = I a -> a
forall a. I a -> a
unI (I a -> a) -> ((NP I '[a], ()) -> I a) -> (NP I '[a], ()) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP I '[a] -> I a
forall {k} (f :: k -> *) (x :: k) (xs :: [k]). NP f (x : xs) -> f x
hd (NP I '[a] -> I a)
-> ((NP I '[a], ()) -> NP I '[a]) -> (NP I '[a], ()) -> I a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NP I '[a], ()) -> NP I '[a]
forall a b. (a, b) -> a
fst

-- single-header non-empty response, return value is a tuple of the response and the header
instance AsHeaders '[h] a (a, h) where
  toHeaders :: (a, h) -> (NP I '[h], a)
toHeaders (a
t, h
cc) = (h -> I h
forall a. a -> I a
I h
cc I h -> NP I '[] -> NP I '[h]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP I '[]
forall {k} (a :: k -> *). NP a '[]
Nil, a
t)
  fromHeaders :: (NP I '[h], a) -> (a, h)
fromHeaders (I x
cc :* NP I xs
Nil, a
t) = (a
t, h
x
cc)

data DescHeader (name :: Symbol) (desc :: Symbol) (a :: Type)

-- | A wrapper to turn a response header into an optional one.
data OptHeader h

class ServantHeaders hs xs | hs -> xs where
  constructHeaders :: NP I xs -> [HTTP.Header]
  extractHeaders :: Seq HTTP.Header -> Maybe (NP I xs)

instance ServantHeaders '[] '[] where
  constructHeaders :: NP I '[] -> [Header]
constructHeaders NP I '[]
Nil = []
  extractHeaders :: Seq Header -> Maybe (NP I '[])
extractHeaders Seq Header
_ = NP I '[] -> Maybe (NP I '[])
forall a. a -> Maybe a
Just NP I '[]
forall {k} (a :: k -> *). NP a '[]
Nil

headerName :: forall name. (KnownSymbol name) => HTTP.HeaderName
headerName :: forall (name :: Symbol). KnownSymbol name => HeaderName
headerName =
  ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk
    (ByteString -> HeaderName)
-> (String -> ByteString) -> String -> HeaderName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8
    (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
    (String -> HeaderName) -> String -> HeaderName
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)

instance
  ( KnownSymbol name,
    ServantHeader h name x,
    FromHttpApiData x,
    ServantHeaders hs xs
  ) =>
  ServantHeaders (h ': hs) (x ': xs)
  where
  constructHeaders :: NP I (x : xs) -> [Header]
constructHeaders (I x
x :* NP I xs
xs) =
    forall (h :: a) (name :: Symbol) x.
ServantHeader h name x =>
x -> [Header]
forall {k} (h :: k) (name :: Symbol) x.
ServantHeader h name x =>
x -> [Header]
constructHeader @h x
x
      [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> forall (hs :: [a]) (xs :: [*]).
ServantHeaders hs xs =>
NP I xs -> [Header]
forall {k} (hs :: k) (xs :: [*]).
ServantHeaders hs xs =>
NP I xs -> [Header]
constructHeaders @hs NP I xs
xs

  -- FUTUREWORK: should we concatenate all the matching headers instead of just
  -- taking the first one?
  extractHeaders :: Seq Header -> Maybe (NP I (x : xs))
extractHeaders Seq Header
hs = do
    let name' :: HeaderName
name' = forall (name :: Symbol). KnownSymbol name => HeaderName
headerName @name
        (Seq Header
hs0, Seq Header
hs1) = (Header -> Bool) -> Seq Header -> (Seq Header, Seq Header)
forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
Seq.partition (\(HeaderName
h, ByteString
_) -> HeaderName
h HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
name') Seq Header
hs
    x
x <- case Seq Header
hs0 of
      Seq Header
Seq.Empty -> Maybe x
forall a. Maybe a
forall (f :: * -> *) a. Alternative f => f a
empty
      ((HeaderName
_, ByteString
h) :<| Seq Header
_) -> (Text -> Maybe x) -> (x -> Maybe x) -> Either Text x -> Maybe x
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe x -> Text -> Maybe x
forall a b. a -> b -> a
const Maybe x
forall a. Maybe a
forall (f :: * -> *) a. Alternative f => f a
empty) x -> Maybe x
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Either Text x
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader ByteString
h)
    NP I xs
xs <- forall (hs :: [a]) (xs :: [*]).
ServantHeaders hs xs =>
Seq Header -> Maybe (NP I xs)
forall {k} (hs :: k) (xs :: [*]).
ServantHeaders hs xs =>
Seq Header -> Maybe (NP I xs)
extractHeaders @hs Seq Header
hs1
    pure (x -> I x
forall a. a -> I a
I x
x I x -> NP I xs -> NP I (x : xs)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP I xs
xs)

class ServantHeader h (name :: Symbol) x | h -> name x where
  constructHeader :: x -> [HTTP.Header]

instance
  (KnownSymbol name, ToHttpApiData x) =>
  ServantHeader (Header' mods name x) name x
  where
  constructHeader :: x -> [Header]
constructHeader x
x = [(forall (name :: Symbol). KnownSymbol name => HeaderName
headerName @name, x -> ByteString
forall a. ToHttpApiData a => a -> ByteString
toHeader x
x)]

instance
  (KnownSymbol name, ToHttpApiData x) =>
  ServantHeader (DescHeader name desc x) name x
  where
  constructHeader :: x -> [Header]
constructHeader x
x = [(forall (name :: Symbol). KnownSymbol name => HeaderName
headerName @name, x -> ByteString
forall a. ToHttpApiData a => a -> ByteString
toHeader x
x)]

instance (ServantHeader h name x) => ServantHeader (OptHeader h) name (Maybe x) where
  constructHeader :: Maybe x -> [Header]
constructHeader = (x -> [Header]) -> Maybe x -> [Header]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (h :: k) (name :: Symbol) x.
ServantHeader h name x =>
x -> [Header]
forall {k} (h :: k) (name :: Symbol) x.
ServantHeader h name x =>
x -> [Header]
constructHeader @h)

instance
  (KnownSymbol name, KnownSymbol desc, S.ToParamSchema a) =>
  ToResponseHeader (DescHeader name desc a)
  where
  toResponseHeader :: Proxy (DescHeader name desc a) -> (Text, Header)
toResponseHeader Proxy (DescHeader name desc a)
_ = (Text
name', Maybe Text
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Value
-> InsOrdHashMap Text (Referenced Example)
-> Maybe (Referenced Schema)
-> Header
S.Header (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
desc) Maybe Bool
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe Value
forall a. Maybe a
Nothing InsOrdHashMap Text (Referenced Example)
forall a. Monoid a => a
mempty Maybe (Referenced Schema)
sch)
    where
      name' :: Text
name' = String -> Text
Text.pack (Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name))
      desc :: Text
desc = String -> Text
Text.pack (Proxy desc -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @desc))
      sch :: Maybe (Referenced Schema)
sch = Referenced Schema -> Maybe (Referenced Schema)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Referenced Schema -> Maybe (Referenced Schema))
-> Referenced Schema -> Maybe (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$ Proxy a -> Schema
forall a. ToParamSchema a => Proxy a -> Schema
S.toParamSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)

instance (ToResponseHeader h) => ToResponseHeader (OptHeader h) where
  toResponseHeader :: Proxy (OptHeader h) -> (Text, Header)
toResponseHeader Proxy (OptHeader h)
_ = Proxy h -> (Text, Header)
forall {k} (h :: k).
ToResponseHeader h =>
Proxy h -> (Text, Header)
toResponseHeader (forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @h)

type instance ResponseType (WithHeaders hs a r) = a

instance
  ( AsHeaders xs (ResponseType r) a,
    ServantHeaders hs xs,
    IsResponse cs r
  ) =>
  IsResponse cs (WithHeaders hs a r)
  where
  type ResponseStatus (WithHeaders hs a r) = ResponseStatus r
  type ResponseBody (WithHeaders hs a r) = ResponseBody r

  responseRender :: AcceptHeader
-> ResponseType (WithHeaders hs a r)
-> Maybe (ResponseF (ResponseBody (WithHeaders hs a r)))
responseRender AcceptHeader
acc ResponseType (WithHeaders hs a r)
x = ResponseF (ResponseBody r) -> ResponseF (ResponseBody r)
addHeaders (ResponseF (ResponseBody r) -> ResponseF (ResponseBody r))
-> Maybe (ResponseF (ResponseBody r))
-> Maybe (ResponseF (ResponseBody r))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 @r AcceptHeader
acc ResponseType r
y
    where
      (NP I xs
hs, ResponseType r
y) = forall (xs :: [*]) a b. AsHeaders xs a b => b -> (NP I xs, a)
toHeaders @xs a
ResponseType (WithHeaders hs a r)
x
      addHeaders :: ResponseF (ResponseBody r) -> ResponseF (ResponseBody r)
addHeaders ResponseF (ResponseBody r)
r =
        ResponseF (ResponseBody r)
r
          { responseHeaders = responseHeaders r <> Seq.fromList (constructHeaders @hs hs)
          }

  responseUnrender :: MediaType
-> ResponseF (ResponseBody (WithHeaders hs a r))
-> UnrenderResult (ResponseType (WithHeaders hs a r))
responseUnrender MediaType
c ResponseF (ResponseBody (WithHeaders hs a r))
output = do
    ResponseType r
x <- 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 @r MediaType
c ResponseF (ResponseBody r)
ResponseF (ResponseBody (WithHeaders hs a r))
output
    case forall (hs :: [*]) (xs :: [*]).
ServantHeaders hs xs =>
Seq Header -> Maybe (NP I xs)
forall {k} (hs :: k) (xs :: [*]).
ServantHeaders hs xs =>
Seq Header -> Maybe (NP I xs)
extractHeaders @hs (ResponseF (ResponseBody r) -> Seq Header
forall a. ResponseF a -> Seq Header
responseHeaders ResponseF (ResponseBody r)
ResponseF (ResponseBody (WithHeaders hs a r))
output) of
      Maybe (NP I xs)
Nothing -> String -> UnrenderResult a
forall a. String -> UnrenderResult a
UnrenderError String
"Failed to parse headers"
      Just NP I xs
hs -> a -> UnrenderResult a
forall a. a -> UnrenderResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> UnrenderResult a) -> a -> UnrenderResult a
forall a b. (a -> b) -> a -> b
$ forall (xs :: [*]) a b. AsHeaders xs a b => (NP I xs, a) -> b
fromHeaders @xs (NP I xs
hs, ResponseType r
x)

instance
  (AllToResponseHeader hs, IsSwaggerResponse r) =>
  IsSwaggerResponse (WithHeaders hs a r)
  where
  responseSwagger :: Declare Response
responseSwagger =
    (Response -> Response) -> Declare Response -> Declare Response
forall a b.
(a -> b)
-> DeclareT (Definitions Schema) Identity a
-> DeclareT (Definitions Schema) Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      ((InsOrdHashMap Text (Referenced Header)
 -> Identity (InsOrdHashMap Text (Referenced Header)))
-> Response -> Identity Response
forall s a. HasHeaders s a => Lens' s a
Lens' Response (InsOrdHashMap Text (Referenced Header))
S.headers ((InsOrdHashMap Text (Referenced Header)
  -> Identity (InsOrdHashMap Text (Referenced Header)))
 -> Response -> Identity Response)
-> InsOrdHashMap Text (Referenced Header) -> Response -> Response
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Header -> Referenced Header)
-> InsOrdHashMap Text Header
-> InsOrdHashMap Text (Referenced Header)
forall a b.
(a -> b) -> InsOrdHashMap Text a -> InsOrdHashMap Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Header -> Referenced Header
forall a. a -> Referenced a
S.Inline (Proxy hs -> InsOrdHashMap Text Header
forall {k} (hs :: k).
AllToResponseHeader hs =>
Proxy hs -> InsOrdHashMap Text Header
toAllResponseHeaders (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @hs)))
      (forall a. IsSwaggerResponse a => Declare Response
forall {k} (a :: k). IsSwaggerResponse a => Declare Response
responseSwagger @r)

class IsSwaggerResponseList as where
  responseListSwagger :: Declare (InsOrdHashMap S.HttpStatusCode S.Response)

type family ResponseTypes (as :: [Type]) where
  ResponseTypes '[] = '[]
  ResponseTypes (a ': as) = ResponseType a ': ResponseTypes as

class IsResponseList cs as where
  responseListRender :: AcceptHeader -> Union (ResponseTypes as) -> Maybe SomeResponse
  responseListUnrender :: M.MediaType -> SomeResponse -> UnrenderResult (Union (ResponseTypes as))

  responseListStatuses :: [Status]

instance IsResponseList cs '[] where
  responseListRender :: AcceptHeader -> Union (ResponseTypes '[]) -> Maybe SomeResponse
responseListRender AcceptHeader
_ Union (ResponseTypes '[])
x = case Union (ResponseTypes '[])
x of {}
  responseListUnrender :: MediaType
-> SomeResponse -> UnrenderResult (Union (ResponseTypes '[]))
responseListUnrender MediaType
_ SomeResponse
_ = UnrenderResult (Union '[])
UnrenderResult (Union (ResponseTypes '[]))
forall a. UnrenderResult a
forall (f :: * -> *) a. Alternative f => f a
empty
  responseListStatuses :: [Status]
responseListStatuses = []

instance IsSwaggerResponseList '[] where
  responseListSwagger :: Declare (InsOrdHashMap Int Response)
responseListSwagger = InsOrdHashMap Int Response -> Declare (InsOrdHashMap Int Response)
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InsOrdHashMap Int Response
forall a. Monoid a => a
mempty

instance
  ( IsResponse cs a,
    IsResponseList cs as,
    KnownStatus (ResponseStatus a)
  ) =>
  IsResponseList cs (a ': as)
  where
  responseListRender :: AcceptHeader
-> Union (ResponseTypes (a : as)) -> Maybe SomeResponse
responseListRender AcceptHeader
acc (Z (I x
x)) = (ResponseF (ResponseBody a) -> SomeResponse)
-> Maybe (ResponseF (ResponseBody a)) -> Maybe SomeResponse
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ResponseF (ResponseBody a) -> SomeResponse
forall a. IsWaiBody a => ResponseF a -> SomeResponse
SomeResponse (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 @a AcceptHeader
acc x
ResponseType a
x)
  responseListRender AcceptHeader
acc (S NS I xs
x) = forall (cs :: k) (as :: [*]).
IsResponseList cs as =>
AcceptHeader -> Union (ResponseTypes as) -> Maybe SomeResponse
forall {k} (cs :: k) (as :: [*]).
IsResponseList cs as =>
AcceptHeader -> Union (ResponseTypes as) -> Maybe SomeResponse
responseListRender @cs @as AcceptHeader
acc NS I xs
Union (ResponseTypes as)
x

  responseListUnrender :: MediaType
-> SomeResponse -> UnrenderResult (Union (ResponseTypes (a : as)))
responseListUnrender MediaType
c SomeResponse
output =
    I (ResponseType a) -> NS I (ResponseType a : ResponseTypes as)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (I (ResponseType a) -> NS I (ResponseType a : ResponseTypes as))
-> (ResponseType a -> I (ResponseType a))
-> ResponseType a
-> NS I (ResponseType a : ResponseTypes as)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseType a -> I (ResponseType a)
forall a. a -> I a
I (ResponseType a -> NS I (ResponseType a : ResponseTypes as))
-> UnrenderResult (ResponseType a)
-> UnrenderResult (NS I (ResponseType a : ResponseTypes as))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 @a MediaType
c (ResponseF (ResponseBody a) -> UnrenderResult (ResponseType a))
-> UnrenderResult (ResponseF (ResponseBody a))
-> UnrenderResult (ResponseType a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SomeResponse -> UnrenderResult (ResponseF (ResponseBody a))
forall (m :: * -> *) a.
(Alternative m, Typeable a) =>
SomeResponse -> m (ResponseF a)
fromSomeResponse SomeResponse
output)
      UnrenderResult (NS I (ResponseType a : ResponseTypes as))
-> UnrenderResult (NS I (ResponseType a : ResponseTypes as))
-> UnrenderResult (NS I (ResponseType a : ResponseTypes as))
forall a. UnrenderResult a -> UnrenderResult a -> UnrenderResult a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Union (ResponseTypes as)
-> NS I (ResponseType a : ResponseTypes as)
forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (Union (ResponseTypes as)
 -> NS I (ResponseType a : ResponseTypes as))
-> UnrenderResult (Union (ResponseTypes as))
-> UnrenderResult (NS I (ResponseType a : ResponseTypes as))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (cs :: k) (as :: [*]).
IsResponseList cs as =>
MediaType
-> SomeResponse -> UnrenderResult (Union (ResponseTypes as))
forall {k} (cs :: k) (as :: [*]).
IsResponseList cs as =>
MediaType
-> SomeResponse -> UnrenderResult (Union (ResponseTypes as))
responseListUnrender @cs @as MediaType
c SomeResponse
output

  responseListStatuses :: [Status]
responseListStatuses = Proxy (ResponseStatus a) -> Status
forall (n :: Nat) (proxy :: Nat -> *).
KnownStatus n =>
proxy n -> Status
forall (proxy :: Nat -> *). proxy (ResponseStatus a) -> Status
statusVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ResponseStatus a)) Status -> [Status] -> [Status]
forall a. a -> [a] -> [a]
: forall (cs :: k) (as :: [*]). IsResponseList cs as => [Status]
forall {k} (cs :: k) (as :: [*]). IsResponseList cs as => [Status]
responseListStatuses @cs @as

instance
  ( IsSwaggerResponse a,
    KnownNat (ResponseStatus a),
    IsSwaggerResponseList as
  ) =>
  IsSwaggerResponseList (a ': as)
  where
  responseListSwagger :: Declare (InsOrdHashMap Int Response)
responseListSwagger =
    (Response -> Response -> Response)
-> Int
-> Response
-> InsOrdHashMap Int Response
-> InsOrdHashMap Int Response
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> InsOrdHashMap k v -> InsOrdHashMap k v
InsOrdHashMap.insertWith
      Response -> Response -> Response
combineResponseSwagger
      (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy (ResponseStatus a) -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ResponseStatus a))))
      (Response
 -> InsOrdHashMap Int Response -> InsOrdHashMap Int Response)
-> Declare Response
-> DeclareT
     (Definitions Schema)
     Identity
     (InsOrdHashMap Int Response -> InsOrdHashMap Int Response)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IsSwaggerResponse a => Declare Response
forall {k} (a :: k). IsSwaggerResponse a => Declare Response
responseSwagger @a
      DeclareT
  (Definitions Schema)
  Identity
  (InsOrdHashMap Int Response -> InsOrdHashMap Int Response)
-> Declare (InsOrdHashMap Int Response)
-> Declare (InsOrdHashMap Int Response)
forall a b.
DeclareT (Definitions Schema) Identity (a -> b)
-> DeclareT (Definitions Schema) Identity a
-> DeclareT (Definitions Schema) Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (as :: [*]).
IsSwaggerResponseList as =>
Declare (InsOrdHashMap Int Response)
forall {k} (as :: k).
IsSwaggerResponseList as =>
Declare (InsOrdHashMap Int Response)
responseListSwagger @as

combineResponseSwagger :: S.Response -> S.Response -> S.Response
combineResponseSwagger :: Response -> Response -> Response
combineResponseSwagger Response
r1 Response
r2 =
  Response
r1
    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 a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ (Text
"\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Response
r2 Response -> Getting Text Response Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Response Text
forall s a. HasDescription s a => Lens' s a
Lens' Response Text
S.description)
    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
    -> InsOrdHashMap MediaType MediaTypeObject)
-> Response
-> Response
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (InsOrdHashMap MediaType MediaTypeObject
 -> InsOrdHashMap MediaType MediaTypeObject
 -> InsOrdHashMap MediaType MediaTypeObject)
-> InsOrdHashMap MediaType MediaTypeObject
-> InsOrdHashMap MediaType MediaTypeObject
-> InsOrdHashMap MediaType MediaTypeObject
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((MediaTypeObject -> MediaTypeObject -> MediaTypeObject)
-> InsOrdHashMap MediaType MediaTypeObject
-> InsOrdHashMap MediaType MediaTypeObject
-> InsOrdHashMap MediaType MediaTypeObject
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v)
-> InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v
unionWith MediaTypeObject -> MediaTypeObject -> MediaTypeObject
combineMediaTypeObject) (Response
r2 Response
-> Getting
     (InsOrdHashMap MediaType MediaTypeObject)
     Response
     (InsOrdHashMap MediaType MediaTypeObject)
-> InsOrdHashMap MediaType MediaTypeObject
forall s a. s -> Getting a s a -> a
^. Getting
  (InsOrdHashMap MediaType MediaTypeObject)
  Response
  (InsOrdHashMap MediaType MediaTypeObject)
forall s a. HasContent s a => Lens' s a
Lens' Response (InsOrdHashMap MediaType MediaTypeObject)
S.content)

combineMediaTypeObject :: S.MediaTypeObject -> S.MediaTypeObject -> S.MediaTypeObject
combineMediaTypeObject :: MediaTypeObject -> MediaTypeObject -> MediaTypeObject
combineMediaTypeObject MediaTypeObject
m1 MediaTypeObject
m2 =
  MediaTypeObject
m1 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)
-> Maybe (Referenced Schema) -> MediaTypeObject -> MediaTypeObject
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe (Referenced Schema)
-> Maybe (Referenced Schema) -> Maybe (Referenced Schema)
merge (MediaTypeObject
m1 MediaTypeObject
-> Getting
     (Maybe (Referenced Schema))
     MediaTypeObject
     (Maybe (Referenced Schema))
-> Maybe (Referenced Schema)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (Referenced Schema))
  MediaTypeObject
  (Maybe (Referenced Schema))
forall s a. HasSchema s a => Lens' s a
Lens' MediaTypeObject (Maybe (Referenced Schema))
S.schema) (MediaTypeObject
m2 MediaTypeObject
-> Getting
     (Maybe (Referenced Schema))
     MediaTypeObject
     (Maybe (Referenced Schema))
-> Maybe (Referenced Schema)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (Referenced Schema))
  MediaTypeObject
  (Maybe (Referenced Schema))
forall s a. HasSchema s a => Lens' s a
Lens' MediaTypeObject (Maybe (Referenced Schema))
S.schema)
  where
    merge :: Maybe (Referenced Schema)
-> Maybe (Referenced Schema) -> Maybe (Referenced Schema)
merge Maybe (Referenced Schema)
Nothing Maybe (Referenced Schema)
a = Maybe (Referenced Schema)
a
    merge Maybe (Referenced Schema)
a Maybe (Referenced Schema)
Nothing = Maybe (Referenced Schema)
a
    merge (Just (Inline Schema
a)) (Just (Inline Schema
b)) = Referenced Schema -> Maybe (Referenced Schema)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Referenced Schema -> Maybe (Referenced Schema))
-> Referenced Schema -> Maybe (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$ Schema -> Schema -> Schema
combineSwaggerSchema Schema
a Schema
b
    merge a :: Maybe (Referenced Schema)
a@(Just (Ref Reference
_)) Maybe (Referenced Schema)
_ = Maybe (Referenced Schema)
a
    merge Maybe (Referenced Schema)
_ a :: Maybe (Referenced Schema)
a@(Just (Ref Reference
_)) = Maybe (Referenced Schema)
a

combineSwaggerSchema :: S.Schema -> S.Schema -> S.Schema
combineSwaggerSchema :: Schema -> Schema -> Schema
combineSwaggerSchema Schema
s1 Schema
s2
  -- if they are both errors, merge label enums
  | Getting
  Any Schema (IxValue (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Bool
forall s a. Getting Any s a -> s -> Bool
notNullOf ((InsOrdHashMap Text (Referenced Schema)
 -> Const Any (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Const Any Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
S.properties ((InsOrdHashMap Text (Referenced Schema)
  -> Const Any (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Const Any Schema)
-> ((IxValue (InsOrdHashMap Text (Referenced Schema))
     -> Const Any (IxValue (InsOrdHashMap Text (Referenced Schema))))
    -> InsOrdHashMap Text (Referenced Schema)
    -> Const Any (InsOrdHashMap Text (Referenced Schema)))
-> Getting
     Any Schema (IxValue (InsOrdHashMap Text (Referenced Schema)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap Text (Referenced Schema))
-> Traversal'
     (InsOrdHashMap Text (Referenced Schema))
     (IxValue (InsOrdHashMap Text (Referenced Schema)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (InsOrdHashMap Text (Referenced Schema))
"code") Schema
s1
      Bool -> Bool -> Bool
&& Getting
  Any Schema (IxValue (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Bool
forall s a. Getting Any s a -> s -> Bool
notNullOf ((InsOrdHashMap Text (Referenced Schema)
 -> Const Any (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Const Any Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
S.properties ((InsOrdHashMap Text (Referenced Schema)
  -> Const Any (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Const Any Schema)
-> ((IxValue (InsOrdHashMap Text (Referenced Schema))
     -> Const Any (IxValue (InsOrdHashMap Text (Referenced Schema))))
    -> InsOrdHashMap Text (Referenced Schema)
    -> Const Any (InsOrdHashMap Text (Referenced Schema)))
-> Getting
     Any Schema (IxValue (InsOrdHashMap Text (Referenced Schema)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap Text (Referenced Schema))
-> Traversal'
     (InsOrdHashMap Text (Referenced Schema))
     (IxValue (InsOrdHashMap Text (Referenced Schema)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (InsOrdHashMap Text (Referenced Schema))
"code") Schema
s2 =
      Schema
s1
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
S.properties ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> (([Value] -> Identity [Value])
    -> InsOrdHashMap Text (Referenced Schema)
    -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> ([Value] -> Identity [Value])
-> Schema
-> Identity Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap Text (Referenced Schema))
-> Traversal'
     (InsOrdHashMap Text (Referenced Schema))
     (IxValue (InsOrdHashMap Text (Referenced Schema)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (InsOrdHashMap Text (Referenced Schema))
"label" ((Referenced Schema -> Identity (Referenced Schema))
 -> InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> (([Value] -> Identity [Value])
    -> Referenced Schema -> Identity (Referenced Schema))
-> ([Value] -> Identity [Value])
-> InsOrdHashMap Text (Referenced Schema)
-> Identity (InsOrdHashMap Text (Referenced Schema))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Schema -> Identity Schema)
-> Referenced Schema -> Identity (Referenced Schema)
forall a1 a2 (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a1 (f a2) -> p (Referenced a1) (f (Referenced a2))
S._Inline ((Schema -> Identity Schema)
 -> Referenced Schema -> Identity (Referenced Schema))
-> (([Value] -> Identity [Value]) -> Schema -> Identity Schema)
-> ([Value] -> Identity [Value])
-> Referenced Schema
-> Identity (Referenced Schema)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema
forall s a. HasEnum s a => Lens' s a
Lens' Schema (Maybe [Value])
S.enum_ ((Maybe [Value] -> Identity (Maybe [Value]))
 -> Schema -> Identity Schema)
-> (([Value] -> Identity [Value])
    -> Maybe [Value] -> Identity (Maybe [Value]))
-> ([Value] -> Identity [Value])
-> Schema
-> Identity Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Value] -> Identity [Value])
-> Maybe [Value] -> Identity (Maybe [Value])
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just
          (([Value] -> Identity [Value]) -> Schema -> Identity Schema)
-> [Value] -> Schema -> Schema
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ (Schema
s2 Schema -> Getting [Value] Schema [Value] -> [Value]
forall s a. s -> Getting a s a -> a
^. (InsOrdHashMap Text (Referenced Schema)
 -> Const [Value] (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Const [Value] Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
S.properties ((InsOrdHashMap Text (Referenced Schema)
  -> Const [Value] (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Const [Value] Schema)
-> (([Value] -> Const [Value] [Value])
    -> InsOrdHashMap Text (Referenced Schema)
    -> Const [Value] (InsOrdHashMap Text (Referenced Schema)))
-> Getting [Value] Schema [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap Text (Referenced Schema))
-> Traversal'
     (InsOrdHashMap Text (Referenced Schema))
     (IxValue (InsOrdHashMap Text (Referenced Schema)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (InsOrdHashMap Text (Referenced Schema))
"label" ((Referenced Schema -> Const [Value] (Referenced Schema))
 -> InsOrdHashMap Text (Referenced Schema)
 -> Const [Value] (InsOrdHashMap Text (Referenced Schema)))
-> (([Value] -> Const [Value] [Value])
    -> Referenced Schema -> Const [Value] (Referenced Schema))
-> ([Value] -> Const [Value] [Value])
-> InsOrdHashMap Text (Referenced Schema)
-> Const [Value] (InsOrdHashMap Text (Referenced Schema))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Schema -> Const [Value] Schema)
-> Referenced Schema -> Const [Value] (Referenced Schema)
forall a1 a2 (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a1 (f a2) -> p (Referenced a1) (f (Referenced a2))
S._Inline ((Schema -> Const [Value] Schema)
 -> Referenced Schema -> Const [Value] (Referenced Schema))
-> Getting [Value] Schema [Value]
-> ([Value] -> Const [Value] [Value])
-> Referenced Schema
-> Const [Value] (Referenced Schema)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe [Value] -> Const [Value] (Maybe [Value]))
-> Schema -> Const [Value] Schema
forall s a. HasEnum s a => Lens' s a
Lens' Schema (Maybe [Value])
S.enum_ ((Maybe [Value] -> Const [Value] (Maybe [Value]))
 -> Schema -> Const [Value] Schema)
-> (([Value] -> Const [Value] [Value])
    -> Maybe [Value] -> Const [Value] (Maybe [Value]))
-> Getting [Value] Schema [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Value] -> Const [Value] [Value])
-> Maybe [Value] -> Const [Value] (Maybe [Value])
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just)
  | Bool
otherwise = Schema
s1

-- | This type can be used in Servant to produce an endpoint which can return
-- multiple values with various content types and status codes. It is similar to
-- 'UVerb' and behaves similarly, but it has some important differences:
--
--  * Descriptions and statuses can be attached to individual responses without
--    using wrapper types and without affecting the handler return type.
--  * The return type of the handler can be decoupled from the types of the
--    individual responses. One can use a 'Union' type just like for 'UVerb',
--    but 'MultiVerb' also supports using an arbitrary type with an 'AsUnion'
--    instance.
--  * Headers can be attached to individual responses, also without affecting
--    the handler return type.
data MultiVerb (method :: StdMethod) cs (as :: [Type]) (r :: Type)

-- | A 'MultiVerb' endpoint with a single response.
type MultiVerb1 m cs a = MultiVerb m cs '[a] (ResponseType a)

-- | This class is used to convert a handler return type to a union type
-- including all possible responses of a 'MultiVerb' endpoint.
--
-- Any glue code necessary to convert application types to and from the
-- canonical 'Union' type corresponding to a 'MultiVerb' endpoint should be
-- packaged into an 'AsUnion' instance.
class AsUnion (as :: [Type]) (r :: Type) where
  toUnion :: r -> Union (ResponseTypes as)
  fromUnion :: Union (ResponseTypes as) -> r

-- | Unions can be used directly as handler return types using this trivial
-- instance.
instance (rs ~ ResponseTypes as) => AsUnion as (Union rs) where
  toUnion :: Union rs -> Union (ResponseTypes as)
toUnion = Union rs -> Union rs
Union rs -> Union (ResponseTypes as)
forall a. a -> a
id
  fromUnion :: Union (ResponseTypes as) -> Union rs
fromUnion = Union rs -> Union rs
Union (ResponseTypes as) -> Union rs
forall a. a -> a
id

-- | A handler with a single response.
instance (ResponseType r ~ a) => AsUnion '[r] a where
  toUnion :: a -> Union (ResponseTypes '[r])
toUnion = I a -> NS I '[a]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (I a -> NS I '[a]) -> (a -> I a) -> a -> NS I '[a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> I a
forall a. a -> I a
I
  fromUnion :: Union (ResponseTypes '[r]) -> a
fromUnion = I a -> a
forall a. I a -> a
unI (I a -> a) -> (NS I '[a] -> I a) -> NS I '[a] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS I '[a] -> I a
forall {k} (f :: k -> *) (x :: k). NS f '[x] -> f x
unZ

class InjectAfter as bs where
  injectAfter :: Union bs -> Union (as .++ bs)

instance InjectAfter '[] bs where
  injectAfter :: Union bs -> Union ('[] .++ bs)
injectAfter = Union bs -> Union bs
Union bs -> Union ('[] .++ bs)
forall a. a -> a
id

instance (InjectAfter as bs) => InjectAfter (a ': as) bs where
  injectAfter :: Union bs -> Union ((a : as) .++ bs)
injectAfter = NS I (as .++ bs) -> NS I (a : (as .++ bs))
forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (NS I (as .++ bs) -> NS I (a : (as .++ bs)))
-> (Union bs -> NS I (as .++ bs))
-> Union bs
-> NS I (a : (as .++ bs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (as :: [*]) (bs :: [*]).
InjectAfter as bs =>
Union bs -> Union (as .++ bs)
injectAfter @as @bs

class InjectBefore as bs where
  injectBefore :: Union as -> Union (as .++ bs)

instance InjectBefore '[] bs where
  injectBefore :: Union '[] -> Union ('[] .++ bs)
injectBefore Union '[]
x = case Union '[]
x of {}

instance (InjectBefore as bs) => InjectBefore (a ': as) bs where
  injectBefore :: Union (a : as) -> Union ((a : as) .++ bs)
injectBefore (Z I x
x) = I x -> NS I (x : (as .++ bs))
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z I x
x
  injectBefore (S NS I xs
x) = NS I (as .++ bs) -> NS I (a : (as .++ bs))
forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (forall (as :: [*]) (bs :: [*]).
InjectBefore as bs =>
Union as -> Union (as .++ bs)
injectBefore @as @bs Union as
NS I xs
x)

eitherToUnion ::
  forall as bs a b.
  (InjectAfter as bs, InjectBefore as bs) =>
  (a -> Union as) ->
  (b -> Union bs) ->
  (Either a b -> Union (as .++ bs))
eitherToUnion :: forall (as :: [*]) (bs :: [*]) a b.
(InjectAfter as bs, InjectBefore as bs) =>
(a -> Union as)
-> (b -> Union bs) -> Either a b -> Union (as .++ bs)
eitherToUnion a -> Union as
f b -> Union bs
_ (Left a
a) = forall (as :: [*]) (bs :: [*]).
InjectBefore as bs =>
Union as -> Union (as .++ bs)
injectBefore @as @bs (a -> Union as
f a
a)
eitherToUnion a -> Union as
_ b -> Union bs
g (Right b
b) = forall (as :: [*]) (bs :: [*]).
InjectAfter as bs =>
Union bs -> Union (as .++ bs)
injectAfter @as @bs (b -> Union bs
g b
b)

class EitherFromUnion as bs where
  eitherFromUnion ::
    (Union as -> a) ->
    (Union bs -> b) ->
    (Union (as .++ bs) -> Either a b)

instance EitherFromUnion '[] bs where
  eitherFromUnion :: forall a b.
(Union '[] -> a)
-> (Union bs -> b) -> Union ('[] .++ bs) -> Either a b
eitherFromUnion Union '[] -> a
_ Union bs -> b
g = b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> (Union bs -> b) -> Union bs -> Either a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Union bs -> b
g

instance (EitherFromUnion as bs) => EitherFromUnion (a ': as) bs where
  eitherFromUnion :: forall a b.
(Union (a : as) -> a)
-> (Union bs -> b) -> Union ((a : as) .++ bs) -> Either a b
eitherFromUnion Union (a : as) -> a
f Union bs -> b
_ (Z I x
x) = a -> Either a b
forall a b. a -> Either a b
Left (Union (a : as) -> a
f (I a -> Union (a : as)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z I a
I x
x))
  eitherFromUnion Union (a : as) -> a
f Union bs -> b
g (S NS I xs
x) = forall (as :: [*]) (bs :: [*]) a b.
EitherFromUnion as bs =>
(Union as -> a)
-> (Union bs -> b) -> Union (as .++ bs) -> Either a b
eitherFromUnion @as @bs (Union (a : as) -> a
f (Union (a : as) -> a)
-> (Union as -> Union (a : as)) -> Union as -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Union as -> Union (a : as)
forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S) Union bs -> b
g NS I xs
Union (as .++ bs)
x

maybeToUnion ::
  forall as a.
  (InjectAfter as '[()], InjectBefore as '[()]) =>
  (a -> Union as) ->
  (Maybe a -> Union (as .++ '[()]))
maybeToUnion :: forall (as :: [*]) a.
(InjectAfter as '[()], InjectBefore as '[()]) =>
(a -> Union as) -> Maybe a -> Union (as .++ '[()])
maybeToUnion a -> Union as
f (Just a
a) = forall (as :: [*]) (bs :: [*]).
InjectBefore as bs =>
Union as -> Union (as .++ bs)
injectBefore @as @'[()] (a -> Union as
f a
a)
maybeToUnion a -> Union as
_ Maybe a
Nothing = forall (as :: [*]) (bs :: [*]).
InjectAfter as bs =>
Union bs -> Union (as .++ bs)
injectAfter @as @'[()] (I () -> Union '[()]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (() -> I ()
forall a. a -> I a
I ()))

maybeFromUnion ::
  forall as a.
  (EitherFromUnion as '[()]) =>
  (Union as -> a) ->
  (Union (as .++ '[()]) -> Maybe a)
maybeFromUnion :: forall (as :: [*]) a.
EitherFromUnion as '[()] =>
(Union as -> a) -> Union (as .++ '[()]) -> Maybe a
maybeFromUnion Union as -> a
f = Either a (NS I (() : Any)) -> Maybe a
forall a b. Either a b -> Maybe a
leftToMaybe (Either a (NS I (() : Any)) -> Maybe a)
-> (Union (as .++ '[()]) -> Either a (NS I (() : Any)))
-> Union (as .++ '[()])
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (as :: [*]) (bs :: [*]) a b.
EitherFromUnion as bs =>
(Union as -> a)
-> (Union bs -> b) -> Union (as .++ bs) -> Either a b
eitherFromUnion @as @'[()] Union as -> a
f (NS I (() : Any) -> Union '[()] -> NS I (() : Any)
forall a b. a -> b -> a
const (I () -> NS I (() : Any)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (() -> I ()
forall a. a -> I a
I ())))

-- | This class can be instantiated to get automatic derivation of 'AsUnion'
-- instances via 'GenericAsUnion'. The idea is that one has to make sure that for
-- each response @r@ in a 'MultiVerb' endpoint, there is an instance of
-- @AsConstructor xs r@ for some @xs@, and that the list @xss@ of all the
-- corresponding @xs@ is equal to 'GSOP.Code' of the handler type. Then one can
-- write:
-- @
--   type Responses = ...
--   data Result = ...
--     deriving stock (Generic)
--     deriving (AsUnion Responses) via (GenericAsUnion Responses Result)
--
--   instance GSOP.Generic Result
-- @
-- and get an 'AsUnion' instance for free.
--
-- There are a few predefined instances for constructors taking a single type
-- corresponding to a simple response, and for empty responses, but in more
-- general cases one either has to define an 'AsConstructor' instance by hand,
-- or derive it via 'GenericAsConstructor'.
class AsConstructor xs r where
  toConstructor :: ResponseType r -> NP I xs
  fromConstructor :: NP I xs -> ResponseType r

class AsConstructors xss rs where
  toSOP :: Union (ResponseTypes rs) -> SOP I xss
  fromSOP :: SOP I xss -> Union (ResponseTypes rs)

instance AsConstructors '[] '[] where
  toSOP :: Union (ResponseTypes '[]) -> SOP I '[]
toSOP Union (ResponseTypes '[])
x = case Union (ResponseTypes '[])
x of {}
  fromSOP :: SOP I '[] -> Union (ResponseTypes '[])
fromSOP SOP I '[]
x = case SOP I '[]
x of {}

instance AsConstructor '[a] (Respond code desc a) where
  toConstructor :: ResponseType (Respond code desc a) -> NP I '[a]
toConstructor ResponseType (Respond code desc a)
x = a -> I a
forall a. a -> I a
I a
ResponseType (Respond code desc a)
x I a -> NP I '[] -> NP I '[a]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP I '[]
forall {k} (a :: k -> *). NP a '[]
Nil
  fromConstructor :: NP I '[a] -> ResponseType (Respond code desc a)
fromConstructor = I a -> a
forall a. I a -> a
unI (I a -> a) -> (NP I '[a] -> I a) -> NP I '[a] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP I '[a] -> I a
forall {k} (f :: k -> *) (x :: k) (xs :: [k]). NP f (x : xs) -> f x
hd

instance AsConstructor '[a] (RespondAs (ct :: Type) code desc a) where
  toConstructor :: ResponseType (RespondAs ct code desc a) -> NP I '[a]
toConstructor ResponseType (RespondAs ct code desc a)
x = a -> I a
forall a. a -> I a
I a
ResponseType (RespondAs ct code desc a)
x I a -> NP I '[] -> NP I '[a]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP I '[]
forall {k} (a :: k -> *). NP a '[]
Nil
  fromConstructor :: NP I '[a] -> ResponseType (RespondAs ct code desc a)
fromConstructor = I a -> a
forall a. I a -> a
unI (I a -> a) -> (NP I '[a] -> I a) -> NP I '[a] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP I '[a] -> I a
forall {k} (f :: k -> *) (x :: k) (xs :: [k]). NP f (x : xs) -> f x
hd

instance AsConstructor '[] (RespondEmpty code desc) where
  toConstructor :: ResponseType (RespondEmpty code desc) -> NP I '[]
toConstructor ResponseType (RespondEmpty code desc)
_ = NP I '[]
forall {k} (a :: k -> *). NP a '[]
Nil
  fromConstructor :: NP I '[] -> ResponseType (RespondEmpty code desc)
fromConstructor NP I '[]
_ = ()

newtype GenericAsConstructor r = GenericAsConstructor r

type instance ResponseType (GenericAsConstructor r) = ResponseType r

instance
  (GSOP.Code (ResponseType r) ~ '[xs], GSOP.Generic (ResponseType r)) =>
  AsConstructor xs (GenericAsConstructor r)
  where
  toConstructor :: ResponseType (GenericAsConstructor r) -> NP I xs
toConstructor = NS (NP I) '[xs] -> NP I xs
forall {k} (f :: k -> *) (x :: k). NS f '[x] -> f x
unZ (NS (NP I) '[xs] -> NP I xs)
-> (ResponseType r -> NS (NP I) '[xs]) -> ResponseType r -> NP I xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SOP I '[xs] -> NS (NP I) '[xs]
forall {k} (f :: k -> *) (xss :: [[k]]). SOP f xss -> NS (NP f) xss
unSOP (SOP I '[xs] -> NS (NP I) '[xs])
-> (ResponseType r -> SOP I '[xs])
-> ResponseType r
-> NS (NP I) '[xs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseType r -> SOP I '[xs]
ResponseType r -> Rep (ResponseType r)
forall a. Generic a => a -> Rep a
GSOP.from
  fromConstructor :: NP I xs -> ResponseType (GenericAsConstructor r)
fromConstructor = SOP I '[xs] -> ResponseType r
Rep (ResponseType r) -> ResponseType r
forall a. Generic a => Rep a -> a
GSOP.to (SOP I '[xs] -> ResponseType r)
-> (NP I xs -> SOP I '[xs]) -> NP I xs -> ResponseType r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS (NP I) '[xs] -> SOP I '[xs]
forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP (NS (NP I) '[xs] -> SOP I '[xs])
-> (NP I xs -> NS (NP I) '[xs]) -> NP I xs -> SOP I '[xs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP I xs -> NS (NP I) '[xs]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z

instance
  (AsConstructor xs r, AsConstructors xss rs) =>
  AsConstructors (xs ': xss) (r ': rs)
  where
  toSOP :: Union (ResponseTypes (r : rs)) -> SOP I (xs : xss)
toSOP (Z (I x
x)) = NS (NP I) (xs : xss) -> SOP I (xs : xss)
forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP (NS (NP I) (xs : xss) -> SOP I (xs : xss))
-> (NP I xs -> NS (NP I) (xs : xss)) -> NP I xs -> SOP I (xs : xss)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP I xs -> NS (NP I) (xs : xss)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (NP I xs -> SOP I (xs : xss)) -> NP I xs -> SOP I (xs : xss)
forall a b. (a -> b) -> a -> b
$ forall (xs :: [*]) r.
AsConstructor xs r =>
ResponseType r -> NP I xs
toConstructor @xs @r x
ResponseType r
x
  toSOP (S NS I xs
x) = NS (NP I) (xs : xss) -> SOP I (xs : xss)
forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP (NS (NP I) (xs : xss) -> SOP I (xs : xss))
-> (SOP I xss -> NS (NP I) (xs : xss))
-> SOP I xss
-> SOP I (xs : xss)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS (NP I) xss -> NS (NP I) (xs : xss)
forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (NS (NP I) xss -> NS (NP I) (xs : xss))
-> (SOP I xss -> NS (NP I) xss)
-> SOP I xss
-> NS (NP I) (xs : xss)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SOP I xss -> NS (NP I) xss
forall {k} (f :: k -> *) (xss :: [[k]]). SOP f xss -> NS (NP f) xss
unSOP (SOP I xss -> SOP I (xs : xss)) -> SOP I xss -> SOP I (xs : xss)
forall a b. (a -> b) -> a -> b
$ forall (xss :: [[*]]) (rs :: [*]).
AsConstructors xss rs =>
Union (ResponseTypes rs) -> SOP I xss
toSOP @xss @rs NS I xs
Union (ResponseTypes rs)
x

  fromSOP :: SOP I (xs : xss) -> Union (ResponseTypes (r : rs))
fromSOP (SOP (Z NP I x
x)) = I (ResponseType r) -> NS I (ResponseType r : ResponseTypes rs)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (ResponseType r -> I (ResponseType r)
forall a. a -> I a
I (forall (xs :: [*]) r.
AsConstructor xs r =>
NP I xs -> ResponseType r
fromConstructor @xs @r NP I xs
NP I x
x))
  fromSOP (SOP (S NS (NP I) xs
x)) = Union (ResponseTypes rs)
-> NS I (ResponseType r : ResponseTypes rs)
forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (forall (xss :: [[*]]) (rs :: [*]).
AsConstructors xss rs =>
SOP I xss -> Union (ResponseTypes rs)
fromSOP @xss @rs (NS (NP I) xss -> SOP I xss
forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP NS (NP I) xss
NS (NP I) xs
x))

-- | This type is meant to be used with @deriving via@ in order to automatically
-- generate an 'AsUnion' instance using 'Generics.SOP'.
--
-- See 'AsConstructor' for more information and examples.
newtype GenericAsUnion rs a = GenericAsUnion a

instance
  (GSOP.Code a ~ xss, GSOP.Generic a, AsConstructors xss rs) =>
  AsUnion rs (GenericAsUnion rs a)
  where
  toUnion :: GenericAsUnion rs a -> Union (ResponseTypes rs)
toUnion (GenericAsUnion a
x) = forall (xss :: [[*]]) (rs :: [*]).
AsConstructors xss rs =>
SOP I xss -> Union (ResponseTypes rs)
fromSOP @xss @rs (a -> Rep a
forall a. Generic a => a -> Rep a
GSOP.from a
x)
  fromUnion :: Union (ResponseTypes rs) -> GenericAsUnion rs a
fromUnion = a -> GenericAsUnion rs a
forall {k} (rs :: k) a. a -> GenericAsUnion rs a
GenericAsUnion (a -> GenericAsUnion rs a)
-> (Union (ResponseTypes rs) -> a)
-> Union (ResponseTypes rs)
-> GenericAsUnion rs a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SOP I xss -> a
Rep a -> a
forall a. Generic a => Rep a -> a
GSOP.to (SOP I xss -> a)
-> (Union (ResponseTypes rs) -> SOP I xss)
-> Union (ResponseTypes rs)
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (xss :: [[*]]) (rs :: [*]).
AsConstructors xss rs =>
Union (ResponseTypes rs) -> SOP I xss
toSOP @xss @rs

-- | A handler for a pair of empty responses can be implemented simply by
-- returning a boolean value. The convention is that the "failure" case, normally
-- represented by 'False', corresponds to the /first/ response.
instance
  AsUnion
    '[ RespondEmpty s1 desc1,
       RespondEmpty s2 desc2
     ]
    Bool
  where
  toUnion :: Bool
-> Union
     (ResponseTypes '[RespondEmpty s1 desc1, RespondEmpty s2 desc2])
toUnion Bool
False = I () -> NS I '[(), ()]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (() -> I ()
forall a. a -> I a
I ())
  toUnion Bool
True = Union '[()] -> NS I '[(), ()]
forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (I () -> Union '[()]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (() -> I ()
forall a. a -> I a
I ()))

  fromUnion :: Union
  (ResponseTypes '[RespondEmpty s1 desc1, RespondEmpty s2 desc2])
-> Bool
fromUnion (Z (I ())) = Bool
False
  fromUnion (S (Z (I ()))) = Bool
True
  fromUnion (S (S NS I xs
x)) = case NS I xs
x of {}

-- | A handler for a pair of responses where the first is empty can be
-- implemented simply by returning a 'Maybe' value. The convention is that the
-- "failure" case, normally represented by 'Nothing', corresponds to the /first/
-- response.
instance
  {-# OVERLAPPABLE #-}
  (ResponseType r1 ~ (), ResponseType r2 ~ a) =>
  AsUnion '[r1, r2] (Maybe a)
  where
  toUnion :: Maybe a -> Union (ResponseTypes '[r1, r2])
toUnion Maybe a
Nothing = I () -> NS I '[(), a]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (() -> I ()
forall a. a -> I a
I ())
  toUnion (Just a
x) = NS I '[a] -> NS I '[(), 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 '[r1, r2]) -> Maybe a
fromUnion (Z (I ())) = 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 {}

instance
  (OpenApiMethod method, IsSwaggerResponseList as) =>
  S.HasOpenApi (MultiVerb method '() as r)
  where
  toOpenApi :: Proxy (MultiVerb method '() as r) -> OpenApi
toOpenApi Proxy (MultiVerb method '() as r)
_ =
    OpenApi
forall a. Monoid a => a
mempty
      OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& (Components -> Identity Components) -> OpenApi -> Identity OpenApi
forall s a. HasComponents s a => Lens' s a
Lens' OpenApi Components
S.components ((Components -> Identity Components)
 -> OpenApi -> Identity OpenApi)
-> ((Definitions Schema -> Identity (Definitions Schema))
    -> Components -> Identity Components)
-> (Definitions Schema -> Identity (Definitions Schema))
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Definitions Schema -> Identity (Definitions Schema))
-> Components -> Identity Components
forall s a. HasSchemas s a => Lens' s a
Lens' Components (Definitions Schema)
S.schemas ((Definitions Schema -> Identity (Definitions Schema))
 -> OpenApi -> Identity OpenApi)
-> Definitions Schema -> OpenApi -> OpenApi
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ Definitions Schema
defs
      OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap String PathItem
 -> Identity (InsOrdHashMap String PathItem))
-> OpenApi -> Identity OpenApi
forall s a. HasPaths s a => Lens' s a
Lens' OpenApi (InsOrdHashMap String PathItem)
S.paths
        ((InsOrdHashMap String PathItem
  -> Identity (InsOrdHashMap String PathItem))
 -> OpenApi -> Identity OpenApi)
-> ((Maybe (IxValue (InsOrdHashMap String PathItem))
     -> Identity (Maybe PathItem))
    -> InsOrdHashMap String PathItem
    -> Identity (InsOrdHashMap String PathItem))
-> (Maybe (IxValue (InsOrdHashMap String PathItem))
    -> Identity (Maybe PathItem))
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap String PathItem)
-> Lens'
     (InsOrdHashMap String PathItem)
     (Maybe (IxValue (InsOrdHashMap String PathItem)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (InsOrdHashMap String PathItem)
"/"
        ((Maybe (IxValue (InsOrdHashMap String PathItem))
  -> Identity (Maybe PathItem))
 -> OpenApi -> Identity OpenApi)
-> PathItem -> OpenApi -> OpenApi
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ( PathItem
forall a. Monoid a => a
mempty
               PathItem -> (PathItem -> PathItem) -> PathItem
forall a b. a -> (a -> b) -> b
& (Maybe Operation -> Identity (Maybe Operation))
-> PathItem -> Identity PathItem
method
                 ((Maybe Operation -> Identity (Maybe Operation))
 -> PathItem -> Identity PathItem)
-> Operation -> PathItem -> PathItem
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ( Operation
forall a. Monoid a => a
mempty
                        Operation -> (Operation -> Operation) -> Operation
forall a b. a -> (a -> b) -> b
& (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)
-> ((InsOrdHashMap Int (Referenced Response)
     -> Identity (InsOrdHashMap Int (Referenced Response)))
    -> Responses -> Identity Responses)
-> (InsOrdHashMap Int (Referenced Response)
    -> Identity (InsOrdHashMap Int (Referenced Response)))
-> Operation
-> Identity Operation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InsOrdHashMap Int (Referenced Response)
 -> Identity (InsOrdHashMap Int (Referenced Response)))
-> Responses -> Identity Responses
forall s a. HasResponses s a => Lens' s a
Lens' Responses (InsOrdHashMap Int (Referenced Response))
S.responses ((InsOrdHashMap Int (Referenced Response)
  -> Identity (InsOrdHashMap Int (Referenced Response)))
 -> Operation -> Identity Operation)
-> InsOrdHashMap Int (Referenced Response)
-> Operation
-> Operation
forall s t a b. ASetter s t a b -> b -> s -> t
.~ InsOrdHashMap Int (Referenced Response)
refResps
                    )
           )
    where
      method :: (Maybe Operation -> Identity (Maybe Operation))
-> PathItem -> Identity PathItem
method = Proxy method -> Lens' PathItem (Maybe Operation)
forall {k} (method :: k) (proxy :: k -> *).
OpenApiMethod method =>
proxy method -> Lens' PathItem (Maybe Operation)
forall (proxy :: StdMethod -> *).
proxy method -> Lens' PathItem (Maybe Operation)
S.openApiMethod (forall {k} (t :: k). Proxy t
forall (t :: StdMethod). Proxy t
Proxy @method)
      (Definitions Schema
defs, InsOrdHashMap Int Response
resps) = Declare (InsOrdHashMap Int Response)
-> Definitions Schema
-> (Definitions Schema, InsOrdHashMap Int Response)
forall d a. Declare d a -> d -> (d, a)
S.runDeclare (forall (as :: [*]).
IsSwaggerResponseList as =>
Declare (InsOrdHashMap Int Response)
forall {k} (as :: k).
IsSwaggerResponseList as =>
Declare (InsOrdHashMap Int Response)
responseListSwagger @as) Definitions Schema
forall a. Monoid a => a
mempty
      refResps :: InsOrdHashMap Int (Referenced Response)
refResps = Response -> Referenced Response
forall a. a -> Referenced a
S.Inline (Response -> Referenced Response)
-> InsOrdHashMap Int Response
-> InsOrdHashMap Int (Referenced Response)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InsOrdHashMap Int Response
resps

instance
  (OpenApiMethod method, IsSwaggerResponseList as, AllMime cs) =>
  S.HasOpenApi (MultiVerb method (cs :: [Type]) as r)
  where
  toOpenApi :: Proxy (MultiVerb method cs as r) -> OpenApi
toOpenApi Proxy (MultiVerb method cs as r)
_ =
    OpenApi
forall a. Monoid a => a
mempty
      OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& (Components -> Identity Components) -> OpenApi -> Identity OpenApi
forall s a. HasComponents s a => Lens' s a
Lens' OpenApi Components
S.components ((Components -> Identity Components)
 -> OpenApi -> Identity OpenApi)
-> ((Definitions Schema -> Identity (Definitions Schema))
    -> Components -> Identity Components)
-> (Definitions Schema -> Identity (Definitions Schema))
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Definitions Schema -> Identity (Definitions Schema))
-> Components -> Identity Components
forall s a. HasSchemas s a => Lens' s a
Lens' Components (Definitions Schema)
S.schemas ((Definitions Schema -> Identity (Definitions Schema))
 -> OpenApi -> Identity OpenApi)
-> Definitions Schema -> OpenApi -> OpenApi
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ Definitions Schema
defs
      OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap String PathItem
 -> Identity (InsOrdHashMap String PathItem))
-> OpenApi -> Identity OpenApi
forall s a. HasPaths s a => Lens' s a
Lens' OpenApi (InsOrdHashMap String PathItem)
S.paths
        ((InsOrdHashMap String PathItem
  -> Identity (InsOrdHashMap String PathItem))
 -> OpenApi -> Identity OpenApi)
-> ((Maybe (IxValue (InsOrdHashMap String PathItem))
     -> Identity (Maybe PathItem))
    -> InsOrdHashMap String PathItem
    -> Identity (InsOrdHashMap String PathItem))
-> (Maybe (IxValue (InsOrdHashMap String PathItem))
    -> Identity (Maybe PathItem))
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap String PathItem)
-> Lens'
     (InsOrdHashMap String PathItem)
     (Maybe (IxValue (InsOrdHashMap String PathItem)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (InsOrdHashMap String PathItem)
"/"
        ((Maybe (IxValue (InsOrdHashMap String PathItem))
  -> Identity (Maybe PathItem))
 -> OpenApi -> Identity OpenApi)
-> PathItem -> OpenApi -> OpenApi
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ( PathItem
forall a. Monoid a => a
mempty
               PathItem -> (PathItem -> PathItem) -> PathItem
forall a b. a -> (a -> b) -> b
& (Maybe Operation -> Identity (Maybe Operation))
-> PathItem -> Identity PathItem
method
                 ((Maybe Operation -> Identity (Maybe Operation))
 -> PathItem -> Identity PathItem)
-> Operation -> PathItem -> PathItem
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ( Operation
forall a. Monoid a => a
mempty
                        Operation -> (Operation -> Operation) -> Operation
forall a b. a -> (a -> b) -> b
& (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)
-> ((InsOrdHashMap Int (Referenced Response)
     -> Identity (InsOrdHashMap Int (Referenced Response)))
    -> Responses -> Identity Responses)
-> (InsOrdHashMap Int (Referenced Response)
    -> Identity (InsOrdHashMap Int (Referenced Response)))
-> Operation
-> Identity Operation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InsOrdHashMap Int (Referenced Response)
 -> Identity (InsOrdHashMap Int (Referenced Response)))
-> Responses -> Identity Responses
forall s a. HasResponses s a => Lens' s a
Lens' Responses (InsOrdHashMap Int (Referenced Response))
S.responses ((InsOrdHashMap Int (Referenced Response)
  -> Identity (InsOrdHashMap Int (Referenced Response)))
 -> Operation -> Identity Operation)
-> InsOrdHashMap Int (Referenced Response)
-> Operation
-> Operation
forall s t a b. ASetter s t a b -> b -> s -> t
.~ InsOrdHashMap Int (Referenced Response)
refResps
                    )
           )
    where
      method :: (Maybe Operation -> Identity (Maybe Operation))
-> PathItem -> Identity PathItem
method = Proxy method -> Lens' PathItem (Maybe Operation)
forall {k} (method :: k) (proxy :: k -> *).
OpenApiMethod method =>
proxy method -> Lens' PathItem (Maybe Operation)
forall (proxy :: StdMethod -> *).
proxy method -> Lens' PathItem (Maybe Operation)
S.openApiMethod (forall {k} (t :: k). Proxy t
forall (t :: StdMethod). Proxy t
Proxy @method)
      -- This has our content types.
      cs :: [MediaType]
cs = Proxy cs -> [MediaType]
forall (list :: [*]). AllMime list => Proxy list -> [MediaType]
allMime (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @cs)
      -- This has our schemas
      (Definitions Schema
defs, InsOrdHashMap Int Response
resps) = Declare (InsOrdHashMap Int Response)
-> Definitions Schema
-> (Definitions Schema, InsOrdHashMap Int Response)
forall d a. Declare d a -> d -> (d, a)
S.runDeclare (forall (as :: [*]).
IsSwaggerResponseList as =>
Declare (InsOrdHashMap Int Response)
forall {k} (as :: k).
IsSwaggerResponseList as =>
Declare (InsOrdHashMap Int Response)
responseListSwagger @as) Definitions Schema
forall a. Monoid a => a
mempty
      -- We need to zip them together, and stick it all back into the contentMap
      -- Since we have a single schema per type, and are only changing the content-types,
      -- we should be able to pick a schema out of the resps' map, and then use it for
      -- all of the values of cs
      addMime :: S.Response -> S.Response
      addMime :: Response -> Response
addMime Response
resp =
        Response
resp
          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
    -> InsOrdHashMap MediaType MediaTypeObject)
-> Response
-> Response
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~
            -- pick out an element from the map, if any exist.
            -- These will all have the same schemas, and we are reapplying the content types.
            (MediaTypeObject -> InsOrdHashMap MediaType MediaTypeObject)
-> Maybe MediaTypeObject -> InsOrdHashMap MediaType MediaTypeObject
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\MediaTypeObject
c -> [(MediaType, MediaTypeObject)]
-> InsOrdHashMap MediaType MediaTypeObject
forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
InsOrdHashMap.fromList ([(MediaType, MediaTypeObject)]
 -> InsOrdHashMap MediaType MediaTypeObject)
-> [(MediaType, MediaTypeObject)]
-> InsOrdHashMap MediaType MediaTypeObject
forall a b. (a -> b) -> a -> b
$ (,MediaTypeObject
c) (MediaType -> (MediaType, MediaTypeObject))
-> [MediaType] -> [(MediaType, MediaTypeObject)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MediaType]
cs)
              (Maybe MediaTypeObject -> InsOrdHashMap MediaType MediaTypeObject)
-> (InsOrdHashMap MediaType MediaTypeObject
    -> Maybe MediaTypeObject)
-> InsOrdHashMap MediaType MediaTypeObject
-> InsOrdHashMap MediaType MediaTypeObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MediaTypeObject] -> Maybe MediaTypeObject
forall a. [a] -> Maybe a
listToMaybe
              ([MediaTypeObject] -> Maybe MediaTypeObject)
-> (InsOrdHashMap MediaType MediaTypeObject -> [MediaTypeObject])
-> InsOrdHashMap MediaType MediaTypeObject
-> Maybe MediaTypeObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InsOrdHashMap MediaType MediaTypeObject -> [MediaTypeObject]
forall a. InsOrdHashMap MediaType a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
      refResps :: InsOrdHashMap Int (Referenced Response)
refResps = Response -> Referenced Response
forall a. a -> Referenced a
S.Inline (Response -> Referenced Response)
-> (Response -> Response) -> Response -> Referenced Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Response
addMime (Response -> Referenced Response)
-> InsOrdHashMap Int Response
-> InsOrdHashMap Int (Referenced Response)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InsOrdHashMap Int Response
resps

class (Typeable a) => IsWaiBody a where
  responseToWai :: ResponseF a -> Wai.Response

instance IsWaiBody LByteString where
  responseToWai :: Response -> Response
responseToWai Response
r =
    Status -> [Header] -> LByteString -> Response
Wai.responseLBS
      (Response -> Status
forall a. ResponseF a -> Status
responseStatusCode Response
r)
      (Seq Header -> [Header]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Response -> Seq Header
forall a. ResponseF a -> Seq Header
responseHeaders Response
r))
      (Response -> LByteString
forall a. ResponseF a -> a
responseBody Response
r)

instance IsWaiBody () where
  responseToWai :: ResponseF () -> Response
responseToWai ResponseF ()
r =
    Status -> [Header] -> LByteString -> Response
Wai.responseLBS
      (ResponseF () -> Status
forall a. ResponseF a -> Status
responseStatusCode ResponseF ()
r)
      (Seq Header -> [Header]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (ResponseF () -> Seq Header
forall a. ResponseF a -> Seq Header
responseHeaders ResponseF ()
r))
      LByteString
forall a. Monoid a => a
mempty

instance IsWaiBody (SourceIO ByteString) where
  responseToWai :: ResponseF (SourceIO ByteString) -> Response
responseToWai ResponseF (SourceIO ByteString)
r =
    Status -> [Header] -> StreamingBody -> Response
Wai.responseStream
      (ResponseF (SourceIO ByteString) -> Status
forall a. ResponseF a -> Status
responseStatusCode ResponseF (SourceIO ByteString)
r)
      (Seq Header -> [Header]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (ResponseF (SourceIO ByteString) -> Seq Header
forall a. ResponseF a -> Seq Header
responseHeaders ResponseF (SourceIO ByteString)
r))
      (StreamingBody -> Response) -> StreamingBody -> Response
forall a b. (a -> b) -> a -> b
$ \Builder -> IO ()
output IO ()
flush -> do
        (String -> IO ())
-> (ByteString -> IO ()) -> SourceIO ByteString -> IO ()
forall (m :: * -> *) a.
Monad m =>
(String -> m ()) -> (a -> m ()) -> SourceT m a -> m ()
foreach
          (IO () -> String -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
          (\ByteString
chunk -> Builder -> IO ()
output (ByteString -> Builder
byteString ByteString
chunk) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO ()
flush)
          (ResponseF (SourceIO ByteString) -> SourceIO ByteString
forall a. ResponseF a -> a
responseBody ResponseF (SourceIO ByteString)
r)

data SomeResponse = forall a. (IsWaiBody a) => SomeResponse (ResponseF a)

addContentType :: forall ct a. (Accept ct) => ResponseF a -> ResponseF a
addContentType :: forall {k} (ct :: k) a. Accept ct => ResponseF a -> ResponseF a
addContentType = MediaType -> ResponseF a -> ResponseF a
forall a. MediaType -> ResponseF a -> ResponseF a
addContentType' (Proxy ct -> MediaType
forall {k} (ctype :: k). Accept ctype => Proxy ctype -> MediaType
contentType (forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @ct))

addContentType' :: M.MediaType -> ResponseF a -> ResponseF a
addContentType' :: forall a. MediaType -> ResponseF a -> ResponseF a
addContentType' MediaType
c ResponseF a
r = ResponseF a
r {responseHeaders = (hContentType, M.renderHeader c) <| responseHeaders r}

setEmptyBody :: SomeResponse -> SomeResponse
setEmptyBody :: SomeResponse -> SomeResponse
setEmptyBody (SomeResponse ResponseF a
r) = Response -> SomeResponse
forall a. IsWaiBody a => ResponseF a -> SomeResponse
SomeResponse (ResponseF a -> Response
forall a. ResponseF a -> Response
go ResponseF a
r)
  where
    go :: ResponseF a -> ResponseF LByteString
    go :: forall a. ResponseF a -> Response
go Response {a
Seq Header
Status
HttpVersion
responseStatusCode :: forall a. ResponseF a -> Status
responseBody :: forall a. ResponseF a -> a
responseHeaders :: forall a. ResponseF a -> Seq Header
responseHttpVersion :: forall a. ResponseF a -> HttpVersion
responseStatusCode :: Status
responseHeaders :: Seq Header
responseHttpVersion :: HttpVersion
responseBody :: a
..} = Response {responseBody :: LByteString
responseBody = LByteString
forall a. Monoid a => a
mempty, Seq Header
Status
HttpVersion
responseStatusCode :: Status
responseHeaders :: Seq Header
responseHttpVersion :: HttpVersion
responseStatusCode :: Status
responseHeaders :: Seq Header
responseHttpVersion :: HttpVersion
..}

someResponseToWai :: SomeResponse -> Wai.Response
someResponseToWai :: SomeResponse -> Response
someResponseToWai (SomeResponse ResponseF a
r) = ResponseF a -> Response
forall a. IsWaiBody a => ResponseF a -> Response
responseToWai ResponseF a
r

fromSomeResponse :: (Alternative m, Typeable a) => SomeResponse -> m (ResponseF a)
fromSomeResponse :: forall (m :: * -> *) a.
(Alternative m, Typeable a) =>
SomeResponse -> m (ResponseF a)
fromSomeResponse (SomeResponse Response {a
Seq Header
Status
HttpVersion
responseStatusCode :: forall a. ResponseF a -> Status
responseBody :: forall a. ResponseF a -> a
responseHeaders :: forall a. ResponseF a -> Seq Header
responseHttpVersion :: forall a. ResponseF a -> HttpVersion
responseStatusCode :: Status
responseHeaders :: Seq Header
responseHttpVersion :: HttpVersion
responseBody :: a
..}) = do
  a
body <- m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m a) -> Maybe a -> m a
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
responseBody
  pure $
    Response
      { responseBody :: a
responseBody = a
body,
        Seq Header
Status
HttpVersion
responseStatusCode :: Status
responseHeaders :: Seq Header
responseHttpVersion :: HttpVersion
responseStatusCode :: Status
responseHeaders :: Seq Header
responseHttpVersion :: HttpVersion
..
      }

class HasAcceptCheck cs where
  acceptCheck' :: Proxy cs -> AcceptHeader -> DelayedIO ()

instance (AllMime cs) => HasAcceptCheck cs where
  acceptCheck' :: Proxy cs -> AcceptHeader -> DelayedIO ()
acceptCheck' = Proxy cs -> AcceptHeader -> DelayedIO ()
forall (cs :: [*]).
AllMime cs =>
Proxy cs -> AcceptHeader -> DelayedIO ()
acceptCheck

instance HasAcceptCheck '() where
  acceptCheck' :: Proxy '() -> AcceptHeader -> DelayedIO ()
acceptCheck' Proxy '()
_ AcceptHeader
_ = () -> DelayedIO ()
forall a. a -> DelayedIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance
  ( HasAcceptCheck cs,
    IsResponseList cs as,
    AsUnion as r,
    ReflectMethod method
  ) =>
  HasServer (MultiVerb method cs as r) ctx
  where
  type ServerT (MultiVerb method cs as r) m = m r

  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (MultiVerb method cs as r)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (MultiVerb method cs as r) m
-> ServerT (MultiVerb method cs as r) n
hoistServerWithContext Proxy (MultiVerb method cs as r)
_ Proxy ctx
_ forall x. m x -> n x
f = m r -> n r
ServerT (MultiVerb method cs as r) m
-> ServerT (MultiVerb method cs as r) n
forall x. m x -> n x
f

  route ::
    forall env.
    Proxy (MultiVerb method cs as r) ->
    Context ctx ->
    Delayed env (Handler r) ->
    Router env
  route :: forall env.
Proxy (MultiVerb method cs as r)
-> Context ctx -> Delayed env (Handler r) -> Router env
route Proxy (MultiVerb method cs as r)
_ Context ctx
_ Delayed env (Handler r)
action = (env -> RoutingApplication) -> Router' env RoutingApplication
forall env a. (env -> a) -> Router' env a
leafRouter ((env -> RoutingApplication) -> Router' env RoutingApplication)
-> (env -> RoutingApplication) -> Router' env RoutingApplication
forall a b. (a -> b) -> a -> b
$ \env
env Request
req RouteResult Response -> IO ResponseReceived
k -> do
    let acc :: AcceptHeader
acc = Request -> AcceptHeader
getAcceptHeader Request
req
        action' :: Delayed env (Handler r)
action' =
          Delayed env (Handler r)
action
            Delayed env (Handler r) -> DelayedIO () -> Delayed env (Handler r)
forall env a. Delayed env a -> DelayedIO () -> Delayed env a
`addMethodCheck` ByteString -> Request -> DelayedIO ()
methodCheck ByteString
method Request
req
            Delayed env (Handler r) -> DelayedIO () -> Delayed env (Handler r)
forall env a. Delayed env a -> DelayedIO () -> Delayed env a
`addAcceptCheck` Proxy cs -> AcceptHeader -> DelayedIO ()
forall {k} (cs :: k).
HasAcceptCheck cs =>
Proxy cs -> AcceptHeader -> DelayedIO ()
acceptCheck' (forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @cs) AcceptHeader
acc
    Delayed env (Handler r)
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> (r -> RouteResult Response)
-> IO ResponseReceived
forall env a r.
Delayed env (Handler a)
-> env
-> Request
-> (RouteResult Response -> IO r)
-> (a -> RouteResult Response)
-> IO r
runAction Delayed env (Handler r)
action' env
env Request
req RouteResult Response -> IO ResponseReceived
k ((r -> RouteResult Response) -> IO ResponseReceived)
-> (r -> RouteResult Response) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \r
output -> do
      let mresp :: Maybe SomeResponse
mresp = forall (cs :: k) (as :: [*]).
IsResponseList cs as =>
AcceptHeader -> Union (ResponseTypes as) -> Maybe SomeResponse
forall {k} (cs :: k) (as :: [*]).
IsResponseList cs as =>
AcceptHeader -> Union (ResponseTypes as) -> Maybe SomeResponse
responseListRender @cs @as AcceptHeader
acc (forall (as :: [*]) r. AsUnion as r => r -> Union (ResponseTypes as)
toUnion @as r
output)
      SomeResponse -> Response
someResponseToWai (SomeResponse -> Response)
-> RouteResult SomeResponse -> RouteResult Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe SomeResponse
mresp of
        Maybe SomeResponse
Nothing -> ServerError -> RouteResult SomeResponse
forall a. ServerError -> RouteResult a
FailFatal ServerError
err406
        Just SomeResponse
resp
          | ByteString -> Request -> Bool
allowedMethodHead ByteString
method Request
req -> SomeResponse -> RouteResult SomeResponse
forall a. a -> RouteResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeResponse -> SomeResponse
setEmptyBody SomeResponse
resp)
          | Bool
otherwise -> SomeResponse -> RouteResult SomeResponse
forall a. a -> RouteResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SomeResponse
resp
    where
      method :: ByteString
method = Proxy method -> ByteString
forall {k} (a :: k). ReflectMethod a => Proxy a -> ByteString
reflectMethod (forall {k} (t :: k). Proxy t
forall (t :: StdMethod). Proxy t
Proxy @method)

-- taken from Servant.Client.Core.HasClient
getResponseContentType :: (RunClient m) => Response -> m M.MediaType
getResponseContentType :: forall (m :: * -> *). RunClient m => Response -> m MediaType
getResponseContentType Response
response =
  case HeaderName -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Content-Type" (Seq Header -> [Header]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Response -> Seq Header
forall a. ResponseF a -> Seq Header
responseHeaders Response
response)) of
    Maybe ByteString
Nothing -> MediaType -> m MediaType
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MediaType -> m MediaType) -> MediaType -> m MediaType
forall a b. (a -> b) -> a -> b
$ ByteString
"application" ByteString -> ByteString -> MediaType
M.// ByteString
"octet-stream"
    Just ByteString
t -> case ByteString -> Maybe MediaType
forall a. Accept a => ByteString -> Maybe a
M.parseAccept ByteString
t of
      Maybe MediaType
Nothing -> ClientError -> m MediaType
forall a. ClientError -> m a
forall (m :: * -> *) a. RunClient m => ClientError -> m a
throwClientError (ClientError -> m MediaType) -> ClientError -> m MediaType
forall a b. (a -> b) -> a -> b
$ Response -> ClientError
InvalidContentTypeHeader Response
response
      Just MediaType
t' -> MediaType -> m MediaType
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MediaType
t'

-- FUTUREWORK: add tests for client support
instance
  ( IsResponseList cs as,
    AllMime cs,
    ReflectMethod method,
    AsUnion as r,
    RunClient m
  ) =>
  HasClient m (MultiVerb method cs as r)
  where
  type Client m (MultiVerb method cs as r) = m r

  clientWithRoute :: Proxy m
-> Proxy (MultiVerb method cs as r)
-> Request
-> Client m (MultiVerb method cs as r)
clientWithRoute Proxy m
_ Proxy (MultiVerb method cs as r)
_ Request
req = do
    Response
response <-
      Maybe [Status] -> Request -> m Response
forall (m :: * -> *).
RunClient m =>
Maybe [Status] -> Request -> m Response
runRequestAcceptStatus
        ([Status] -> Maybe [Status]
forall a. a -> Maybe a
Just (forall (cs :: [*]) (as :: [*]). IsResponseList cs as => [Status]
forall {k} (cs :: k) (as :: [*]). IsResponseList cs as => [Status]
responseListStatuses @cs @as))
        Request
req
          { requestMethod = method,
            requestAccept = Seq.fromList accept
          }

    MediaType
c <- Response -> m MediaType
forall (m :: * -> *). RunClient m => Response -> m MediaType
getResponseContentType Response
response
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((MediaType -> Bool) -> [MediaType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (MediaType -> MediaType -> Bool
forall a. Accept a => a -> a -> Bool
M.matches MediaType
c) [MediaType]
accept) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      ClientError -> m ()
forall a. ClientError -> m a
forall (m :: * -> *) a. RunClient m => ClientError -> m a
throwClientError (ClientError -> m ()) -> ClientError -> m ()
forall a b. (a -> b) -> a -> b
$ MediaType -> Response -> ClientError
UnsupportedContentType MediaType
c Response
response

    -- FUTUREWORK: support streaming
    let sresp :: SomeResponse
sresp =
          if LByteString -> Bool
LBS.null (Response -> LByteString
forall a. ResponseF a -> a
responseBody Response
response)
            then ResponseF () -> SomeResponse
forall a. IsWaiBody a => ResponseF a -> SomeResponse
SomeResponse Response
response {responseBody = ()}
            else Response -> SomeResponse
forall a. IsWaiBody a => ResponseF a -> SomeResponse
SomeResponse Response
response
    case forall (cs :: [*]) (as :: [*]).
IsResponseList cs as =>
MediaType
-> SomeResponse -> UnrenderResult (Union (ResponseTypes as))
forall {k} (cs :: k) (as :: [*]).
IsResponseList cs as =>
MediaType
-> SomeResponse -> UnrenderResult (Union (ResponseTypes as))
responseListUnrender @cs @as MediaType
c SomeResponse
sresp of
      UnrenderResult (Union (ResponseTypes as))
StatusMismatch -> ClientError -> m r
forall a. ClientError -> m a
forall (m :: * -> *) a. RunClient m => ClientError -> m a
throwClientError (Text -> Response -> ClientError
DecodeFailure Text
"Status mismatch" Response
response)
      UnrenderError String
e -> ClientError -> m r
forall a. ClientError -> m a
forall (m :: * -> *) a. RunClient m => ClientError -> m a
throwClientError (Text -> Response -> ClientError
DecodeFailure (String -> Text
Text.pack String
e) Response
response)
      UnrenderSuccess Union (ResponseTypes as)
x -> r -> m r
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (as :: [*]) r. AsUnion as r => Union (ResponseTypes as) -> r
fromUnion @as Union (ResponseTypes as)
x)
    where
      accept :: [MediaType]
accept = Proxy cs -> [MediaType]
forall (list :: [*]). AllMime list => Proxy list -> [MediaType]
allMime (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @cs)
      method :: ByteString
method = Proxy method -> ByteString
forall {k} (a :: k). ReflectMethod a => Proxy a -> ByteString
reflectMethod (forall {k} (t :: k). Proxy t
forall (t :: StdMethod). Proxy t
Proxy @method)

  hoistClientMonad :: forall (mon :: * -> *) (mon' :: * -> *).
Proxy m
-> Proxy (MultiVerb method cs as r)
-> (forall x. mon x -> mon' x)
-> Client mon (MultiVerb method cs as r)
-> Client mon' (MultiVerb method cs as r)
hoistClientMonad Proxy m
_ Proxy (MultiVerb method cs as r)
_ forall x. mon x -> mon' x
f = mon r -> mon' r
Client mon (MultiVerb method cs as r)
-> Client mon' (MultiVerb method cs as r)
forall x. mon x -> mon' x
f

instance RoutesToPaths (MultiVerb method cs as r) where
  getRoutes :: Forest PathSegment
getRoutes = []

instance HasLink (MultiVerb method cs as r) where
  type MkLink (MultiVerb method cs as r) a = a
  toLink :: forall a.
(Link -> a)
-> Proxy (MultiVerb method cs as r)
-> Link
-> MkLink (MultiVerb method cs as r) a
toLink Link -> a
toA Proxy (MultiVerb method cs as r)
_ = Link -> a
Link -> MkLink (MultiVerb method cs as r) a
toA