37c2cc6 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Tests all pass

37c2cc6Michael Snoyman16 years ago

Network/Wai/Parse.hs+6−32

compare with master

unifiedsplit

@@ -3,8 +3,7 @@

3-- | Some helpers for parsing data out of a raw WAI 'Request'.

5module Network.Wai.Parse

6− ( parseQueryString

7− , parseHttpAccept

6+ ( parseHttpAccept

8 , parseRequestBody

7 , parseRequestBody

9 , Sink (..)

8 , Sink (..)

10 , lbsSink

9 , lbsSink

@@ -36,6 +35,7 @@ import qualified Data.Enumerator as E

36import qualified Data.Enumerator.List as EL

35import qualified Data.Enumerator.List as EL

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

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

38import qualified Data.Ascii as A

37import qualified Data.Ascii as A

38+import qualified Network.HTTP.Types as H

40uncons :: S.ByteString -> Maybe (Word8, S.ByteString)

41uncons s

@@ -47,33 +47,6 @@ breakDiscard w s =

47 let (x, y) = S.break (== w) s

48 in (x, S.drop 1 y)

50−-- | Split out the query string into a list of keys and values. A few

51−-- importants points:

52−--

53−-- * There is no way to distinguish between a parameter with no value and a

54−-- parameter with an empty value. Eg, "foo=" and "foo" are the same.

55−--

56−-- * The result returned is still bytestrings, since we perform no character

57−-- decoding here. Most likely, you will want to use UTF-8 decoding, but this is

58−-- left to the user of the library.

59−--

60−-- * Percent decoding errors are ignored. In particular, "%Q" will be output as

61−-- "%Q".

62−parseQueryString :: S.ByteString -> [(S.ByteString, S.ByteString)]

63−parseQueryString = parseQueryString' . dropQuestion

64− where

65− dropQuestion q | S.null q || S.head q /= 63 = q

66− dropQuestion q | otherwise = S.tail q

67− parseQueryString' q | S.null q = []

68− parseQueryString' q =

69− let (x, xs) = breakDiscard 38 q -- ampersand

70− in parsePair x : parseQueryString' xs

71− where

72− parsePair x =

73− let (k, v) = breakDiscard 61 x -- equal sign

74− in (qsDecode k, qsDecode v)

75−

76−

77qsDecode :: S.ByteString -> S.ByteString

50qsDecode :: S.ByteString -> S.ByteString

78qsDecode z = fst $ S.unfoldrN (S.length z) go z

51qsDecode z = fst $ S.unfoldrN (S.length z) go z

79 where

52 where

@@ -97,11 +70,12 @@ qsDecode z = fst $ S.unfoldrN (S.length z) go z

97 combine a b = shiftL a 4 .|. b

70 combine a b = shiftL a 4 .|. b

99-- | Parse the HTTP accept string to determine supported content types.

72-- | Parse the HTTP accept string to determine supported content types.

100−parseHttpAccept :: S.ByteString -> [S.ByteString]

73+parseHttpAccept :: A.Ascii -> [A.Ascii]

101−parseHttpAccept = map fst

74+parseHttpAccept = map (A.unsafeFromByteString . fst)

102 . sortBy (rcompare `on` snd)

75 . sortBy (rcompare `on` snd)

103 . map grabQ

76 . map grabQ

104 . S.split 44 -- comma

77 . S.split 44 -- comma

78+ . A.toByteString

105 where

79 where

106 rcompare :: Double -> Double -> Ordering

80 rcompare :: Double -> Double -> Ordering

107 rcompare = flip compare

81 rcompare = flip compare

@@ -164,7 +138,7 @@ parseRequestBody sink req = do

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

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

165 -- strict byte strings here.

139 -- strict byte strings here.

166 bs <- EL.consume

140 bs <- EL.consume

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

141+ return (H.parseSimpleQuery $ S.concat bs, [])

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

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

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

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

170 in parsePieces sink bound''

144 in parsePieces sink bound''

Network/Wai/Zlib.hs+2−1

@@ -3,8 +3,9 @@ module Network.Wai.Zlib (compress) where

3import Prelude hiding (head)

4import Data.Enumerator

5 ( Enumeratee, checkDone, Stream (..)

6− , (>>==), head, ($$), joinI

6+ , (>>==), ($$), joinI

7 )

8+import Data.Enumerator.List (head)

8import Blaze.ByteString.Builder (Builder, fromByteString)

9import Blaze.ByteString.Builder (Builder, fromByteString)

9import Blaze.ByteString.Builder.Enumerator (builderToByteString)

10import Blaze.ByteString.Builder.Enumerator (builderToByteString)

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

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

runtests.hs+21−20

@@ -24,6 +24,8 @@ import Data.Enumerator (run_, enumList, ($$), Iteratee)

24import Data.Enumerator.Binary (enumFile)

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

26import Data.Maybe (fromMaybe)

27+import Network.HTTP.Types (parseSimpleQuery, status200)

28+import qualified Data.Ascii as A

28main :: IO ()

30main :: IO ()

29main = defaultMain [testSuite]

31main = defaultMain [testSuite]

@@ -51,7 +53,7 @@ testSuite = testGroup "Network.Wai.Parse"

51caseParseQueryString :: Assertion

53caseParseQueryString :: Assertion

52caseParseQueryString = do

54caseParseQueryString = do

53 let go l r =

55 let go l r =

54− map (S8.pack *** S8.pack) l @=? parseQueryString (S8.pack r)

56+ map (S8.pack *** S8.pack) l @=? parseSimpleQuery (S8.pack r)

56 go [] ""

58 go [] ""

57 go [("foo", "")] "foo"

59 go [("foo", "")] "foo"

@@ -68,7 +70,7 @@ caseParseQueryStringQM :: Assertion

68caseParseQueryStringQM = do

70caseParseQueryStringQM = do

69 let go l r =

71 let go l r =

70 map (S8.pack *** S8.pack) l

72 map (S8.pack *** S8.pack) l

71− @=? parseQueryString (S8.pack $ '?' : r)

73+ @=? parseSimpleQuery (S8.pack $ '?' : r)

73 go [] ""

75 go [] ""

74 go [("foo", "")] "foo"

76 go [("foo", "")] "foo"

@@ -83,10 +85,9 @@ caseParseQueryStringQM = do

84caseParseHttpAccept :: Assertion

86caseParseHttpAccept :: Assertion

85caseParseHttpAccept = do

87caseParseHttpAccept = do

86− let input =

87− S8.pack "text/plain; q=0.5, text/html, text/x-dvi; q=0.8, text/x-c"

88+ let input = "text/plain; q=0.5, text/html, text/x-dvi; q=0.8, text/x-c"

88 expected = ["text/html", "text/x-c", "text/x-dvi", "text/plain"]

89 expected = ["text/html", "text/x-c", "text/x-dvi", "text/plain"]

89− map S8.pack expected @=? parseHttpAccept input

90+ expected @=? parseHttpAccept input

91parseRequestBody' :: Sink ([S8.ByteString] -> [S8.ByteString]) L.ByteString

92parseRequestBody' :: Sink ([S8.ByteString] -> [S8.ByteString]) L.ByteString

92 -> SRequest

93 -> SRequest

@@ -114,14 +115,14 @@ caseParseRequestBody = run_ t where

114 "--AaB03x--"

115 "--AaB03x--"

115 content3 = S8.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"

116 content3 = S8.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"

116 t = do

117 t = do

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

118+ let content1 = "foo=bar&baz=bin"

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

119+ let ctype1 = "application/x-www-form-urlencoded"

119 result1 <- parseRequestBody' lbsSink $ toRequest ctype1 content1

120 result1 <- parseRequestBody' lbsSink $ toRequest ctype1 content1

120 liftIO $ assertEqual "parsing post x-www-form-urlencoded"

121 liftIO $ assertEqual "parsing post x-www-form-urlencoded"

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

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

122 result1

123 result1

123

124

124− let ctype2 = S8.pack "multipart/form-data; boundary=AaB03x"

125+ let ctype2 = "multipart/form-data; boundary=AaB03x"

125 result2 <- parseRequestBody' lbsSink $ toRequest ctype2 content2

126 result2 <- parseRequestBody' lbsSink $ toRequest ctype2 content2

126 let expectedsmap2 =

127 let expectedsmap2 =

127 [ ("title", "A File")

128 [ ("title", "A File")

@@ -136,7 +137,7 @@ caseParseRequestBody = run_ t where

136 expected2

137 expected2

137 result2

138 result2

138

139

139− let ctype3 = S8.pack "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh"

140+ let ctype3 = "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh"

140 result3 <- parseRequestBody' lbsSink $ toRequest ctype3 content3

141 result3 <- parseRequestBody' lbsSink $ toRequest ctype3 content3

141 let expectedsmap3 = []

142 let expectedsmap3 = []

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

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

@@ -156,12 +157,12 @@ caseParseRequestBody = run_ t where

156 expected3

157 expected3

157 result3'

158 result3'

158

159

159−toRequest :: S8.ByteString -> S8.ByteString -> SRequest

160+toRequest :: A.Ascii -> S8.ByteString -> SRequest

160toRequest ctype content = SRequest (Request

161toRequest ctype content = SRequest (Request

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

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

162 }) (L.fromChunks [content])

163 }) (L.fromChunks [content])

163

164

164−toRequest' :: S8.ByteString -> S8.ByteString -> SRequest

165+toRequest' :: A.Ascii -> S8.ByteString -> SRequest

165toRequest' ctype content = SRequest (Request

166toRequest' ctype content = SRequest (Request

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

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

167 }) (L.fromChunks $ map S.singleton $ S.unpack content)

168 }) (L.fromChunks $ map S.singleton $ S.unpack content)

@@ -223,21 +224,21 @@ jsonpApp = jsonp $ const $ return $ responseLBS

223caseJsonp :: Assertion

224caseJsonp :: Assertion

224caseJsonp = flip runSession jsonpApp $ do

225caseJsonp = flip runSession jsonpApp $ do

225 sres1 <- request Request

226 sres1 <- request Request

226− { queryString = "callback=test"

227+ { queryString = [("callback", Just "test")]

227 , requestHeaders = [("Accept", "text/javascript")]

228 , requestHeaders = [("Accept", "text/javascript")]

228 }

229 }

229 assertContentType "text/javascript" sres1

230 assertContentType "text/javascript" sres1

230 assertBody "test({\"foo\":\"bar\"})" sres1

231 assertBody "test({\"foo\":\"bar\"})" sres1

231

232

232 sres2 <- request Request

233 sres2 <- request Request

233− { queryString = "call_back=test"

234+ { queryString = [("call_back", Just "test")]

234 , requestHeaders = [("Accept", "text/javascript")]

235 , requestHeaders = [("Accept", "text/javascript")]

235 }

236 }

236 assertContentType "application/json" sres2

237 assertContentType "application/json" sres2

237 assertBody "{\"foo\":\"bar\"}" sres2

