Full support for ResponseEnumerator

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
+    yar <- unYesodApp ya eh rr types sessionMap
-    let sessionVal =
+    case yar of
-            case key' of
+        YARPlain s hs ct c sessionFinal -> do
-                Nothing -> B.empty
+            let sessionVal =
-                Just key'' ->
+                    case key' of
-                     encodeSession key'' exp' host
+                        Nothing -> B.empty
-                   $ Map.toList
+                        Just key'' ->
-                   $ Map.insert nonceKey (reqNonce rr) sessionFinal
+                             encodeSession key'' exp' host
-    let hs' =
+                           $ Map.toList
-            case key' of
+                           $ Map.insert nonceKey (reqNonce rr) sessionFinal
-                Nothing -> hs
+            let hs' =
-                Just _ -> AddCookie
+                    case key' of
-                            (clientSessionDuration y)
+                        Nothing -> hs
-                            sessionName
+                        Just _ -> AddCookie
-                            (bsToChars sessionVal)
+                                    (clientSessionDuration y)
-                          : hs
+                                    sessionName
-        hs'' = map (headerToPair getExpires) hs'
+                                    (bsToChars sessionVal)
-        hs''' = ("Content-Type", charsToBs ct) : hs''
+                                  : hs
-    return $
+                hs'' = map (headerToPair getExpires) hs'
-        case c of
+                hs''' = ("Content-Type", charsToBs ct) : hs''
-            ContentLBS lbs -> W.ResponseLBS s hs''' lbs
+            return $
-            ContentFile fp -> W.ResponseFile s hs''' fp
+                case c of
-            ContentEnum e -> W.ResponseEnumerator $ \iter ->
+                    ContentLBS lbs -> W.ResponseLBS s hs''' lbs
-                run_ $ e $$ iter s hs'''
+                    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

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
+            yar <- unYesodApp (eh e) safeEh rr cts finalSession
-            let hs' = headers hs
+            case yar of
-            return (getStatus e, hs', ct, c, sess)
+                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,
+            return $ YARPlain
-                    finalSession)
+                (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,
+            return $ YARPlain
-                    emptyContent,
+                (W.Status 201 (S8.pack "Created"))
-                    finalSession)
+                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",
+    return $ YARPlain
-            session)
+        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