From 84172c613554af58db1f9736c3e148d4d90d6179 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 19:00:31 +0100 Subject: [PATCH] Augment Delayed to handle authentication. --- .../Server/Internal/RoutingApplication.hs | 92 +++++++++++++++---- 1 file changed, 72 insertions(+), 20 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 3be47123..7e846504 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -52,6 +52,7 @@ toApplication ra request respond = ra request routingRespond -- static routes (can cause 404) -- delayed captures (can cause 404) -- methods (can cause 405) +-- authentication and authorization (can cause 401, 403) -- delayed body (can cause 415, 400) -- accept header (can cause 406) -- @@ -119,36 +120,71 @@ toApplication ra request respond = ra request routingRespond -- The accept header check can be performed as the final -- computation in this block. It can cause a 406. -- -data Delayed :: * -> * where - Delayed :: IO (RouteResult a) - -> IO (RouteResult ()) - -> IO (RouteResult b) - -> (a -> b -> RouteResult c) - -> Delayed c +data Delayed c where + Delayed :: { capturesD :: IO (RouteResult captures) + , methodD :: IO (RouteResult ()) + , authD :: IO (RouteResult auth) + , bodyD :: IO (RouteResult body) + , serverD :: (captures -> auth -> body -> RouteResult c) + } -> Delayed c instance Functor Delayed where - fmap f (Delayed a b c g) = Delayed a b c ((fmap . fmap . fmap) f g) + fmap f Delayed{..} + = Delayed { capturesD = capturesD + , methodD = methodD + , authD = authD + , bodyD = bodyD + , serverD = (fmap.fmap.fmap.fmap) f serverD + } -- Note [Existential Record Update] -- | Add a capture to the end of the capture block. addCapture :: Delayed (a -> b) -> IO (RouteResult a) -> Delayed b -addCapture (Delayed captures method body server) new = - Delayed (combineRouteResults (,) captures new) method body (\ (x, v) y -> ($ v) <$> server x y) +addCapture Delayed{..} new + = Delayed { capturesD = combineRouteResults (,) capturesD new + , methodD = methodD + , authD = authD + , bodyD = bodyD + , serverD = \ (x, v) y z -> ($ v) <$> serverD x y z + } -- Note [Existential Record Update] -- | Add a method check to the end of the method block. addMethodCheck :: Delayed a -> IO (RouteResult ()) -> Delayed a -addMethodCheck (Delayed captures method body server) new = - Delayed captures (combineRouteResults const method new) body server +addMethodCheck Delayed{..} new + = Delayed { capturesD = capturesD + , methodD = combineRouteResults const methodD new + , authD = authD + , bodyD = bodyD + , serverD = serverD + } -- Note [Existential Record Update] + +-- | Add an auth check to the end of the auth block. +addAuthCheck :: Delayed (a -> b) + -> IO (RouteResult a) + -> Delayed b +addAuthCheck Delayed{..} new + = Delayed { capturesD = capturesD + , methodD = methodD + , authD = combineRouteResults (,) authD new + , bodyD = bodyD + , serverD = \ x (y, v) z -> ($ v) <$> serverD x y z + } -- Note [Existential Record Update] -- | Add a body check to the end of the body block. addBodyCheck :: Delayed (a -> b) -> IO (RouteResult a) -> Delayed b -addBodyCheck (Delayed captures method body server) new = - Delayed captures method (combineRouteResults (,) body new) (\ x (y, v) -> ($ v) <$> server x y) +addBodyCheck Delayed{..} new + = Delayed { capturesD = capturesD + , methodD = methodD + , authD = authD + , bodyD = combineRouteResults (,) bodyD new + , serverD = \ x y (z, v) -> ($ v) <$> serverD x y z + } -- Note [Existential Record Update] + -- | Add an accept header check to the end of the body block. -- The accept header check should occur after the body check, @@ -157,8 +193,13 @@ addBodyCheck (Delayed captures method body server) new = addAcceptCheck :: Delayed a -> IO (RouteResult ()) -> Delayed a -addAcceptCheck (Delayed captures method body server) new = - Delayed captures method (combineRouteResults const body new) server +addAcceptCheck Delayed{..} new + = Delayed { capturesD = capturesD + , methodD = methodD + , authD = authD + , bodyD = combineRouteResults const bodyD new + , serverD = serverD + } -- Note [Existential Record Update] -- | Many combinators extract information that is passed to -- the handler without the possibility of failure. In such a @@ -190,13 +231,17 @@ combineRouteResults f m1 m2 = -- | 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 a -> IO (RouteResult a) -runDelayed (Delayed captures method body server) = - captures `bindRouteResults` \ c -> - method `bindRouteResults` \ _ -> - body `bindRouteResults` \ b -> - return (server c b) +runDelayed Delayed{..} = + capturesD `bindRouteResults` \ c -> + methodD `bindRouteResults` \ _ -> + authD `bindRouteResults` \ a -> + bodyD `bindRouteResults` \ b -> + return (serverD c a b) -- | Runs a delayed server and the resulting action. -- Takes a continuation that lets us send a response. @@ -215,3 +260,10 @@ runAction action respond k = runDelayed action >>= go >>= respond case e of Left err -> return . Route $ responseServantErr err Right x -> return $! k x + +{- Note [Existential Record Update] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Due to GHC issue , we cannot +do the more succint thing - just update the records we actually change. +-}