{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# 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 Data.Proxy (Proxy (Proxy))
import Data.SOP (I (I))
import Data.SOP.Constraint (All, And)
import Data.String.Conversions (LBS, cs)
import Network.HTTP.Types (Status, hContentType)
import Network.Wai (responseLBS)
import Servant.API (ReflectMethod, reflectMethod)
import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)
import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, 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 :: *) (xs :: [*]) (f :: * -> *).
  (Applicative f, HasStatus x, IsMember x xs) =>
  x ->
  f (Union xs)
respond :: x -> f (Union xs)
respond = Union xs -> f (Union xs)
forall (f :: * -> *) 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 -> *).
UElem x xs =>
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

-- | Helper constraint used in @instance 'HasServer' 'UVerb'@.
type IsServerResource contentTypes = AllCTRender contentTypes `And` HasStatus

instance
  ( ReflectMethod method,
    AllMime contentTypes,
    All (IsServerResource 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 :: 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 :: 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
 -> Request
 -> (RouteResult Response -> IO ResponseReceived)
 -> IO ResponseReceived)
-> Router env
forall env a. (env -> a) -> Router' env a
leafRouter env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
route'
    where
      method :: Method
method = Proxy method -> Method
forall k (a :: k). ReflectMethod a => Proxy a -> Method
reflectMethod (Proxy method
forall k (t :: k). Proxy t
Proxy @method)
      route' :: env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
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` Method -> Request -> DelayedIO ()
methodCheck Method
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 :: [*]).
AllMime list =>
Proxy list -> AcceptHeader -> DelayedIO ()
acceptCheck (Proxy contentTypes
forall k (t :: k). Proxy t
Proxy @contentTypes) (Request -> AcceptHeader
getAcceptHeader Request
request)
            mkProxy :: a -> Proxy a
            mkProxy :: a -> Proxy a
mkProxy a
_ = Proxy a
forall k (t :: k). Proxy t
Proxy

        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 encodeResource :: (AllCTRender contentTypes a, HasStatus a) => a -> (Status, Maybe (LBS, LBS))
              encodeResource :: a -> (Status, Maybe (LBS, LBS))
encodeResource a
res =
                ( Proxy a -> Status
forall a (proxy :: * -> *). HasStatus a => proxy a -> Status
statusOf (Proxy a -> Status) -> Proxy a -> Status
forall a b. (a -> b) -> a -> b
$ a -> Proxy a
forall a. a -> Proxy a
mkProxy a
res,
                  Proxy contentTypes -> AcceptHeader -> a -> Maybe (LBS, LBS)
forall (list :: [*]) a.
AllCTRender list a =>
Proxy list -> AcceptHeader -> a -> Maybe (LBS, LBS)
handleAcceptH (Proxy contentTypes
forall k (t :: k). Proxy t
Proxy @contentTypes) (Request -> AcceptHeader
getAcceptHeader Request
request) a
res
                )
              pickResource :: Union as -> (Status, Maybe (LBS, LBS))
              pickResource :: Union as -> (Status, Maybe (LBS, LBS))
pickResource = Proxy (IsServerResource contentTypes)
-> (forall x.
    IsServerResource contentTypes x =>
    x -> (Status, Maybe (LBS, LBS)))
-> Union as
-> (Status, Maybe (LBS, LBS))
forall (c :: * -> Constraint) a (as :: [*]).
All c as =>
Proxy c -> (forall x. c x => x -> a) -> Union as -> a
foldMapUnion (Proxy (IsServerResource contentTypes)
forall k (t :: k). Proxy t
Proxy @(IsServerResource contentTypes)) forall a.
(AllCTRender contentTypes a, HasStatus a) =>
a -> (Status, Maybe (LBS, LBS))
forall x.
IsServerResource contentTypes x =>
x -> (Status, Maybe (LBS, LBS))
encodeResource

          case Union as -> (Status, Maybe (LBS, LBS))
pickResource Union as
output of
            (Status
_, Maybe (LBS, LBS)
Nothing) -> 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 (LBS
contentT, LBS
body)) ->
              let bdy :: LBS
bdy = if Method -> Request -> Bool
allowedMethodHead Method
method Request
request then LBS
"" else LBS
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 -> ResponseHeaders -> LBS -> Response
responseLBS Status
status ((HeaderName
hContentType, LBS -> Method
forall a b. ConvertibleStrings a b => a -> b
cs LBS
contentT) (HeaderName, Method) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: []) LBS
bdy