diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Changelog for wai-extra +## 3.1.18 + +* Fixed handling of quoted strings and semicolons in `parseRequestBodyEx` [#1038](https://github.com/yesodweb/wai/pull/1038). + In particular, multipart form data containing filenames with semicolons and `\` escaped characters + are now parsed correctly. +* Added instances `Foldable` and `Traversable` for `UrlMap'` [#992](https://github.com/yesodweb/wai/pull/992) + ## 3.1.17 * Started deprecation of `data-default` [#1011](https://github.com/yesodweb/wai/pull/1011) diff --git a/Network/Wai/Middleware/Approot.hs b/Network/Wai/Middleware/Approot.hs --- a/Network/Wai/Middleware/Approot.hs +++ b/Network/Wai/Middleware/Approot.hs @@ -36,7 +36,7 @@ import Data.Typeable (Typeable) import qualified Data.Vault.Lazy as V import Network.Wai (Middleware, Request, vault) -import System.Environment (getEnvironment) +import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO) import Network.Wai.Request (guessApproot) @@ -75,8 +75,8 @@ -- Since 3.0.7 envFallbackNamed :: String -> IO Middleware envFallbackNamed name = do - env <- getEnvironment - pure $ case lookup name env of + approot <- lookupEnv name + pure $ case approot of Just s -> hardcoded $ S8.pack s Nothing -> fromRequest diff --git a/Network/Wai/Parse.hs b/Network/Wai/Parse.hs --- a/Network/Wai/Parse.hs +++ b/Network/Wai/Parse.hs @@ -576,7 +576,7 @@ let x = do cd <- lookup contDisp ls' let ct = lookup contType ls' - let attrs = parseAttrs cd + let attrs = parseContentDispositionAttrs cd name <- lookup "name" attrs return (ct, name, lookup "filename" attrs) case x of @@ -796,17 +796,35 @@ b <- final return (b, seed) -parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)] -parseAttrs = map go . S.split _semicolon - where - tw = S.dropWhile (== _space) - dq s = - if S.length s > 2 && S.head s == _quotedbl && S.last s == _quotedbl - then S.tail $ S.init s - else s - go s = - let (x, y) = breakDiscard _equal s - in (tw x, dq $ tw y) +parseContentDispositionAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)] +parseContentDispositionAttrs = parseTokenValues + where + nonTokenChars = [_semicolon, _equal] + dropSpace = S.dropWhile (== _space) + parseTokenValues input | S.null input = [] + parseTokenValues input = + let (token, rest) = parseToken $ dropSpace input + in case S.uncons rest of + Just (c, rest') + | c == _equal -> + let (value, rest'') = parseValue rest' + in (token, value) : parseTokenValues (S.drop 1 rest'') + | otherwise -> (token, S.empty) : parseTokenValues rest' + Nothing -> (token, S.empty) : parseTokenValues S.empty + parseToken = S.break (`elem` nonTokenChars) + parseValue input = + case S.uncons $ dropSpace input of + Just (c, rest) | c == _quotedbl -> parseQuotedString [] rest + _ -> S.break (`elem` nonTokenChars) $ dropSpace input + parseQuotedString acc input = + let (prefix, rest) = S.break (`elem` [_quotedbl, _backslash]) input + in case S.uncons rest of + Just (c, rest') + | c == _quotedbl -> (S.concat $ reverse (prefix:acc), rest') + | c == _backslash -> + let (slashed, postSlash) = S.splitAt 1 rest' + in parseQuotedString (slashed:prefix:acc) postSlash + _ -> (S.concat $ reverse (prefix:acc), rest) killCRLF :: S.ByteString -> S.ByteString killCRLF bs diff --git a/Network/Wai/UrlMap.hs b/Network/Wai/UrlMap.hs --- a/Network/Wai/UrlMap.hs +++ b/Network/Wai/UrlMap.hs @@ -52,6 +52,14 @@ empty = UrlMap' empty (UrlMap' xs) <|> (UrlMap' ys) = UrlMap' (xs <|> ys) +-- | @since 3.1.18 +instance Foldable UrlMap' where + foldr f z (UrlMap' xs) = foldr (f . snd) z xs + +-- | @since 3.1.18 +instance Traversable UrlMap' where + traverse f (UrlMap' xs) = UrlMap' <$> traverse (traverse f) xs + type UrlMap = UrlMap' Application -- | Mount an application under a given path. The ToApplication typeclass gives diff --git a/test/Network/Wai/ParseSpec.hs b/test/Network/Wai/ParseSpec.hs --- a/test/Network/Wai/ParseSpec.hs +++ b/test/Network/Wai/ParseSpec.hs @@ -197,6 +197,16 @@ SRequest req _bod <- toRequest'' ctype content parseRequestBodyEx (setMaxRequestParmsSize 10 def) lbsBackEnd req `shouldThrow` anyException + it "parsing filename with semi-colon" $ do + SRequest req _bod <- toRequest'' ctype3 content6 + let expected = ([], [("yaml", FileInfo "semi; colon;" "application/octet-stream" "Photo blog using Hack.\n")]) + body <- parseRequestBodyEx def lbsBackEnd req + body `shouldBe` expected + it "parsing filename with semi-colon" $ do + SRequest req _bod <- toRequest'' ctype3 content7 + let expected = ([], [("yaml", FileInfo "this will be dropped, !only this will be returned" "application/octet-stream" "Photo blog using Hack.\n")]) + body <- parseRequestBodyEx def lbsBackEnd req + body `shouldBe` expected where content2 = "--AaB03x\n" @@ -242,6 +252,18 @@ <> "Content-Type: application/octet-stream\r\n\r\n" <> "Photo blog using Hack.\n\r\n" <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n" + content6 = + "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n" + <> "Content-Disposition: form-data; name=\"yaml\"; filename=\"semi; colon;\"\r\n" + <> "Content-Type: application/octet-stream\r\n\r\n" + <> "Photo blog using Hack.\n\r\n" + <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n" + content7 = + "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n" + <> "Content-Disposition: form-data; name=\"yaml\"; filename=\"this will be dropped, \\!only this will be returned\r\n" + <> "Content-Type: application/octet-stream\r\n\r\n" + <> "Photo blog using Hack.\n\r\n" + <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n" caseMultipartPlus :: Assertion caseMultipartPlus = do 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.1.17 +Version: 3.1.18 Synopsis: Provides some basic WAI handlers and middleware. description: Provides basic WAI handler and middleware functionality: