diff --git a/Web/Encodings.hs b/Web/Encodings.hs --- a/Web/Encodings.hs +++ b/Web/Encodings.hs @@ -1,5 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} --------------------------------------------------------- -- | -- Module : Web.Encodings @@ -42,6 +44,11 @@ , parseHttpAccept -- * Date/time encoding , formatW3 + -- * WAI-specific decodings + , parseRequestBody + , Sink (..) + , lbsSink + , tempFileSink ) where import Numeric (showHex) @@ -62,6 +69,14 @@ import Data.Typeable (Typeable) import Control.Exception (Exception) import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BL +import Data.Maybe (catMaybes) +import Data.Either (partitionEithers) +import Network.Wai +import System.Directory (getTemporaryDirectory, removeFile) +import System.IO +import Control.Monad (foldM) -- | Encode all but unreserved characters with percentage encoding. -- @@ -295,28 +310,15 @@ , fileContentType :: s , fileContent :: c } -instance Show s => Show (FileInfo s a) where - show (FileInfo fn ct _) = - "FileInfo: " ++ show fn ++ " (" ++ show ct ++ ")" + deriving (Eq, Show) -- | Parse a multipart form into parameters and files. parseMultipart :: StringLike s => String -- ^ boundary -> s -- ^ content -> ([(s, s)], [(s, FileInfo s s)]) -parseMultipart boundary content = - let pieces = getPieces boundary content - getJusts [] = [] - getJusts (Nothing:rest) = getJusts rest - getJusts ((Just x):rest) = x : getJusts rest - getLefts [] = [] - getLefts (Left x:rest) = x : getLefts rest - getLefts (Right _:rest) = getLefts rest - getRights [] = [] - getRights (Left _:rest) = getRights rest - getRights (Right x:rest) = x : getRights rest - pieces' = getJusts $ map parsePiece pieces - in (getLefts pieces', getRights pieces') +parseMultipart boundary = + partitionEithers . catMaybes . map parsePiece . getPieces boundary -- | Parse a single segment of a multipart/form-data POST. parsePiece :: (StringLike s, MonadFailure (AttributeNotFound s) m) @@ -343,14 +345,6 @@ => String -- ^ boundary -> s -- ^ content -> [s] -{- FIXME this would be nice... -getPieces b c = - let fullBound = ord '-' `BS.cons'` (ord '-' `BS.cons'` b) - pieces = fullBound `BS.split` c - in filter (/= toLazyByteString "--") $ - filter (not . BS.null) $ - map chompBS pieces --} getPieces _ c | SL.null c = [] getPieces b c = let fullBound = SL.pack $ '-' `SL.cons` ('-' `SL.cons` b) @@ -386,10 +380,14 @@ ((x, _):_) -> x [] -> 0 content = SL.take len body - urlenc = "application/x-www-form-urlencoded" - formBound = "multipart/form-data; boundary=" boundProcessed = drop (length formBound) ctype +urlenc :: String +urlenc = "application/x-www-form-urlencoded" + +formBound :: String +formBound = "multipart/form-data; boundary=" + {-# DEPRECATED decodeCookies "Please use parseCookies instead" #-} -- | Deprecate alias for 'parseCookies'. decodeCookies :: StringLike s => s -> [(s, s)] @@ -441,3 +439,235 @@ -- | Format a 'UTCTime' in W3 format; useful for setting cookies. formatW3 :: UTCTime -> String formatW3 = formatTime defaultTimeLocale "%FT%X-00:00" + +-- | A destination for data, the opposite of a 'Source'. +data Sink x y = Sink + { sinkInit :: IO x + , sinkAppend :: x -> BS.ByteString -> IO x + , sinkClose :: x -> IO y + , sinkFinalize :: y -> IO () + } + +lbsSink :: Sink ([BS.ByteString] -> [BS.ByteString]) BL.ByteString +lbsSink = Sink + { sinkInit = return id + , sinkAppend = \front bs -> return $ front . (:) bs + , sinkClose = \front -> return $ BL.fromChunks $ front [] + , sinkFinalize = \_ -> return () + } + +tempFileSink :: Sink (FilePath, Handle) FilePath +tempFileSink = Sink + { sinkInit = do + tempDir <- getTemporaryDirectory + openBinaryTempFile tempDir "webenc.buf" + , sinkAppend = \(fp, h) bs -> BS.hPut h bs >> return (fp, h) + , sinkClose = \(fp, h) -> do + hClose h + return fp + , sinkFinalize = \fp -> removeFile fp + } + +-- | This function works just like 'parsePost', which two important distinctions: +-- +-- * It runs on a 'Source', which is the datatype used by the WAI for feeding a +-- request body. +-- +-- * It allows you to specify a 'Sink' for receiving each individual file +-- parameter, so that you can avoid allocating large amounts of memory if +-- desired. +-- +-- Remember that it is your obligation to call 'sinkFinalize' on the returned +-- values. +parseRequestBody :: Sink x y + -> Request + -> IO ([(BL.ByteString, BL.ByteString)], + [(BS.ByteString, FileInfo BS.ByteString y)]) +parseRequestBody sink req = do + let ctype = do + {- NOTE: Ignoring length, WAI must handle it + clen' <- lookup ReqContentLength $ requestHeaders req + clen'' <- readMay $ B8.unpack clen' + -} + ctype' <- lookup ReqContentType $ requestHeaders req + if B8.pack urlenc `BS.isPrefixOf` ctype' + then Just Nothing + else if B8.pack formBound `BS.isPrefixOf` ctype' + then Just $ Just (BS.drop (length formBound) ctype') + else Nothing + case ctype of + Nothing -> return ([], []) + Just Nothing -> do + lbs <- sourceToLbsStrict $ requestBody req + return (decodeUrlPairs lbs, []) + Just (Just bound) -> + parsePieces sink (PSBegin id) bound BS.empty (requestBody req) id id + +type PieceReturn sink = + Either + (BL.ByteString, BL.ByteString) + (BS.ByteString, FileInfo BS.ByteString sink) + +data ParseState seed + = PSBegin ([BS.ByteString] -> [BS.ByteString]) + | PSParam BL.ByteString BL.ByteString + | PSFile BL.ByteString BL.ByteString BL.ByteString seed BS.ByteString + | PSNothing +instance Show (ParseState x) where + show (PSBegin x) = show ("PSBegin", B8.unpack $ B8.concat $ x []) + show (PSParam x y) = show ("PSParam", x, y) + show (PSFile x y z _ _) = show ("PSFile", x, y, z) + show PSNothing = "PSNothing" + +-- | Parse a single segment of a multipart/form-data POST. +parsePiece' :: Sink x y + -> ParseState x + -> BS.ByteString + -> IO (ParseState x) +parsePiece' sink (PSBegin front) bs = + case SL.takeUntilBlankMaybe $ BL.fromChunks $ front [bs] of + Nothing -> return $ PSBegin $ front . (:) bs + Just (headers', content) -> + let headers = map parseHeader headers' + name = lookupHeaderAttr + (SL.pack "Content-Disposition") + (SL.pack "name") + headers + fname = lookupHeaderAttr + (SL.pack "Content-Disposition") + (SL.pack "filename") + headers + ctype = lookupHeader (SL.pack "Content-Type") headers + in case (name, fname, ctype) of + (Just name', Nothing, _) -> + return $ PSParam name' content + (Just name', Just fname', Just ctype') -> do + seed <- sinkInit sink + (seed', hasNewLine) + <- foldM (sinkAppendNL sink) (seed, BS.empty) + $ BL.toChunks content + return $ PSFile name' fname' ctype' seed' hasNewLine + _ -> return PSNothing +parsePiece' _ PSNothing _ = return PSNothing +parsePiece' _ (PSParam name content) bs = + return $ PSParam name $ BL.append content $ BL.fromChunks [bs] +parsePiece' sink (PSFile name fname ctype seed newLine) bs = do + let (bs', newLine') = mychomp bs + seed' <- sinkAppend sink seed newLine + seed'' <- sinkAppend sink seed' bs' + return $ PSFile name fname ctype seed'' newLine' + +mychomp :: BS.ByteString -> (BS.ByteString, BS.ByteString) +mychomp bs + | BS.null bs = (bs, BS.empty) + | B8.last bs == '\n' && BS.null (BS.init bs) = (BS.empty, bs) + | B8.last bs == '\n' && B8.last (BS.init bs) == '\r' = + (BS.init $ BS.init bs, B8.pack "\r\n") + | B8.last bs == '\n' = (BS.init bs, B8.pack "\n") + | otherwise = (bs, BS.empty) + +-- | Removes one new line from end. +sinkAppendNL :: Sink x y -> (x, BS.ByteString) -> BS.ByteString + -> IO (x, BS.ByteString) +sinkAppendNL sink (seed, prev) bs = do + seed' <- sinkAppend sink seed prev + let (bs', prev') = mychomp bs + seed'' <- sinkAppend sink seed' bs' + return (seed'', prev') + +type Param = (BL.ByteString, BL.ByteString) +type File y = (BS.ByteString, FileInfo BS.ByteString y) + +parsePieces :: Sink x y + -> ParseState x + -> BS.ByteString + -> BS.ByteString + -> Source + -> ([Param] -> [Param]) + -> ([File y] -> [File y]) + -> IO ([Param], [File y]) +parsePieces sink pstate boundary prev (Source source) frontp frontf = do + res <- source + case res of + Nothing -> do + (pstate', prev', frontp', frontf') <- go prev + if BS.null prev' || prev == prev' -- second clause ensures termination + then return (frontp' [], frontf' []) + else parsePieces sink pstate' boundary prev' (Source $ return Nothing) frontp' frontf' + Just (bs', source') -> do + let bs = BS.append prev bs' + (pstate', prev', frontp', frontf') <- go bs + parsePieces sink pstate' boundary prev' source' frontp' frontf' + where + go bs = + case hasBound boundary bs of + NoBound -> do + pstate' <- parsePiece' sink pstate bs + return (pstate', BS.empty, frontp, frontf) + MaybeBound -> return (pstate, bs, frontp, frontf) + HasBound before after -> do + pstate' <- parsePiece' sink pstate before + es <- extractState sink pstate' + let (frontp', frontf') = + case es of + Nothing -> (frontp, frontf) + Just (Left p) -> (frontp . (:) p, frontf) + Just (Right f) -> (frontp, frontf . (:) f) + return (PSBegin id, after, frontp', frontf') + +extractState :: Sink x y + -> ParseState x + -> IO (Maybe (PieceReturn y)) +extractState _ (PSBegin _) = return Nothing +extractState _ PSNothing = return Nothing +extractState _ (PSParam name val) = + return $ Just $ Left (name, SL.chomp val) +extractState sink (PSFile name fname ctype seed _newLine) = do + output <- sinkClose sink seed + return $ Just $ Right (BS.concat $ BL.toChunks name, FileInfo + { fileName = BS.concat $ BL.toChunks fname + , fileContentType = BS.concat $ BL.toChunks ctype + , fileContent = output + }) + +data HasBound = NoBound | MaybeBound | HasBound BS.ByteString BS.ByteString +hasBound :: BS.ByteString -> BS.ByteString -> HasBound +hasBound bound content = + case notEmpty $ BS.breakSubstring fullBound1 content of + Just (before, after) -> + let after' = BS.drop (BS.length fullBound1) after + in HasBound before $ SL.chompStart after' + Nothing -> + case notEmpty $ BS.breakSubstring fullBound2 content of + Just (before, after) -> + let after' = BS.drop (BS.length fullBound2) after + in HasBound before $ SL.chompStart after' + Nothing -> + case notEmpty $ BS.breakSubstring fullBound3 content of + Just (before, after) -> + let after' = BS.drop (BS.length fullBound3) after + in HasBound before $ SL.chompStart after' + Nothing -> + if endsWithBound + then MaybeBound + else NoBound + where + fullBound' = B8.cons '-' $ B8.cons '-' bound + fullBound1 = fullBound' `B8.snoc` '\n' + fullBound2 = fullBound' `B8.snoc` '\r' `B8.snoc` '\n' + fullBound3 = fullBound' `B8.snoc` '-' `B8.snoc` '-' + endsWithBound = + or $ map (\x -> x `BS.isSuffixOf` content) + $ (BS.inits fullBound2 ++ BS.inits fullBound3) + notEmpty (x, y) + | BS.null y = Nothing + | otherwise = Just (x, y) + +sourceToLbsStrict :: Source -> IO BL.ByteString +sourceToLbsStrict source0 = go source0 id + where + go (Source source) front = do + res <- source + case res of + Nothing -> return $ BL.fromChunks $ front [] + Just (bs, source') -> go source' $ front . (:) bs diff --git a/Web/Encodings/StringLike.hs b/Web/Encodings/StringLike.hs --- a/Web/Encodings/StringLike.hs +++ b/Web/Encodings/StringLike.hs @@ -65,6 +65,14 @@ '\n' -> chomp $ init s '\r' -> chomp $ init s _ -> s + chompStart :: a -> a + chompStart s = case uncons s of + Just ('\r', rest) -> + case uncons rest of + Just ('\n', rest') -> rest' + _ -> s + Just ('\n', rest) -> rest + _ -> s split :: Char -> a -> [a] split c s = let (next, rest) = breakChar c s @@ -109,6 +117,10 @@ let (x, y) = breakChar '\n' a x' = chomp x in (x', y) + takeLineMaybe :: a -> Maybe (a, a) + takeLineMaybe a = do + (x, y) <- breakCharMaybe '\n' a + Just (chomp x, y) takeUntilBlank :: a -> ([a], a) takeUntilBlank a = let (next, rest) = takeLine a @@ -116,6 +128,14 @@ then ([], rest) else let (nexts, rest') = takeUntilBlank rest in (next : nexts, rest') + takeUntilBlankMaybe :: a -> Maybe ([a], a) + takeUntilBlankMaybe a = do + (next, rest) <- takeLineMaybe a + if null next + then Just ([], rest) + else do + (nexts, rest') <- takeUntilBlankMaybe rest + Just (next : nexts, rest') lengthLT :: Int -> a -> Bool lengthLT i _ | i <= 0 = False diff --git a/runtests.hs b/runtests.hs --- a/runtests.hs +++ b/runtests.hs @@ -8,7 +8,7 @@ import Test.QuickCheck import Web.Encodings -import Data.Char (chr, ord) +import Data.Convertible.Text (cs) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BL @@ -19,6 +19,8 @@ import qualified Web.Encodings.StringLike as SL import Web.Encodings.StringLike (StringLike) import Control.Arrow ((***)) +import qualified Data.ByteString as B +import Network.Wai main :: IO () main = defaultMain [tests] @@ -36,7 +38,6 @@ , testCase "decode URL pairs" $ caseDecodeUrlPairs s , testCase "parse cookies" $ caseParseCookies s , testCase "parse http accept" $ caseParseHttpAccept s - -- FIXME , testCase "parse post" huParsePost , testCase "hebrew query string encode" $ caseHebrewQueryStringEncode s , testCase "hebrew query string decode" $ caseHebrewQueryStringDecode s , testCase "bad query string decode" $ caseBadQueryStringDecode s @@ -49,6 +50,8 @@ , allTests "Lazy ByteString" (undefined :: BL.ByteString) , allTests "Strict Text" (undefined :: TS.Text) , allTests "Lazy Text" (undefined :: TL.Text) + , testCase "parse post" huParsePost + , testCase "parse request body" huParseRequestBody ] qcEncodeDecodeUrl :: StringLike a => a -> a -> Bool @@ -113,48 +116,47 @@ instance Arbitrary TL.Text where arbitrary = fmap SL.pack arbitrary -{- FIXME +huParsePost :: Assertion huParsePost = t where - content2 = BSLU.fromString $ + content2 = cs $ "--AaB03x\n" ++ "Content-Disposition: form-data; name=\"document\"; filename=\"b.txt\"\n" ++ - "Content-Type: text/plain; charset=iso-8859-1\n" ++ + "Content-Type: text/plain; charset=iso-8859-1\n\n" ++ "This is a file.\n" ++ "It has two lines.\n" ++ "--AaB03x\n" ++ "Content-Disposition: form-data; name=\"title\"\n" ++ - "Content-Type: text/plain; charset=iso-8859-1\n" ++ + "Content-Type: text/plain; charset=iso-8859-1\n\n" ++ "A File\n" ++ "--AaB03x\n" ++ "Content-Disposition: form-data; name=\"summary\"\n" ++ - "Content-Type: text/plain; charset=iso-8859-1\n" ++ + "Content-Type: text/plain; charset=iso-8859-1\n\n" ++ "This is my file\n" ++ "file test\n" ++ "--AaB03x--\n" t = do - let content1 = BSLU.fromString "foo=bar&baz=bin" - let len1 = BSLU.fromString $ show $ BS.length content1 - let ctype1 = BSLU.fromString "application/x-www-form-urlencoded" + let content1 = cs "foo=bar&baz=bin" + let len1 = cs $ show $ BS.length content1 + let ctype1 = cs "application/x-www-form-urlencoded" let result1 = parsePost ctype1 len1 content1 assertEqual "parsing post x-www-form-urlencoded" - ([("foo", "bar"), ("baz", "bin")], []) + (map (cs *** cs) [("foo", "bar"), ("baz", "bin")], []) result1 - let ctype2 = BSLU.fromString "multipart/form-data; boundary=AaB03x" - let len2 = BSLU.fromString $ show $ BS.length content2 + let ctype2 = cs "multipart/form-data; boundary=AaB03x" + let len2 = cs $ show $ BS.length content2 let result2 = parsePost ctype2 len2 content2 let expectedsmap2 = [ ("title", "A File") , ("summary", "This is my file\nfile test") ] let expectedfile2 = - [ ("document", "b.txt", "text/plain", BSLU.fromString $ - "This is a file.\nIt has two lines.\n") ] - let expected2 = (expectedsmap2, expectedfile2) + [(cs "document", FileInfo (cs "b.txt") (cs "text/plain") $ cs + "This is a file.\nIt has two lines.")] + let expected2 = (map (cs *** cs) expectedsmap2, expectedfile2) assertEqual "parsing post multipart/form-data" expected2 result2 --} caseDecodeUrlPairs :: StringLike a => a -> IO () caseDecodeUrlPairs dummy = do @@ -196,3 +198,103 @@ encoded = SL.pack raw `asTypeOf` dummy expected = SL.unpackUtf8 bs expected @=? decodeUrlFailure encoded + +huParseRequestBody :: Assertion +huParseRequestBody = t where + content2 = cs $ + "--AaB03x\n" ++ + "Content-Disposition: form-data; name=\"document\"; filename=\"b.txt\"\n" ++ + "Content-Type: text/plain; charset=iso-8859-1\n\n" ++ + "This is a file.\n" ++ + "It has two lines.\n" ++ + "--AaB03x\n" ++ + "Content-Disposition: form-data; name=\"title\"\n" ++ + "Content-Type: text/plain; charset=iso-8859-1\n\n" ++ + "A File\n" ++ + "--AaB03x\n" ++ + "Content-Disposition: form-data; name=\"summary\"\n" ++ + "Content-Type: text/plain; charset=iso-8859-1\n\n" ++ + "This is my file\n" ++ + "file test\n" ++ + "--AaB03x--" + content3 = cs "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\nContent-Disposition: form-data; name=\"yaml\"; filename=\"README\"\r\nContent-Type: application/octet-stream\r\n\r\nPhoto blog using Hack.\n\r\n------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n" + t = do + let content1 = cs "foo=bar&baz=bin" + let ctype1 = cs "application/x-www-form-urlencoded" + result1 <- parseRequestBody lbsSink $ toRequest ctype1 content1 + assertEqual "parsing post x-www-form-urlencoded" + (map (cs *** cs) [("foo", "bar"), ("baz", "bin")], []) + result1 + + let ctype2 = cs "multipart/form-data; boundary=AaB03x" + result2 <- parseRequestBody lbsSink $ toRequest ctype2 content2 + let expectedsmap2 = + [ ("title", "A File") + , ("summary", "This is my file\nfile test") + ] + let expectedfile2 = + [(cs "document", FileInfo (cs "b.txt") (cs "text/plain") $ cs + "This is a file.\nIt has two lines.")] + let expected2 = (map (cs *** cs) expectedsmap2, expectedfile2) + assertEqual "parsing post multipart/form-data" + expected2 + result2 + + let ctype3 = cs "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh" + result3 <- parseRequestBody lbsSink $ toRequest ctype3 content3 + let expectedsmap3 = [] + let expectedfile3 = [(cs "yaml", FileInfo (cs "README") (cs "application/octet-stream") $ + cs "Photo blog using Hack.\n")] + let expected3 = (expectedsmap3, expectedfile3) + assertEqual "parsing actual post multipart/form-data" + expected3 + result3 + + result2' <- parseRequestBody lbsSink $ toRequest' ctype2 content2 + assertEqual "parsing post multipart/form-data 2" + expected2 + result2 + putStrLn "\n\n\n\n\n" + result3' <- parseRequestBody lbsSink $ toRequest' ctype3 content3 + assertEqual "parsing actual post multipart/form-data 2" + expected3 + result3' + +toRequest :: BS.ByteString -> BS.ByteString -> Request +toRequest ctype content = Request + { requestHeaders = [(ReqContentType, ctype)] + , requestBody = toSource content + , requestMethod = undefined + , httpVersion = undefined + , pathInfo = undefined + , queryString = undefined + , serverName = undefined + , serverPort = undefined + , urlScheme = undefined + , errorHandler = undefined + , remoteHost = undefined + } + +toRequest' :: BS.ByteString -> BS.ByteString -> Request +toRequest' ctype content = Request + { requestHeaders = [(ReqContentType, ctype)] + , requestBody = toSource' content + , requestMethod = undefined + , httpVersion = undefined + , pathInfo = undefined + , queryString = undefined + , serverName = undefined + , serverPort = undefined + , urlScheme = undefined + , errorHandler = undefined + , remoteHost = undefined + } + +toSource :: BS.ByteString -> Source +toSource bs = Source $ + case B.uncons bs of + Nothing -> return Nothing + Just (x, xs) -> return $ Just (B.singleton x, toSource xs) + +toSource' :: BS.ByteString -> Source +toSource' bs = Source $ return $ Just (bs, Source $ return Nothing) diff --git a/web-encodings.cabal b/web-encodings.cabal --- a/web-encodings.cabal +++ b/web-encodings.cabal @@ -1,5 +1,5 @@ name: web-encodings -version: 0.2.3 +version: 0.2.4 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -23,7 +23,9 @@ bytestring >= 0.9.1.4 && < 0.10, text >= 0.5 && < 0.8, failure >= 0.0.0 && < 0.1, - safe >= 0.2 && < 0.3 + safe >= 0.2 && < 0.3, + wai >= 0.0.0 && < 0.1, + directory >= 1 && < 1.1 exposed-modules: Web.Encodings Web.Encodings.MimeHeader, Web.Encodings.StringLike, @@ -34,10 +36,11 @@ if flag(buildtests) Buildable: True build-depends: test-framework, - test-framework-quickcheck, + test-framework-quickcheck2, test-framework-hunit, HUnit, - QuickCheck >= 1 && < 2 + QuickCheck >= 2 && < 3, + convertible-text >= 0.2.0 && < 0.3 else Buildable: False ghc-options: -Wall