diff --git a/Web/Encodings.hs b/Web/Encodings.hs --- a/Web/Encodings.hs +++ b/Web/Encodings.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------- -- | -- Module : Web.Encodings @@ -45,7 +46,6 @@ -- * Date/time encoding , formatW3 -- * WAI-specific decodings - , parseRequestBody , Sink (..) , lbsSink , tempFileSink @@ -72,10 +72,8 @@ 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. -- @@ -475,206 +473,13 @@ , 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 (PSBegin x) = show ("PSBegin" :: String, B8.unpack $ B8.concat $ x []) + show (PSParam x y) = show ("PSParam" :: String, x, y) + show (PSFile x y z _ _) = show ("PSFile" :: String, 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 @@ -220,11 +220,11 @@ concatMapUtf8 = concatMap instance StringLike TS.Text where - span = TS.spanBy + span = TS.span null = TS.null concatMap f = TS.concatMap $ pack . f dropWhile = TS.dropWhile - break = TS.breakBy + break = TS.break cons = TS.cons uncons = TS.uncons append = TS.append @@ -243,11 +243,11 @@ concatMapUtf8 f = concatMap (concatMap f . utf8EncodeChar) instance StringLike TL.Text where - span = TL.spanBy + span = TL.span null = TL.null concatMap f = TL.concatMap $ pack . f dropWhile = TL.dropWhile - break = TL.breakBy + break = TL.break cons = TL.cons uncons = TL.uncons append = TL.append diff --git a/runtests.hs b/runtests.hs --- a/runtests.hs +++ b/runtests.hs @@ -20,7 +20,6 @@ import Web.Encodings.StringLike (StringLike) import Control.Arrow ((***)) import qualified Data.ByteString as B -import Network.Wai main :: IO () main = defaultMain [tests] @@ -51,7 +50,6 @@ , 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 @@ -198,103 +196,3 @@ 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,10 +1,10 @@ name: web-encodings -version: 0.2.6.2 +version: 0.3.0.9 license: BSD3 license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman -synopsis: Encapsulate multiple web encoding in a single package. +synopsis: Encapsulate multiple web encoding in a single package. (deprecated) description: The idea is to minimize external dependencies so this is usable in just about any context. category: Web stability: stable @@ -18,13 +18,12 @@ library build-depends: base >= 4 && <5, - time >= 1.1.2.4 && < 1.3, + time >= 1.1.2.4, old-locale >= 1.0.0.1 && < 1.1, bytestring >= 0.9.1.4 && < 0.10, - text >= 0.5 && < 0.8, + text >= 0.11 && < 0.12, failure >= 0.0.0 && < 0.2, - wai >= 0.0.0 && < 0.2, - directory >= 1 && < 1.1 + directory >= 1 && < 1.2 exposed-modules: Web.Encodings Web.Encodings.MimeHeader, Web.Encodings.StringLike, @@ -39,7 +38,7 @@ test-framework-hunit, HUnit, QuickCheck >= 2 && < 3, - convertible-text >= 0.2.0 && < 0.3 + convertible-text >= 0.2.0 && < 0.4 else Buildable: False ghc-options: -Wall