add and use RequestParseException in Network.Wai.Parse

wai-extra/ChangeLog.md

@@ -1,5 +1,11 @@
 # Changelog for wai-extra
 
+## 3.1.15
+
+* Request parsing throws an exception rather than `error`ing [#964](https://github.com/yesodweb/wai/pull/964):
+    * Add `RequestParseException` type and expose it from the `Network.Wai.Parse` module.
+    * Behavior change : `parseRequestBody` and `parseRequestBodyEx` (exported from `Network.Wai.Parse`) throw `RequestParseException` rather than calling `error`.
+
 ## 3.1.14.0
 
 * `defaultGzipSettings` now exported to not depend on `Data.Default` [#959](https://github.com/yesodweb/wai/pull/959)

wai-extra/Network/Wai/Parse.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE CPP #-}
+{-# language DeriveDataTypeable #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# language LambdaCase #-}
 {-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE RankNTypes #-}
@@ -12,6 +14,7 @@ module Network.Wai.Parse
     , getRequestBodyType
     , sinkRequestBody
     , sinkRequestBodyEx
+    , RequestParseException(..)
     , BackEnd
     , lbsBackEnd
     , tempFileBackEnd
@@ -67,6 +70,7 @@ import Data.IORef
 import Data.Int (Int64)
 import Data.List (sortBy)
 import Data.Maybe (catMaybes, fromMaybe)
+import Data.Typeable
 import Data.Word (Word8)
 import Network.HTTP.Types (hContentType)
 import qualified Network.HTTP.Types as H
@@ -360,6 +364,8 @@ parseContentType a = do
 -- When dealing with untrusted data (as is usually the case when
 -- receiving input from the internet), it is recommended to
 -- use the 'parseRequestBodyEx' function instead.
+--
+-- since 3.1.15 : throws 'RequestParseException' if something goes wrong
 parseRequestBody :: BackEnd y
                  -> Request
                  -> IO ([Param], [File y])
@@ -371,6 +377,8 @@ parseRequestBody = parseRequestBodyEx noLimitParseRequestBodyOptions
 -- for all parameters, and a list of key,a pairs
 -- for filenames. The a depends on the used backend that
 -- is responsible for storing the received files.
+--
+-- since 3.1.15 : throws 'RequestParseException' if something goes wrong
 parseRequestBodyEx :: ParseRequestBodyOptions
                    -> BackEnd y
                    -> Request
@@ -380,15 +388,18 @@ parseRequestBodyEx o s r =
         Nothing -> return ([], [])
         Just rbt -> sinkRequestBodyEx o s rbt (getRequestBodyChunk r)
 
+-- | since 3.1.15 : throws 'RequestParseException' if something goes wrong
 sinkRequestBody :: BackEnd y
                 -> RequestBodyType
                 -> IO S.ByteString
                 -> IO ([Param], [File y])
 sinkRequestBody = sinkRequestBodyEx noLimitParseRequestBodyOptions
 
--- |
+-- | Throws 'RequestParseException' if something goes wrong
 --
 -- @since 3.0.16.0
+--
+-- since 3.1.15 : throws 'RequestParseException' if something goes wrong
 sinkRequestBodyEx :: ParseRequestBodyOptions
                   -> BackEnd y
                   -> RequestBodyType
@@ -421,7 +432,7 @@ conduitRequestBodyEx o _ UrlEncoded rbody add = do
                     let newsize = size + S.length bs
                     case prboMaxParmsSize o of
                         Just maxSize -> when (newsize > maxSize) $
-                            error "Maximum size of parameters exceeded"
+                          E.throwIO $ MaxParamSizeExceeded newsize
                         Nothing -> return ()
                     loop newsize $ front . (bs:)
     bs <- loop 0 id
@@ -461,10 +472,12 @@ takeLine maxlen src =
                         Nothing -> return ()
                     return . Just $ killCR res
 
+-- | @since 3.1.15 : throws 'RequestParseException' if something goes wrong
 takeLines' :: Maybe Int -> Maybe Int -> Source -> IO [S.ByteString]
 takeLines' lineLength maxLines source =
     reverse <$> takeLines'' [] lineLength maxLines source
 
+-- | @since 3.1.15 : throws 'RequestParseException' if something goes wrong
 takeLines''
     :: [S.ByteString]
     -> Maybe Int
@@ -475,7 +488,7 @@ takeLines'' lines lineLength maxLines src = do
     case maxLines of
         Just maxLines' ->
             when (length lines > maxLines') $
-                error "Too many lines in mime/multipart header"
+                E.throwIO $ TooManyHeaderLines (length lines)
         Nothing -> return ()
     res <- takeLine lineLength src
     case res of
@@ -502,6 +515,7 @@ readSource (Source f ref) = do
 leftover :: Source -> S.ByteString -> IO ()
 leftover (Source _ ref) = writeIORef ref
 
+-- | @since 3.1.15 : throws 'RequestParseException' if something goes wrong
 parsePiecesEx :: ParseRequestBodyOptions
               -> BackEnd y
               -> S.ByteString
@@ -529,11 +543,11 @@ parsePiecesEx o sink bound rbody add =
                     case prboKeyLength o of
                         Just maxKeyLength ->
                             when (S.length name > maxKeyLength) $
-                                error "Filename is too long"
+                                E.throwIO $ FilenameTooLong name maxKeyLength
                         Nothing -> return ()
                     case prboMaxNumFiles o of
                         Just maxFiles -> when (numFiles >= maxFiles) $
-                            error "Maximum number of files exceeded"
+                          E.throwIO $ MaxFileNumberExceeded numFiles
                         Nothing -> return ()
                     let ct = fromMaybe "application/octet-stream" mct
                         fi0 = FileInfo filename ct ()
@@ -548,7 +562,7 @@ parsePiecesEx o sink bound rbody add =
                     case prboKeyLength o of
                         Just maxKeyLength ->
                             when (S.length name > maxKeyLength) $
-                                error "Parameter name is too long"
+                                E.throwIO $ ParamNameTooLong name maxKeyLength
                         Nothing -> return ()
                     let seed = id
                     let iter front bs = return $ front . (:) bs
@@ -559,7 +573,7 @@ parsePiecesEx o sink bound rbody add =
                     let newParmSize = parmSize + S.length name + S.length bs
                     case prboMaxParmsSize o of
                         Just maxParmSize -> when (newParmSize > maxParmSize) $
-                            error "Maximum size of parameters exceeded"
+                          E.throwIO $ MaxParamSizeExceeded newParmSize
                         Nothing -> return ()
                     add $ Left x'
                     when wasFound $ loop (numParms + 1) numFiles
@@ -577,6 +591,25 @@ parsePiecesEx o sink bound rbody add =
             let (x, y) = breakDiscard 58 s -- colon
              in (mk x, S.dropWhile (== 32) y) -- space
 
+-- | Things that could go wrong while parsing a 'Request'
+--
+-- @since 3.1.15
+data RequestParseException = MaxParamSizeExceeded Int
+                           | ParamNameTooLong S.ByteString Int
+                           | MaxFileNumberExceeded Int
+                           | FilenameTooLong S.ByteString Int
+                           | TooManyHeaderLines Int
+                           deriving (Eq, Typeable)
+instance E.Exception RequestParseException
+instance Show RequestParseException where
+  show = \case
+    MaxParamSizeExceeded lmax -> unwords ["maximum parameter size exceeded:", show lmax]
+    ParamNameTooLong s lmax -> unwords ["parameter name", S8.unpack s, "is too long:", show lmax]
+    MaxFileNumberExceeded lmax -> unwords ["maximum number of files exceeded:", show lmax]
+    FilenameTooLong fn lmax ->
+      unwords ["file name", S8.unpack fn, "too long:", show lmax]
+    TooManyHeaderLines nmax -> unwords ["Too many lines in mime/multipart header:", show nmax]
+
 
 data Bound = FoundBound S.ByteString S.ByteString
            | NoBound

wai-extra/test/Network/Wai/ParseSpec.hs

@@ -113,11 +113,11 @@ caseParseRequestBody = do
 
   it "exceeding number of files" $ do
     SRequest req4 _bod4 <- toRequest'' ctype3 content3
-    (parseRequestBodyEx ( setMaxRequestNumFiles 0 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall
+    (parseRequestBodyEx ( setMaxRequestNumFiles 0 def ) lbsBackEnd req4) `shouldThrow` anyException
 
   it "exceeding parameter length" $ do
     SRequest req4 _bod4 <- toRequest'' ctype3 content3
-    (parseRequestBodyEx ( setMaxRequestKeyLength 2 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall
+    (parseRequestBodyEx ( setMaxRequestKeyLength 2 def ) lbsBackEnd req4) `shouldThrow` anyException
 
   it "exceeding file size" $ do
     SRequest req4 _bod4 <- toRequest'' ctype3 content3
@@ -139,7 +139,7 @@ caseParseRequestBody = do
 
   it "exceeding max header lines" $ do
     SRequest req4 _bod4 <- toRequest'' ctype2 content2
-    (parseRequestBodyEx ( setMaxHeaderLines 1 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall
+    (parseRequestBodyEx ( setMaxHeaderLines 1 def ) lbsBackEnd req4) `shouldThrow` anyException
 
   it "exceeding header line size" $ do
     SRequest req4 _bod4 <- toRequest'' ctype3 content4
@@ -158,7 +158,7 @@ caseParseRequestBody = do
     let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"
     let ctype = "application/x-www-form-urlencoded"
     SRequest req _bod <- toRequest'' ctype content
-    (parseRequestBodyEx ( setMaxRequestParmsSize 10 def ) lbsBackEnd req) `shouldThrow` anyErrorCall
+    (parseRequestBodyEx ( setMaxRequestParmsSize 10 def ) lbsBackEnd req) `shouldThrow` anyException
 
   where
     content2 =

wai-extra/wai-extra.cabal

@@ -1,5 +1,5 @@
 Name:                wai-extra
-Version:             3.1.14.0
+Version:             3.1.15
 Synopsis:            Provides some basic WAI handlers and middleware.
 description:
   Provides basic WAI handler and middleware functionality: