web-encodings 0.2.6.2 → 0.3.0.9
raw patch · 4 files changed
Files
- Web/Encodings.hs +4/−199
- Web/Encodings/StringLike.hs +4/−4
- runtests.hs +0/−102
- web-encodings.cabal +6/−7
Web/Encodings.hs view
@@ -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
Web/Encodings/StringLike.hs view
@@ -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
runtests.hs view
@@ -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)
web-encodings.cabal view
@@ -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 <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com>-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