diff --git a/Yesod/Core/Handler.hs b/Yesod/Core/Handler.hs --- a/Yesod/Core/Handler.hs +++ b/Yesod/Core/Handler.hs @@ -89,6 +89,9 @@ , sendResponseStatus , sendResponseCreated , sendWaiResponse +#if MIN_VERSION_wai(2, 1, 0) + , sendRawResponse +#endif -- * Different representations -- $representations , selectRep @@ -170,7 +173,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map -import Data.Conduit (Source) +import Data.Conduit (Source, Sink) import Control.Arrow ((***)) import qualified Data.ByteString.Char8 as S8 import Data.Maybe (mapMaybe) @@ -198,6 +201,9 @@ #if MIN_VERSION_wai(2, 0, 0) import qualified System.PosixCompat.Files as PC #endif +#if MIN_VERSION_wai(2, 1, 0) +import Control.Monad.Trans.Control (MonadBaseControl, control) +#endif get :: MonadHandler m => m GHState get = liftHandlerT $ HandlerT $ I.readIORef . handlerState @@ -546,6 +552,23 @@ -- you don't. sendWaiResponse :: MonadHandler m => W.Response -> m b sendWaiResponse = handlerError . HCWai + +#if MIN_VERSION_wai(2, 1, 0) +-- | Send a raw response. This is used for cases such as WebSockets. Requires +-- WAI 2.1 or later, and a web server which supports raw responses (e.g., +-- Warp). +-- +-- Since 1.2.7 +sendRawResponse :: (MonadHandler m, MonadBaseControl IO m) + => (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ()) + -> m a +sendRawResponse raw = control $ \runInIO -> + runInIO $ sendWaiResponse $ flip W.responseRaw fallback + $ \src sink -> runInIO (raw src sink) >> return () + where + fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")] + "sendRawResponse: backend does not support raw responses" +#endif -- | Return a 404 not found page. Also denotes no handler available. notFound :: MonadHandler m => m a diff --git a/Yesod/Core/Internal/Response.hs b/Yesod/Core/Internal/Response.hs --- a/Yesod/Core/Internal/Response.hs +++ b/Yesod/Core/Internal/Response.hs @@ -47,9 +47,20 @@ case a of ResponseSource s hs w -> return $ ResponseSource s hs $ \f -> w f `finally` closeInternalState is - _ -> do + ResponseBuilder{} -> do closeInternalState is return a + ResponseFile{} -> do + closeInternalState is + return a +#if MIN_VERSION_wai(2, 1, 0) + -- Ignore the fallback provided, in case it refers to a ResourceT state + -- in a ResponseSource. + ResponseRaw raw _ -> return $ ResponseRaw + (\f -> raw f `finally` closeInternalState is) + (responseLBS H.status500 [("Content-Type", "text/plain")] + "yarToResponse: backend does not support raw responses") +#endif #else yarToResponse (YRWai a) _ _ _ = return a #endif @@ -128,7 +139,9 @@ evaluateContent :: Content -> IO (Either ErrorResponse Content) evaluateContent (ContentBuilder b mlen) = handle f $ do let lbs = toLazyByteString b - L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen) + len = L.length lbs + mlen' = maybe (Just $ fromIntegral len) Just mlen + len `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen') where f :: SomeException -> IO (Either ErrorResponse Content) f = return . Left . InternalError . T.pack . show diff --git a/Yesod/Core/Json.hs b/Yesod/Core/Json.hs --- a/Yesod/Core/Json.hs +++ b/Yesod/Core/Json.hs @@ -10,6 +10,7 @@ -- * Convert to a JSON value , parseJsonBody , parseJsonBody_ + , requireJsonBody -- * Produce JSON values , J.Value (..) @@ -99,7 +100,13 @@ -- | Same as 'parseJsonBody', but return an invalid args response on a parse -- error. parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a -parseJsonBody_ = do +parseJsonBody_ = requireJsonBody +{-# DEPRECATED parseJsonBody_ "Use requireJsonBody instead" #-} + +-- | Same as 'parseJsonBody', but return an invalid args response on a parse +-- error. +requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a +requireJsonBody = do ra <- parseJsonBody case ra of J.Error s -> invalidArgs [pack s] diff --git a/bench/widget.hs b/bench/widget.hs new file mode 100644 --- /dev/null +++ b/bench/widget.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | BigTable benchmark implemented using Hamlet. +-- +{-# LANGUAGE QuasiQuotes #-} +module Main where + +import Criterion.Main +import Text.Hamlet +import Numeric (showInt) +import qualified Data.ByteString.Lazy as L +import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8 +import Data.Monoid (mconcat) +import Text.Blaze.Html5 (table, tr, td) +import Text.Blaze.Html (toHtml) +import Yesod.Core.Widget +import Control.Monad.Trans.Writer +import Control.Monad.Trans.RWS +import Data.Functor.Identity +import Yesod.Core.Types +import Data.Monoid +import Data.IORef + +main = defaultMain + [ bench "bigTable html" $ nf bigTableHtml bigTableData + , bench "bigTable hamlet" $ nf bigTableHamlet bigTableData + , bench "bigTable widget" $ nfIO (bigTableWidget bigTableData) + , bench "bigTable blaze" $ nf bigTableBlaze bigTableData + ] + where + rows :: Int + rows = 1000 + + bigTableData :: [[Int]] + bigTableData = replicate rows [1..10] + {-# NOINLINE bigTableData #-} + +bigTableHtml rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet| + + $forall row <- rows + + $forall cell <- row +
#{show cell} +|] + +bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet| + + $forall row <- rows + + $forall cell <- row +
#{show cell} +|] + +bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet| + + $forall row <- rows + + $forall cell <- row +
#{show cell} +|]) + where + render _ _ = "foo" + run (WidgetT w) = do + (_, GWData { gwdBody = Body x }) <- w undefined + return x + +bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ mconcat $ map row t + where + row r = tr $ mconcat $ map (td . toHtml . show) r diff --git a/test/YesodCoreTest.hs b/test/YesodCoreTest.hs --- a/test/YesodCoreTest.hs +++ b/test/YesodCoreTest.hs @@ -14,6 +14,7 @@ import qualified YesodCoreTest.JsLoader as JsLoader import qualified YesodCoreTest.RequestBodySize as RequestBodySize import qualified YesodCoreTest.Json as Json +import qualified YesodCoreTest.RawResponse as RawResponse import qualified YesodCoreTest.Streaming as Streaming import qualified YesodCoreTest.Reps as Reps import qualified YesodCoreTest.Auth as Auth @@ -37,6 +38,7 @@ JsLoader.specs RequestBodySize.specs Json.specs + RawResponse.specs Streaming.specs Reps.specs Auth.specs diff --git a/test/YesodCoreTest/ErrorHandling.hs b/test/YesodCoreTest/ErrorHandling.hs --- a/test/YesodCoreTest/ErrorHandling.hs +++ b/test/YesodCoreTest/ErrorHandling.hs @@ -13,6 +13,8 @@ import qualified Data.ByteString.Char8 as S8 import Control.Exception (SomeException, try) import Network.HTTP.Types (mkStatus) +import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString) +import Data.Monoid (mconcat) data App = App @@ -29,6 +31,8 @@ /builder BuilderR GET /file-bad-len FileBadLenR GET /file-bad-name FileBadNameR GET + +/good-builder GoodBuilderR GET |] overrideStatus = mkStatus 15 "OVERRIDE" @@ -88,6 +92,12 @@ getFileBadNameR :: Handler TypedContent getFileBadNameR = return $ TypedContent "ignored" $ ContentFile (error "filebadname") Nothing +goodBuilderContent :: Builder +goodBuilderContent = mconcat $ replicate 100 $ fromByteString "This is a test\n" + +getGoodBuilderR :: Handler TypedContent +getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent + errorHandlingTest :: Spec errorHandlingTest = describe "Test.ErrorHandling" $ do it "says not found" caseNotFound @@ -99,6 +109,7 @@ it "builder" caseBuilder it "file with bad len" caseFileBadLen it "file with bad name" caseFileBadName + it "builder includes content-length" caseGoodBuilder runner :: Session () -> IO () runner f = toWaiApp App >>= runSession f @@ -175,3 +186,11 @@ res <- request defaultRequest { pathInfo = ["file-bad-name"] } assertStatus 500 res assertBodyContains "filebadname" res + +caseGoodBuilder :: IO () +caseGoodBuilder = runner $ do + res <- request defaultRequest { pathInfo = ["good-builder"] } + assertStatus 200 res + let lbs = toLazyByteString goodBuilderContent + assertBody lbs res + assertHeader "content-length" (S8.pack $ show $ L.length lbs) res diff --git a/test/YesodCoreTest/RawResponse.hs b/test/YesodCoreTest/RawResponse.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/RawResponse.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ScopedTypeVariables #-} +module YesodCoreTest.RawResponse (specs, Widget) where + +import Yesod.Core +import Test.Hspec +import qualified Data.Map as Map +import Network.Wai.Test +import Data.Text (Text) +import Data.ByteString.Lazy (ByteString) +import qualified Data.Conduit.List as CL +import qualified Data.ByteString.Char8 as S8 +import Data.Conduit +import qualified Data.Conduit.Binary as CB +import Data.Char (toUpper) +import Control.Exception (try, IOException) +import Data.Conduit.Network +import Network.Socket (sClose) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (withAsync) +import Control.Monad.Trans.Resource (register) +import Data.IORef + +data App = App + +mkYesod "App" [parseRoutes| +/ HomeR GET +|] + +instance Yesod App + +getHomeR :: Handler () +getHomeR = do + ref <- liftIO $ newIORef 0 + _ <- register $ writeIORef ref 1 + sendRawResponse $ \src sink -> liftIO $ do + val <- readIORef ref + yield (S8.pack $ show val) $$ sink + src $$ CL.map (S8.map toUpper) =$ sink + +getFreePort :: IO Int +getFreePort = do + loop 43124 + where + loop port = do + esocket <- try $ bindPort port "*" + case esocket of + Left (_ :: IOException) -> loop (succ port) + Right socket -> do + sClose socket + return port + +specs :: Spec +specs = describe "RawResponse" $ do + it "works" $ do + port <- getFreePort + withAsync (warp port App) $ \_ -> do + threadDelay 100000 + runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do + yield "GET / HTTP/1.1\r\n\r\nhello" $$ appSink ad + (appSource ad $$ CB.take 6) >>= (`shouldBe` "0HELLO") + yield "WORLd" $$ appSink ad + (appSource ad $$ await) >>= (`shouldBe` Just "WORLD") diff --git a/test/YesodCoreTest/WaiSubsiteSub.hs b/test/YesodCoreTest/WaiSubsiteSub.hs deleted file mode 100644 --- a/test/YesodCoreTest/WaiSubsiteSub.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-} -module YesodCoreTest.WaiSubsiteSub where - -import Yesod.Core - -data NonWaiSubsite = NonWaiSubsite - -mkYesodSubData "NonWaiSubsite" [parseRoutes| -/ SubHomeR GET -/waisub WaiSubsite2R WaiSubsite getApp -|] - -getSubHomeR :: HandlerT NonWaiSubsite (HandlerT parent IO) () -getSubHomeR = return () diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.2.6.7 +version: 1.2.7 license: MIT license-file: LICENSE author: Michael Snoyman @@ -122,8 +122,25 @@ , containers , lifted-base , resourcet + , network-conduit + , network + , async ghc-options: -Wall extensions: TemplateHaskell + +benchmark widgets + type: exitcode-stdio-1.0 + hs-source-dirs: bench + build-depends: base + , criterion + , bytestring + , text + , hamlet + , transformers + , yesod-core + , blaze-html + main-is: widget.hs + ghc-options: -Wall -O2 source-repository head type: git