{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{- |
Module      :  Servant.Checked.Exceptions.Internal.Servant.Server

Copyright   :  Dennis Gosnell 2017
License     :  BSD3

Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)
Stability   :  experimental
Portability :  unknown

This module exports 'HasServer' instances for 'Throws' and 'Throwing'.
-}

module Servant.Checked.Exceptions.Internal.Servant.Server where

import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LBS
import Data.Functor.Identity
import Data.Maybe
import Data.Proxy (Proxy(Proxy))
import Data.WorldPeace (OpenUnion, Union(That, This))
import GHC.TypeLits (KnownNat, natVal)
import Network.HTTP.Types
import Network.Wai
import Servant.API.ContentTypes
  ( AcceptHeader(AcceptHeader)
  , AllCTRender
  , AllMime
  , canHandleAcceptH
  , handleAcceptH
  )
import Servant.Server.Internal (ct_wildcard)
import Servant.Server.Internal.Router (Router, Router', leafRouter)
import Servant.Server.Internal.RouteResult (RouteResult(FailFatal, Route))
import Servant.Server.Internal.DelayedIO (DelayedIO, delayedFail)
import Servant.Server.Internal.Delayed
  ( Delayed
  , addAcceptCheck
  , addMethodCheck
  , runAction
  )
import Servant
  ( (:<|>)(..)
  , (:>)
  , Context
  , Handler
  , HasServer(..)
  , ReflectMethod
  , ServerT
  , Verb
  , err405
  , err406
  , reflectMethod
  )

import Servant.Checked.Exceptions.Internal.Envelope (Envelope, envelope)
import Servant.Checked.Exceptions.Internal.Servant.API
  ( AllErrStatus
  , ErrStatus(toErrStatus)
  , NoThrow
  , Throwing
  , ThrowingNonterminal
  , Throws
  )
import Servant.Checked.Exceptions.Verbs (VerbWithErr)

-- TODO: Make sure to also account for when headers are being used.
-- This might be hard to do:
-- https://github.com/cdepillabout/servant-checked-exceptions/issues/4

-- | Change a 'Throws' into 'Throwing'.
instance (HasServer (Throwing '[e] :> api) context) =>
    HasServer (Throws e :> api) context where

  type ServerT (Throws e :> api) m =
    ServerT (Throwing '[e] :> api) m

  hoistServerWithContext :: Proxy (Throws e :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Throws e :> api) m
-> ServerT (Throws e :> api) n
hoistServerWithContext Proxy (Throws e :> api)
_ =
    Proxy (Throwing '[e] :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Throwing '[e] :> api) m
-> ServerT (Throwing '[e] :> api) n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy (Throwing '[e] :> api)
forall k (t :: k). Proxy t
Proxy :: Proxy (Throwing '[e] :> api))

  route
    :: Proxy (Throws e :> api)
    -> Context context
    -> Delayed env (ServerT (Throwing '[e] :> api) Handler)
    -> Router env
  route :: Proxy (Throws e :> api)
-> Context context
-> Delayed env (ServerT (Throwing '[e] :> api) Handler)
-> Router env
route Proxy (Throws e :> api)
_ = Proxy (Throwing '[e] :> api)
-> Context context
-> Delayed env (ServerT (Throwing '[e] :> api) Handler)
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy (Throwing '[e] :> api)
forall k (t :: k). Proxy t
Proxy :: Proxy (Throwing '[e] :> api))

-- | When @'Throwing' es@ comes before a 'Verb', change it into the same 'Verb'
-- but returning an @'Envelope' es@.
instance (HasServer (VerbWithErr method status ctypes es a) context) =>
    HasServer (Throwing es :> Verb method status ctypes a) context where

  type ServerT (Throwing es :> Verb method status ctypes a) m =
    ServerT (VerbWithErr method status ctypes es a) m

  hoistServerWithContext :: Proxy (Throwing es :> Verb method status ctypes a)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Throwing es :> Verb method status ctypes a) m
-> ServerT (Throwing es :> Verb method status ctypes a) n
hoistServerWithContext Proxy (Throwing es :> Verb method status ctypes a)
_ =
    Proxy (VerbWithErr method status ctypes es a)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (VerbWithErr method status ctypes es a) m
-> ServerT (VerbWithErr method status ctypes es a) n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy (VerbWithErr method status ctypes es a)
forall k (t :: k). Proxy t
Proxy :: Proxy (VerbWithErr method status ctypes es a))

  route
    :: Proxy (Throwing es :> Verb method status ctypes a)
    -> Context context
    -> Delayed env
         (ServerT (VerbWithErr method status ctypes es a) Handler)
    -> Router env
  route :: Proxy (Throwing es :> Verb method status ctypes a)
-> Context context
-> Delayed
     env (ServerT (VerbWithErr method status ctypes es a) Handler)
-> Router env
route Proxy (Throwing es :> Verb method status ctypes a)
_ =
    Proxy (VerbWithErr method status ctypes es a)
-> Context context
-> Delayed
     env (ServerT (VerbWithErr method status ctypes es a) Handler)
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route
      (Proxy (VerbWithErr method status ctypes es a)
forall k (t :: k). Proxy t
Proxy :: Proxy (VerbWithErr method status ctypes es a))

-- | When 'NoThrow' comes before a 'Verb', change it into the same 'Verb'
-- but returning an @'Envelope' \'[]@.
instance
    ( HasServer (VerbWithErr method status ctypes '[] a) context
    ) =>
    HasServer (NoThrow :> Verb method status ctypes a) context where

  type ServerT (NoThrow :> Verb method status ctypes a) m =
    ServerT (VerbWithErr method status ctypes '[] a) m

  hoistServerWithContext :: Proxy (NoThrow :> Verb method status ctypes a)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (NoThrow :> Verb method status ctypes a) m
-> ServerT (NoThrow :> Verb method status ctypes a) n
hoistServerWithContext Proxy (NoThrow :> Verb method status ctypes a)
_ =
    Proxy (VerbWithErr method status ctypes '[] a)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (VerbWithErr method status ctypes '[] a) m
-> ServerT (VerbWithErr method status ctypes '[] a) n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy (VerbWithErr method status ctypes '[] a)
forall k (t :: k). Proxy t
Proxy :: Proxy (VerbWithErr method status ctypes '[] a))

  route
    :: Proxy (NoThrow :> Verb method status ctypes a)
    -> Context context
    -> Delayed env (ServerT (VerbWithErr method status ctypes '[] a) Handler)
    -> Router env
  route :: Proxy (NoThrow :> Verb method status ctypes a)
-> Context context
-> Delayed
     env (ServerT (VerbWithErr method status ctypes '[] a) Handler)
-> Router env
route Proxy (NoThrow :> Verb method status ctypes a)
_ = Proxy (VerbWithErr method status ctypes '[] a)
-> Context context
-> Delayed
     env (ServerT (VerbWithErr method status ctypes '[] a) Handler)
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy (VerbWithErr method status ctypes '[] a)
forall k (t :: k). Proxy t
Proxy :: Proxy (VerbWithErr method status ctypes '[] a))

-- | When @'Throwing' es@ comes before ':<|>', push @'Throwing' es@ into each
-- branch of the API.
instance HasServer ((Throwing es :> api1) :<|> (Throwing es :> api2)) context =>
    HasServer (Throwing es :> (api1 :<|> api2)) context where

  type ServerT (Throwing es :> (api1 :<|> api2)) m =
    ServerT ((Throwing es :> api1) :<|> (Throwing es :> api2)) m

  hoistServerWithContext :: Proxy (Throwing es :> (api1 :<|> api2))
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Throwing es :> (api1 :<|> api2)) m
-> ServerT (Throwing es :> (api1 :<|> api2)) n
hoistServerWithContext Proxy (Throwing es :> (api1 :<|> api2))
_ =
    Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2))
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT ((Throwing es :> api1) :<|> (Throwing es :> api2)) m
-> ServerT ((Throwing es :> api1) :<|> (Throwing es :> api2)) n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2))
forall k (t :: k). Proxy t
Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2)))

  route
    :: Proxy (Throwing es :> (api1 :<|> api2))
    -> Context context
    -> Delayed env (ServerT ((Throwing es :> api1) :<|> (Throwing es :> api2)) Handler)
    -> Router env
  route :: Proxy (Throwing es :> (api1 :<|> api2))
-> Context context
-> Delayed
     env
     (ServerT
        ((Throwing es :> api1) :<|> (Throwing es :> api2)) Handler)
-> Router env
route Proxy (Throwing es :> (api1 :<|> api2))
_ = Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2))
-> Context context
-> Delayed
     env
     (ServerT
        ((Throwing es :> api1) :<|> (Throwing es :> api2)) Handler)
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2))
forall k (t :: k). Proxy t
Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2)))

-- | When 'NoThrow' comes before ':<|>', push 'NoThrow' into each
-- branch of the API.
instance HasServer ((NoThrow :> api1) :<|> (NoThrow :> api2)) context =>
    HasServer (NoThrow :> (api1 :<|> api2)) context where

  type ServerT (NoThrow :> (api1 :<|> api2)) m =
    ServerT ((NoThrow :> api1) :<|> (NoThrow :> api2)) m

  hoistServerWithContext :: Proxy (NoThrow :> (api1 :<|> api2))
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (NoThrow :> (api1 :<|> api2)) m
-> ServerT (NoThrow :> (api1 :<|> api2)) n
hoistServerWithContext Proxy (NoThrow :> (api1 :<|> api2))
_ =
    Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2))
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT ((NoThrow :> api1) :<|> (NoThrow :> api2)) m
-> ServerT ((NoThrow :> api1) :<|> (NoThrow :> api2)) n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2))
forall k (t :: k). Proxy t
Proxy :: Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2)))

  route
    :: Proxy (NoThrow :> (api1 :<|> api2))
    -> Context context
    -> Delayed env (ServerT ((NoThrow :> api1) :<|> (NoThrow :> api2)) Handler)
    -> Router env
  route :: Proxy (NoThrow :> (api1 :<|> api2))
-> Context context
-> Delayed
     env (ServerT ((NoThrow :> api1) :<|> (NoThrow :> api2)) Handler)
-> Router env
route Proxy (NoThrow :> (api1 :<|> api2))
_ = Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2))
-> Context context
-> Delayed
     env (ServerT ((NoThrow :> api1) :<|> (NoThrow :> api2)) Handler)
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2))
forall k (t :: k). Proxy t
Proxy :: Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2)))

