git.iko.soy/typeable/wai
on wai-extra/0.3.2.1 help sign in
typeable/wai/runtests.hs
366 lines 13 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)
28main :: IO ()
29main = defaultMain [testSuite]
31testSuite :: Test
32testSuite = testGroup "Network.Wai.Parse"
33 [ testCase "parseQueryString" caseParseQueryString
34 , testCase "parseQueryString with question mark" caseParseQueryStringQM
35 , testCase "parseHttpAccept" caseParseHttpAccept
36 , testCase "parseRequestBody" caseParseRequestBody
37 , testCase "findBound" caseFindBound
38 , testCase "sinkTillBound" caseSinkTillBound
39 , testCase "killCR" caseKillCR
40 , testCase "killCRLF" caseKillCRLF
41 , testCase "takeLine" caseTakeLine
42 , testCase "jsonp" caseJsonp
43 , testCase "gzip" caseGzip
44 , testCase "vhost" caseVhost
45 , testCase "autohead" caseAutohead
46 , testCase "method override" caseMethodOverride
47 , testCase "accept override" caseAcceptOverride
48 , testCase "dalvik multipart" caseDalvikMultipart
49 ]
51caseParseQueryString :: Assertion
52caseParseQueryString = do
53 let go l r =
54 map (S8.pack *** S8.pack) l @=? parseQueryString (S8.pack r)
56 go [] ""
57 go [("foo", "")] "foo"
58 go [("foo", "bar")] "foo=bar"
59 go [("foo", "bar"), ("baz", "bin")] "foo=bar&baz=bin"
60 go [("%Q", "")] "%Q"
61 go [("%1Q", "")] "%1Q"
62 go [("%1", "")] "%1"
63 go [("/", "")] "%2F"
64 go [("/", "")] "%2f"
65 go [("foo bar", "")] "foo+bar"
67caseParseQueryStringQM :: Assertion
68caseParseQueryStringQM = do
69 let go l r =
70 map (S8.pack *** S8.pack) l
71 @=? parseQueryString (S8.pack $ '?' : r)
73 go [] ""
74 go [("foo", "")] "foo"
75 go [("foo", "bar")] "foo=bar"
76 go [("foo", "bar"), ("baz", "bin")] "foo=bar&baz=bin"
77 go [("%Q", "")] "%Q"
78 go [("%1Q", "")] "%1Q"
79 go [("%1", "")] "%1"
80 go [("/", "")] "%2F"
81 go [("/", "")] "%2f"
82 go [("foo bar", "")] "foo+bar"
84caseParseHttpAccept :: Assertion
85caseParseHttpAccept = do
86 let input =
87 S8.pack "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 map S8.pack expected @=? parseHttpAccept input
91parseRequestBody' :: Sink ([S8.ByteString] -> [S8.ByteString]) L.ByteString
92 -> SRequest
93 -> Iteratee S.ByteString IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo L.ByteString)])
94parseRequestBody' sink (SRequest req bod) =
95 enumList 1 (L.toChunks bod) $$ parseRequestBody sink req
97caseParseRequestBody :: Assertion
98caseParseRequestBody = run_ t where
99 content2 = S8.pack $
100 "--AaB03x\n" ++
101 "Content-Disposition: form-data; name=\"document\"; filename=\"b.txt\"\n" ++
102 "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
103 "This is a file.\n" ++
104 "It has two lines.\n" ++
105 "--AaB03x\n" ++
106 "Content-Disposition: form-data; name=\"title\"\n" ++
107 "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
108 "A File\n" ++
109 "--AaB03x\n" ++
110 "Content-Disposition: form-data; name=\"summary\"\n" ++
111 "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
112 "This is my file\n" ++
113 "file test\n" ++
114 "--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 t = do
117 let content1 = S8.pack "foo=bar&baz=bin"
118 let ctype1 = S8.pack "application/x-www-form-urlencoded"
119 result1 <- parseRequestBody' lbsSink $ toRequest ctype1 content1
120 liftIO $ assertEqual "parsing post x-www-form-urlencoded"
121 (map (S8.pack *** S8.pack) [("foo", "bar"), ("baz", "bin")], [])
122 result1
124 let ctype2 = S8.pack "multipart/form-data; boundary=AaB03x"
125 result2 <- parseRequestBody' lbsSink $ toRequest ctype2 content2
126 let expectedsmap2 =
127 [ ("title", "A File")
128 , ("summary", "This is my file\nfile test")
129 ]
130 let textPlain = S8.pack $ "text/plain; charset=iso-8859-1"
131 let expectedfile2 =
132 [(S8.pack "document", FileInfo (S8.pack "b.txt") textPlain $ L8.pack
133 "This is a file.\nIt has two lines.")]
134 let expected2 = (map (S8.pack *** S8.pack) expectedsmap2, expectedfile2)
135 liftIO $ assertEqual "parsing post multipart/form-data"
136 expected2
137 result2
139 let ctype3 = S8.pack "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh"
140 result3 <- parseRequestBody' lbsSink $ toRequest ctype3 content3
141 let expectedsmap3 = []
142 let expectedfile3 = [(S8.pack "yaml", FileInfo (S8.pack "README") (S8.pack "application/octet-stream") $
143 L8.pack "Photo blog using Hack.\n")]
144 let expected3 = (expectedsmap3, expectedfile3)
145 liftIO $ assertEqual "parsing actual post multipart/form-data"
146 expected3
147 result3
149 result2' <- parseRequestBody' lbsSink $ toRequest' ctype2 content2
150 liftIO $ assertEqual "parsing post multipart/form-data 2"
151 expected2
152 result2'
154 result3' <- parseRequestBody' lbsSink $ toRequest' ctype3 content3
155 liftIO $ assertEqual "parsing actual post multipart/form-data 2"
156 expected3
157 result3'
159toRequest :: S8.ByteString -> S8.ByteString -> SRequest
160toRequest ctype content = SRequest (Request
161 { requestHeaders = [("Content-Type", ctype)]
162 }) (L.fromChunks [content])
164toRequest' :: S8.ByteString -> S8.ByteString -> SRequest
165toRequest' ctype content = SRequest (Request
166 { requestHeaders = [("Content-Type", ctype)]
167 }) (L.fromChunks $ map S.singleton $ S.unpack content)
169caseFindBound :: Assertion
170caseFindBound = do
171 findBound (S8.pack "def") (S8.pack "abcdefghi") @?=
172 FoundBound (S8.pack "abc") (S8.pack "ghi")
173 findBound (S8.pack "def") (S8.pack "ABC") @?= NoBound
174 findBound (S8.pack "def") (S8.pack "abcd") @?= PartialBound
175 findBound (S8.pack "def") (S8.pack "abcdE") @?= NoBound
176 findBound (S8.pack "def") (S8.pack "abcdEdef") @?=
177 FoundBound (S8.pack "abcdE") (S8.pack "")
179caseSinkTillBound :: Assertion
180caseSinkTillBound = do
181 let iter () _ = return ()
182 let src = S8.pack "this is some text"
183 bound1 = S8.pack "some"
184 bound2 = S8.pack "some!"
185 let enum = enumList 1 [src]
186 let helper _ _ = return ()
187 (_, res1) <- run_ $ enum $$ sinkTillBound bound1 helper ()
188 res1 @?= True
189 (_, res2) <- run_ $ enum $$ sinkTillBound bound2 helper ()
190 res2 @?= False
192caseKillCR :: Assertion
193caseKillCR = do
194 "foo" @=? killCR "foo"
195 "foo" @=? killCR "foo\r"
196 "foo\r\n" @=? killCR "foo\r\n"
197 "foo\r'" @=? killCR "foo\r'"
199caseKillCRLF :: Assertion
200caseKillCRLF = do
201 "foo" @=? killCRLF "foo"
202 "foo\r" @=? killCRLF "foo\r"
203 "foo" @=? killCRLF "foo\r\n"
204 "foo\r'" @=? killCRLF "foo\r'"
205 "foo" @=? killCRLF "foo\n"
207caseTakeLine :: Assertion
208caseTakeLine = do
209 helper "foo\nbar\nbaz" "foo"
210 helper "foo\r\nbar\nbaz" "foo"
211 helper "foo\nbar\r\nbaz" "foo"
212 helper "foo\rbar\r\nbaz" "foo\rbar"
213 where
214 helper haystack needle = do
215 x <- run_ $ enumList 1 [haystack] $$ takeLine
216 Just needle @=? x
218jsonpApp = jsonp $ const $ return $ responseLBS
219 status200
220 [("Content-Type", "application/json")]
221 "{\"foo\":\"bar\"}"
223caseJsonp :: Assertion
224caseJsonp = flip runSession jsonpApp $ do
225 sres1 <- request Request
226 { queryString = "callback=test"
227 , requestHeaders = [("Accept", "text/javascript")]
228 }
229 assertContentType "text/javascript" sres1
230 assertBody "test({\"foo\":\"bar\"})" sres1
232 sres2 <- request Request
233 { queryString = "call_back=test"
234 , requestHeaders = [("Accept", "text/javascript")]
235 }
236 assertContentType "application/json" sres2
237 assertBody "{\"foo\":\"bar\"}" sres2
239 sres3 <- request Request
240 { queryString = "callback=test"
241 , requestHeaders = [("Accept", "text/html")]
242 }
243 assertContentType "application/json" sres3
244 assertBody "{\"foo\":\"bar\"}" sres3
246gzipApp = gzip True $ const $ return $ responseLBS status200 [] "test"
248caseGzip :: Assertion
249caseGzip = flip runSession gzipApp $ do
250 sres1 <- request Request
251 { requestHeaders = [("Accept-Encoding", "gzip")]
252 }
253 assertHeader "Content-Encoding" "gzip" sres1
254 liftIO $ decompress (simpleBody sres1) @?= "test"
256 sres2 <- request Request
257 { requestHeaders = []
258 }
259 assertNoHeader "Content-Encoding" sres2
260 assertBody "test" sres2
262vhostApp1 = const $ return $ responseLBS status200 [] "app1"
263vhostApp2 = const $ return $ responseLBS status200 [] "app2"
264vhostApp = vhost
265 [ ((== "foo.com") . serverName, vhostApp1)
266 ]
267 vhostApp2
269caseVhost = flip runSession vhostApp $ do
270 sres1 <- request Request
271 { serverName = "foo.com"
272 }
273 assertBody "app1" sres1
275 sres2 <- request Request
276 { serverName = "bar.com"
277 }
278 assertBody "app2" sres2
280autoheadApp = autohead $ const $ return $ responseLBS status200
281 [("Foo", "Bar")] "body"
283caseAutohead = flip runSession autoheadApp $ do
284 sres1 <- request Request
285 { requestMethod = "GET"
286 }
287 assertHeader "Foo" "Bar" sres1
288 assertBody "body" sres1
290 sres1 <- request Request
291 { requestMethod = "HEAD"
292 }
293 assertHeader "Foo" "Bar" sres1
294 assertBody "" sres1
296moApp = methodOverride $ \req -> return $ responseLBS status200
297 [("Method", requestMethod req)] ""
299caseMethodOverride = flip runSession moApp $ do
300 sres1 <- request Request
301 { requestMethod = "GET"
302 , queryString = ""
303 }
304 assertHeader "Method" "GET" sres1
306 sres2 <- request Request
307 { requestMethod = "POST"
308 , queryString = ""
309 }
310 assertHeader "Method" "POST" sres2
312 sres3 <- request Request
313 { requestMethod = "POST"
314 , queryString = "_method=PUT"
315 }
316 assertHeader "Method" "PUT" sres3
318aoApp = acceptOverride $ \req -> return $ responseLBS status200
319 [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] ""
321caseAcceptOverride = flip runSession aoApp $ do
322 sres1 <- request Request
323 { queryString = ""
324 , requestHeaders = [("Accept", "foo")]
325 }
326 assertHeader "Accept" "foo" sres1
328 sres2 <- request Request
329 { queryString = ""
330 , requestHeaders = [("Accept", "bar")]
331 }
332 assertHeader "Accept" "bar" sres2
334 sres3 <- request Request
335 { queryString = "_accept=baz"
336 , requestHeaders = [("Accept", "bar")]
337 }
338 assertHeader "Accept" "baz" sres3
340caseDalvikMultipart = do
341 let headers =
342 [ ("content-length", "12098")
343 , ("content-type", "multipart/form-data;boundary=*****")
344 , ("GATEWAY_INTERFACE", "CGI/1.1")
345 , ("PATH_INFO", "/")
346 , ("QUERY_STRING", "")
347 , ("REMOTE_ADDR", "192.168.1.115")
348 , ("REMOTE_HOST", "ganjizza")
349 , ("REQUEST_URI", "http://192.168.1.115:3000/")
350 , ("REQUEST_METHOD", "POST")
351 , ("HTTP_CONNECTION", "Keep-Alive")
352 , ("HTTP_COOKIE", "_SESSION=fgUGM5J/k6mGAAW+MMXIJZCJHobw/oEbb6T17KQN0p9yNqiXn/m/ACrsnRjiCEgqtG4fogMUDI+jikoFGcwmPjvuD5d+MDz32iXvDdDJsFdsFMfivuey2H+n6IF6yFGD")
353 , ("HTTP_USER_AGENT", "Dalvik/1.1.0 (Linux; U; Android 2.1-update1; sdk Build/ECLAIR)")
354 , ("HTTP_HOST", "192.168.1.115:3000")
355 , ("HTTP_ACCEPT", "*, */*")
356 , ("HTTP_VERSION", "HTTP/1.1")
357 , ("REQUEST_PATH", "/")
358 ]
359 let request = Request
360 { requestHeaders = headers
361 }
362 (params, files) <- run_ $ enumFile "test/dalvik-request" $$ parseRequestBody lbsSink request
363 lookup "scannedTime" params @?= Just "1.298590056748E9"
364 lookup "geoLong" params @?= Just "0"
365 lookup "geoLat" params @?= Just "0"
366 length files @?= 1