{-# LANGUAGE CPP                   #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
module Servant.Server.Internal.Delayed where

import           Control.Monad.IO.Class
                 (MonadIO (..))
import           Control.Monad.Reader
                 (ask)
import           Control.Monad.Trans.Resource
                 (ResourceT, runResourceT)
import           Network.Wai
                 (Request, Response)

import           Servant.Server.Internal.DelayedIO
import           Servant.Server.Internal.Handler
import           Servant.Server.Internal.RouteResult
import           Servant.Server.Internal.ServerError

-- | A 'Delayed' is a representation of a handler with scheduled
-- delayed checks that can trigger errors.
--
-- Why would we want to delay checks?
--
-- There are two reasons:
--
-- 1. In a straight-forward implementation, the order in which we
-- perform checks will determine the error we generate. This is
-- because once an error occurs, we would abort and not perform
-- any subsequent checks, but rather return the current error.
--
-- This is not a necessity: we could continue doing other checks,
-- and choose the preferred error. However, that would in general
-- mean more checking, which leads us to the other reason.
--
-- 2. We really want to avoid doing certain checks too early. For
-- example, captures involve parsing, and are much more costly
-- than static route matches. In particular, if several paths
-- contain the "same" capture, we'd like as much as possible to
-- avoid trying the same parse many times. Also tricky is the
-- request body. Again, this involves parsing, but also, WAI makes
-- obtaining the request body a side-effecting operation. We
-- could/can work around this by manually caching the request body,
-- but we'd rather keep the number of times we actually try to
-- decode the request body to an absolute minimum.
--
-- We prefer to have the following relative priorities of error
-- codes:
--
-- @
-- 404
-- 405 (bad method)
-- 401 (unauthorized)
-- 415 (unsupported media type)
-- 406 (not acceptable)
-- 400 (bad request)
-- @
--
-- Therefore, while routing, we delay most checks so that they
-- will ultimately occur in the right order.
--
-- A 'Delayed' contains many delayed blocks of tests, and
-- the actual handler:
--
-- 1. Delayed captures. These can actually cause 404, and
-- while they're costly, they should be done first among the
-- delayed checks (at least as long as we do not decouple the
-- check order from the error reporting, see above). Delayed
-- captures can provide inputs to the actual handler.
--
-- 2. Method check(s). This can cause a 405. On success,
-- it does not provide an input for the handler. Method checks
-- are comparatively cheap.
--
-- 3. Authentication checks. This can cause 401.
--
-- 4. Accept and content type header checks. These checks
-- can cause 415 and 406 errors.
--
-- 5. Query parameter checks. They require parsing and can cause 400 if the
-- parsing fails. Query parameter checks provide inputs to the handler
--
-- 6. Header Checks. They also require parsing and can cause 400 if parsing fails.
--
-- 7. Body check. The request body check can cause 400.
--
data Delayed env c where
  Delayed :: { ()
capturesD :: env -> DelayedIO captures
             , Delayed env c -> DelayedIO ()
methodD   :: DelayedIO ()
             , ()
authD     :: DelayedIO auth
             , Delayed env c -> DelayedIO ()
acceptD   :: DelayedIO ()
             , ()
contentD  :: DelayedIO contentType
             , ()
paramsD   :: DelayedIO params
             , ()
headersD  :: DelayedIO headers
             , ()
bodyD     :: contentType -> DelayedIO body
             , ()
serverD   :: captures
                         -> params
                         -> headers
                         -> auth
                         -> body
                         -> Request
                         -> RouteResult c
             } -> Delayed env c

instance Functor (Delayed env) where
  fmap :: (a -> b) -> Delayed env a -> Delayed env b
fmap a -> b
f Delayed{DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
captures
-> params -> headers -> auth -> body -> Request -> RouteResult a
contentType -> DelayedIO body
serverD :: captures
-> params -> headers -> auth -> body -> Request -> RouteResult a
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
serverD :: ()
bodyD :: ()
headersD :: ()
paramsD :: ()
contentD :: ()
acceptD :: forall env c. Delayed env c -> DelayedIO ()
authD :: ()
methodD :: forall env c. Delayed env c -> DelayedIO ()
capturesD :: ()
..} =
    Delayed :: forall env captures auth contentType params headers body c.
(env -> DelayedIO captures)
-> DelayedIO ()
-> DelayedIO auth
-> DelayedIO ()
-> DelayedIO contentType
-> DelayedIO params
-> DelayedIO headers
-> (contentType -> DelayedIO body)
-> (captures
    -> params -> headers -> auth -> body -> Request -> RouteResult c)
-> Delayed env c
Delayed
      { serverD :: captures
-> params -> headers -> auth -> body -> Request -> RouteResult b
serverD = \ captures
c params
p headers
h auth
a body
b Request
req -> a -> b
f (a -> b) -> RouteResult a -> RouteResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> captures
-> params -> headers -> auth -> body -> Request -> RouteResult a
serverD captures
c params
p headers
h auth
a body
b Request
req
      , DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
contentType -> DelayedIO body
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
..
      } -- Note [Existential Record Update]

-- | A 'Delayed' without any stored checks.
emptyDelayed :: RouteResult a -> Delayed env a
emptyDelayed :: RouteResult a -> Delayed env a
emptyDelayed RouteResult a
result =
  (env -> DelayedIO ())
-> DelayedIO ()
-> DelayedIO ()
-> DelayedIO ()
-> DelayedIO ()
-> DelayedIO ()
-> DelayedIO ()
-> (() -> DelayedIO ())
-> (() -> () -> () -> () -> () -> Request -> RouteResult a)
-> Delayed env a
forall env captures auth contentType params headers body c.
(env -> DelayedIO captures)
-> DelayedIO ()
-> DelayedIO auth
-> DelayedIO ()
-> DelayedIO contentType
-> DelayedIO params
-> DelayedIO headers
-> (contentType -> DelayedIO body)
-> (captures
    -> params -> headers -> auth -> body -> Request -> RouteResult c)
-> Delayed env c
Delayed (DelayedIO () -> env -> DelayedIO ()
forall a b. a -> b -> a
const DelayedIO ()
r) DelayedIO ()
r DelayedIO ()
r DelayedIO ()
r DelayedIO ()
r DelayedIO ()
r DelayedIO ()
r (DelayedIO () -> () -> DelayedIO ()
forall a b. a -> b -> a
const DelayedIO ()
r) (\ ()
_ ()
_ ()
_ ()
_ ()
_ Request
_ -> RouteResult a
result)
  where
    r :: DelayedIO ()
r = () -> DelayedIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Add a capture to the end of the capture block.
addCapture :: Delayed env (a -> b)
           -> (captured -> DelayedIO a)
           -> Delayed (captured, env) b
addCapture :: Delayed env (a -> b)
-> (captured -> DelayedIO a) -> Delayed (captured, env) b
addCapture Delayed{DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (a -> b)
contentType -> DelayedIO body
serverD :: captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (a -> b)
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
serverD :: ()
bodyD :: ()
headersD :: ()
paramsD :: ()
contentD :: ()
acceptD :: forall env c. Delayed env c -> DelayedIO ()
authD :: ()
methodD :: forall env c. Delayed env c -> DelayedIO ()
capturesD :: ()
..} captured -> DelayedIO a
new =
  Delayed :: forall env captures auth contentType params headers body c.
(env -> DelayedIO captures)
-> DelayedIO ()
-> DelayedIO auth
-> DelayedIO ()
-> DelayedIO contentType
-> DelayedIO params
-> DelayedIO headers
-> (contentType -> DelayedIO body)
-> (captures
    -> params -> headers -> auth -> body -> Request -> RouteResult c)
-> Delayed env c
Delayed
    { capturesD :: (captured, env) -> DelayedIO (captures, a)
capturesD = \ (captured
txt, env
env) -> (,) (captures -> a -> (captures, a))
-> DelayedIO captures -> DelayedIO (a -> (captures, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> DelayedIO captures
capturesD env
env DelayedIO (a -> (captures, a))
-> DelayedIO a -> DelayedIO (captures, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> captured -> DelayedIO a
new captured
txt
    , serverD :: (captures, a)
-> params -> headers -> auth -> body -> Request -> RouteResult b
serverD   = \ (captures
x, a
v) params
p headers
h auth
a body
b Request
req -> ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
v) ((a -> b) -> b) -> RouteResult (a -> b) -> RouteResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (a -> b)
serverD captures
x params
p headers
h auth
a body
b Request
req
    , DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
contentType -> DelayedIO body
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
..
    } -- Note [Existential Record Update]

-- | Add a parameter check to the end of the params block
addParameterCheck :: Delayed env (a -> b)
                  -> DelayedIO a
                  -> Delayed env b
addParameterCheck :: Delayed env (a -> b) -> DelayedIO a -> Delayed env b
addParameterCheck Delayed {DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (a -> b)
contentType -> DelayedIO body
serverD :: captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (a -> b)
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
serverD :: ()
bodyD :: ()
headersD :: ()
paramsD :: ()
contentD :: ()
acceptD :: forall env c. Delayed env c -> DelayedIO ()
authD :: ()
methodD :: forall env c. Delayed env c -> DelayedIO ()
capturesD :: ()
..} DelayedIO a
new =
  Delayed :: forall env captures auth contentType params headers body c.
(env -> DelayedIO captures)
-> DelayedIO ()
-> DelayedIO auth
-> DelayedIO ()
-> DelayedIO contentType
-> DelayedIO params
-> DelayedIO headers
-> (contentType -> DelayedIO body)
-> (captures
    -> params -> headers -> auth -> body -> Request -> RouteResult c)
-> Delayed env c
Delayed
    { paramsD :: DelayedIO (params, a)
paramsD = (,) (params -> a -> (params, a))
-> DelayedIO params -> DelayedIO (a -> (params, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DelayedIO params
paramsD DelayedIO (a -> (params, a))
-> DelayedIO a -> DelayedIO (params, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DelayedIO a
new
    , serverD :: captures
-> (params, a)
-> headers
-> auth
-> body
-> Request
-> RouteResult b
serverD = \captures
c (params
p, a
pNew) headers
h auth
a body
b Request
req -> ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
pNew) ((a -> b) -> b) -> RouteResult (a -> b) -> RouteResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (a -> b)
serverD captures
c params
p headers
h auth
a body
b Request
req
    , DelayedIO auth
DelayedIO contentType
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
contentType -> DelayedIO body
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
..
    }

-- | Add a parameter check to the end of the params block
addHeaderCheck :: Delayed env (a -> b)
               -> DelayedIO a
               -> Delayed env b
addHeaderCheck :: Delayed env (a -> b) -> DelayedIO a -> Delayed env b
addHeaderCheck Delayed {DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (a -> b)
contentType -> DelayedIO body
serverD :: captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (a -> b)
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
serverD :: ()
bodyD :: ()
headersD :: ()
paramsD :: ()
contentD :: ()
acceptD :: forall env c. Delayed env c -> DelayedIO ()
authD :: ()
methodD :: forall env c. Delayed env c -> DelayedIO ()
capturesD :: ()
..} DelayedIO a
new =
  Delayed :: forall env captures auth contentType params headers body c.
(env -> DelayedIO captures)
-> DelayedIO ()
-> DelayedIO auth
-> DelayedIO ()
-> DelayedIO contentType
-> DelayedIO params
-> DelayedIO headers
-> (contentType -> DelayedIO body)
-> (captures
    -> params -> headers -> auth -> body -> Request -> RouteResult c)
-> Delayed env c
Delayed
    { headersD :: DelayedIO (headers, a)
headersD = (,) (headers -> a -> (headers, a))
-> DelayedIO headers -> DelayedIO (a -> (headers, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DelayedIO headers
headersD DelayedIO (a -> (headers, a))
-> DelayedIO a -> DelayedIO (headers, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DelayedIO a
new
    , serverD :: captures
-> params
-> (headers, a)
-> auth
-> body
-> Request
-> RouteResult b
serverD = \captures
c params
p (headers
h, a
hNew) auth
a body
b Request
req -> ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
hNew) ((a -> b) -> b) -> RouteResult (a -> b) -> RouteResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (a -> b)
serverD captures
c params
p headers
h auth
a body
b Request
req
    , DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO ()
env -> DelayedIO captures
contentType -> DelayedIO body
bodyD :: contentType -> DelayedIO body
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
bodyD :: contentType -> DelayedIO body
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
..
    }

-- | Add a method check to the end of the method block.
addMethodCheck :: Delayed env a
               -> DelayedIO ()
               -> Delayed env a
addMethodCheck :: Delayed env a -> DelayedIO () -> Delayed env a
addMethodCheck Delayed{DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
captures
-> params -> headers -> auth -> body -> Request -> RouteResult a
contentType -> DelayedIO body
serverD :: captures
-> params -> headers -> auth -> body -> Request -> RouteResult a
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
serverD :: ()
bodyD :: ()
headersD :: ()
paramsD :: ()
contentD :: ()
acceptD :: forall env c. Delayed env c -> DelayedIO ()
authD :: ()
methodD :: forall env c. Delayed env c -> DelayedIO ()
capturesD :: ()
..} DelayedIO ()
new =
  Delayed :: forall env captures auth contentType params headers body c.
(env -> DelayedIO captures)
-> DelayedIO ()
-> DelayedIO auth
-> DelayedIO ()
-> DelayedIO contentType
-> DelayedIO params
-> DelayedIO headers
-> (contentType -> DelayedIO body)
-> (captures
    -> params -> headers -> auth -> body -> Request -> RouteResult c)
-> Delayed env c
Delayed
    { methodD :: DelayedIO ()
methodD = DelayedIO ()
methodD DelayedIO () -> DelayedIO () -> DelayedIO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* DelayedIO ()
new
    , DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
captures
-> params -> headers -> auth -> body -> Request -> RouteResult a
contentType -> DelayedIO body
serverD :: captures
-> params -> headers -> auth -> body -> Request -> RouteResult a
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
capturesD :: env -> DelayedIO captures
serverD :: captures
-> params -> headers -> auth -> body -> Request -> RouteResult a
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
capturesD :: env -> DelayedIO captures
..
    } -- Note [Existential Record Update]

-- | Add an auth check to the end of the auth block.
addAuthCheck :: Delayed env (a -> b)
             -> DelayedIO a
             -> Delayed env b
addAuthCheck :: Delayed env (a -> b) -> DelayedIO a -> Delayed env b
addAuthCheck Delayed{DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (a -> b)
contentType -> DelayedIO body
serverD :: captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (a -> b)
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
serverD :: ()
bodyD :: ()
headersD :: ()
paramsD :: ()
contentD :: ()
acceptD :: forall env c. Delayed env c -> DelayedIO ()
authD :: ()
methodD :: forall env c. Delayed env c -> DelayedIO ()
capturesD :: ()
..} DelayedIO a
new =
  Delayed :: forall env captures auth contentType params headers body c.
(env -> DelayedIO captures)
-> DelayedIO ()
-> DelayedIO auth
-> DelayedIO ()
-> DelayedIO contentType
-> DelayedIO params
-> DelayedIO headers
-> (contentType -> DelayedIO body)
-> (captures
    -> params -> headers -> auth -> body -> Request -> RouteResult c)
-> Delayed env c
Delayed
    { authD :: DelayedIO (auth, a)
authD   = (,) (auth -> a -> (auth, a))
-> DelayedIO auth -> DelayedIO (a -> (auth, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DelayedIO auth
authD DelayedIO (a -> (auth, a)) -> DelayedIO a -> DelayedIO (auth, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DelayedIO a
new
    , serverD :: captures
-> params
-> headers
-> (auth, a)
-> body
-> Request
-> RouteResult b
serverD = \ captures
c params
p headers
h (auth
y, a
v) body
b Request
req -> ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
v) ((a -> b) -> b) -> RouteResult (a -> b) -> RouteResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (a -> b)
serverD captures
c params
p headers
h auth
y body
b Request
req
    , DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
contentType -> DelayedIO body
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
..
    } -- Note [Existential Record Update]

-- | Add a content type and body checks around parameter checks.
--
-- We'll report failed content type check (415), before trying to parse
-- query parameters (400). Which, in turn, happens before request body parsing.
addBodyCheck :: Delayed env (a -> b)
             -> DelayedIO c         -- ^ content type check
             -> (c -> DelayedIO a)  -- ^ body check
             -> Delayed env b
addBodyCheck :: Delayed env (a -> b)
-> DelayedIO c -> (c -> DelayedIO a) -> Delayed env b
addBodyCheck Delayed{DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (a -> b)
contentType -> DelayedIO body
serverD :: captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (a -> b)
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
serverD :: ()
bodyD :: ()
headersD :: ()
paramsD :: ()
contentD :: ()
acceptD :: forall env c. Delayed env c -> DelayedIO ()
authD :: ()
methodD :: forall env c. Delayed env c -> DelayedIO ()
capturesD :: ()
..} DelayedIO c
newContentD c -> DelayedIO a
newBodyD =
  Delayed :: forall env captures auth contentType params headers body c.
(env -> DelayedIO captures)
-> DelayedIO ()
-> DelayedIO auth
-> DelayedIO ()
-> DelayedIO contentType
-> DelayedIO params
-> DelayedIO headers
-> (contentType -> DelayedIO body)
-> (captures
    -> params -> headers -> auth -> body -> Request -> RouteResult c)
-> Delayed env c
Delayed
    { contentD :: DelayedIO (contentType, c)
contentD = (,) (contentType -> c -> (contentType, c))
-> DelayedIO contentType -> DelayedIO (c -> (contentType, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DelayedIO contentType
contentD DelayedIO (c -> (contentType, c))
-> DelayedIO c -> DelayedIO (contentType, c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DelayedIO c
newContentD
    , bodyD :: (contentType, c) -> DelayedIO (body, a)
bodyD    = \(contentType
content, c
c) -> (,) (body -> a -> (body, a))
-> DelayedIO body -> DelayedIO (a -> (body, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> contentType -> DelayedIO body
bodyD contentType
content DelayedIO (a -> (body, a)) -> DelayedIO a -> DelayedIO (body, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> c -> DelayedIO a
newBodyD c
c
    , serverD :: captures
-> params
-> headers
-> auth
-> (body, a)
-> Request
-> RouteResult b
serverD  = \ captures
c params
p headers
h auth
a (body
z, a
v) Request
req -> ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
v) ((a -> b) -> b) -> RouteResult (a -> b) -> RouteResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (a -> b)
serverD captures
c params
p headers
h auth
a body
z Request
req
    , DelayedIO auth
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
headersD :: DelayedIO headers
paramsD :: DelayedIO params
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
headersD :: DelayedIO headers
paramsD :: DelayedIO params
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
..
    } -- Note [Existential Record Update]


-- | Add an accept header check before handling parameters.
-- In principle, we'd like
-- to take a bad body (400) response take precedence over a
-- failed accept check (406). BUT to allow streaming the body,
-- we cannot run the body check and then still backtrack.
-- We therefore do the accept check before the body check,
-- when we can still backtrack. There are other solutions to
-- this, but they'd be more complicated (such as delaying the
-- body check further so that it can still be run in a situation
-- where we'd otherwise report 406).
addAcceptCheck :: Delayed env a
               -> DelayedIO ()
               -> Delayed env a
addAcceptCheck :: Delayed env a -> DelayedIO () -> Delayed env a
addAcceptCheck Delayed{DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
captures
-> params -> headers -> auth -> body -> Request -> RouteResult a
contentType -> DelayedIO body
serverD :: captures
-> params -> headers -> auth -> body -> Request -> RouteResult a
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
serverD :: ()
bodyD :: ()
headersD :: ()
paramsD :: ()
contentD :: ()
acceptD :: forall env c. Delayed env c -> DelayedIO ()
authD :: ()
methodD :: forall env c. Delayed env c -> DelayedIO ()
capturesD :: ()
..} DelayedIO ()
new =
  Delayed :: forall env captures auth contentType params headers body c.
(env -> DelayedIO captures)
-> DelayedIO ()
-> DelayedIO auth
-> DelayedIO ()
-> DelayedIO contentType
-> DelayedIO params
-> DelayedIO headers
-> (contentType -> DelayedIO body)
-> (captures
    -> params -> headers -> auth -> body -> Request -> RouteResult c)
-> Delayed env c
Delayed
    { acceptD :: DelayedIO ()
acceptD = DelayedIO ()
acceptD DelayedIO () -> DelayedIO () -> DelayedIO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> DelayedIO ()
new
    , DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
captures
-> params -> headers -> auth -> body -> Request -> RouteResult a
contentType -> DelayedIO body
serverD :: captures
-> params -> headers -> auth -> body -> Request -> RouteResult a
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
serverD :: captures
-> params -> headers -> auth -> body -> Request -> RouteResult a
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
..
    } -- Note [Existential Record Update]

-- | Many combinators extract information that is passed to
-- the handler without the possibility of failure. In such a
-- case, 'passToServer' can be used.
passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b
passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b
passToServer Delayed{DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (a -> b)
contentType -> DelayedIO body
serverD :: captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (a -> b)
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
serverD :: ()
bodyD :: ()
headersD :: ()
paramsD :: ()
contentD :: ()
acceptD :: forall env c. Delayed env c -> DelayedIO ()
authD :: ()
methodD :: forall env c. Delayed env c -> DelayedIO ()
capturesD :: ()
..} Request -> a
x =
  Delayed :: forall env captures auth contentType params headers body c.
(env -> DelayedIO captures)
-> DelayedIO ()
-> DelayedIO auth
-> DelayedIO ()
-> DelayedIO contentType
-> DelayedIO params
-> DelayedIO headers
-> (contentType -> DelayedIO body)
-> (captures
    -> params -> headers -> auth -> body -> Request -> RouteResult c)
-> Delayed env c
Delayed
    { serverD :: captures
-> params -> headers -> auth -> body -> Request -> RouteResult b
serverD = \ captures
c params
p headers
h auth
a body
b Request
req -> ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ Request -> a
x Request
req) ((a -> b) -> b) -> RouteResult (a -> b) -> RouteResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> captures
-> params
-> headers
-> auth
-> body
-> Request
-> RouteResult (a -> b)
serverD captures
c params
p headers
h auth
a body
b Request
req
    , DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
contentType -> DelayedIO body
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
..
    } -- Note [Existential Record Update]

-- | Run a delayed server. Performs all scheduled operations
-- in order, and passes the results from the capture and body
-- blocks on to the actual handler.
--
-- This should only be called once per request; otherwise the guarantees about
-- effect and HTTP error ordering break down.
runDelayed :: Delayed env a
           -> env
           -> Request
           -> ResourceT IO (RouteResult a)
runDelayed :: Delayed env a -> env -> Request -> ResourceT IO (RouteResult a)
runDelayed Delayed{DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
captures
-> params -> headers -> auth -> body -> Request -> RouteResult a
contentType -> DelayedIO body
serverD :: captures
-> params -> headers -> auth -> body -> Request -> RouteResult a
bodyD :: contentType -> DelayedIO body
headersD :: DelayedIO headers
paramsD :: DelayedIO params
contentD :: DelayedIO contentType
acceptD :: DelayedIO ()
authD :: DelayedIO auth
methodD :: DelayedIO ()
capturesD :: env -> DelayedIO captures
serverD :: ()
bodyD :: ()
headersD :: ()
paramsD :: ()
contentD :: ()
acceptD :: forall env c. Delayed env c -> DelayedIO ()
authD :: ()
methodD :: forall env c. Delayed env c -> DelayedIO ()
capturesD :: ()
..} env
env = DelayedIO a -> Request -> ResourceT IO (RouteResult a)
forall a. DelayedIO a -> Request -> ResourceT IO (RouteResult a)
runDelayedIO (DelayedIO a -> Request -> ResourceT IO (RouteResult a))
-> DelayedIO a -> Request -> ResourceT IO (RouteResult a)
forall a b. (a -> b) -> a -> b
$ do
    Request
r <- DelayedIO Request
forall r (m :: * -> *). MonadReader r m => m r
ask
    captures
c <- env -> DelayedIO captures
capturesD env
env
    DelayedIO ()
methodD
    auth
a <- DelayedIO auth
authD
    DelayedIO ()
acceptD
    contentType
content <- DelayedIO contentType
contentD
    params
p <- DelayedIO params
paramsD       -- Has to be before body parsing, but after content-type checks
    headers
h <- DelayedIO headers
headersD
    body
b <- contentType -> DelayedIO body
bodyD contentType
content
    RouteResult a -> DelayedIO a
forall a. RouteResult a -> DelayedIO a
liftRouteResult (captures
-> params -> headers -> auth -> body -> Request -> RouteResult a
serverD captures
c params
p headers
h auth
a body
b Request
r)

-- | Runs a delayed server and the resulting action.
-- Takes a continuation that lets us send a response.
-- Also takes a continuation for how to turn the
-- result of the delayed server into a response.
runAction :: Delayed env (Handler a)
          -> env
          -> Request
          -> (RouteResult Response -> IO r)
          -> (a -> RouteResult Response)
          -> IO r
runAction :: Delayed env (Handler a)
-> env
-> Request
-> (RouteResult Response -> IO r)
-> (a -> RouteResult Response)
-> IO r
runAction Delayed env (Handler a)
action env
env Request
req RouteResult Response -> IO r
respond a -> RouteResult Response
k = ResourceT IO r -> IO r
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO r -> IO r) -> ResourceT IO r -> IO r
forall a b. (a -> b) -> a -> b
$
    Delayed env (Handler a)
-> env -> Request -> ResourceT IO (RouteResult (Handler a))
forall env a.
Delayed env a -> env -> Request -> ResourceT IO (RouteResult a)
runDelayed Delayed env (Handler a)
action env
env Request
req ResourceT IO (RouteResult (Handler a))
-> (RouteResult (Handler a) -> ResourceT IO (RouteResult Response))
-> ResourceT IO (RouteResult Response)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RouteResult (Handler a) -> ResourceT IO (RouteResult Response)
go ResourceT IO (RouteResult Response)
-> (RouteResult Response -> ResourceT IO r) -> ResourceT IO r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO r -> ResourceT IO r
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO r -> ResourceT IO r)
-> (RouteResult Response -> IO r)
-> RouteResult Response
-> ResourceT IO r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RouteResult Response -> IO r
respond
  where
    go :: RouteResult (Handler a) -> ResourceT IO (RouteResult Response)
go (Fail ServerError
e)      = RouteResult Response -> ResourceT IO (RouteResult Response)
forall (m :: * -> *) a. Monad m => a -> m a
return (RouteResult Response -> ResourceT IO (RouteResult Response))
-> RouteResult Response -> ResourceT IO (RouteResult Response)
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult Response
forall a. ServerError -> RouteResult a
Fail ServerError
e
    go (FailFatal ServerError
e) = RouteResult Response -> ResourceT IO (RouteResult Response)
forall (m :: * -> *) a. Monad m => a -> m a
return (RouteResult Response -> ResourceT IO (RouteResult Response))
-> RouteResult Response -> ResourceT IO (RouteResult Response)
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult Response
forall a. ServerError -> RouteResult a
FailFatal ServerError
e
    go (Route Handler a
a)     = IO (RouteResult Response) -> ResourceT IO (RouteResult Response)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RouteResult Response) -> ResourceT IO (RouteResult Response))
-> IO (RouteResult Response) -> ResourceT IO (RouteResult Response)
forall a b. (a -> b) -> a -> b
$ do
      Either ServerError a
e <- Handler a -> IO (Either ServerError a)
forall a. Handler a -> IO (Either ServerError a)
runHandler Handler a
a
      case Either ServerError a
e of
        Left ServerError
err -> RouteResult Response -> IO (RouteResult Response)
forall (m :: * -> *) a. Monad m => a -> m a
return (RouteResult Response -> IO (RouteResult Response))
-> (Response -> RouteResult Response)
-> Response
-> IO (RouteResult Response)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> RouteResult Response
forall a. a -> RouteResult a
Route (Response -> IO (RouteResult Response))
-> Response -> IO (RouteResult Response)
forall a b. (a -> b) -> a -> b
$ ServerError -> Response
responseServerError ServerError
err
        Right a
x  -> RouteResult Response -> IO (RouteResult Response)
forall (m :: * -> *) a. Monad m => a -> m a
return (RouteResult Response -> IO (RouteResult Response))
-> RouteResult Response -> IO (RouteResult Response)
forall a b. (a -> b) -> a -> b
$! a -> RouteResult Response
k a
x

{- Note [Existential Record Update]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot
do the more succinct thing - just update the records we actually change.
-}