diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 3.0.15 + +* add requestSizeCheck [#525](https://github.com/yesodweb/wai/pull/525) + ## 3.0.14.3 * Add missing `requestHeaderReferer` and `requestHeaderUserAgent` fields to CGI [yesod#1186](https://github.com/yesodweb/yesod/issues/1186) diff --git a/Network/Wai/Request.hs b/Network/Wai/Request.hs --- a/Network/Wai/Request.hs +++ b/Network/Wai/Request.hs @@ -1,18 +1,26 @@ +{-# LANGUAGE DeriveDataTypeable #-} -- | Some helpers for interrogating a WAI 'Request'. module Network.Wai.Request ( appearsSecure , guessApproot + , RequestSizeException(..) + , requestSizeCheck ) where import Data.ByteString (ByteString) import Data.Maybe (fromMaybe) import Network.HTTP.Types (HeaderName) -import Network.Wai (Request, isSecure, requestHeaders, requestHeaderHost) +import Network.Wai import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C +import Control.Exception (Exception, throwIO) +import Data.Typeable (Typeable) +import Data.Word (Word64) +import Data.IORef (atomicModifyIORef', newIORef) + -- | Does this request appear to have been made over an SSL connection? -- -- This function first checks @'isSecure'@, but also checks for headers that may @@ -24,7 +32,7 @@ -- force a non-SSL request to SSL by redirect. One can safely choose not to -- redirect when the request /appears/ secure, even if it's actually not. -- --- Since 3.0.7 +-- @since 3.0.7 appearsSecure :: Request -> Bool appearsSecure request = isSecure request || any (uncurry matchHeader) [ ("HTTPS" , (== "on")) @@ -44,8 +52,50 @@ -- application. For more information and relevant caveats, please see -- "Network.Wai.Middleware.Approot". -- --- Since 3.0.7 +-- @since 3.0.7 guessApproot :: Request -> ByteString guessApproot req = (if appearsSecure req then "https://" else "http://") `S.append` (fromMaybe "localhost" $ requestHeaderHost req) + +-- | see 'requestSizeCheck' +-- +-- @since 3.0.15 +data RequestSizeException + = RequestSizeException Word64 + deriving (Eq, Ord, Typeable) + +instance Exception RequestSizeException + +instance Show RequestSizeException where + showsPrec p (RequestSizeException limit) = + showString ("Request Body is larger than ") . showsPrec p limit . showString " bytes." + +-- | Check request body size to avoid server crash when request is too large. +-- +-- This function first checks @'requestBodyLength'@, if content-length is known +-- but larger than limit, or it's unknown but we have received too many chunks, +-- a 'RequestSizeException' are thrown when user use @'requestBody'@ to extract +-- request body inside IO. +-- +-- @since 3.0.15 +requestSizeCheck :: Word64 -> Request -> IO Request +requestSizeCheck maxSize req = + case requestBodyLength req of + KnownLength len -> + if len > maxSize + then return $ req { requestBody = throwIO (RequestSizeException maxSize) } + else return req + ChunkedBody -> do + currentSize <- newIORef 0 + return $ req + { requestBody = do + bs <- requestBody req + total <- + atomicModifyIORef' currentSize $ \sz -> + let nextSize = sz + fromIntegral (S.length bs) + in (nextSize, nextSize) + if total > maxSize + then throwIO (RequestSizeException maxSize) + else return bs + } diff --git a/test/Network/Wai/RequestSpec.hs b/test/Network/Wai/RequestSpec.hs --- a/test/Network/Wai/RequestSpec.hs +++ b/test/Network/Wai/RequestSpec.hs @@ -8,52 +8,82 @@ import Data.ByteString (ByteString) import Network.HTTP.Types (HeaderName) -import Network.Wai (Request(..), defaultRequest) +import Network.Wai (Request(..), defaultRequest, RequestBodyLength(..)) import Network.Wai.Request +import Control.Exception (try) +import Control.Monad (forever) main :: IO () main = hspec spec spec :: Spec -spec = describe "appearsSecure" $ do - let insecureRequest = defaultRequest - { isSecure = False - , requestHeaders = - [ ("HTTPS", "off") - , ("HTTP_X_FORWARDED_SSL", "off") - , ("HTTP_X_FORWARDED_SCHEME", "http") - , ("HTTP_X_FORWARDED_PROTO", "http,xyz") - ] - } +spec = do + describe "requestSizeCheck" $ do + it "too large content length should throw RequestSizeException" $ do + let limit = 1024 + largeRequest = defaultRequest + { isSecure = False + , requestBodyLength = KnownLength (limit + 1) + , requestBody = return "repeat this chunk" + } + checkedRequest <- requestSizeCheck limit largeRequest + body <- try (requestBody checkedRequest) + case body of + Left (RequestSizeException l) -> l `shouldBe` limit + Right _ -> expectationFailure "request size check failed" - it "returns False for an insecure request" $ - insecureRequest `shouldSatisfy` not . appearsSecure + it "too many chunks should throw RequestSizeException" $ do + let limit = 1024 + largeRequest = defaultRequest + { isSecure = False + , requestBodyLength = ChunkedBody + , requestBody = return "repeat this chunk" + } + checkedRequest <- requestSizeCheck limit largeRequest + body <- try (forever $ requestBody checkedRequest) + case body of + Left (RequestSizeException l) -> l `shouldBe` limit + Right _ -> expectationFailure "request size check failed" - it "checks if the Request is actually secure" $ do - let req = insecureRequest { isSecure = True } + describe "appearsSecure" $ do + let insecureRequest = defaultRequest + { isSecure = False + , requestHeaders = + [ ("HTTPS", "off") + , ("HTTP_X_FORWARDED_SSL", "off") + , ("HTTP_X_FORWARDED_SCHEME", "http") + , ("HTTP_X_FORWARDED_PROTO", "http,xyz") + ] + } - req `shouldSatisfy` appearsSecure + it "returns False for an insecure request" $ + insecureRequest `shouldSatisfy` not . appearsSecure - it "checks for HTTP: on" $ do - let req = addHeader "HTTPS" "on" insecureRequest + it "checks if the Request is actually secure" $ do + let req = insecureRequest { isSecure = True } - req `shouldSatisfy` appearsSecure + req `shouldSatisfy` appearsSecure - it "checks for HTTP_X_FORWARDED_SSL: on" $ do - let req = addHeader "HTTP_X_FORWARDED_SSL" "on" insecureRequest + it "checks for HTTP: on" $ do + let req = addHeader "HTTPS" "on" insecureRequest - req `shouldSatisfy` appearsSecure + req `shouldSatisfy` appearsSecure - it "checks for HTTP_X_FORWARDED_SCHEME: https" $ do - let req = addHeader "HTTP_X_FORWARDED_SCHEME" "https" insecureRequest + it "checks for HTTP_X_FORWARDED_SSL: on" $ do + let req = addHeader "HTTP_X_FORWARDED_SSL" "on" insecureRequest - req `shouldSatisfy` appearsSecure + req `shouldSatisfy` appearsSecure - it "checks for HTTP_X_FORWARDED_PROTO: https,..." $ do - let req = addHeader "HTTP_X_FORWARDED_PROTO" "https,xyz" insecureRequest + it "checks for HTTP_X_FORWARDED_SCHEME: https" $ do + let req = addHeader "HTTP_X_FORWARDED_SCHEME" "https" insecureRequest - req `shouldSatisfy` appearsSecure + req `shouldSatisfy` appearsSecure + + it "checks for HTTP_X_FORWARDED_PROTO: https,..." $ do + let req = addHeader "HTTP_X_FORWARDED_PROTO" "https,xyz" insecureRequest + + req `shouldSatisfy` appearsSecure addHeader :: HeaderName -> ByteString -> Request -> Request addHeader name value req = req diff --git a/wai-extra.cabal b/wai-extra.cabal --- a/wai-extra.cabal +++ b/wai-extra.cabal @@ -1,5 +1,5 @@ Name: wai-extra -Version: 3.0.14.3 +Version: 3.0.15 Synopsis: Provides some basic WAI handlers and middleware. description: Provides basic WAI handler and middleware functionality: @@ -71,7 +71,7 @@ Homepage: http://github.com/yesodweb/wai Category: Web Build-Type: Simple -Cabal-Version: >=1.8 +Cabal-Version: >=1.10 Stability: Stable extra-source-files: test/requests/dalvik-request @@ -119,7 +119,7 @@ else build-depends: unix - extensions: OverloadedStrings + default-extensions: OverloadedStrings Exposed-modules: Network.Wai.Handler.CGI Network.Wai.Handler.SCGI @@ -151,6 +151,7 @@ Network.Wai.EventSource Network.Wai.EventSource.EventStream other-modules: Network.Wai.Middleware.RequestLogger.Internal + default-language: Haskell2010 ghc-options: -Wall test-suite spec @@ -182,6 +183,7 @@ , time , case-insensitive ghc-options: -Wall + default-language: Haskell2010 source-repository head type: git