Hello community, here is the log from the commit of package ghc-wai-extra for openSUSE:Factory checked in at 2016-03-31 13:02:43 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-wai-extra (Old) and /work/SRC/openSUSE:Factory/.ghc-wai-extra.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-wai-extra" Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-wai-extra/ghc-wai-extra.changes 2016-03-26 15:26:24.000000000 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-wai-extra.new/ghc-wai-extra.changes 2016-03-31 13:02:45.000000000 +0200 @@ -1,0 +2,6 @@ +Wed Mar 23 08:24:05 UTC 2016 - mimi...@gmail.com + +- update to 3.0.15 +* add requestSizeCheck + +------------------------------------------------------------------- Old: ---- wai-extra-3.0.14.3.tar.gz New: ---- wai-extra-3.0.15.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-wai-extra.spec ++++++ --- /var/tmp/diff_new_pack.CMbPSh/_old 2016-03-31 13:02:48.000000000 +0200 +++ /var/tmp/diff_new_pack.CMbPSh/_new 2016-03-31 13:02:48.000000000 +0200 @@ -21,7 +21,7 @@ %bcond_with tests Name: ghc-wai-extra -Version: 3.0.14.3 +Version: 3.0.15 Release: 0 Summary: Provides some basic WAI handlers and middleware License: MIT ++++++ wai-extra-3.0.14.3.tar.gz -> wai-extra-3.0.15.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/wai-extra-3.0.14.3/ChangeLog.md new/wai-extra-3.0.15/ChangeLog.md --- old/wai-extra-3.0.14.3/ChangeLog.md 2016-03-16 13:47:43.000000000 +0100 +++ new/wai-extra-3.0.15/ChangeLog.md 2016-03-22 10:15:32.000000000 +0100 @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/wai-extra-3.0.14.3/Network/Wai/Request.hs new/wai-extra-3.0.15/Network/Wai/Request.hs --- old/wai-extra-3.0.14.3/Network/Wai/Request.hs 2016-03-16 13:47:43.000000000 +0100 +++ new/wai-extra-3.0.15/Network/Wai/Request.hs 2016-03-22 10:15:32.000000000 +0100 @@ -1,17 +1,25 @@ +{-# 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? -- @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/wai-extra-3.0.14.3/test/Network/Wai/RequestSpec.hs new/wai-extra-3.0.15/test/Network/Wai/RequestSpec.hs --- old/wai-extra-3.0.14.3/test/Network/Wai/RequestSpec.hs 2016-03-16 13:47:43.000000000 +0100 +++ new/wai-extra-3.0.15/test/Network/Wai/RequestSpec.hs 2016-03-22 10:15:32.000000000 +0100 @@ -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 "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" + + 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") + ] + } + + it "returns False for an insecure request" $ + insecureRequest `shouldSatisfy` not . appearsSecure + + it "checks if the Request is actually secure" $ do + let req = insecureRequest { isSecure = True } + + req `shouldSatisfy` appearsSecure + + it "checks for HTTP: on" $ do + let req = addHeader "HTTPS" "on" insecureRequest + + req `shouldSatisfy` appearsSecure + + it "checks for HTTP_X_FORWARDED_SSL: on" $ do + let req = addHeader "HTTP_X_FORWARDED_SSL" "on" insecureRequest + + req `shouldSatisfy` appearsSecure + + it "checks for HTTP_X_FORWARDED_SCHEME: https" $ do + let req = addHeader "HTTP_X_FORWARDED_SCHEME" "https" insecureRequest - it "returns False for an insecure request" $ - insecureRequest `shouldSatisfy` not . appearsSecure + req `shouldSatisfy` appearsSecure - it "checks if the Request is actually secure" $ do - let req = insecureRequest { isSecure = True } + it "checks for HTTP_X_FORWARDED_PROTO: https,..." $ do + let req = addHeader "HTTP_X_FORWARDED_PROTO" "https,xyz" insecureRequest - req `shouldSatisfy` appearsSecure - - it "checks for HTTP: on" $ do - let req = addHeader "HTTPS" "on" insecureRequest - - req `shouldSatisfy` appearsSecure - - it "checks for HTTP_X_FORWARDED_SSL: on" $ do - let req = addHeader "HTTP_X_FORWARDED_SSL" "on" insecureRequest - - req `shouldSatisfy` appearsSecure - - it "checks for HTTP_X_FORWARDED_SCHEME: https" $ do - let req = addHeader "HTTP_X_FORWARDED_SCHEME" "https" insecureRequest - - 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 + req `shouldSatisfy` appearsSecure addHeader :: HeaderName -> ByteString -> Request -> Request addHeader name value req = req diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/wai-extra-3.0.14.3/wai-extra.cabal new/wai-extra-3.0.15/wai-extra.cabal --- old/wai-extra-3.0.14.3/wai-extra.cabal 2016-03-16 13:47:43.000000000 +0100 +++ new/wai-extra-3.0.15/wai-extra.cabal 2016-03-22 10:15:32.000000000 +0100 @@ -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