238 assertBody "{\"foo\":\"bar\"}" sres2

238

239

239 sres3 <- request Request

240 sres3 <- request Request

240− { queryString = "callback=test"

241+ { queryString = [("callback", Just "test")]

241 , requestHeaders = [("Accept", "text/html")]

242 , requestHeaders = [("Accept", "text/html")]

242 }

243 }

243 assertContentType "application/json" sres3

244 assertContentType "application/json" sres3

@@ -299,19 +300,19 @@ moApp = methodOverride $ \req -> return $ responseLBS status200

299caseMethodOverride = flip runSession moApp $ do

300caseMethodOverride = flip runSession moApp $ do

300 sres1 <- request Request

301 sres1 <- request Request

301 { requestMethod = "GET"

302 { requestMethod = "GET"

302− , queryString = ""

303+ , queryString = []

303 }

304 }

304 assertHeader "Method" "GET" sres1

305 assertHeader "Method" "GET" sres1

305

306

306 sres2 <- request Request

307 sres2 <- request Request

307 { requestMethod = "POST"

308 { requestMethod = "POST"

308− , queryString = ""

309+ , queryString = []

309 }

310 }

310 assertHeader "Method" "POST" sres2

311 assertHeader "Method" "POST" sres2

311

312

312 sres3 <- request Request

313 sres3 <- request Request

313 { requestMethod = "POST"

314 { requestMethod = "POST"

314− , queryString = "_method=PUT"

315+ , queryString = [("_method", Just "PUT")]

315 }

316 }

316 assertHeader "Method" "PUT" sres3

317 assertHeader "Method" "PUT" sres3

317

318

@@ -320,19 +321,19 @@ aoApp = acceptOverride $ \req -> return $ responseLBS status200

320

321

321caseAcceptOverride = flip runSession aoApp $ do

322caseAcceptOverride = flip runSession aoApp $ do

322 sres1 <- request Request

323 sres1 <- request Request

323− { queryString = ""

324+ { queryString = []

324 , requestHeaders = [("Accept", "foo")]

325 , requestHeaders = [("Accept", "foo")]

325 }

326 }

326 assertHeader "Accept" "foo" sres1

327 assertHeader "Accept" "foo" sres1

327

328

328 sres2 <- request Request

329 sres2 <- request Request

329− { queryString = ""

330+ { queryString = []

330 , requestHeaders = [("Accept", "bar")]

331 , requestHeaders = [("Accept", "bar")]

331 }

332 }

332 assertHeader "Accept" "bar" sres2

333 assertHeader "Accept" "bar" sres2

333

334

334 sres3 <- request Request

335 sres3 <- request Request

335− { queryString = "_accept=baz"

336+ { queryString = [("_accept", Just "baz")]

336 , requestHeaders = [("Accept", "bar")]

337 , requestHeaders = [("Accept", "bar")]

337 }

338 }

338 assertHeader "Accept" "baz" sres3

339 assertHeader "Accept" "baz" sres3