-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the
-- @e@ onto the @es@. Otherwise, if @'Throws' e@ comes before any other
-- combinator, push it down so it is closer to the 'Verb'.
instance HasServer (ThrowingNonterminal (Throwing es :> api :> apis)) context =>
    HasServer (Throwing es :> api :> apis) context where

  type ServerT (Throwing es :> api :> apis) m =
    ServerT (ThrowingNonterminal (Throwing es :> api :> apis)) m

  hoistServerWithContext :: Proxy (Throwing es :> (api :> apis))
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (Throwing es :> (api :> apis)) m
-> ServerT (Throwing es :> (api :> apis)) n
hoistServerWithContext Proxy (Throwing es :> (api :> apis))
_ =
    Proxy (ThrowingNonterminal (Throwing es :> (api :> apis)))
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (ThrowingNonterminal (Throwing es :> (api :> apis))) m
-> ServerT (ThrowingNonterminal (Throwing es :> (api :> apis))) n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy (ThrowingNonterminal (Throwing es :> (api :> apis)))
forall k (t :: k). Proxy t
Proxy :: Proxy (ThrowingNonterminal (Throwing es :> api :> apis)))

  route
    :: Proxy (Throwing es :> api :> apis)
    -> Context context
    -> Delayed env (ServerT (ThrowingNonterminal (Throwing es :> api :> apis)) Handler)
    -> Router env
  route :: Proxy (Throwing es :> (api :> apis))
