{-# 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 :: forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (x :: k) (xs :: [k]) (f :: k -> *).
UElem x xs =>
f x -> NS f xs
inject forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 = forall (cts :: [*]) a.
IsServerResource cts a =>
Request -> Proxy cts -> a -> Maybe (LBS, LBS)
resourceResponse Request
request Proxy cts
p (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 = forall ls. GetHeaders ls => ls -> [(HeaderName, ByteString)]
getHeaders Headers h a
res forall a. [a] -> [a] -> [a]
++ forall (cts :: [*]) a.
IsServerResource cts a =>
Proxy cts -> a -> [(HeaderName, ByteString)]
resourceHeaders Proxy cts
cts (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) = 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) = 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 :: forall a (cts :: [*]).
(IsServerResource cts a, HasStatus a) =>
Request
-> Proxy cts
-> a
-> (Status, Maybe (LBS, LBS), [(HeaderName, ByteString)])
encodeResource Request
request Proxy cts
cts a
res = (forall a (proxy :: * -> *). HasStatus a => proxy a -> Status
statusOf (forall {k} (t :: k). Proxy t
Proxy @a),
                                  forall (cts :: [*]) a.
IsServerResource cts a =>
Request -> Proxy cts -> a -> Maybe (LBS, LBS)
resourceResponse Request
request Proxy cts
cts a
res,
                                  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 :: forall (m :: * -> *) (n :: * -> *).
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 = forall x. m x -> n x
nt 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 = forall env a. (env -> a) -> Router' env a
leafRouter env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
route'
    where
      method :: ByteString
method = forall {k} (a :: k). ReflectMethod a => Proxy a -> ByteString
reflectMethod (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 (Server (UVerb method contentTypes as))
action
                forall env a. Delayed env a -> DelayedIO () -> Delayed env a
`addMethodCheck` ByteString -> Request -> DelayedIO ()
methodCheck ByteString
method Request
request
                forall env a. Delayed env a -> DelayedIO () -> Delayed env a
`addAcceptCheck` forall (list :: [*]).
AllMime list =>
Proxy list -> AcceptHeader -> DelayedIO ()
acceptCheck (forall {k} (t :: k). Proxy t
Proxy @contentTypes) (Request -> AcceptHeader
getAcceptHeader Request
request)

        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 forall a b. (a -> b) -> a -> b
$ \(Union as
output :: Union as) -> do
          let cts :: Proxy contentTypes
cts = 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 = forall (c :: * -> Constraint) a (as :: [*]).
All c as =>
Proxy c -> (forall x. c x => x -> a) -> Union as -> a
foldMapUnion (forall {k} (t :: k). Proxy t
Proxy @(IsServerResourceWithStatus contentTypes)) (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)]
_) -> 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 forall a. a -> RouteResult a
Route forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> LBS -> Response
responseLBS Status
status ((HeaderName
hContentType, forall a b. ConvertibleStrings a b => a -> b
cs LBS
contentT) forall a. a -> [a] -> [a]
: [(HeaderName, ByteString)]
headers) LBS
bdy