5e70fef · typeable/wai

git.iko.soy/typeable/wai

Got tests passing again

commit5e70fef3f1028d9adcfad89a533bdd28d50af6d3 authorMichael Snoyman <michael@snoyman.com> dateFri 24 Dec 2010, 11:41 (16 years ago) parentb9be2fc

2 files changed+68−73

compare with master

unifiedsplit

Network/Wai/Parse.hs+20−22 runtests.hs+48−51

Network/Wai/Parse.hs+20−22

@@ -14,6 +14,9 @@ module Network.Wai.Parse

1414 , Bound (..)

1515 , findBound

1616 , sinkTillBound

17+ , killCR

18+ , killCRLF

19+ , takeLine

1720#endif

1821 ) where

1922

@@ -28,7 +31,7 @@ import Data.Function (on)

2831import System.Directory (removeFile, getTemporaryDirectory)

2932import System.IO (hClose, openBinaryTempFile, Handle)

3033import Network.Wai

31−import Data.Enumerator (Iteratee, yield)

34+import Data.Enumerator (Iteratee, yield, ($$))

3235import qualified Data.Enumerator as E

3336import Control.Monad.IO.Class (liftIO)

3437

@@ -154,7 +157,7 @@ parseRequestBody :: Sink x y

154157parseRequestBody sink req = do

155158 case ctype of

156159 Nothing -> return ([], [])

157− Just Nothing -> do -- url-encoded

160+ Just Nothing -> requestBody req $$ do -- url-encoded

158161 -- NOTE: in general, url-encoded data will be in a single chunk.

159162 -- Therefore, I'm optimizing for the usual case by sticking with

160163 -- strict byte strings here.

@@ -162,7 +165,7 @@ parseRequestBody sink req = do

162165 return (parseQueryString $ S.concat bs, [])

163166 Just (Just bound) -> -- multi-part

164167 let bound' = S8.pack "--" `S.append` bound

165− in parsePieces sink bound'

168+ in requestBody req $$ parsePieces sink bound'

166169 where

167170 urlenc = S8.pack "application/x-www-form-urlencoded"

168171 formBound = S8.pack "multipart/form-data; boundary="

@@ -185,25 +188,22 @@ takeLine = do

185188 then do

186189 x' <- takeLine

187190 case x' of

188− Nothing -> return $ Just x

189− Just x'' -> return $ Just $ S.append x x''

191+ Nothing -> return $ Just $ killCR x

192+ Just x'' -> return $ Just $ killCR $ S.append x x''

190193 else do

191194 E.yield () $ E.Chunks [S.drop 1 y]

192− return $ Just $ killCarriage x

193− where

194− killCarriage bs

195− | S.null bs = bs

196− | S.last bs == 13 = S.init bs -- carriage return

197− | otherwise = bs

195+ return $ Just $ killCR x

198196

199197takeLines :: Iteratee S.ByteString IO [S.ByteString]

200198takeLines = do

201199 res <- takeLine

202200 case res of

203201 Nothing -> return []

204− Just l -> do

205− ls <- takeLines

206− return $ l : ls

202+ Just l

203+ | S.null l -> return []

204+ | otherwise -> do

205+ ls <- takeLines

206+ return $ l : ls

207207

208208parsePieces :: Sink x y -> S.ByteString

209209 -> Iteratee S.ByteString IO ([Param], [File y])

@@ -212,16 +212,14 @@ parsePieces sink bound = do

212212 res' <- takeLines

213213 case res' of

214214 [] -> return ([], [])

215− ls -> do

216− let ls' = map parsePair ls

215+ _ -> do

216+ let ls' = map parsePair res'

217217 let x = do

218218 cd <- lookup contDisp ls'

219219 let ct = lookup contType ls'

220220 let attrs = parseAttrs cd

221− let nameBS = S8.pack "name"

222− name <- lookup nameBS attrs

223− let fnBS = S8.pack "filename"

224− return (ct, name, lookup fnBS attrs)

221+ name <- lookup "name" attrs

222+ return (ct, name, lookup "filename" attrs)

225223 case x of

226224 Just (mct, name, Just filename) -> do

227225 let ct = fromMaybe "application/octet-stream" mct

@@ -352,10 +350,10 @@ parseAttrs = map go . S.split 59 -- semicolon

352350

353351killCRLF :: S.ByteString -> S.ByteString

354352killCRLF bs

355− | S.null bs || S8.last bs /= '\n' = bs

353+ | S.null bs || S.last bs /= 10 = bs -- line feed

