diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 7d4d5683..e8fe59b0 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -8,7 +8,7 @@ module Yesod.Content ( -- * Content - Content + Content (..) , emptyContent , ToContent (..) -- * Mime types @@ -57,8 +57,6 @@ import qualified Data.ByteString.Lazy as L import Data.Text.Lazy (Text) import qualified Data.Text as T -import qualified Network.Wai as W - import Data.Time import System.Locale @@ -72,11 +70,16 @@ import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit hiding (Test) #endif -type Content = W.ResponseBody +import Data.Enumerator (Enumerator) +import Blaze.ByteString.Builder (Builder) + +data Content = ContentLBS L.ByteString + | ContentEnum (forall a. Enumerator Builder IO a) + | ContentFile FilePath -- | Zero-length enumerator. emptyContent :: Content -emptyContent = W.ResponseLBS L.empty +emptyContent = ContentLBS L.empty -- | Anything which can be converted into 'Content'. Most of the time, you will -- want to use the 'ContentEnum' constructor. An easier approach will be to use @@ -86,13 +89,13 @@ class ToContent a where toContent :: a -> Content instance ToContent B.ByteString where - toContent = W.ResponseLBS . L.fromChunks . return + toContent = ContentLBS . L.fromChunks . return instance ToContent L.ByteString where - toContent = W.ResponseLBS + toContent = ContentLBS instance ToContent T.Text where toContent = toContent . Data.Text.Encoding.encodeUtf8 instance ToContent Text where - toContent = W.ResponseLBS . Data.Text.Lazy.Encoding.encodeUtf8 + toContent = ContentLBS . Data.Text.Lazy.Encoding.encodeUtf8 instance ToContent String where toContent = toContent . T.pack diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index afd94551..f95af393 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -43,7 +43,7 @@ import Web.Routes.Quasi.TH import Language.Haskell.TH.Syntax import qualified Network.Wai as W -import Network.Wai.Middleware.CleanPath (cleanPathFunc) +import Network.Wai.Middleware.CleanPath (cleanPath) import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Gzip @@ -75,6 +75,9 @@ import System.Random (randomR, newStdGen) import qualified Data.Map as Map +import Control.Applicative ((<$>)) +import Data.Enumerator (($$), run_) + #if TEST import Test.Framework (testGroup, Test) import Test.Framework.Providers.QuickCheck2 (testProperty) @@ -234,15 +237,25 @@ sessionName :: String sessionName = "_SESSION" -- | Convert the given argument into a WAI application, executable with any WAI --- handler. You can use 'basicHandler' if you wish. -toWaiApp :: (Yesod y, YesodSite y) => y -> IO W.Application -toWaiApp a = do +-- handler. This is the same as 'toWaiAppPlain', except it includes three +-- middlewares: GZIP compression, JSON-P and path cleaning. This is the +-- recommended approach for most users. +toWaiApp :: (Yesod y, YesodSite y) => y -> IO (W.Application a) +toWaiApp y = do + a <- toWaiAppPlain y + return $ gzip False + $ jsonp + a + +-- | Convert the given argument into a WAI application, executable with any WAI +-- handler. This differs from 'toWaiApp' in that it only uses the cleanpath +-- middleware. +toWaiAppPlain :: (Yesod y, YesodSite y) => y -> IO (W.Application a) +toWaiAppPlain a = do key' <- if enableClientSessions a then Just `fmap` encryptKey a else return Nothing - return $ gzip - $ jsonp - $ cleanPathFunc (splitPath a) (B.pack $ approot a) + return $ cleanPath (splitPath a) (B.pack $ approot a) $ toWaiApp' a key' toWaiApp' :: (Yesod y, YesodSite y) @@ -250,7 +263,7 @@ toWaiApp' :: (Yesod y, YesodSite y) -> Maybe Key -> [String] -> W.Request - -> IO W.Response + -> IO (W.Response a) toWaiApp' y key' segments env = do now <- getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now @@ -318,7 +331,12 @@ toWaiApp' y key' segments env = do : hs hs'' = map (headerToPair getExpires) hs' hs''' = ("Content-Type", charsToBs ct) : hs'' - return $ W.Response s hs''' c + 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''' httpAccept :: W.Request -> [ContentType] httpAccept = map B.unpack @@ -399,8 +417,12 @@ nonceKey :: String nonceKey = "_NONCE" rbHelper :: W.Request -> IO RequestBodyContents -rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where - fix1 = map (bsToChars *** bsToChars) +rbHelper req = + (map fix1 *** map fix2) <$> run_ (enum $$ iter) + where + enum = W.requestBody req + iter = parseRequestBody lbsSink req + fix1 = bsToChars *** bsToChars fix2 (x, NWP.FileInfo a b c) = (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index be1740d5..7bb01d74 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -311,7 +311,7 @@ runHandler handler mrender sroute tomr ma tosa = let hs' = headers hs return (getStatus e, hs', ct, c, sess) let sendFile' ct fp = - return (W.status200, headers [], ct, W.ResponseFile fp, finalSession) + return (W.status200, headers [], ct, ContentFile fp, finalSession) case contents of HCContent status a -> do (ct, c) <- chooseRep a cts @@ -559,3 +559,6 @@ testSuite = testGroup "Yesod.Handler" ] #endif + +-- FIXME add a sendEnum that uses a ResponseEnumerator and bypasses all status +-- and header stuff diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 3e96aca3..bd22f66e 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -1,4 +1,5 @@ -- | Efficient generation of JSON documents. +-- FIXME remove this module, possibly make a blaze-json {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/yesod.cabal b/yesod.cabal index ff1d5f72..6276a1d3 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -29,8 +29,8 @@ library else build-depends: base >= 4 && < 4.3 build-depends: time >= 1.1.4 && < 1.3 - , wai >= 0.2.0 && < 0.3 - , wai-extra >= 0.2.4 && < 0.3 + , wai >= 0.3 && < 0.4 + , wai-extra >= 0.3 && < 0.4 , bytestring >= 0.9.1.4 && < 0.10 , directory >= 1 && < 1.2 , text >= 0.5 && < 0.12 @@ -55,6 +55,7 @@ library , failure >= 0.1 && < 0.2 , containers >= 0.2 && < 0.5 , monad-peel >= 0.1 && < 0.2 + , enumerator >= 0.4 && < 0.5 exposed-modules: Yesod Yesod.Content Yesod.Dispatch