-> Context context
-> Delayed
     env
     (ServerT
        (ThrowingNonterminal (Throwing es :> (api :> apis))) Handler)
-> Router env
route Proxy (Throwing es :> (api :> apis))
_ = Proxy (ThrowingNonterminal (Throwing es :> (api :> apis)))
-> Context context
-> Delayed
     env
     (ServerT
        (ThrowingNonterminal (Throwing es :> (api :> apis))) Handler)
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy (ThrowingNonterminal (Throwing es :> (api :> apis)))
forall k (t :: k). Proxy t
Proxy :: Proxy (ThrowingNonterminal (Throwing es :> api :> apis)))

-- | When 'NoThrow' comes before any combinator, push it down so it is closer
-- to the 'Verb'.
instance HasServer (api :> NoThrow :> apis) context =>
    HasServer (NoThrow :> api :> apis) context where

  type ServerT (NoThrow :> api :> apis) m =
    ServerT (api :> NoThrow :> apis) m

  hoistServerWithContext :: Proxy (NoThrow :> (api :> apis))
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (NoThrow :> (api :> apis)) m
-> ServerT (NoThrow :> (api :> apis)) n
hoistServerWithContext Proxy (NoThrow :> (api :> apis))
_ =
    Proxy (api :> (NoThrow :> apis))
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (api :> (NoThrow :> apis)) m
-> ServerT (api :> (NoThrow :> apis)) n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy (api :> (NoThrow :> apis))
forall k (t :: k). Proxy t
Proxy :: Proxy (api :> NoThrow :> apis))

  route
    :: Proxy (NoThrow :> api :> apis)
    -> Context context
    -> Delayed env (ServerT (api :> NoThrow :> apis) Handler)
    -> Router env
  route :: Proxy (NoThrow :> (api :> apis))
