respondSource

yesod-core/Yesod/Core/Handler.hs

@@ -54,6 +54,8 @@ module Yesod.Core.Handler
     , lookupCookies
     , lookupFiles
       -- * Special responses
+      -- ** Streaming
+    , respondSource
       -- ** Redirecting
     , RedirectUrl (..)
     , redirect
@@ -139,7 +141,7 @@ import           Control.Monad.Trans.Resource  (MonadResource, liftResourceT)
 import qualified Network.HTTP.Types            as H
 import qualified Network.Wai                   as W
 import Control.Monad.Trans.Class (lift)
-import Data.Conduit (transPipe)
+import Data.Conduit (transPipe, Flush)
 
 import qualified Data.Text                     as T
 import           Data.Text.Encoding            (decodeUtf8With, encodeUtf8)
@@ -173,6 +175,7 @@ import           Yesod.Core.Class.Handler
 import           Yesod.Core.Types
 import           Yesod.Routes.Class            (Route)
 import Control.Failure (failure)
+import Blaze.ByteString.Builder (Builder)
 
 get :: MonadHandler m => m GHState
 get = liftHandlerT $ HandlerT $ I.readIORef . handlerState
@@ -894,7 +897,7 @@ provideRepType ct handler =
 -- | Stream in the raw request body without any parsing.
 --
 -- Since 1.2.0
-rawRequestBody :: (MonadHandler m, MonadResource m) => Source m S.ByteString
+rawRequestBody :: MonadHandler m => Source m S.ByteString
 rawRequestBody = do
     req <- lift waiRequest
     transPipe liftResourceT $ W.requestBody req
@@ -903,3 +906,16 @@ rawRequestBody = do
 -- to work in any @MonadResource@.
 fileSource :: MonadResource m => FileInfo -> Source m S.ByteString
 fileSource = transPipe liftResourceT . fileSourceRaw
+
+-- | Use a @Source@ for the response body.
+--
+-- Since 1.2.0
+respondSource :: ContentType
+              -> Source (HandlerT site IO) (Flush Builder)
+              -> HandlerT site IO TypedContent
+respondSource ctype src = HandlerT $ \hd ->
+    -- Note that this implementation relies on the fact that the ResourceT
+    -- environment provided by the server is the same one used in HandlerT.
+    -- This is a safe assumption assuming the HandlerT is run correctly.
+    return $ TypedContent ctype $ ContentSource
+           $ transPipe (lift . flip unHandlerT hd) src

yesod-core/Yesod/Core/Internal/LiteApp.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE PatternGuards #-}
 module Yesod.Core.Internal.LiteApp where
 
-import Yesod.Routes.Dispatch
 import Yesod.Routes.Class
 import Data.Monoid
 import Yesod.Core.Class.Yesod
@@ -11,9 +10,6 @@ import Yesod.Core.Types
 import Yesod.Core.Content
 import Data.Text (Text)
 import Web.PathPieces
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.ByteString (ByteString)
 import Network.Wai
 import Yesod.Core.Handler
 import Yesod.Core.Internal.Run

yesod-core/test/YesodCoreTest.hs

@@ -14,6 +14,7 @@ import qualified YesodCoreTest.Redirect as Redirect
 import qualified YesodCoreTest.JsLoader as JsLoader
 import qualified YesodCoreTest.RequestBodySize as RequestBodySize
 import qualified YesodCoreTest.Json as Json
+import qualified YesodCoreTest.Streaming as Streaming
 import qualified YesodCoreTest.Reps as Reps
 import qualified YesodCoreTest.Auth as Auth
 import qualified YesodCoreTest.LiteApp as LiteApp
@@ -36,6 +37,7 @@ specs = do
       JsLoader.specs
       RequestBodySize.specs
       Json.specs
+      Streaming.specs
       Reps.specs
       Auth.specs
       LiteApp.specs

yesod-core/test/YesodCoreTest/Streaming.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+module YesodCoreTest.Streaming (specs) where
+
+import Yesod.Core
+import Test.Hspec
+import Network.Wai.Test
+import Data.Conduit
+import Blaze.ByteString.Builder (fromByteString)
+
+app :: LiteApp
+app = dispatchTo $ respondSource typeHtml $
+    yield $ Chunk $ fromByteString "Hello World!"
+
+test :: String
+     -> (SResponse -> Session ())
+     -> Spec
+test name f = it name $ do
+    wapp <- toWaiApp app
+    flip runSession wapp $ do
+        sres <- request defaultRequest
+        f sres
+
+specs :: Spec
+specs = describe "Streaming" $ do
+    test "works" $ \sres -> do
+        assertStatus 200 sres
+        assertBody "Hello World!" sres