    {-# LANGUAGE ConstraintKinds #-}
    {-# LANGUAGE DataKinds #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE InstanceSigs #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE TypeApplications #-}
    {-# LANGUAGE TypeFamilies #-}
    {-# LANGUAGE TypeOperators #-}
    {-# LANGUAGE UndecidableInstances #-}

    {-# OPTIONS_GHC -Wno-orphans #-}
    {-# OPTIONS_GHC -Wno-redundant-constraints #-}

    module Servant.Server.UVerb
      ( respond,
        IsServerResource,
      )
    where

    import qualified Data.ByteString as B
    import qualified Data.ByteString.Lazy as BSL
    import Data.Kind (Type)
    import Data.Proxy (Proxy (Proxy))
    import Data.SOP (I (I))
    import Data.SOP.Constraint (All, And)
    import Network.HTTP.Types (Status, HeaderName, hContentType)
    import Network.Wai (responseLBS, Request)
    import Servant.API (ReflectMethod, reflectMethod)
    import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)
    import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..))
    import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf)
    import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction)

    -- | 'return' for 'UVerb' handlers.  Takes a value of any of the members of the open union,
    -- and will construct a union value in an 'Applicative' (eg. 'Server').
    respond ::
      forall (x :: Type) (xs :: [Type]) (f :: Type -> Type).
      (Applicative f, HasStatus x, IsMember x xs) =>
      x ->
      f (Union xs)
    respond :: forall x (xs :: [Type]) (f :: Type -> Type).
    (Applicative f, HasStatus x, IsMember x xs) =>
    x -> f (Union xs)
    respond = Union xs -> f (Union xs)
    forall a. a -> f a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure (Union xs -> f (Union xs)) -> (x -> Union xs) -> x -> f (Union xs)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . I x -> Union xs
    forall {k} (x :: k) (xs :: [k]) (f :: k -> Type).
    UElem x xs =>
    f x -> NS f xs
    forall (f :: Type -> Type). f x -> NS f xs
    inject (I x -> Union xs) -> (x -> I x) -> x -> Union xs
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . x -> I x
    forall a. a -> I a
    I

    class IsServerResource (cts :: [Type]) a where
      resourceResponse :: Request -> Proxy cts -> a -> Maybe (BSL.ByteString, BSL.ByteString)
      resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)]

    instance {-# OVERLAPPABLE #-} AllCTRender cts a
      => IsServerResource cts a where
      resourceResponse :: Request -> Proxy cts -> a -> Maybe (ByteString, ByteString)
    resourceResponse Request
    request Proxy cts
    p a
    res = Proxy cts -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
    forall (list :: [Type]) a.
    AllCTRender list a =>
    Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
    handleAcceptH Proxy cts
    p (Request -> AcceptHeader
    getAcceptHeader Request
    request) a
    res
      resourceHeaders :: Proxy cts -> a -> [(HeaderName, ByteString)]
    resourceHeaders Proxy cts
    _ a
    _ = []

    instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a))
      => IsServerResource cts (Headers h a) where
      resourceResponse :: Request
    -> Proxy cts -> Headers h a -> Maybe (ByteString, ByteString)
    resourceResponse Request
    request Proxy cts
    p Headers h a
    res = Request -> Proxy cts -> a -> Maybe (ByteString, ByteString)
    forall (cts :: [Type]) a.
    IsServerResource cts a =>
    Request -> Proxy cts -> a -> Maybe (ByteString, ByteString)
    resourceResponse Request
    request Proxy cts
    p (Headers h a -> a
    forall (ls :: [Type]) a. Headers ls a -> a
    getResponse Headers h a
    res)
      resourceHeaders :: Proxy cts -> Headers h a -> [(HeaderName, ByteString)]
    resourceHeaders Proxy cts
    cts Headers h a
    res = Headers h a -> [(HeaderName, ByteString)]
    forall ls. GetHeaders ls => ls -> [(HeaderName, ByteString)]
    getHeaders Headers h a
    res [(HeaderName, ByteString)]
    -> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
    forall a. [a] -> [a] -> [a]
    ++ Proxy cts -> a -> [(HeaderName, ByteString)]
    forall (cts :: [Type]) a.
    IsServerResource cts a =>
    Proxy cts -> a -> [(HeaderName, ByteString)]
    resourceHeaders Proxy cts
    cts (Headers h a -> a
    forall (ls :: [Type]) a. Headers ls a -> a
    getResponse Headers h a
    res)

    instance {-# OVERLAPPING #-} IsServerResource cts a
      => IsServerResource cts (WithStatus n a) where
      resourceResponse :: Request
    -> Proxy cts -> WithStatus n a -> Maybe (ByteString, ByteString)
    resourceResponse Request
    request Proxy cts
    p (WithStatus a
    x) = Request -> Proxy cts -> a -> Maybe (ByteString, ByteString)
    forall (cts :: [Type]) a.
    IsServerResource cts a =>
    Request -> Proxy cts -> a -> Maybe (ByteString, ByteString)
    resourceResponse Request
    request Proxy cts
    p a
    x
      resourceHeaders :: Proxy cts -> WithStatus n a -> [(HeaderName, ByteString)]
    resourceHeaders Proxy cts
    cts (WithStatus a
    x) = Proxy cts -> a -> [(HeaderName, ByteString)]
    forall (cts :: [Type]) a.
    IsServerResource cts a =>
    Proxy cts -> a -> [(HeaderName, ByteString)]
    resourceHeaders Proxy cts
    cts a
    x

    encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a)
                   => Request -> Proxy cts -> a
                   -> (Status, Maybe (BSL.ByteString, BSL.ByteString), [(HeaderName, B.ByteString)])
    encodeResource :: forall a (cts :: [Type]).
    (IsServerResource cts a, HasStatus a) =>
    Request
    -> Proxy cts
    -> a
    -> (Status, Maybe (ByteString, ByteString),
        [(HeaderName, ByteString)])
    encodeResource Request
    request Proxy cts
    cts a
    res = (Proxy a -> Status
    forall a (proxy :: Type -> Type). HasStatus a => proxy a -> Status
    statusOf (forall t. Proxy t
    forall {k} (t :: k). Proxy t
    Proxy @a),
                                      Request -> Proxy cts -> a -> Maybe (ByteString, ByteString)
    forall (cts :: [Type]) a.
    IsServerResource cts a =>
    Request -> Proxy cts -> a -> Maybe (ByteString, ByteString)
    resourceResponse Request
    request Proxy cts
    cts a
    res,
                                      Proxy cts -> a -> [(HeaderName, ByteString)]
    forall (cts :: [Type]) a.
    IsServerResource cts a =>
    Proxy cts -> a -> [(HeaderName, ByteString)]
    resourceHeaders Proxy cts
    cts a
    res)

    type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus

    instance
      ( ReflectMethod method,
        AllMime contentTypes,
        All (IsServerResourceWithStatus contentTypes) as,
        Unique (Statuses as) -- for consistency with servant-swagger (server would work fine
            -- without; client is a bit of a corner case, because it dispatches
            -- the parser based on the status code.  with this uniqueness
            -- constraint it won't have to run more than one parser in weird
            -- corner cases.
      ) =>
      HasServer (UVerb method contentTypes as) context
      where
      type ServerT (UVerb method contentTypes as) m = m (Union as)

      hoistServerWithContext :: forall (m :: Type -> Type) (n :: Type -> Type).
    Proxy (UVerb method contentTypes as)
    -> Proxy context
    -> (forall x. m x -> n x)
    -> ServerT (UVerb method contentTypes as) m
    -> ServerT (UVerb method contentTypes as) n
    hoistServerWithContext Proxy (UVerb method contentTypes as)
    _ Proxy context
    _ forall x. m x -> n x
    nt ServerT (UVerb method contentTypes as) m
    s = m (Union as) -> n (Union as)
    forall x. m x -> n x
    nt m (Union as)
    ServerT (UVerb method contentTypes as) m
    s

      route ::
        forall env.
        Proxy (UVerb method contentTypes as) ->
        Context context ->
        Delayed env (Server (UVerb method contentTypes as)) ->
        Router env
      route :: forall env.
    Proxy (UVerb method contentTypes as)
    -> Context context
    -> Delayed env (Server (UVerb method contentTypes as))
    -> Router env
    route Proxy (UVerb method contentTypes as)
    _proxy Context context
    _ctx Delayed env (Server (UVerb method contentTypes as))
    action = (env -> RoutingApplication) -> Router' env RoutingApplication
    forall env a. (env -> a) -> Router' env a
    leafRouter env -> RoutingApplication
    route'
        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)
          route' :: env -> RoutingApplication
    route' env
    env Request
    request RouteResult Response -> IO ResponseReceived
    cont = do
            let action' :: Delayed env (Handler (Union as))
                action' :: Delayed env (Handler (Union as))
    action' =
                  Delayed env (Handler (Union as))
    Delayed env (Server (UVerb method contentTypes as))
    action
                    Delayed env (Handler (Union as))
    -> DelayedIO () -> Delayed env (Handler (Union as))
    forall env a. Delayed env a -> DelayedIO () -> Delayed env a
    `addMethodCheck` ByteString -> Request -> DelayedIO ()
    methodCheck ByteString
    method Request
    request
                    Delayed env (Handler (Union as))
    -> DelayedIO () -> Delayed env (Handler (Union as))
    forall env a. Delayed env a -> DelayedIO () -> Delayed env a
    `addAcceptCheck` Proxy contentTypes -> AcceptHeader -> DelayedIO ()
    forall (list :: [Type]).
    AllMime list =>
    Proxy list -> AcceptHeader -> DelayedIO ()
    acceptCheck (forall (t :: [Type]). Proxy t
    forall {k} (t :: k). Proxy t
    Proxy @contentTypes) (Request -> AcceptHeader
    getAcceptHeader Request
    request)

            Delayed env (Handler (Union as))
    -> env
    -> Request
    -> (RouteResult Response -> IO ResponseReceived)
    -> (Union as -> 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 (Union as))
    action' env
    env Request
    request RouteResult Response -> IO ResponseReceived
    cont ((Union as -> RouteResult Response) -> IO ResponseReceived)
    -> (Union as -> RouteResult Response) -> IO ResponseReceived
    forall a b. (a -> b) -> a -> b
    $ \(Union as
    output :: Union as) -> do
              let cts :: Proxy contentTypes
    cts = forall (t :: [Type]). Proxy t
    forall {k} (t :: k). Proxy t
    Proxy @contentTypes
                  pickResource :: Union as -> (Status, Maybe (BSL.ByteString, BSL.ByteString), [(HeaderName, B.ByteString)])
                  pickResource :: Union as
    -> (Status, Maybe (ByteString, ByteString),
        [(HeaderName, ByteString)])
    pickResource = Proxy (IsServerResourceWithStatus contentTypes)
    -> (forall x.
        IsServerResourceWithStatus contentTypes x =>
        x
        -> (Status, Maybe (ByteString, ByteString),
            [(HeaderName, ByteString)]))
    -> Union as
    -> (Status, Maybe (ByteString, ByteString),
        [(HeaderName, ByteString)])
    forall (c :: Type -> Constraint) a (as :: [Type]).
    All c as =>
    Proxy c -> (forall x. c x => x -> a) -> Union as -> a
    foldMapUnion (forall {k} (t :: k). Proxy t
    forall (t :: Type -> Constraint). Proxy t
    Proxy @(IsServerResourceWithStatus contentTypes)) (Request
    -> Proxy contentTypes
    -> x
    -> (Status, Maybe (ByteString, ByteString),
        [(HeaderName, ByteString)])
    forall a (cts :: [Type]).
    (IsServerResource cts a, HasStatus a) =>
    Request
    -> Proxy cts
    -> a
    -> (Status, Maybe (ByteString, ByteString),
        [(HeaderName, ByteString)])
    encodeResource Request
    request Proxy contentTypes
    cts)
              case Union as
    -> (Status, Maybe (ByteString, ByteString),
        [(HeaderName, ByteString)])
    pickResource Union as
    output of
                (Status
    _, Maybe (ByteString, ByteString)
    Nothing, [(HeaderName, ByteString)]
    _) -> ServerError -> RouteResult Response
    forall a. ServerError -> RouteResult a
    FailFatal ServerError
    err406 -- this should not happen (checked before), so we make it fatal if it does
                (Status
    status, Just (ByteString
    contentT, ByteString
    body), [(HeaderName, ByteString)]
    headers) ->
                  let bdy :: ByteString
    bdy = if ByteString -> Request -> Bool
    allowedMethodHead ByteString
    method Request
    request then ByteString
    "" else ByteString
    body
                   in Response -> RouteResult Response
    forall a. a -> RouteResult a
    Route (Response -> RouteResult Response)
    -> Response -> RouteResult Response
    forall a b. (a -> b) -> a -> b
    $ Status -> [(HeaderName, ByteString)] -> ByteString -> Response
    responseLBS Status
    status ((HeaderName
    hContentType, ByteString -> ByteString
    BSL.toStrict ByteString
    contentT) (HeaderName, ByteString)
    -> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
    forall a. a -> [a] -> [a]
    : [(HeaderName, ByteString)]
    headers) ByteString
    bdy