-> Context context
-> Delayed env (ServerT (api :> (NoThrow :> apis)) Handler)
-> Router env
route Proxy (NoThrow :> (api :> apis))
_ = Proxy (api :> (NoThrow :> apis))
-> Context context
-> Delayed env (ServerT (api :> (NoThrow :> apis)) Handler)
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy (api :> (NoThrow :> apis))
forall k (t :: k). Proxy t
Proxy :: Proxy (api :> NoThrow :> apis))

---------------------
-- Verb With Error --
---------------------

instance
    {-# OVERLAPPABLE #-}
    ( AllCTRender ctypes (Envelope es a)
    , AllErrStatus es
    , KnownNat successStatus
    , ReflectMethod method
    ) =>
    HasServer (VerbWithErr method successStatus ctypes es a) context where

  type ServerT (VerbWithErr method successStatus ctypes es a) m =
    m (Envelope es a)

  hoistServerWithContext :: Proxy (VerbWithErr method successStatus ctypes es a)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (VerbWithErr method successStatus ctypes es a) m
-> ServerT (VerbWithErr method successStatus ctypes es a) n
hoistServerWithContext Proxy (VerbWithErr method successStatus ctypes es a)
_ Proxy context
_ forall x. m x -> n x
nt = ServerT (VerbWithErr method successStatus ctypes es a) m
-> ServerT (VerbWithErr method successStatus ctypes es a) n
forall x. m x -> n x
nt

  route
    :: Proxy (VerbWithErr method successStatus ctypes es a)
    -> Context context
    -> Delayed env (Handler (Envelope es a))
    -> Router' env
         ( Request ->
           (RouteResult Response -> IO ResponseReceived) ->
           IO ResponseReceived
         )
  route :: Proxy (VerbWithErr method successStatus ctypes es a)
-> Context context
-> Delayed env (Handler (Envelope es a))
-> Router'
     env
     (Request
      -> (RouteResult Response -> IO ResponseReceived)
      -> IO ResponseReceived)
route Proxy (VerbWithErr method successStatus ctypes es a)
Proxy Context context
_ = Method
-> Status
-> Proxy ctypes
-> Delayed env (Handler (Envelope es a))
-> Router'
     env
     (Request
      -> (RouteResult Response -> IO ResponseReceived)
      -> IO ResponseReceived)
forall (ctypes :: [*]) a (es :: [*]) env.
(AllCTRender ctypes (Envelope es a), AllErrStatus es) =>
Method
-> Status
-> Proxy ctypes
-> Delayed env (Handler (Envelope es a))
-> Router'
     env
     (Request
      -> (RouteResult Response -> IO ResponseReceived)
      -> IO ResponseReceived)
methodRouter Method
method Status
successStatus (Proxy ctypes
forall k (t :: k). Proxy t
Proxy :: Proxy ctypes)
    where
      method :: Method
      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 :: Proxy method)

      successStatus :: Status
      successStatus :: Status
successStatus =
        Int -> Status
