@@ -52,6 +52,7 @@ toApplication ra request respond = ra request routingRespond
52-- static routes (can cause 404)
52-- static routes (can cause 404)
53-- delayed captures (can cause 404)
53-- delayed captures (can cause 404)
54-- methods (can cause 405)
54-- methods (can cause 405)
55+-- authentication and authorization (can cause 401, 403)
55-- delayed body (can cause 415, 400)
56-- delayed body (can cause 415, 400)
56-- accept header (can cause 406)
57-- accept header (can cause 406)
@@ -119,36 +120,71 @@ toApplication ra request respond = ra request routingRespond
119-- The accept header check can be performed as the final
120-- The accept header check can be performed as the final
120-- computation in this block. It can cause a 406.
121-- computation in this block. It can cause a 406.
122−data Delayed :: * -> * where
123+data Delayed c where
123− Delayed :: IO (RouteResult a)
124+ Delayed :: { capturesD :: IO (RouteResult captures)
124− -> IO (RouteResult ())
125+ , methodD :: IO (RouteResult ())
125− -> IO (RouteResult b)
126+ , authD :: IO (RouteResult auth)
127+ , bodyD :: IO (RouteResult body)
126− -> (a -> b -> RouteResult c)
128+ , serverD :: (captures -> auth -> body -> RouteResult c)
127− -> Delayed c
129+ } -> Delayed c
129instance Functor Delayed where
131instance 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
137+ , serverD = (fmap.fmap.fmap.fmap) f serverD
138+ } -- Note [Existential Record Update]
132-- | Add a capture to the end of the capture block.
140-- | Add a capture to the end of the capture block.
133addCapture :: Delayed (a -> b)
141addCapture :: Delayed (a -> b)
134 -> IO (RouteResult a)
142 -> IO (RouteResult a)
135 -> Delayed b
143 -> Delayed b
136−addCapture (Delayed captures method body server) new =
144+addCapture Delayed{..} new
137− Delayed (combineRouteResults (,) captures new) method body (\ (x, v) y -> ($ v) <$> server x y)
145+ = Delayed { capturesD = combineRouteResults (,) capturesD new
149+ , serverD = \ (x, v) y z -> ($ v) <$> serverD x y z
150+ } -- Note [Existential Record Update]
139-- | Add a method check to the end of the method block.
152-- | Add a method check to the end of the method block.
140addMethodCheck :: Delayed a
153addMethodCheck :: Delayed a
141 -> IO (RouteResult ())
154 -> IO (RouteResult ())
142 -> Delayed a
155 -> Delayed a
143−addMethodCheck (Delayed captures method body server) new =
156+addMethodCheck Delayed{..} new
157+ = Delayed { capturesD = capturesD
144− Delayed captures (combineRouteResults const method new) body server
158+ , methodD = combineRouteResults const methodD new
162+ } -- Note [Existential Record Update]
164+-- | Add an auth check to the end of the auth block.
165+addAuthCheck :: Delayed (a -> b)
166+ -> IO (RouteResult a)
168+addAuthCheck Delayed{..} new
169+ = Delayed { capturesD = capturesD
171+ , authD = combineRouteResults (,) authD new
173+ , serverD = \ x (y, v) z -> ($ v) <$> serverD x y z
174+ } -- Note [Existential Record Update]
146-- | Add a body check to the end of the body block.
176-- | Add a body check to the end of the body block.
147addBodyCheck :: Delayed (a -> b)
177addBodyCheck :: Delayed (a -> b)
148 -> IO (RouteResult a)
178 -> IO (RouteResult a)
149 -> Delayed b
179 -> Delayed b
150−addBodyCheck (Delayed captures method body server) new =
180+addBodyCheck Delayed{..} new
181+ = Delayed { capturesD = capturesD
151− Delayed captures method (combineRouteResults (,) body new) (\ x (y, v) -> ($ v) <$> server x y)
184+ , bodyD = combineRouteResults (,) bodyD new
185+ , serverD = \ x y (z, v) -> ($ v) <$> serverD x y z
186+ } -- Note [Existential Record Update]
153-- | Add an accept header check to the end of the body block.
189-- | Add an accept header check to the end of the body block.
154-- The accept header check should occur after the body check,
190-- The accept header check should occur after the body check,
@@ -157,8 +193,13 @@ addBodyCheck (Delayed captures method body server) new =
157addAcceptCheck :: Delayed a
193addAcceptCheck :: Delayed a
158 -> IO (RouteResult ())
194 -> IO (RouteResult ())
159 -> Delayed a
195 -> Delayed a
160−addAcceptCheck (Delayed captures method body server) new =
196+addAcceptCheck Delayed{..} new
197+ = Delayed { capturesD = capturesD
161− Delayed captures method (combineRouteResults const body new) server
200+ , bodyD = combineRouteResults const bodyD new
202+ } -- Note [Existential Record Update]
163-- | Many combinators extract information that is passed to
204-- | Many combinators extract information that is passed to
164-- the handler without the possibility of failure. In such a
205-- the handler without the possibility of failure. In such a
@@ -190,13 +231,17 @@ combineRouteResults f m1 m2 =
190-- | Run a delayed server. Performs all scheduled operations
231-- | Run a delayed server. Performs all scheduled operations
191-- in order, and passes the results from the capture and body
232-- in order, and passes the results from the capture and body
192-- blocks on to the actual handler.
233-- blocks on to the actual handler.
235+-- This should only be called once per request; otherwise the guarantees about
236+-- effect and HTTP error ordering break down.
193runDelayed :: Delayed a
237runDelayed :: Delayed a
194 -> IO (RouteResult a)
238 -> IO (RouteResult a)
195−runDelayed (Delayed captures method body server) =
239+runDelayed Delayed{..} =
196− captures `bindRouteResults` \ c ->
240+ capturesD `bindRouteResults` \ c ->
197− method `bindRouteResults` \ _ ->
241+ methodD `bindRouteResults` \ _ ->
242+ authD `bindRouteResults` \ a ->
198− body `bindRouteResults` \ b ->
243+ bodyD `bindRouteResults` \ b ->
199− return (server c b)
244+ return (serverD c a b)
201-- | Runs a delayed server and the resulting action.
246-- | Runs a delayed server and the resulting action.
202-- Takes a continuation that lets us send a response.
247-- Takes a continuation that lets us send a response.
@@ -215,3 +260,10 @@ runAction action respond k = runDelayed action >>= go >>= respond
215 case e of
260 case e of
216 Left err -> return . Route $ responseServantErr err
261 Left err -> return . Route $ responseServantErr err
217 Right x -> return $! k x
262 Right x -> return $! k x
264+{- Note [Existential Record Update]
265+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.