git.iko.soy/typeable/wai
on master help sign in
Beginning of parseRequestBody code
e2e63ffMichael Snoyman
Network/Wai/Parse.hs+160−5
compare with master
unifiedsplit
@@ -4,15 +4,24 @@ module Network.Wai.Parse
4 ( parseQueryString
4 ( parseQueryString
5 , parseCookies
5 , parseCookies
6 , parseHttpAccept
6 , parseHttpAccept
7+ , parseRequestBody
8+ , Sink (..)
9+ , lbsSink
10+ , tempFileSink
11+ , FileInfo (..)
7 ) where
12 ) where
8
13
9import qualified Data.ByteString as S
14import qualified Data.ByteString as S
15+import qualified Data.ByteString.Lazy as L
10import qualified Data.ByteString.Char8 as S8
16import qualified Data.ByteString.Char8 as S8
11import Data.Word (Word8)
17import Data.Word (Word8)
12import Data.Bits
18import Data.Bits
13import Data.Maybe (fromMaybe)
19import Data.Maybe (fromMaybe)
14import Data.List (sortBy)
20import Data.List (sortBy)
15import Data.Function (on)
21import Data.Function (on)
22+import System.Directory (removeFile, getTemporaryDirectory)
23+import System.IO (hClose, openBinaryTempFile, Handle)
24+import Network.Wai
16
25
17uncons :: S.ByteString -> Maybe (Word8, S.ByteString)
26uncons :: S.ByteString -> Maybe (Word8, S.ByteString)
18uncons s
27uncons s
@@ -84,7 +93,7 @@ parseHttpAccept :: S.ByteString -> [S.ByteString]
84parseHttpAccept = map fst
93parseHttpAccept = map fst
85 . sortBy (rcompare `on` snd)
94 . sortBy (rcompare `on` snd)
86 . map grabQ
95 . map grabQ
87− . split
96+ . S.split 44 -- comma
88 where
97 where
89 rcompare x y = compare y x
98 rcompare x y = compare y x
90 grabQ s =
99 grabQ s =
@@ -95,7 +104,153 @@ parseHttpAccept = map fst
95 (x, _):_ -> x
104 (x, _):_ -> x
96 _ -> 1.0
105 _ -> 1.0
97 trimWhite = S.dropWhile (== 32) -- space
106 trimWhite = S.dropWhile (== 32) -- space
98− split s
107+
99− | S.null s = []
108+-- | A destination for data, the opposite of a 'Source'.
109+data Sink x y = Sink
110+ { sinkInit :: IO x
111+ , sinkAppend :: x -> S.ByteString -> IO x
112+ , sinkClose :: x -> IO y
113+ , sinkFinalize :: y -> IO ()
114+ }
115+
116+lbsSink :: Sink ([S.ByteString] -> [S.ByteString]) L.ByteString
117+lbsSink = Sink
118+ { sinkInit = return id
119+ , sinkAppend = \front bs -> return $ front . (:) bs
120+ , sinkClose = \front -> return $ L.fromChunks $ front []
121+ , sinkFinalize = \_ -> return ()
122+ }
123+
124+tempFileSink :: Sink (FilePath, Handle) FilePath
125+tempFileSink = Sink
126+ { sinkInit = do
127+ tempDir <- getTemporaryDirectory
128+ openBinaryTempFile tempDir "webenc.buf"
129+ , sinkAppend = \(fp, h) bs -> S.hPut h bs >> return (fp, h)
130+ , sinkClose = \(fp, h) -> do
131+ hClose h
132+ return fp
133+ , sinkFinalize = \fp -> removeFile fp
134+ }
135+
136+-- | Information on an uploaded file.
137+data FileInfo c = FileInfo
138+ { fileName :: S.ByteString
139+ , fileContentType :: S.ByteString
140+ , fileContent :: c
141+ }
142+ deriving (Eq, Show)
143+
144+type Param = (S.ByteString, S.ByteString)
145+type File y = (S.ByteString, FileInfo y)
146+
147+parseRequestBody :: Sink x y
148+ -> Request
149+ -> IO ([Param], [File y])
150+parseRequestBody sink req = do
151+ let ctype = do
152+ ctype' <- lookup ReqContentType $ requestHeaders req
153+ if urlenc `S.isPrefixOf` ctype'
154+ then Just Nothing
155+ else if formBound `S.isPrefixOf` ctype'
156+ then Just $ Just $ S.drop (S.length formBound) ctype'
157+ else Nothing
158+ case ctype of
159+ Nothing -> return ([], [])
160+ Just Nothing -> do -- url-encoded
161+ -- NOTE: in general, url-encoded data will be in a single chunk.
162+ -- Therefore, I'm optimizing for the usual case by sticking with
163+ -- strict byte strings here.
164+ bs <- sourceToBs $ requestBody req
165+ return (parseQueryString bs, [])
166+ Just (Just bound) -> -- multi-part
167+ parsePieces sink bound (S.empty, Just $ requestBody req) True
168+ where
169+ urlenc = S8.pack "application/x-www-form-urlencoded"
170+ formBound = S8.pack "multipart/form-data; boundary="
171+
172+sourceToBs :: Source -> IO S.ByteString
173+sourceToBs = fmap S.concat . go id
174+ where
175+ go front (Source src) = do
176+ res <- src
177+ case res of
178+ Nothing -> return $ front []
179+ Just (bs, src') -> go (front . (:) bs) src'
180+
181+type Source' = (S.ByteString, Maybe Source)
182+
183+takeLine :: Source' -> IO (Maybe (S.ByteString, Source'))
184+takeLine (s, msrc)
185+ | S.null s = case msrc of
186+ Nothing -> return Nothing
187+ Just (Source src) -> do
188+ res <- src
189+ case res of
190+ Nothing -> return Nothing
191+ Just (x, y) -> takeLine (x, Just y)
192+takeLine (s, msrc) =
193+ let (x, y) = S.break (== 10) s -- newline
194+ in if S.null y
195+ then do
196+ case msrc of
197+ Nothing -> return $ Just (x, (y, msrc))
198+ Just (Source src) -> do
199+ res <- src
200+ case res of
201+ Nothing -> return $ Just (x, (y, Nothing))
202+ Just (s', src') ->
203+ takeLine (s `S.append` s', Just src')
204+ else return $ Just (killCarriage x, (S.drop 1 y, msrc))
205+ where
206+ killCarriage bs
207+ | S.null bs = bs
208+ | S.last bs == 13 = S.init bs -- carriage return
209+ | otherwise = bs
210+
211+takeLines :: Source' -> IO (Maybe ([S.ByteString], Source'))
212+takeLines src = do
213+ res <- takeLine src
214+ case res of
215+ Nothing -> return Nothing
216+ Just (l, src') ->
217+ if S.null l
218+ then return $ Just ([], src')
219+ else do
220+ res' <- takeLines src'
221+ case res' of
222+ Nothing -> return $ Just ([l], src')
223+ Just (ls, src'') -> return $ Just (l : ls, src'')
224+
225+parsePieces :: Sink x y -> S.ByteString -> Source' -> Bool
226+ -> IO ([Param], [File y])
227+parsePieces sink bound src isFirst = do
228+ print ("bound", bound)
229+ src' <- if isFirst
230+ then do
231+ res <- takeLine src -- first line should be bound
232+ case res of
233+ Nothing -> return (S.empty, Nothing)
234+ Just (_, x) -> return x
235+ else return src
236+ res <- takeLines src'
237+ case res of
238+ Nothing -> return ([], [])
239+ Just (ls, src'') -> do
240+ let ls' = map parsePair ls
241+ case (lookup contDisp ls', lookup contType ls') of
242+ (Just cd, Just ct) -> do
243+ return ([], []) -- FIXME
244+ _ -> do
245+ (isEnd, src''') <- dropTillBound bound src''
246+ if isEnd
247+ then return ([], [])
248+ else parsePieces sink bound src''' False
249+ where
250+ contDisp = S8.pack "Content-Disposition"
251+ contType = S8.pack "Content-Type"
252+ parsePair s =
100− | otherwise = let (x, y) = breakDiscard 44 s -- comma
253+ let (x, y) = breakDiscard 58 s -- colon
101− in x : split y
254+ in (x, S.dropWhile (== 32) y) -- space
255+
256+dropTillBound bound (bs, msrc) = error "FIXME dropTillBound"
runtests.hs+110
@@ -2,8 +2,11 @@ import Test.Framework (defaultMain, testGroup, Test)
2import Test.Framework.Providers.HUnit
2import Test.Framework.Providers.HUnit
3import Test.HUnit hiding (Test)
3import Test.HUnit hiding (Test)
4
4
5+import Network.Wai
5import Network.Wai.Parse
6import Network.Wai.Parse
7+import Network.Wai.Source
6import qualified Data.ByteString.Char8 as B8
8import qualified Data.ByteString.Char8 as B8
9+import qualified Data.ByteString.Lazy.Char8 as L8
7import Control.Arrow
10import Control.Arrow
8
11
9main :: IO ()
12main :: IO ()
@@ -14,6 +17,7 @@ testSuite = testGroup "Network.Wai.Parse"
14 [ testCase "parseQueryString" caseParseQueryString
17 [ testCase "parseQueryString" caseParseQueryString
15 , testCase "parseCookies" caseParseCookies
18 , testCase "parseCookies" caseParseCookies
16 , testCase "parseHttpAccept" caseParseHttpAccept
19 , testCase "parseHttpAccept" caseParseHttpAccept
20+ , testCase "parseRequestBody" caseParseRequestBody
17 ]
21 ]
18
22
19caseParseQueryString :: Assertion
23caseParseQueryString :: Assertion
@@ -44,3 +48,109 @@ caseParseHttpAccept = do
44 B8.pack "text/plain; q=0.5, text/html, text/x-dvi; q=0.8, text/x-c"
48 B8.pack "text/plain; q=0.5, text/html, text/x-dvi; q=0.8, text/x-c"
45 expected = ["text/html", "text/x-c", "text/x-dvi", "text/plain"]
49 expected = ["text/html", "text/x-c", "text/x-dvi", "text/plain"]
46 map B8.pack expected @=? parseHttpAccept input
50 map B8.pack expected @=? parseHttpAccept input
51+
52+caseParseRequestBody :: Assertion
53+caseParseRequestBody = t where
54+ content2 = B8.pack $
55+ "--AaB03x\n" ++
56+ "Content-Disposition: form-data; name=\"document\"; filename=\"b.txt\"\n" ++
57+ "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
58+ "This is a file.\n" ++
59+ "It has two lines.\n" ++
60+ "--AaB03x\n" ++
61+ "Content-Disposition: form-data; name=\"title\"\n" ++
62+ "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
63+ "A File\n" ++
64+ "--AaB03x\n" ++
65+ "Content-Disposition: form-data; name=\"summary\"\n" ++
66+ "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
67+ "This is my file\n" ++
68+ "file test\n" ++
69+ "--AaB03x--"
70+ content3 = B8.pack "------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"
71+ t = do
72+ let content1 = B8.pack "foo=bar&baz=bin"
73+ let ctype1 = B8.pack "application/x-www-form-urlencoded"
74+ result1 <- parseRequestBody lbsSink $ toRequest ctype1 content1
75+ assertEqual "parsing post x-www-form-urlencoded"
76+ (map (B8.pack *** B8.pack) [("foo", "bar"), ("baz", "bin")], [])
77+ result1
78+ putStrLn "passed 1" -- FIXME remove
79+
80+ let ctype2 = B8.pack "multipart/form-data; boundary=AaB03x"
81+ result2 <- parseRequestBody lbsSink $ toRequest ctype2 content2
82+ let expectedsmap2 =
83+ [ ("title", "A File")
84+ , ("summary", "This is my file\nfile test")
85+ ]
86+ let expectedfile2 =
87+ [(B8.pack "document", FileInfo (B8.pack "b.txt") (B8.pack "text/plain") $ L8.pack
88+ "This is a file.\nIt has two lines.")]
89+ let expected2 = (map (B8.pack *** B8.pack) expectedsmap2, expectedfile2)
90+ assertEqual "parsing post multipart/form-data"
91+ expected2
92+ result2
93+ putStrLn "passed 2" -- FIXME remove
94+
95+ let ctype3 = B8.pack "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh"
96+ result3 <- parseRequestBody lbsSink $ toRequest ctype3 content3
97+ let expectedsmap3 = []
98+ let expectedfile3 = [(B8.pack "yaml", FileInfo (B8.pack "README") (B8.pack "application/octet-stream") $
99+ L8.pack "Photo blog using Hack.\n")]
100+ let expected3 = (expectedsmap3, expectedfile3)
101+ assertEqual "parsing actual post multipart/form-data"
102+ expected3
103+ result3
104+ putStrLn "passed 3" -- FIXME remove
105+
106+ result2' <- parseRequestBody lbsSink $ toRequest' ctype2 content2
107+ assertEqual "parsing post multipart/form-data 2"
108+ expected2
109+ result2'
110+ putStrLn "passed 4" -- FIXME remove
111+
112+ putStrLn "\n\n\n\n\n"
113+ result3' <- parseRequestBody lbsSink $ toRequest' ctype3 content3
114+ assertEqual "parsing actual post multipart/form-data 2"
115+ expected3
116+ result3'
117+ putStrLn "passed 5" -- FIXME remove
118+
119+toRequest :: B8.ByteString -> B8.ByteString -> Request
120+toRequest ctype content = Request
121+ { requestHeaders = [(ReqContentType, ctype)]
122+ , requestBody = toSource content
123+ , requestMethod = undefined
124+ , httpVersion = undefined
125+ , pathInfo = undefined
126+ , queryString = undefined
127+ , serverName = undefined
128+ , serverPort = undefined
129+ , urlScheme = undefined
130+ , errorHandler = undefined
131+ , remoteHost = undefined
132+ }
133+
134+toRequest' :: B8.ByteString -> B8.ByteString -> Request
135+toRequest' ctype content = Request
136+ { requestHeaders = [(ReqContentType, ctype)]
137+ , requestBody = toSource' content
138+ , requestMethod = undefined
139+ , httpVersion = undefined
140+ , pathInfo = undefined
141+ , queryString = undefined
142+ , serverName = undefined
143+ , serverPort = undefined
144+ , urlScheme = undefined
145+ , errorHandler = undefined
146+ , remoteHost = undefined
147+ }
148+
149+toSource :: B8.ByteString -> Source
150+toSource bs = Source $
151+ case B8.uncons bs of
152+ Nothing -> return Nothing
153+ Just (x, xs) -> return $ Just (B8.singleton x, toSource xs)
154+
155+toSource' :: B8.ByteString -> Source
156+toSource' bs = Source $ return $ Just (bs, Source $ return Nothing)