From b2e95911d853bf098e95c49ce29f470e8e14f94e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 16 Dec 2010 21:38:01 +0200 Subject: [PATCH] Full support for ResponseEnumerator --- Yesod/Dispatch.hs | 51 +++++++++++++++++++++-------------------- Yesod/Handler.hs | 58 +++++++++++++++++++++++++++++++++-------------- 2 files changed, 68 insertions(+), 41 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index bc508a39..27847cfc 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -313,30 +313,33 @@ toWaiApp' y key' segments env = do let ya = runHandler h render eurl' id y id let sessionMap = Map.fromList $ filter (\(x, _) -> x /= nonceKey) session' - (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types sessionMap - let sessionVal = - case key' of - Nothing -> B.empty - Just key'' -> - encodeSession key'' exp' host - $ Map.toList - $ Map.insert nonceKey (reqNonce rr) sessionFinal - let hs' = - case key' of - Nothing -> hs - Just _ -> AddCookie - (clientSessionDuration y) - sessionName - (bsToChars sessionVal) - : hs - hs'' = map (headerToPair getExpires) hs' - hs''' = ("Content-Type", charsToBs ct) : hs'' - return $ - case c of - ContentLBS lbs -> W.ResponseLBS s hs''' lbs - ContentFile fp -> W.ResponseFile s hs''' fp - ContentEnum e -> W.ResponseEnumerator $ \iter -> - run_ $ e $$ iter s hs''' + yar <- unYesodApp ya eh rr types sessionMap + case yar of + YARPlain s hs ct c sessionFinal -> do + let sessionVal = + case key' of + Nothing -> B.empty + Just key'' -> + encodeSession key'' exp' host + $ Map.toList + $ Map.insert nonceKey (reqNonce rr) sessionFinal + let hs' = + case key' of + Nothing -> hs + Just _ -> AddCookie + (clientSessionDuration y) + sessionName + (bsToChars sessionVal) + : hs + hs'' = map (headerToPair getExpires) hs' + hs''' = ("Content-Type", charsToBs ct) : hs'' + return $ + case c of + ContentLBS lbs -> W.ResponseLBS s hs''' lbs + ContentFile fp -> W.ResponseFile s hs''' fp + ContentEnum e -> W.ResponseEnumerator $ \iter -> + run_ $ e $$ iter s hs''' + YAREnum e -> return $ W.ResponseEnumerator e httpAccept :: W.Request -> [ContentType] httpAccept = map B.unpack diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 7bb01d74..1420a8f4 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -51,6 +51,7 @@ module Yesod.Handler , sendResponse , sendResponseStatus , sendResponseCreated + , sendResponseEnumerator -- * Setting headers , setCookie , deleteCookie @@ -85,6 +86,7 @@ module Yesod.Handler , localNoCurrent , HandlerData , ErrorResponse (..) + , YesodAppResult (..) #if TEST , testSuite #endif @@ -232,15 +234,20 @@ newtype YesodApp = YesodApp -> Request -> [ContentType] -> SessionMap - -> IO (W.Status, [Header], ContentType, Content, SessionMap) + -> IO YesodAppResult } +data YesodAppResult + = YAREnum (forall a. W.ResponseEnumerator a) + | YARPlain W.Status [Header] ContentType Content SessionMap + data HandlerContents = HCContent W.Status ChooseRep | HCError ErrorResponse | HCSendFile ContentType FilePath | HCRedirect RedirectType String | HCCreated String + | HCEnum (forall a. W.ResponseEnumerator a) instance Failure ErrorResponse (GHandler sub master) where failure = GHandler . lift . throwMEither . HCError @@ -307,34 +314,46 @@ runHandler handler mrender sroute tomr ma tosa = ) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), initSession)) let contents = meither id (HCContent W.status200 . chooseRep) contents' let handleError e = do - (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts finalSession - let hs' = headers hs - return (getStatus e, hs', ct, c, sess) + yar <- unYesodApp (eh e) safeEh rr cts finalSession + case yar of + YARPlain _ hs ct c sess -> + let hs' = headers hs + in return $ YARPlain (getStatus e) hs' ct c sess + YAREnum _ -> return yar let sendFile' ct fp = - return (W.status200, headers [], ct, ContentFile fp, finalSession) + return $ YARPlain W.status200 (headers []) ct (ContentFile fp) finalSession case contents of HCContent status a -> do (ct, c) <- chooseRep a cts - return (status, headers [], ct, c, finalSession) + return $ YARPlain status (headers []) ct c finalSession HCError e -> handleError e HCRedirect rt loc -> do let hs = Header "Location" loc : headers [] - return (getRedirectStatus rt, hs, typePlain, emptyContent, - finalSession) + return $ YARPlain + (getRedirectStatus rt) hs typePlain emptyContent + finalSession HCSendFile ct fp -> E.catch (sendFile' ct fp) (handleError . toErrorHandler) - HCCreated loc -> do + HCCreated loc -> do -- FIXME add status201 to WAI let hs = Header "Location" loc : headers [] - return (W.Status 201 (S8.pack "Created"), hs, typePlain, - emptyContent, - finalSession) + return $ YARPlain + (W.Status 201 (S8.pack "Created")) + hs + typePlain + emptyContent + finalSession + HCEnum e -> return $ YAREnum e safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ session -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return (W.status500, [], typePlain, toContent "Internal Server Error", - session) + return $ YARPlain + W.status500 + [] + typePlain + (toContent "Internal Server Error") + session -- | Redirect to the given route. redirect :: RedirectType -> Route master -> GHandler sub master a @@ -439,6 +458,14 @@ sendResponseCreated url = do r <- getUrlRender GHandler $ lift $ throwMEither $ HCCreated $ r url +-- | Send a 'W.ResponseEnumerator'. Please note: this function is rarely +-- necessary, and will /disregard/ any changes to response headers and session +-- that you have already specified. This function short-circuits. It should be +-- considered only for they specific needs. If you are not sure if you need it, +-- you don't. +sendResponseEnumerator :: (forall a. W.ResponseEnumerator a) -> GHandler s m b +sendResponseEnumerator = GHandler . lift . throwMEither . HCEnum + -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a notFound = failure NotFound @@ -559,6 +586,3 @@ testSuite = testGroup "Yesod.Handler" ] #endif - --- FIXME add a sendEnum that uses a ResponseEnumerator and bypasses all status --- and header stuff