356354 | otherwise = killCR $ S.init bs

357355

358356killCR :: S.ByteString -> S.ByteString

359357killCR bs

360− | S.null bs || S8.last bs /= '\r' = bs

358+ | S.null bs || S.last bs /= 13 = bs -- carriage return

361359 | otherwise = S.init bs

runtests.hs+48−51

@@ -1,13 +1,18 @@

1+{-# LANGUAGE OverloadedStrings #-}

12import Test.Framework (defaultMain, testGroup, Test)

23import Test.Framework.Providers.HUnit

34import Test.HUnit hiding (Test)

56import Network.Wai

67import Network.Wai.Parse

8+import qualified Data.ByteString as S

79import qualified Data.ByteString.Char8 as S8

810import qualified Data.ByteString.Lazy.Char8 as L8

911import Control.Arrow

1012

13+import Data.Enumerator (run_, enumList, ($$))

14+import Control.Monad.IO.Class (liftIO)

15+

1116main :: IO ()

1217main = defaultMain [testSuite]

1318

@@ -15,11 +20,13 @@ testSuite :: Test

1520testSuite = testGroup "Network.Wai.Parse"

1621 [ testCase "parseQueryString" caseParseQueryString

1722 , testCase "parseQueryString with question mark" caseParseQueryStringQM

18− , testCase "parseCookies" caseParseCookies

1923 , testCase "parseHttpAccept" caseParseHttpAccept

2024 , testCase "parseRequestBody" caseParseRequestBody

2125 , testCase "findBound" caseFindBound

2226 , testCase "sinkTillBound" caseSinkTillBound

27+ , testCase "killCR" caseKillCR

28+ , testCase "killCRLF" caseKillCRLF

29+ , testCase "takeLine" caseTakeLine

2330 ]

2431

2532caseParseQueryString :: Assertion

@@ -55,12 +62,6 @@ caseParseQueryStringQM = do

5562 go [("/", "")] "%2f"

5663 go [("foo bar", "")] "foo+bar"

5764

58−caseParseCookies :: Assertion

59−caseParseCookies = do

60− let input = S8.pack "a=a1;b=b2; c=c3"

61− expected = [("a", "a1"), ("b", "b2"), ("c", "c3")]

62− map (S8.pack *** S8.pack) expected @=? parseCookies input

63−

6465caseParseHttpAccept :: Assertion

6566caseParseHttpAccept = do

6667 let input =

@@ -69,7 +70,7 @@ caseParseHttpAccept = do

6970 map S8.pack expected @=? parseHttpAccept input

7071

7172caseParseRequestBody :: Assertion

72−caseParseRequestBody = t where

73+caseParseRequestBody = run_ t where

7374 content2 = S8.pack $

7475 "--AaB03x\n" ++

7576 "Content-Disposition: form-data; name=\"document\"; filename=\"b.txt\"\n" ++

@@ -91,7 +92,7 @@ caseParseRequestBody = t where

9192 let content1 = S8.pack "foo=bar&baz=bin"

9293 let ctype1 = S8.pack "application/x-www-form-urlencoded"

9394 result1 <- parseRequestBody lbsSink $ toRequest ctype1 content1

94− assertEqual "parsing post x-www-form-urlencoded"

95+ liftIO $ assertEqual "parsing post x-www-form-urlencoded"

9596 (map (S8.pack *** S8.pack) [("foo", "bar"), ("baz", "bin")], [])

9697 result1

9798

@@ -106,7 +107,7 @@ caseParseRequestBody = t where

106107 [(S8.pack "document", FileInfo (S8.pack "b.txt") textPlain $ L8.pack

107108 "This is a file.\nIt has two lines.")]

108109 let expected2 = (map (S8.pack *** S8.pack) expectedsmap2, expectedfile2)

109− assertEqual "parsing post multipart/form-data"

110+ liftIO $ assertEqual "parsing post multipart/form-data"

110111 expected2

111112 result2

112113

@@ -116,59 +117,32 @@ caseParseRequestBody = t where

116117 let expectedfile3 = [(S8.pack "yaml", FileInfo (S8.pack "README") (S8.pack "application/octet-stream") $

117118 L8.pack "Photo blog using Hack.\n")]

118119 let expected3 = (expectedsmap3, expectedfile3)

119− assertEqual "parsing actual post multipart/form-data"

120+ liftIO $ assertEqual "parsing actual post multipart/form-data"

120121 expected3

121122 result3

122123

123124 result2' <- parseRequestBody lbsSink $ toRequest' ctype2 content2

124− assertEqual "parsing post multipart/form-data 2"

125+ liftIO $ assertEqual "parsing post multipart/form-data 2"

125126 expected2

126127 result2'

127128

128129 result3' <- parseRequestBody lbsSink $ toRequest' ctype3 content3

129− assertEqual "parsing actual post multipart/form-data 2"

130+ liftIO $ assertEqual "parsing actual post multipart/form-data 2"

130131 expected3

131132 result3'

132133

133134toRequest :: S8.ByteString -> S8.ByteString -> Request

134135toRequest ctype content = Request

135− { requestHeaders = [(ReqContentType, ctype)]

136− , requestBody = toSource content

137− , requestMethod = undefined

138− , httpVersion = undefined

139− , pathInfo = undefined

140− , queryString = undefined

141− , serverName = undefined

142− , serverPort = undefined

143− , urlScheme = undefined

144− , errorHandler = undefined

145− , remoteHost = undefined

136+ { requestHeaders = [("Content-Type", ctype)]

137+ , requestBody = enumList 1 [content]

146138 }

147139

148140toRequest' :: S8.ByteString -> S8.ByteString -> Request

149141toRequest' ctype content = Request

150− { requestHeaders = [(ReqContentType, ctype)]

151− , requestBody = toSource' content

152− , requestMethod = undefined

153− , httpVersion = undefined

154− , pathInfo = undefined

155− , queryString = undefined

156− , serverName = undefined

157− , serverPort = undefined

158− , urlScheme = undefined

159− , errorHandler = undefined

160− , remoteHost = undefined

142+ { requestHeaders = [("Content-Type", ctype)]

143+ , requestBody = enumList 1 $ map S.singleton $ S.unpack content

161144 }

162145

163−toSource :: S8.ByteString -> Source

164−toSource bs = Source $

165− case S8.uncons bs of

166− Nothing -> return Nothing

167− Just (x, xs) -> return $ Just (S8.singleton x, toSource xs)

168−

169−toSource' :: S8.ByteString -> Source

170−toSource' bs = Source $ return $ Just (bs, Source $ return Nothing)

171−

172146caseFindBound :: Assertion

173147caseFindBound = do

174148 findBound (S8.pack "def") (S8.pack "abcdefghi") @?=

@@ -181,16 +155,39 @@ caseFindBound = do

181155

182156caseSinkTillBound :: Assertion

183157caseSinkTillBound = do

184− caseSinkTillBoundHelper $ Just . toSource

185− caseSinkTillBoundHelper $ Just . toSource'

186−

187−caseSinkTillBoundHelper :: (S8.ByteString -> Maybe Source) -> Assertion

188−caseSinkTillBoundHelper tosrc = do

189158 let iter () _ = return ()

190159 let src = S8.pack "this is some text"

191160 bound1 = S8.pack "some"

192161 bound2 = S8.pack "some!"

193− (_, res1, _) <- sinkTillBound bound1 (S8.empty, tosrc src) iter ()

162+ let enum = enumList 1 [src]

163+ let helper _ _ = return ()

164+ (_, res1) <- run_ $ enum $$ sinkTillBound bound1 helper ()

194165 res1 @?= True

195− (_, res2, _) <- sinkTillBound bound2 (S8.empty, tosrc src) iter ()

166+ (_, res2) <- run_ $ enum $$ sinkTillBound bound2 helper ()

196167 res2 @?= False

168+

169+caseKillCR :: Assertion

170+caseKillCR = do

171+ "foo" @=? killCR "foo"

172+ "foo" @=? killCR "foo\r"

173+ "foo\r\n" @=? killCR "foo\r\n"

174+ "foo\r'" @=? killCR "foo\r'"

175+

176+caseKillCRLF :: Assertion

177+caseKillCRLF = do

178+ "foo" @=? killCRLF "foo"

179+ "foo\r" @=? killCRLF "foo\r"

180+ "foo" @=? killCRLF "foo\r\n"

181+ "foo\r'" @=? killCRLF "foo\r'"

182+ "foo" @=? killCRLF "foo\n"

183+

184+caseTakeLine :: Assertion

185+caseTakeLine = do

186+ helper "foo\nbar\nbaz" "foo"

187+ helper "foo\r\nbar\nbaz" "foo"

188+ helper "foo\nbar\r\nbaz" "foo"

189+ helper "foo\rbar\r\nbaz" "foo\rbar"

190+ where

191+ helper haystack needle = do

192+ x <- run_ $ enumList 1 [haystack] $$ takeLine

193+ Just needle @=? x