yesod-core 1.1.7 → 1.1.7.1
raw patch · 8 files changed
+163/−38 lines, 8 filesdep ~conduit
Dependency ranges changed: conduit
Files
- Yesod/Handler.hs +0/−14
- Yesod/Internal.hs +16/−0
- Yesod/Internal/Core.hs +4/−7
- Yesod/Internal/Request.hs +40/−7
- test/YesodCoreTest.hs +2/−0
- test/YesodCoreTest/InternalRequest.hs +9/−9
- test/YesodCoreTest/RequestBodySize.hs +89/−0
- yesod-core.cabal +3/−1
Yesod/Handler.hs view
@@ -172,7 +172,6 @@ import qualified Yesod.Internal.Cache as Cache import Yesod.Internal.Cache (mkCacheKey, CacheKey)-import Data.Typeable (Typeable) import qualified Data.IORef as I import Control.Exception.Lifted (catch) import Control.Monad.Trans.Control@@ -302,19 +301,6 @@ data YesodAppResult = YARWai W.Response | YARPlain H.Status [Header] ContentType Content SessionMap--data HandlerContents =- HCContent H.Status ChooseRep- | HCError ErrorResponse- | HCSendFile ContentType FilePath (Maybe W.FilePart) -- FIXME replace FilePath with opaque type from system-filepath?- | HCRedirect H.Status Text- | HCCreated Text- | HCWai W.Response- deriving Typeable--instance Show HandlerContents where- show _ = "Cannot show a HandlerContents"-instance Exception HandlerContents getRequest :: GHandler s m Request getRequest = handlerRequest `liftM` ask
Yesod/Internal.hs view
@@ -9,6 +9,7 @@ module Yesod.Internal ( -- * Error responses ErrorResponse (..)+ , HandlerContents (..) -- * Header , Header (..) -- * Cookie names@@ -46,6 +47,8 @@ import Data.Text.Lazy.Builder (Builder) import Web.Cookie (SetCookie (..)) import Data.ByteString (ByteString)+import qualified Network.Wai as W+import Yesod.Content (ChooseRep, ContentType) -- | Responses to indicate some form of an error occurred. These are different -- from 'SpecialResponse' in that they allow for custom error pages.@@ -120,3 +123,16 @@ (Map.unionWith mappend a5 b5) (a6 `mappend` b6) (a7 `mappend` b7)++data HandlerContents =+ HCContent H.Status ChooseRep+ | HCError ErrorResponse+ | HCSendFile ContentType FilePath (Maybe W.FilePart) -- FIXME replace FilePath with opaque type from system-filepath?+ | HCRedirect H.Status Text+ | HCCreated Text+ | HCWai W.Response+ deriving Typeable++instance Show HandlerContents where+ show _ = "Cannot show a HandlerContents"+instance Exception HandlerContents
Yesod/Internal/Core.hs view
@@ -359,7 +359,7 @@ -- | How to store uploaded files. --- -- Default: Whe nthe request body is greater than 50kb, store in a temp+ -- Default: When the request body is greater than 50kb, store in a temp -- file. Otherwise, store in memory. fileUpload :: a -> Word64 -- ^ request body size@@ -433,17 +433,13 @@ -> Maybe (SessionBackend master) -> W.Application defaultYesodRunner logger handler' master sub murl toMasterRoute msb req- | maximumContentLength master (fmap toMasterRoute murl) < len =- return $ W.responseLBS- (H.Status 413 "Too Large")- [("Content-Type", "text/plain")]- "Request body too large to be processed."+ | maxLen < len = return tooLargeResponse | otherwise = do let dontSaveSession _ _ = return [] now <- liftIO getCurrentTime -- FIXME remove in next major version bump (session, saveSession) <- liftIO $ do maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req now) msb- rr <- liftIO $ parseWaiRequest req session (isJust msb) len+ rr <- liftIO $ parseWaiRequest req session (isJust msb) len maxLen let h = {-# SCC "h" #-} do case murl of Nothing -> handler@@ -477,6 +473,7 @@ _ -> return [] return $ yarToResponse yar extraHeaders where+ maxLen = maximumContentLength master $ fmap toMasterRoute murl len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay readMay s = case reads $ S8.unpack s of
Yesod/Internal/Request.hs view
@@ -13,6 +13,7 @@ , mkFileInfoFile , mkFileInfoSource , FileUpload (..)+ , tooLargeResponse -- The below are exported for testing. , randomString , parseWaiRequest'@@ -28,7 +29,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Text (Text, pack)-import Network.HTTP.Types (queryToQueryText)+import Network.HTTP.Types (queryToQueryText, Status (Status)) import Control.Monad (join) import Data.Maybe (fromMaybe, catMaybes) import qualified Data.ByteString.Lazy as L@@ -40,6 +41,8 @@ import Data.Conduit.List (sourceList) import Data.Conduit.Binary (sourceFile, sinkFile) import Data.Word (Word64)+import Control.Monad.IO.Class (liftIO)+import Control.Exception (throwIO) -- | The parsed request information. data Request = Request@@ -51,26 +54,56 @@ -- | A random, session-specific token used to prevent CSRF attacks. , reqToken :: Maybe Text -- | Size of the request body.- , reqBodySize :: Word64+ --+ -- Note: in the presence of chunked request bodies, this value will be 0,+ -- even though data is available.+ , reqBodySize :: Word64 -- FIXME Consider in the future using a Maybe to represent chunked bodies } parseWaiRequest :: W.Request -> [(Text, ByteString)] -- ^ session -> Bool- -> Word64+ -> Word64 -- ^ actual length... might be meaningless, see 'reqBodySize'+ -> Word64 -- ^ maximum allowed body size -> IO Request-parseWaiRequest env session' useToken bodySize =- parseWaiRequest' env session' useToken bodySize <$> newStdGen+parseWaiRequest env session' useToken bodySize maxBodySize =+ parseWaiRequest' env session' useToken bodySize maxBodySize <$> newStdGen +-- | Impose a limit on the size of the request body.+limitRequestBody :: Word64 -> W.Request -> W.Request+limitRequestBody maxLen req =+ req { W.requestBody = W.requestBody req $= limit maxLen }+ where+ tooLarge = liftIO $ throwIO $ HCWai tooLargeResponse++ limit 0 = tooLarge+ limit remaining =+ await >>= maybe (return ()) go+ where+ go bs = do+ let len = fromIntegral $ S8.length bs+ if len > remaining+ then tooLarge+ else do+ yield bs+ limit $ remaining - len++tooLargeResponse :: W.Response+tooLargeResponse = W.responseLBS+ (Status 413 "Too Large")+ [("Content-Type", "text/plain")]+ "Request body too large to be processed."+ parseWaiRequest' :: RandomGen g => W.Request -> [(Text, ByteString)] -- ^ session -> Bool -> Word64+ -> Word64 -- ^ max body size -> g -> Request-parseWaiRequest' env session' useToken bodySize gen =- Request gets'' cookies' env langs'' token bodySize+parseWaiRequest' env session' useToken bodySize maxBodySize gen =+ Request gets'' cookies' (limitRequestBody maxBodySize env) langs'' token bodySize where gets' = queryToQueryText $ W.queryString env gets'' = map (second $ fromMaybe "") gets'
test/YesodCoreTest.hs view
@@ -12,6 +12,7 @@ import qualified YesodCoreTest.WaiSubsite as WaiSubsite import qualified YesodCoreTest.Redirect as Redirect import qualified YesodCoreTest.JsLoader as JsLoader+import qualified YesodCoreTest.RequestBodySize as RequestBodySize import Test.Hspec @@ -29,3 +30,4 @@ WaiSubsite.specs Redirect.specs JsLoader.specs+ RequestBodySize.specs
test/YesodCoreTest/InternalRequest.hs view
@@ -38,19 +38,19 @@ noDisabledToken :: Bool noDisabledToken = reqToken r == Nothing where- r = parseWaiRequest' defaultRequest [] False 0 g+ r = parseWaiRequest' defaultRequest [] False 0 1000 g ignoreDisabledToken :: Bool ignoreDisabledToken = reqToken r == Nothing where- r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] False 0 g+ r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] False 0 1000 g useOldToken :: Bool useOldToken = reqToken r == Just "old" where- r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 0 g+ r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 0 1000 g generateToken :: Bool generateToken = reqToken r /= Nothing where- r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 0 g+ r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 0 1000 g langSpecs :: Spec@@ -64,21 +64,21 @@ respectAcceptLangs :: Bool respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where r = parseWaiRequest' defaultRequest- { requestHeaders = [("Accept-Language", "en-US, es")] } [] False 0 g+ { requestHeaders = [("Accept-Language", "en-US, es")] } [] False 0 1000 g respectSessionLang :: Bool respectSessionLang = reqLangs r == ["en"] where- r = parseWaiRequest' defaultRequest [("_LANG", "en")] False 0 g+ r = parseWaiRequest' defaultRequest [("_LANG", "en")] False 0 1000 g respectCookieLang :: Bool respectCookieLang = reqLangs r == ["en"] where r = parseWaiRequest' defaultRequest { requestHeaders = [("Cookie", "_LANG=en")]- } [] False 0 g+ } [] False 0 1000 g respectQueryLang :: Bool respectQueryLang = reqLangs r == ["en-US", "en"] where- r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] False 0 g+ r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] False 0 1000 g prioritizeLangs :: Bool prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where@@ -87,7 +87,7 @@ , ("Cookie", "_LANG=en-COOKIE") ] , queryString = [("_LANG", Just "en-QUERY")]- } [("_LANG", "en-SESSION")] False 0 g+ } [("_LANG", "en-SESSION")] False 0 10000 g internalRequestTest :: Spec
+ test/YesodCoreTest/RequestBodySize.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+module YesodCoreTest.RequestBodySize (specs, Widget) where++import Test.Hspec++import Yesod.Core hiding (Request)++import Network.Wai+import Network.Wai.Test+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Char8 as S8+import Data.Text (Text)+import qualified Data.Text as T+import Data.Conduit+import Data.Conduit.List (consume)+import Data.Conduit.Binary (isolate)++data Y = Y++mkYesod "Y" [parseRoutes|+/post PostR POST+/consume ConsumeR POST+/partial-consume PartialConsumeR POST+/unused UnusedR POST+|]++instance Yesod Y where+ maximumContentLength _ _ = 10++postPostR, postConsumeR, postPartialConsumeR, postUnusedR :: Handler RepPlain++postPostR = do+ val <- lookupPostParams "foobarbaz"+ return $ RepPlain $ toContent $ T.concat val++postConsumeR = do+ req <- waiRequest+ body <- lift $ requestBody req $$ consume+ return $ RepPlain $ toContent $ S.concat body++postPartialConsumeR = do+ req <- waiRequest+ body <- lift $ requestBody req $$ isolate 5 =$ consume+ return $ RepPlain $ toContent $ S.concat body++postUnusedR = return $ RepPlain ""++runner :: Session () -> IO ()+runner f = toWaiApp Y >>= runSession f++caseHelper :: String -- ^ name+ -> Text -- ^ pathinfo+ -> ByteString -- ^ request body+ -> Int -- ^ expected status code, chunked+ -> Int -- ^ expected status code, non-chunked+ -> Spec+caseHelper name path body statusChunked statusNonChunked = describe name $ do+ it "chunked" $ runner $ do+ res <- mkRequest False+ assertStatus statusChunked res+ it "non-chunked" $ runner $ do+ res <- mkRequest True+ assertStatus statusNonChunked res+ where+ mkRequest includeLength = srequest $ SRequest defaultRequest+ { pathInfo = [path]+ , requestHeaders =+ ("content-type", "application/x-www-form-urlencoded") :++ if includeLength+ then [("content-length", S8.pack $ show $ S.length body)]+ else []+ , requestMethod = "POST"+ } $ L.fromChunks $ map S.singleton $ S.unpack body++specs :: Spec+specs = describe "Test.RequestBodySize" $ do+ caseHelper "lookupPostParam- large" "post" "foobarbaz=bin" 413 413+ caseHelper "lookupPostParam- small" "post" "foo=bin" 200 200+ caseHelper "consume- large" "consume" "this is longer than 10" 413 413+ caseHelper "consume- small" "consume" "smaller" 200 200+ caseHelper "partial consume- large" "partial-consume" "this is longer than 10" 200 413+ caseHelper "partial consume- small" "partial-consume" "smaller" 200 200+ caseHelper "unused- large" "unused" "this is longer than 10" 200 413+ caseHelper "unused- small" "unused" "smaller" 200 200
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 1.1.7+version: 1.1.7.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -30,6 +30,7 @@ test/YesodCoreTest/MediaData.hs test/YesodCoreTest/NoOverloadedStrings.hs test/YesodCoreTest/Redirect.hs+ test/YesodCoreTest/RequestBodySize.hs test/YesodCoreTest/WaiSubsite.hs test/YesodCoreTest/Widget.hs test/YesodCoreTest/YesodTest.hs@@ -123,6 +124,7 @@ ,HUnit ,QuickCheck >= 2 && < 3 ,transformers+ , conduit ghc-options: -Wall source-repository head