forall a. Enum a => Int -> a
toEnum (Int -> Status) -> (Integer -> Int) -> Integer -> Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Status) -> Integer -> Status
forall a b. (a -> b) -> a -> b
$ Proxy successStatus -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy successStatus
forall k (t :: k). Proxy t
Proxy :: Proxy successStatus)

methodRouter ::
     forall ctypes a es env.
     (AllCTRender ctypes (Envelope es a), AllErrStatus es)
  => Method
  -> Status
  -> Proxy ctypes
  -> Delayed env (Handler (Envelope es a))
  -> Router' env
       ( Request ->
         (RouteResult Response -> IO ResponseReceived)->
         IO ResponseReceived
       )
methodRouter :: Method
-> Status
-> Proxy ctypes
-> Delayed env (Handler (Envelope es a))
-> Router'
     env
     (Request
      -> (RouteResult Response -> IO ResponseReceived)
      -> IO ResponseReceived)
methodRouter Method
method Status
successStatus Proxy ctypes
proxy Delayed env (Handler (Envelope es a))
action = (env
 -> Request
 -> (RouteResult Response -> IO ResponseReceived)
 -> IO ResponseReceived)
-> Router'
     env
     (Request
      -> (RouteResult Response -> IO ResponseReceived)
      -> IO ResponseReceived)
forall env a. (env -> a) -> Router' env a
leafRouter env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
route'
  where
    route'
      :: env
      -> Request
      -> (RouteResult Response -> IO ResponseReceived)
      -> IO ResponseReceived
    route' :: env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> IO ResponseReceived
route' env
env Request
request RouteResult Response -> IO ResponseReceived
respond = do
      let accH :: Method
accH = Method -> Maybe Method -> Method
forall a. a -> Maybe a -> a
fromMaybe Method
ct_wildcard (Maybe Method -> Method) -> Maybe Method -> Method
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, Method)] -> Maybe Method
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hAccept ([(HeaderName, Method)] -> Maybe Method)
-> [(HeaderName, Method)] -> Maybe Method
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, Method)]
requestHeaders Request
request
      let theAction :: Delayed env (Handler (Envelope es a))
theAction =
            Delayed env (Handler (Envelope es a))
action
              Delayed env (Handler (Envelope es a))
-> DelayedIO () -> Delayed env (Handler (Envelope es a))
forall env a. Delayed env a -> DelayedIO () -> Delayed env a
`addMethodCheck` Method -> Request -> DelayedIO ()
methodCheck Method
method Request
request
              Delayed env (Handler (Envelope es a))
-> DelayedIO () -> Delayed env (Handler (Envelope es a))
forall env a. Delayed env a -> DelayedIO () -> Delayed env a
`addAcceptCheck` Proxy ctypes -> Method -> DelayedIO ()
forall (list :: [*]).
AllMime list =>
Proxy list -> Method -> DelayedIO ()
acceptCheck Proxy ctypes
proxy Method
accH
      Delayed env (Handler (Envelope es a))
-> env
-> Request
-> (RouteResult Response -> IO ResponseReceived)
-> (Envelope es a -> 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 (Envelope es a))
theAction env
env Request
request RouteResult Response -> IO ResponseReceived
respond ((Envelope es a -> RouteResult Response) -> IO ResponseReceived)
-> (Envelope es a -> RouteResult Response) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Request -> Method -> Envelope es a -> RouteResult Response
go Request
request Method
accH

    go :: Request -> ByteString -> Envelope es a -> RouteResult Response
    go :: Request -> Method -> Envelope es a -> RouteResult Response
go Request
request Method
accH Envelope es a
envel = do
      let status :: Status
status = (OpenUnion es -> Status)
-> (a -> Status) -> Envelope es a -> Status
forall (es :: [*]) c a.
(OpenUnion es -> c) -> (a -> c) -> Envelope es a -> c
envelope OpenUnion es -> Status
forall (es :: [*]). AllErrStatus es => OpenUnion es -> Status
getErrStatus (Status -> a -> Status
forall a b. a -> b -> a
const Status
successStatus) Envelope es a
envel
      let handleA :: Maybe (ByteString, ByteString)
