forked from yesodweb/wai
-
Notifications
You must be signed in to change notification settings - Fork 0
/
WaiExtraTest.hs
506 lines (446 loc) · 18.2 KB
/
WaiExtraTest.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
{-# LANGUAGE OverloadedStrings #-}
module WaiExtraTest (specs) where
import Test.Hspec
import Test.HUnit hiding (Test)
import Network.Wai
import Network.Wai.Test
import Network.Wai.Parse
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.ByteString.Lazy as L
import qualified Data.Text.Lazy as T
import qualified Data.Text.Encoding as TE
import Control.Arrow
import Network.Wai.Middleware.Jsonp
import Network.Wai.Middleware.Gzip
import Network.Wai.Middleware.Vhost
import Network.Wai.Middleware.Autohead
import Network.Wai.Middleware.MethodOverride
import Network.Wai.Middleware.MethodOverridePost
import Network.Wai.Middleware.AcceptOverride
import Network.Wai.Middleware.RequestLogger
import Codec.Compression.GZip (decompress)
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import Data.Conduit.Binary (sourceFile)
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (fromMaybe)
import Network.HTTP.Types (parseSimpleQuery, status200)
import System.Log.FastLogger
import qualified Data.IORef as I
specs :: Spec
specs = do
describe "Network.Wai.Parse" $ do
it "parseQueryString" caseParseQueryString
it "parseQueryString with question mark" caseParseQueryStringQM
it "parseHttpAccept" caseParseHttpAccept
it "parseRequestBody" caseParseRequestBody
it "multipart with plus" caseMultipartPlus
it "urlencoded with plus" caseUrlEncPlus
{-
, it "findBound" caseFindBound
, it "sinkTillBound" caseSinkTillBound
, it "killCR" caseKillCR
, it "killCRLF" caseKillCRLF
, it "takeLine" caseTakeLine
-}
it "jsonp" caseJsonp
it "gzip" caseGzip
it "gzip not for MSIE" caseGzipMSIE
it "vhost" caseVhost
it "autohead" caseAutohead
it "method override" caseMethodOverride
it "method override post" caseMethodOverridePost
it "accept override" caseAcceptOverride
it "dalvik multipart" caseDalvikMultipart
it "debug request body" caseDebugRequestBody
caseParseQueryString :: Assertion
caseParseQueryString = do
let go l r =
map (S8.pack *** S8.pack) l @=? parseSimpleQuery (S8.pack r)
go [] ""
go [("foo", "")] "foo"
go [("foo", "bar")] "foo=bar"
go [("foo", "bar"), ("baz", "bin")] "foo=bar&baz=bin"
go [("%Q", "")] "%Q"
go [("%1Q", "")] "%1Q"
go [("%1", "")] "%1"
go [("/", "")] "%2F"
go [("/", "")] "%2f"
go [("foo bar", "")] "foo+bar"
caseParseQueryStringQM :: Assertion
caseParseQueryStringQM = do
let go l r =
map (S8.pack *** S8.pack) l
@=? parseSimpleQuery (S8.pack $ '?' : r)
go [] ""
go [("foo", "")] "foo"
go [("foo", "bar")] "foo=bar"
go [("foo", "bar"), ("baz", "bin")] "foo=bar&baz=bin"
go [("%Q", "")] "%Q"
go [("%1Q", "")] "%1Q"
go [("%1", "")] "%1"
go [("/", "")] "%2F"
go [("/", "")] "%2f"
go [("foo bar", "")] "foo+bar"
caseParseHttpAccept :: Assertion
caseParseHttpAccept = do
let input = "text/plain; q=0.5, text/html;charset=utf-8, text/*;q=0.8;ext=blah, text/x-dvi; q=0.8, text/x-c"
expected = ["text/html;charset=utf-8", "text/x-c", "text/x-dvi", "text/*", "text/plain"]
expected @=? parseHttpAccept input
parseRequestBody' :: BackEnd L.ByteString
-> SRequest
-> C.ResourceT IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo L.ByteString)])
parseRequestBody' sink (SRequest req bod) =
case getRequestBodyType req of
Nothing -> return ([], [])
Just rbt -> CL.sourceList (L.toChunks bod) C.$$ sinkRequestBody sink rbt
caseParseRequestBody :: Assertion
caseParseRequestBody =
C.runResourceT t
where
content2 = S8.pack $
"--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 = 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"
t = do
let content1 = "foo=bar&baz=bin"
let ctype1 = "application/x-www-form-urlencoded"
result1 <- parseRequestBody' lbsBackEnd $ toRequest ctype1 content1
liftIO $ assertEqual "parsing post x-www-form-urlencoded"
(map (S8.pack *** S8.pack) [("foo", "bar"), ("baz", "bin")], [])
result1
let ctype2 = "multipart/form-data; boundary=AaB03x"
result2 <- parseRequestBody' lbsBackEnd $ toRequest ctype2 content2
let expectedsmap2 =
[ ("title", "A File")
, ("summary", "This is my file\nfile test")
]
let textPlain = S8.pack $ "text/plain; charset=iso-8859-1"
let expectedfile2 =
[(S8.pack "document", FileInfo (S8.pack "b.txt") textPlain $ L8.pack
"This is a file.\nIt has two lines.")]
let expected2 = (map (S8.pack *** S8.pack) expectedsmap2, expectedfile2)
liftIO $ assertEqual "parsing post multipart/form-data"
expected2
result2
let ctype3 = "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh"
result3 <- parseRequestBody' lbsBackEnd $ toRequest ctype3 content3
let expectedsmap3 = []
let expectedfile3 = [(S8.pack "yaml", FileInfo (S8.pack "README") (S8.pack "application/octet-stream") $
L8.pack "Photo blog using Hack.\n")]
let expected3 = (expectedsmap3, expectedfile3)
liftIO $ assertEqual "parsing actual post multipart/form-data"
expected3
result3
result2' <- parseRequestBody' lbsBackEnd $ toRequest' ctype2 content2
liftIO $ assertEqual "parsing post multipart/form-data 2"
expected2
result2'
result3' <- parseRequestBody' lbsBackEnd $ toRequest' ctype3 content3
liftIO $ assertEqual "parsing actual post multipart/form-data 2"
expected3
result3'
caseMultipartPlus :: Assertion
caseMultipartPlus = do
result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content
liftIO $ result @?= ([("email", "has+plus")], [])
where
content = S8.pack $
"--AaB03x\n" ++
"Content-Disposition: form-data; name=\"email\"\n" ++
"Content-Type: text/plain; charset=iso-8859-1\n\n" ++
"has+plus\n" ++
"--AaB03x--"
ctype = "multipart/form-data; boundary=AaB03x"
caseUrlEncPlus :: Assertion
caseUrlEncPlus = do
result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content
liftIO $ result @?= ([("email", "has+plus")], [])
where
content = S8.pack $ "email=has%2Bplus"
ctype = "application/x-www-form-urlencoded"
toRequest :: S8.ByteString -> S8.ByteString -> SRequest
toRequest ctype content = SRequest defaultRequest
{ requestHeaders = [("Content-Type", ctype)]
, requestMethod = "POST"
, rawPathInfo = "/"
, rawQueryString = ""
, queryString = []
} (L.fromChunks [content])
toRequest' :: S8.ByteString -> S8.ByteString -> SRequest
toRequest' ctype content = SRequest defaultRequest
{ requestHeaders = [("Content-Type", ctype)]
} (L.fromChunks $ map S.singleton $ S.unpack content)
{-
caseFindBound :: Assertion
caseFindBound = do
findBound (S8.pack "def") (S8.pack "abcdefghi") @?=
FoundBound (S8.pack "abc") (S8.pack "ghi")
findBound (S8.pack "def") (S8.pack "ABC") @?= NoBound
findBound (S8.pack "def") (S8.pack "abcd") @?= PartialBound
findBound (S8.pack "def") (S8.pack "abcdE") @?= NoBound
findBound (S8.pack "def") (S8.pack "abcdEdef") @?=
FoundBound (S8.pack "abcdE") (S8.pack "")
caseSinkTillBound :: Assertion
caseSinkTillBound = do
let iter () _ = return ()
let src = S8.pack "this is some text"
bound1 = S8.pack "some"
bound2 = S8.pack "some!"
let enum = enumList 1 [src]
let helper _ _ = return ()
(_, res1) <- run_ $ enum $$ sinkTillBound bound1 helper ()
res1 @?= True
(_, res2) <- run_ $ enum $$ sinkTillBound bound2 helper ()
res2 @?= False
caseKillCR :: Assertion
caseKillCR = do
"foo" @=? killCR "foo"
"foo" @=? killCR "foo\r"
"foo\r\n" @=? killCR "foo\r\n"
"foo\r'" @=? killCR "foo\r'"
caseKillCRLF :: Assertion
caseKillCRLF = do
"foo" @=? killCRLF "foo"
"foo\r" @=? killCRLF "foo\r"
"foo" @=? killCRLF "foo\r\n"
"foo\r'" @=? killCRLF "foo\r'"
"foo" @=? killCRLF "foo\n"
caseTakeLine :: Assertion
caseTakeLine = do
helper "foo\nbar\nbaz" "foo"
helper "foo\r\nbar\nbaz" "foo"
helper "foo\nbar\r\nbaz" "foo"
helper "foo\rbar\r\nbaz" "foo\rbar"
where
helper haystack needle = do
x <- run_ $ enumList 1 [haystack] $$ takeLine
Just needle @=? x
-}
jsonpApp :: Application
jsonpApp = jsonp $ const $ return $ responseLBS
status200
[("Content-Type", "application/json")]
"{\"foo\":\"bar\"}"
caseJsonp :: Assertion
caseJsonp = flip runSession jsonpApp $ do
sres1 <- request defaultRequest
{ queryString = [("callback", Just "test")]
, requestHeaders = [("Accept", "text/javascript")]
}
assertContentType "text/javascript" sres1
assertBody "test({\"foo\":\"bar\"})" sres1
sres2 <- request defaultRequest
{ queryString = [("call_back", Just "test")]
, requestHeaders = [("Accept", "text/javascript")]
}
assertContentType "application/json" sres2
assertBody "{\"foo\":\"bar\"}" sres2
sres3 <- request defaultRequest
{ queryString = [("callback", Just "test")]
, requestHeaders = [("Accept", "text/html")]
}
assertContentType "application/json" sres3
assertBody "{\"foo\":\"bar\"}" sres3
gzipApp :: Application
gzipApp = gzip def $ const $ return $ responseLBS status200
[("Content-Type", "text/plain")]
"test"
caseGzip :: Assertion
caseGzip = flip runSession gzipApp $ do
sres1 <- request defaultRequest
{ requestHeaders = [("Accept-Encoding", "gzip")]
}
assertHeader "Content-Encoding" "gzip" sres1
liftIO $ decompress (simpleBody sres1) @?= "test"
sres2 <- request defaultRequest
{ requestHeaders = []
}
assertNoHeader "Content-Encoding" sres2
assertBody "test" sres2
caseGzipMSIE :: Assertion
caseGzipMSIE = flip runSession gzipApp $ do
sres1 <- request defaultRequest
{ requestHeaders =
[ ("Accept-Encoding", "gzip")
, ("User-Agent", "Mozilla/4.0 (Windows; MSIE 6.0; Windows NT 6.0)")
]
}
assertNoHeader "Content-Encoding" sres1
liftIO $ simpleBody sres1 @?= "test"
vhostApp1, vhostApp2, vhostApp :: Application
vhostApp1 = const $ return $ responseLBS status200 [] "app1"
vhostApp2 = const $ return $ responseLBS status200 [] "app2"
vhostApp = vhost
[ ((== "foo.com") . serverName, vhostApp1)
]
vhostApp2
caseVhost :: Assertion
caseVhost = flip runSession vhostApp $ do
sres1 <- request defaultRequest
{ serverName = "foo.com"
}
assertBody "app1" sres1
sres2 <- request defaultRequest
{ serverName = "bar.com"
}
assertBody "app2" sres2
autoheadApp :: Application
autoheadApp = autohead $ const $ return $ responseLBS status200
[("Foo", "Bar")] "body"
caseAutohead :: Assertion
caseAutohead = flip runSession autoheadApp $ do
sres1 <- request defaultRequest
{ requestMethod = "GET"
}
assertHeader "Foo" "Bar" sres1
assertBody "body" sres1
sres2 <- request defaultRequest
{ requestMethod = "HEAD"
}
assertHeader "Foo" "Bar" sres2
assertBody "" sres2
moApp :: Application
moApp = methodOverride $ \req -> return $ responseLBS status200
[("Method", requestMethod req)] ""
caseMethodOverride :: Assertion
caseMethodOverride = flip runSession moApp $ do
sres1 <- request defaultRequest
{ requestMethod = "GET"
, queryString = []
}
assertHeader "Method" "GET" sres1
sres2 <- request defaultRequest
{ requestMethod = "POST"
, queryString = []
}
assertHeader "Method" "POST" sres2
sres3 <- request defaultRequest
{ requestMethod = "POST"
, queryString = [("_method", Just "PUT")]
}
assertHeader "Method" "PUT" sres3
mopApp :: Application
mopApp = methodOverridePost $ \req -> return $ responseLBS status200 [("Method", requestMethod req)] ""
caseMethodOverridePost :: Assertion
caseMethodOverridePost = flip runSession mopApp $ do
-- Get Request are unmodified
sres1 <- let r = toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin"
s = simpleRequest r
m = s { requestMethod = "GET" }
b = r { simpleRequest = m }
in srequest b
assertHeader "Method" "GET" sres1
-- Post requests are modified if _method comes first
sres2 <- srequest $ toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin"
assertHeader "Method" "PUT" sres2
-- Post requests are unmodified if _method doesn't come first
sres3 <- srequest $ toRequest "application/x-www-form-urlencoded" "foo=bar&_method=PUT&baz=bin"
assertHeader "Method" "POST" sres3
-- Post requests are unmodified if Content-Type header isn't set to "application/x-www-form-urlencoded"
sres4 <- srequest $ toRequest "text/html; charset=utf-8" "foo=bar&_method=PUT&baz=bin"
assertHeader "Method" "POST" sres4
aoApp :: Application
aoApp = acceptOverride $ \req -> return $ responseLBS status200
[("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] ""
caseAcceptOverride :: Assertion
caseAcceptOverride = flip runSession aoApp $ do
sres1 <- request defaultRequest
{ queryString = []
, requestHeaders = [("Accept", "foo")]
}
assertHeader "Accept" "foo" sres1
sres2 <- request defaultRequest
{ queryString = []
, requestHeaders = [("Accept", "bar")]
}
assertHeader "Accept" "bar" sres2
sres3 <- request defaultRequest
{ queryString = [("_accept", Just "baz")]
, requestHeaders = [("Accept", "bar")]
}
assertHeader "Accept" "baz" sres3
caseDalvikMultipart :: Assertion
caseDalvikMultipart = do
let headers =
[ ("content-length", "12098")
, ("content-type", "multipart/form-data;boundary=*****")
, ("GATEWAY_INTERFACE", "CGI/1.1")
, ("PATH_INFO", "/")
, ("QUERY_STRING", "")
, ("REMOTE_ADDR", "192.168.1.115")
, ("REMOTE_HOST", "ganjizza")
, ("REQUEST_URI", "http://192.168.1.115:3000/")
, ("REQUEST_METHOD", "POST")
, ("HTTP_CONNECTION", "Keep-Alive")
, ("HTTP_COOKIE", "_SESSION=fgUGM5J/k6mGAAW+MMXIJZCJHobw/oEbb6T17KQN0p9yNqiXn/m/ACrsnRjiCEgqtG4fogMUDI+jikoFGcwmPjvuD5d+MDz32iXvDdDJsFdsFMfivuey2H+n6IF6yFGD")
, ("HTTP_USER_AGENT", "Dalvik/1.1.0 (Linux; U; Android 2.1-update1; sdk Build/ECLAIR)")
, ("HTTP_HOST", "192.168.1.115:3000")
, ("HTTP_ACCEPT", "*, */*")
, ("HTTP_VERSION", "HTTP/1.1")
, ("REQUEST_PATH", "/")
]
let request' = defaultRequest
{ requestHeaders = headers
}
(params, files) <-
case getRequestBodyType request' of
Nothing -> return ([], [])
Just rbt -> C.runResourceT $ sourceFile "test/requests/dalvik-request"
C.$$ sinkRequestBody lbsBackEnd rbt
lookup "scannedTime" params @?= Just "1.298590056748E9"
lookup "geoLong" params @?= Just "0"
lookup "geoLat" params @?= Just "0"
length files @?= 1
caseDebugRequestBody :: Assertion
caseDebugRequestBody = do
flip runSession (debugApp postOutput) $ do
let req = toRequest "application/x-www-form-urlencoded" "foo=bar&baz=bin"
res <- srequest req
assertStatus 200 res
let qs = "?foo=bar&baz=bin"
flip runSession (debugApp $ getOutput params) $ do
assertStatus 200 =<< request defaultRequest
{ requestMethod = "GET"
, queryString = map (\(k,v) -> (k, Just v)) params
, rawQueryString = qs
, requestHeaders = []
, rawPathInfo = "/location"
}
where
params = [("foo", "bar"), ("baz", "bin")]
-- FIXME change back once we include post parameter output in logging postOutput = T.pack $ "POST \nAccept: \nPOST " ++ (show params)
postOutput = T.pack $ "POST /\nAccept: \nStatus: 200 OK. /\n"
getOutput params' = T.pack $ "GET /location\nAccept: \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n"
debugApp output' req = do
iactual <- liftIO $ I.newIORef []
middleware <- liftIO $ mkRequestLogger def
{ destination = Callback $ \strs -> I.modifyIORef iactual $ (++ strs)
, outputFormat = Detailed False
}
res <- middleware (\_req -> return $ responseLBS status200 [ ] "") req
actual <- liftIO $ I.readIORef iactual
liftIO $ assertEqual "debug" output $ logsToBs actual
return res
where
output = TE.encodeUtf8 $ T.toStrict output'
logsToBs = S.concat . map logToBs
logToBs (LB bs) = bs
logToBs (LS s) = S8.pack s
{-debugApp = debug $ \req -> do-}
{-return $ responseLBS status200 [ ] ""-}