git.iko.soy/typeable/wai
on wai-extra/0.4.0.2 help sign in
typeable/wai/runtests.hs
378 lines 14 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2import Test.Framework (defaultMain, testGroup, Test)
3import Test.Framework.Providers.HUnit
4import Test.HUnit hiding (Test)
6import Network.Wai
7import Network.Wai.Test
8import Network.Wai.Parse
9import qualified Data.ByteString as S
10import qualified Data.ByteString.Char8 as S8
11import qualified Data.ByteString.Lazy.Char8 as L8
12import qualified Data.ByteString.Lazy as L
13import Control.Arrow
15import Network.Wai.Middleware.Jsonp
16import Network.Wai.Middleware.Gzip
17import Network.Wai.Middleware.Vhost
18import Network.Wai.Middleware.Autohead
19import Network.Wai.Middleware.MethodOverride
20import Network.Wai.Middleware.AcceptOverride
21import Codec.Compression.GZip (decompress)
23import Data.Enumerator (run_, enumList, ($$), Iteratee)
24import Data.Enumerator.Binary (enumFile)
25import Control.Monad.IO.Class (liftIO)
26import Data.Maybe (fromMaybe)
27import Network.HTTP.Types (parseSimpleQuery, status200)
29main :: IO ()
30main = defaultMain [testSuite]
32testSuite :: Test
33testSuite = testGroup "Network.Wai.Parse"
34 [ testCase "parseQueryString" caseParseQueryString
35 , testCase "parseQueryString with question mark" caseParseQueryStringQM
36 , testCase "parseHttpAccept" caseParseHttpAccept
37 , testCase "parseRequestBody" caseParseRequestBody
38 , testCase "findBound" caseFindBound
39 , testCase "sinkTillBound" caseSinkTillBound
40 , testCase "killCR" caseKillCR
41 , testCase "killCRLF" caseKillCRLF
42 , testCase "takeLine" caseTakeLine
43 , testCase "jsonp" caseJsonp
44 , testCase "gzip" caseGzip
45 , testCase "gzip not for MSIE" caseGzipMSIE
46 , testCase "vhost" caseVhost
47 , testCase "autohead" caseAutohead
48 , testCase "method override" caseMethodOverride
49 , testCase "accept override" caseAcceptOverride
50 , testCase "dalvik multipart" caseDalvikMultipart
51 ]
53caseParseQueryString :: Assertion
54caseParseQueryString = do
55 let go l r =
56 map (S8.pack *** S8.pack) l @=? parseSimpleQuery (S8.pack r)
58 go [] ""
59 go [("foo", "")] "foo"
60 go [("foo", "bar")] "foo=bar"
61 go [("foo", "bar"), ("baz", "bin")] "foo=bar&baz=bin"
62 go [("%Q", "")] "%Q"
63 go [("%1Q", "")] "%1Q"
64 go [("%1", "")] "%1"
65 go [("/", "")] "%2F"
66 go [("/", "")] "%2f"
67 go [("foo bar", "")] "foo+bar"
69caseParseQueryStringQM :: Assertion
70caseParseQueryStringQM = do
71 let go l r =
72 map (S8.pack *** S8.pack) l
73 @=? parseSimpleQuery (S8.pack $ '?' : r)
75 go [] ""
76 go [("foo", "")] "foo"
77 go [("foo", "bar")] "foo=bar"
78 go [("foo", "bar"), ("baz", "bin")] "foo=bar&baz=bin"
79 go [("%Q", "")] "%Q"
80 go [("%1Q", "")] "%1Q"
81 go [("%1", "")] "%1"
82 go [("/", "")] "%2F"
83 go [("/", "")] "%2f"
84 go [("foo bar", "")] "foo+bar"
86caseParseHttpAccept :: Assertion
87caseParseHttpAccept = do
88 let input = "text/plain; q=0.5, text/html, text/x-dvi; q=0.8, text/x-c"
89 expected = ["text/html", "text/x-c", "text/x-dvi", "text/plain"]
90 expected @=? parseHttpAccept input
92parseRequestBody' :: Sink ([S8.ByteString] -> [S8.ByteString]) L.ByteString
93 -> SRequest
94 -> Iteratee S.ByteString IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo L.ByteString)])
95parseRequestBody' sink (SRequest req bod) =
96 enumList 1 (L.toChunks bod) $$ parseRequestBody sink req
98caseParseRequestBody :: Assertion
99caseParseRequestBody = run_ t where
100 content2 = S8.pack $
101 "--AaB03x\n" ++
102 "Content-Disposition: form-data; name=\"document\"; filename=\"b.txt\"\n" ++
103 "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
104 "This is a file.\n" ++
105 "It has two lines.\n" ++
106 "--AaB03x\n" ++
107 "Content-Disposition: form-data; name=\"title\"\n" ++
108 "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
109 "A File\n" ++
110 "--AaB03x\n" ++
111 "Content-Disposition: form-data; name=\"summary\"\n" ++
112 "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
113 "This is my file\n" ++
114 "file test\n" ++
115 "--AaB03x--"
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"
117 t = do
118 let content1 = "foo=bar&baz=bin"
119 let ctype1 = "application/x-www-form-urlencoded"
120 result1 <- parseRequestBody' lbsSink $ toRequest ctype1 content1
121 liftIO $ assertEqual "parsing post x-www-form-urlencoded"
122 (map (S8.pack *** S8.pack) [("foo", "bar"), ("baz", "bin")], [])
123 result1
125 let ctype2 = "multipart/form-data; boundary=AaB03x"
126 result2 <- parseRequestBody' lbsSink $ toRequest ctype2 content2
127 let expectedsmap2 =
128 [ ("title", "A File")
129 , ("summary", "This is my file\nfile test")
130 ]
131 let textPlain = S8.pack $ "text/plain; charset=iso-8859-1"
132 let expectedfile2 =
133 [(S8.pack "document", FileInfo (S8.pack "b.txt") textPlain $ L8.pack
134 "This is a file.\nIt has two lines.")]
135 let expected2 = (map (S8.pack *** S8.pack) expectedsmap2, expectedfile2)
136 liftIO $ assertEqual "parsing post multipart/form-data"
137 expected2
138 result2
140 let ctype3 = "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh"
141 result3 <- parseRequestBody' lbsSink $ toRequest ctype3 content3
142 let expectedsmap3 = []
143 let expectedfile3 = [(S8.pack "yaml", FileInfo (S8.pack "README") (S8.pack "application/octet-stream") $
144 L8.pack "Photo blog using Hack.\n")]
145 let expected3 = (expectedsmap3, expectedfile3)
146 liftIO $ assertEqual "parsing actual post multipart/form-data"
147 expected3
148 result3
150 result2' <- parseRequestBody' lbsSink $ toRequest' ctype2 content2
151 liftIO $ assertEqual "parsing post multipart/form-data 2"
152 expected2
153 result2'
155 result3' <- parseRequestBody' lbsSink $ toRequest' ctype3 content3
156 liftIO $ assertEqual "parsing actual post multipart/form-data 2"
157 expected3
158 result3'
160toRequest :: S8.ByteString -> S8.ByteString -> SRequest
161toRequest ctype content = SRequest (Request
162 { requestHeaders = [("Content-Type", ctype)]
163 }) (L.fromChunks [content])
165toRequest' :: S8.ByteString -> S8.ByteString -> SRequest
166toRequest' ctype content = SRequest (Request
167 { requestHeaders = [("Content-Type", ctype)]
168 }) (L.fromChunks $ map S.singleton $ S.unpack content)
170caseFindBound :: Assertion
171caseFindBound = do
172 findBound (S8.pack "def") (S8.pack "abcdefghi") @?=
173 FoundBound (S8.pack "abc") (S8.pack "ghi")
174 findBound (S8.pack "def") (S8.pack "ABC") @?= NoBound
175 findBound (S8.pack "def") (S8.pack "abcd") @?= PartialBound
176 findBound (S8.pack "def") (S8.pack "abcdE") @?= NoBound
177 findBound (S8.pack "def") (S8.pack "abcdEdef") @?=
178 FoundBound (S8.pack "abcdE") (S8.pack "")
180caseSinkTillBound :: Assertion
181caseSinkTillBound = do
182 let iter () _ = return ()
183 let src = S8.pack "this is some text"
184 bound1 = S8.pack "some"
185 bound2 = S8.pack "some!"
186 let enum = enumList 1 [src]
187 let helper _ _ = return ()
188 (_, res1) <- run_ $ enum $$ sinkTillBound bound1 helper ()
189 res1 @?= True
190 (_, res2) <- run_ $ enum $$ sinkTillBound bound2 helper ()
191 res2 @?= False
193caseKillCR :: Assertion
194caseKillCR = do
195 "foo" @=? killCR "foo"
196 "foo" @=? killCR "foo\r"
197 "foo\r\n" @=? killCR "foo\r\n"
198 "foo\r'" @=? killCR "foo\r'"
200caseKillCRLF :: Assertion
201caseKillCRLF = do
202 "foo" @=? killCRLF "foo"
203 "foo\r" @=? killCRLF "foo\r"
204 "foo" @=? killCRLF "foo\r\n"
205 "foo\r'" @=? killCRLF "foo\r'"
206 "foo" @=? killCRLF "foo\n"
208caseTakeLine :: Assertion
209caseTakeLine = do
210 helper "foo\nbar\nbaz" "foo"
211 helper "foo\r\nbar\nbaz" "foo"
212 helper "foo\nbar\r\nbaz" "foo"
213 helper "foo\rbar\r\nbaz" "foo\rbar"
214 where
215 helper haystack needle = do
216 x <- run_ $ enumList 1 [haystack] $$ takeLine
217 Just needle @=? x
219jsonpApp = jsonp $ const $ return $ responseLBS
220 status200
221 [("Content-Type", "application/json")]
222 "{\"foo\":\"bar\"}"
224caseJsonp :: Assertion
225caseJsonp = flip runSession jsonpApp $ do
226 sres1 <- request Request
227 { queryString = [("callback", Just "test")]
228 , requestHeaders = [("Accept", "text/javascript")]
229 }
230 assertContentType "text/javascript" sres1
231 assertBody "test({\"foo\":\"bar\"})" sres1
233 sres2 <- request Request
234 { queryString = [("call_back", Just "test")]
235 , requestHeaders = [("Accept", "text/javascript")]
236 }
237 assertContentType "application/json" sres2
238 assertBody "{\"foo\":\"bar\"}" sres2
240 sres3 <- request Request
241 { queryString = [("callback", Just "test")]
242 , requestHeaders = [("Accept", "text/html")]
243 }
244 assertContentType "application/json" sres3
245 assertBody "{\"foo\":\"bar\"}" sres3
247gzipApp = gzip True $ const $ return $ responseLBS status200 [] "test"
249caseGzip :: Assertion
250caseGzip = flip runSession gzipApp $ do
251 sres1 <- request Request
252 { requestHeaders = [("Accept-Encoding", "gzip")]
253 }
254 assertHeader "Content-Encoding" "gzip" sres1
255 liftIO $ decompress (simpleBody sres1) @?= "test"
257 sres2 <- request Request
258 { requestHeaders = []
259 }
260 assertNoHeader "Content-Encoding" sres2
261 assertBody "test" sres2
263caseGzipMSIE :: Assertion
264caseGzipMSIE = flip runSession gzipApp $ do
265 sres1 <- request Request
266 { requestHeaders =
267 [ ("Accept-Encoding", "gzip")
268 , ("User-Agent", "Mozilla/4.0 (Windows; MSIE 6.0; Windows NT 6.0)")
269 ]
270 }
271 assertNoHeader "Content-Encoding" sres1
272 liftIO $ simpleBody sres1 @?= "test"
274vhostApp1 = const $ return $ responseLBS status200 [] "app1"
275vhostApp2 = const $ return $ responseLBS status200 [] "app2"
276vhostApp = vhost
277 [ ((== "foo.com") . serverName, vhostApp1)
278 ]
279 vhostApp2
281caseVhost = flip runSession vhostApp $ do
282 sres1 <- request Request
283 { serverName = "foo.com"
284 }
285 assertBody "app1" sres1
287 sres2 <- request Request
288 { serverName = "bar.com"
289 }
290 assertBody "app2" sres2
292autoheadApp = autohead $ const $ return $ responseLBS status200
293 [("Foo", "Bar")] "body"
295caseAutohead = flip runSession autoheadApp $ do
296 sres1 <- request Request
297 { requestMethod = "GET"
298 }
299 assertHeader "Foo" "Bar" sres1
300 assertBody "body" sres1
302 sres1 <- request Request
303 { requestMethod = "HEAD"
304 }
305 assertHeader "Foo" "Bar" sres1
306 assertBody "" sres1
308moApp = methodOverride $ \req -> return $ responseLBS status200
309 [("Method", requestMethod req)] ""
311caseMethodOverride = flip runSession moApp $ do
312 sres1 <- request Request
313 { requestMethod = "GET"
314 , queryString = []
315 }
316 assertHeader "Method" "GET" sres1
318 sres2 <- request Request
319 { requestMethod = "POST"
320 , queryString = []
321 }
322 assertHeader "Method" "POST" sres2
324 sres3 <- request Request
325 { requestMethod = "POST"
326 , queryString = [("_method", Just "PUT")]
327 }
328 assertHeader "Method" "PUT" sres3
330aoApp = acceptOverride $ \req -> return $ responseLBS status200
331 [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] ""
333caseAcceptOverride = flip runSession aoApp $ do
334 sres1 <- request Request
335 { queryString = []
336 , requestHeaders = [("Accept", "foo")]
337 }
338 assertHeader "Accept" "foo" sres1
340 sres2 <- request Request
341 { queryString = []
342 , requestHeaders = [("Accept", "bar")]
343 }
344 assertHeader "Accept" "bar" sres2
346 sres3 <- request Request
347 { queryString = [("_accept", Just "baz")]
348 , requestHeaders = [("Accept", "bar")]
349 }
350 assertHeader "Accept" "baz" sres3
352caseDalvikMultipart = do
353 let headers =
354 [ ("content-length", "12098")
355 , ("content-type", "multipart/form-data;boundary=*****")
356 , ("GATEWAY_INTERFACE", "CGI/1.1")
357 , ("PATH_INFO", "/")
358 , ("QUERY_STRING", "")
359 , ("REMOTE_ADDR", "192.168.1.115")
360 , ("REMOTE_HOST", "ganjizza")
361 , ("REQUEST_URI", "http://192.168.1.115:3000/")
362 , ("REQUEST_METHOD", "POST")
363 , ("HTTP_CONNECTION", "Keep-Alive")
364 , ("HTTP_COOKIE", "_SESSION=fgUGM5J/k6mGAAW+MMXIJZCJHobw/oEbb6T17KQN0p9yNqiXn/m/ACrsnRjiCEgqtG4fogMUDI+jikoFGcwmPjvuD5d+MDz32iXvDdDJsFdsFMfivuey2H+n6IF6yFGD")
365 , ("HTTP_USER_AGENT", "Dalvik/1.1.0 (Linux; U; Android 2.1-update1; sdk Build/ECLAIR)")
366 , ("HTTP_HOST", "192.168.1.115:3000")
367 , ("HTTP_ACCEPT", "*, */*")
368 , ("HTTP_VERSION", "HTTP/1.1")
369 , ("REQUEST_PATH", "/")
370 ]
371 let request = Request
372 { requestHeaders = headers
373 }
374 (params, files) <- run_ $ enumFile "test/dalvik-request" $$ parseRequestBody lbsSink request
375 lookup "scannedTime" params @?= Just "1.298590056748E9"
376 lookup "geoLong" params @?= Just "0"
377 lookup "geoLat" params @?= Just "0"
378 length files @?= 1