handleA = Proxy ctypes
-> AcceptHeader -> Envelope es a -> Maybe (ByteString, ByteString)
forall (list :: [*]) a.
AllCTRender list a =>
Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
handleAcceptH Proxy ctypes
proxy (Method -> AcceptHeader
AcceptHeader Method
accH) Envelope es a
envel
      Maybe (ByteString, ByteString)
-> Status
-> Method
-> Maybe [(HeaderName, Method)]
-> Request
-> RouteResult Response
processMethodRouter Maybe (ByteString, ByteString)
handleA Status
status Method
method Maybe [(HeaderName, Method)]
forall a. Maybe a
Nothing Request
request

allowedMethod :: Method -> Request -> Bool
allowedMethod :: Method -> Request -> Bool
allowedMethod Method
method Request
request =
  Method -> Request -> Bool
allowedMethodHead Method
method Request
request Bool -> Bool -> Bool
|| Request -> Method
requestMethod Request
request Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
method

allowedMethodHead :: Method -> Request -> Bool
allowedMethodHead :: Method -> Request -> Bool
allowedMethodHead Method
method Request
request =
  Method
method Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
methodGet Bool -> Bool -> Bool
&& Request -> Method
requestMethod Request
request Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
methodHead

methodCheck :: Method -> Request -> DelayedIO ()
methodCheck :: Method -> Request -> DelayedIO ()
methodCheck Method
method Request
request
  | Method -> Request -> Bool
allowedMethod Method
method Request
request = () -> DelayedIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise                    = ServerError -> DelayedIO ()
forall a. ServerError -> DelayedIO a
delayedFail ServerError
err405

acceptCheck :: (AllMime list) => Proxy list -> ByteString -> DelayedIO ()
acceptCheck :: Proxy list -> Method -> DelayedIO ()
acceptCheck Proxy list
proxy Method
accH
  | Proxy list -> AcceptHeader -> Bool
forall (list :: [*]).
AllMime list =>
Proxy list -> AcceptHeader -> Bool
canHandleAcceptH Proxy list
proxy (Method -> AcceptHeader
AcceptHeader Method
accH) = () -> DelayedIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise                                  = ServerError -> DelayedIO ()
forall a. ServerError -> DelayedIO a
delayedFail ServerError
err406

getErrStatus :: AllErrStatus es => OpenUnion es -> Status
getErrStatus :: OpenUnion es -> Status
getErrStatus (This (Identity a
e)) = a -> Status
forall e. ErrStatus e => e -> Status
toErrStatus a
e
getErrStatus (That Union Identity as1
es) = Union Identity as1 -> Status
forall (es :: [*]). AllErrStatus es => OpenUnion es -> Status
getErrStatus Union Identity as1
es

processMethodRouter
  :: Maybe (LBS.ByteString, LBS.ByteString)
  -> Status
  -> Method
  -> Maybe [(HeaderName, ByteString)]
  -> Request -> RouteResult Response
processMethodRouter :: Maybe (ByteString, ByteString)
-> Status
-> Method
-> Maybe [(HeaderName, Method)]
-> Request
-> RouteResult Response
processMethodRouter Maybe (ByteString, ByteString)
handleA Status
status Method
method Maybe [(HeaderName, Method)]
headers Request
request = case Maybe (ByteString, ByteString)
handleA of
  Maybe (ByteString, ByteString)
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
  Just (ByteString
contentT, ByteString
body) -> Response -> RouteResult Response
forall a. a -> RouteResult a
Route (Response -> RouteResult Response)
-> Response -> RouteResult Response
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, Method)] -> ByteString -> Response
responseLBS Status
status [(HeaderName, Method)]
hdrs ByteString
bdy
    where
      bdy :: ByteString
bdy = if Method -> Request -> Bool
allowedMethodHead Method
method Request
request then ByteString
"" else ByteString
body
      hdrs :: [(HeaderName, Method)]
hdrs = (HeaderName
hContentType, ByteString -> Method
LBS.toStrict ByteString
contentT) (HeaderName, Method)
-> [(HeaderName, Method)] -> [(HeaderName, Method)]
forall a. a -> [a] -> [a]
: [(HeaderName, Method)]
-> Maybe [(HeaderName, Method)] -> [(HeaderName, Method)]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [(HeaderName, Method)]
headers