@@ -52,6 +52,7 @@ toApplication ra request respond = ra request routingRespond
5252-- static routes (can cause 404)
5353-- delayed captures (can cause 404)
5454-- methods (can cause 405)
55+-- authentication and authorization (can cause 401, 403)
5556-- delayed body (can cause 415, 400)
5657-- accept header (can cause 406)
5758--
@@ -119,36 +120,71 @@ toApplication ra request respond = ra request routingRespond
119120-- The accept header check can be performed as the final
120121-- computation in this block. It can cause a 406.
121122--
122−data Delayed :: * -> * where
123− Delayed :: IO (RouteResult a)
124− -> IO (RouteResult ())
125− -> IO (RouteResult b)
126− -> (a -> b -> RouteResult c)
127− -> Delayed c
123+data Delayed c where
124+ Delayed :: { capturesD :: IO (RouteResult captures)
125+ , methodD :: IO (RouteResult ())
126+ , authD :: IO (RouteResult auth)
127+ , bodyD :: IO (RouteResult body)
128+ , serverD :: (captures -> auth -> body -> RouteResult c)
129+ } -> Delayed c
128130
129131instance Functor Delayed where
130− fmap f (Delayed a b c g) = Delayed a b c ((fmap . fmap . fmap) f g)
132+ fmap f Delayed{..}
133+ = Delayed { capturesD = capturesD
134+ , methodD = methodD
135+ , authD = authD
136+ , bodyD = bodyD
137+ , serverD = (fmap.fmap.fmap.fmap) f serverD
138+ } -- Note [Existential Record Update]
131139
132140-- | Add a capture to the end of the capture block.
133141addCapture :: Delayed (a -> b)
134142 -> IO (RouteResult a)
135143 -> Delayed b
136−addCapture (Delayed captures method body server) new =
137− Delayed (combineRouteResults (,) captures new) method body (\ (x, v) y -> ($ v) <$> server x y)
144+addCapture Delayed{..} new
145+ = Delayed { capturesD = combineRouteResults (,) capturesD new
146+ , methodD = methodD
147+ , authD = authD
148+ , bodyD = bodyD
149+ , serverD = \ (x, v) y z -> ($ v) <$> serverD x y z
150+ } -- Note [Existential Record Update]
138151
139152-- | Add a method check to the end of the method block.
140153addMethodCheck :: Delayed a
141154 -> IO (RouteResult ())
142155 -> Delayed a
143−addMethodCheck (Delayed captures method body server) new =
144− Delayed captures (combineRouteResults const method new) body server
156+addMethodCheck Delayed{..} new
157+ = Delayed { capturesD = capturesD
158+ , methodD = combineRouteResults const methodD new
159+ , authD = authD
160+ , bodyD = bodyD
161+ , serverD = serverD
162+ } -- Note [Existential Record Update]
163+
164+-- | Add an auth check to the end of the auth block.
165+addAuthCheck :: Delayed (a -> b)
166+ -> IO (RouteResult a)
167+ -> Delayed b
168+addAuthCheck Delayed{..} new
169+ = Delayed { capturesD = capturesD
170+ , methodD = methodD
171+ , authD = combineRouteResults (,) authD new
172+ , bodyD = bodyD
173+ , serverD = \ x (y, v) z -> ($ v) <$> serverD x y z
174+ } -- Note [Existential Record Update]
145175
146176-- | Add a body check to the end of the body block.
147177addBodyCheck :: Delayed (a -> b)
148178 -> IO (RouteResult a)
149179 -> Delayed b
150−addBodyCheck (Delayed captures method body server) new =
151− Delayed captures method (combineRouteResults (,) body new) (\ x (y, v) -> ($ v) <$> server x y)
180+addBodyCheck Delayed{..} new
181+ = Delayed { capturesD = capturesD
182+ , methodD = methodD
183+ , authD = authD
184+ , bodyD = combineRouteResults (,) bodyD new
185+ , serverD = \ x y (z, v) -> ($ v) <$> serverD x y z
186+ } -- Note [Existential Record Update]
187+
152188
153189-- | Add an accept header check to the end of the body block.
154190-- The accept header check should occur after the body check,
@@ -157,8 +193,13 @@ addBodyCheck (Delayed captures method body server) new =
157193addAcceptCheck :: Delayed a
158194 -> IO (RouteResult ())
159195 -> Delayed a
160−addAcceptCheck (Delayed captures method body server) new =
161− Delayed captures method (combineRouteResults const body new) server
196+addAcceptCheck Delayed{..} new
197+ = Delayed { capturesD = capturesD
198+ , methodD = methodD
199+ , authD = authD
200+ , bodyD = combineRouteResults const bodyD new
201+ , serverD = serverD
202+ } -- Note [Existential Record Update]
162203
163204-- | Many combinators extract information that is passed to
164205-- the handler without the possibility of failure. In such a
@@ -190,13 +231,17 @@ combineRouteResults f m1 m2 =
190231-- | Run a delayed server. Performs all scheduled operations
191232-- in order, and passes the results from the capture and body
192233-- blocks on to the actual handler.
234+--
235+-- This should only be called once per request; otherwise the guarantees about
236+-- effect and HTTP error ordering break down.
193237runDelayed :: Delayed a
194238 -> IO (RouteResult a)
195−runDelayed (Delayed captures method body server) =
196− captures `bindRouteResults` \ c ->
197− method `bindRouteResults` \ _ ->
198− body `bindRouteResults` \ b ->
199− return (server c b)
239+runDelayed Delayed{..} =
240+ capturesD `bindRouteResults` \ c ->
241+ methodD `bindRouteResults` \ _ ->
242+ authD `bindRouteResults` \ a ->
243+ bodyD `bindRouteResults` \ b ->
244+ return (serverD c a b)
200245
201246-- | Runs a delayed server and the resulting action.
202247-- Takes a continuation that lets us send a response.
@@ -215,3 +260,10 @@ runAction action respond k = runDelayed action >>= go >>= respond
215260 case e of
216261 Left err -> return . Route $ responseServantErr err
217262 Right x -> return $! k x
263+
264+{- Note [Existential Record Update]
265+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
266+
267+Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot
268+do the more succint thing - just update the records we actually change.
269+-}