{-# 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 qualified Data.ByteString as B
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, 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 :: *) (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

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

instance {-# OVERLAPPABLE #-} AllCTRender cts a
  => IsServerResource cts a where
  resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS)
resourceResponse Request
request Proxy cts
p a
res = Proxy cts -> AcceptHeader -> a -> Maybe (LBS, LBS)
forall (list :: [*]) a.
AllCTRender list a =>
Proxy list -> AcceptHeader -> a -> Maybe (LBS, LBS)
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 (LBS, LBS)
resourceResponse Request
request Proxy cts
p Headers h a
res = Request -> Proxy cts -> a -> Maybe (LBS, LBS)
forall (cts :: [*]) a.
IsServerResource cts a =>
Request -> Proxy cts -> a -> Maybe (LBS, LBS)
resourceResponse Request
request Proxy cts
p (Headers h a -> a
forall (ls :: [*]) 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 :: [*]) a.
IsServerResource cts a =>
Proxy cts -> a -> [(HeaderName, ByteString)]
resourceHeaders Proxy cts
cts (Headers h a -> a
forall (ls :: [*]) 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 (LBS, LBS)
resourceResponse Request
request Proxy cts
p (WithStatus a
x) = Request -> Proxy cts -> a -> Maybe (LBS, LBS)
forall (cts :: [*]) a.
IsServerResource cts a =>
Request -> Proxy cts -> a -> Maybe (LBS, LBS)
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 :: [*]) 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 (LBS, LBS), [(HeaderName, B.ByteString)])
encodeResource :: Request
-> Proxy cts
-> a
-> (Status, Maybe (LBS, LBS), [(HeaderName, ByteString)])
encodeResource Request
request Proxy cts
cts a
res = (Proxy a -> Status
forall a (proxy :: * -> *). HasStatus a => proxy a -> Status
statusOf (Proxy a
forall k (t :: k). Proxy t
Proxy @a),
                                  Request -> Proxy cts -> a -> Maybe (LBS, LBS)
forall (cts :: [*]) a.
IsServerResource cts a =>
Request -> Proxy cts -> a -> Maybe (LBS, LBS)
resourceResponse Request
request Proxy cts
cts a
res,
                                  Proxy cts -> a -> [(HeaderName, ByteString)]
forall (cts :: [*]) 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 :: 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 :: ByteString
method = Proxy method -> ByteString
forall k (a :: k). ReflectMethod a => Proxy a -> ByteString
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` 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 :: [*]).
AllMime list =>
Proxy list -> AcceptHeader -> DelayedIO ()
acceptCheck (Proxy contentTypes
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 = Proxy contentTypes
forall k (t :: k). Proxy t
Proxy @contentTypes
              pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
              pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, ByteString)])
pickResource = Proxy (IsServerResourceWithStatus contentTypes)
-> (forall x.
    IsServerResourceWithStatus contentTypes x =>
    x -> (Status, Maybe (LBS, LBS), [(HeaderName, ByteString)]))
-> Union as
-> (Status, Maybe (LBS, LBS), [(HeaderName, ByteString)])
forall (c :: * -> Constraint) a (as :: [*]).
All c as =>
Proxy c -> (forall x. c x => x -> a) -> Union as -> a
foldMapUnion (Proxy (IsServerResourceWithStatus contentTypes)
forall k (t :: k). Proxy t
Proxy @(IsServerResourceWithStatus contentTypes)) (Request
-> Proxy contentTypes
-> x
-> (Status, Maybe (LBS, LBS), [(HeaderName, ByteString)])
forall a (cts :: [*]).
(IsServerResource cts a, HasStatus a) =>
Request
-> Proxy cts
-> a
-> (Status, Maybe (LBS, LBS), [(HeaderName, ByteString)])
encodeResource Request
request Proxy contentTypes
cts)
          case Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, ByteString)])
pickResource Union as
output of
            (Status
_, Maybe (LBS, LBS)
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 (LBS
contentT, LBS
body), [(HeaderName, ByteString)]
headers) ->
              let bdy :: LBS
bdy = if ByteString -> Request -> Bool
allowedMethodHead ByteString
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 -> [(HeaderName, ByteString)] -> LBS -> Response
responseLBS Status
status ((HeaderName
hContentType, LBS -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs LBS
contentT) (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
: [(HeaderName, ByteString)]
headers) LBS
bdy