diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 9f47770d..f82d775a 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/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 diff --git a/yesod-core/Yesod/Core/Internal/LiteApp.hs b/yesod-core/Yesod/Core/Internal/LiteApp.hs index 264d44d8..c9dd4887 100644 --- a/yesod-core/Yesod/Core/Internal/LiteApp.hs +++ b/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 diff --git a/yesod-core/test/YesodCoreTest.hs b/yesod-core/test/YesodCoreTest.hs index e8eec4b5..60a1cb2e 100644 --- a/yesod-core/test/YesodCoreTest.hs +++ b/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 diff --git a/yesod-core/test/YesodCoreTest/Streaming.hs b/yesod-core/test/YesodCoreTest/Streaming.hs new file mode 100644 index 00000000..27236f01 --- /dev/null +++ b/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