@@ -1,5 +1,5 @@
11{-# LANGUAGE OverloadedStrings #-}
2−module WaiExtraTest (specs) where
2+module WaiExtraSpec (spec, toRequest) where
33
44import Test.Hspec
55import Test.HUnit hiding (Test)
@@ -7,18 +7,14 @@ import Data.Monoid (mappend, mempty, (<>))
77
88import Network.Wai
99import Network.Wai.Test
10−import Network.Wai.Parse
1110import Network.Wai.UrlMap
1211import qualified Data.ByteString as S
1312import qualified Data.ByteString.Char8 as S8
14−import qualified Data.ByteString.Lazy.Char8 as L8
1513import qualified Data.ByteString.Lazy as L
1614import qualified Data.Text.Lazy as T
1715import qualified Data.Text as TS
1816import qualified Data.Text.Encoding as TE
19−import Control.Arrow
2017import Control.Applicative
21−import Control.Monad.Trans.Resource (withInternalState, runResourceT)
2218
2319import Network.Wai.Middleware.Jsonp
2420import Network.Wai.Middleware.Gzip
@@ -32,32 +28,17 @@ import Codec.Compression.GZip (decompress)
3228
3329import Control.Monad.IO.Class (liftIO)
3430import Data.Maybe (fromMaybe)
35−import Network.HTTP.Types (parseSimpleQuery, status200)
31+import Network.HTTP.Types (status200)
3632import System.Log.FastLogger
37−import System.IO (withFile, IOMode (ReadMode))
3833
3934import qualified Data.IORef as I
4035
41−specs :: Spec
42−specs = do
36+spec :: Spec
37+spec = do
4338 describe "Network.Wai.UrlMap" $ do
4439 mapM_ (uncurry it) casesUrlMap
4540
46− describe "Network.Wai.Parse" $ do
47− describe "parseContentType" $ do
48− let go (x, y, z) = it (TS.unpack $ TE.decodeUtf8 x) $ parseContentType x `shouldBe` (y, z)
49− mapM_ go
50− [ ("text/plain", "text/plain", [])
51− , ("text/plain; charset=UTF-8 ", "text/plain", [("charset", "UTF-8")])
52− , ("text/plain; charset=UTF-8 ; boundary = foo", "text/plain", [("charset", "UTF-8"), ("boundary", "foo")])
53− ]
54− it "parseQueryString" caseParseQueryString
55− it "parseQueryString with question mark" caseParseQueryStringQM
56− it "parseHttpAccept" caseParseHttpAccept
57− it "parseRequestBody" caseParseRequestBody
58− it "multipart with plus" caseMultipartPlus
59− it "multipart with multiple attributes" caseMultipartAttrs
60− it "urlencoded with plus" caseUrlEncPlus
41+ describe "Network.Wai" $ do
6142 {-
6243 , it "findBound" caseFindBound
6344 , it "sinkTillBound" caseSinkTillBound
@@ -75,163 +56,8 @@ specs = do
7556 it "method override" caseMethodOverride
7657 it "method override post" caseMethodOverridePost
7758 it "accept override" caseAcceptOverride
78− describe "dalvik multipart" $ do
79− it "non-chunked" $ dalvikHelper True
80− it "chunked" $ dalvikHelper False
8159 it "debug request body" caseDebugRequestBody
8260
83−caseParseQueryString :: Assertion
84−caseParseQueryString = do
85− let go l r =
86− map (S8.pack *** S8.pack) l @=? parseSimpleQuery (S8.pack r)
87−
88− go [] ""
89− go [("foo", "")] "foo"
90− go [("foo", "bar")] "foo=bar"
91− go [("foo", "bar"), ("baz", "bin")] "foo=bar&baz=bin"
92− go [("%Q", "")] "%Q"
93− go [("%1Q", "")] "%1Q"
94− go [("%1", "")] "%1"
95− go [("/", "")] "%2F"
96− go [("/", "")] "%2f"
97− go [("foo bar", "")] "foo+bar"
98−
99−caseParseQueryStringQM :: Assertion
100−caseParseQueryStringQM = do
101− let go l r =
102− map (S8.pack *** S8.pack) l
103− @=? parseSimpleQuery (S8.pack $ '?' : r)
104−
105− go [] ""
106− go [("foo", "")] "foo"
107− go [("foo", "bar")] "foo=bar"
108− go [("foo", "bar"), ("baz", "bin")] "foo=bar&baz=bin"
109− go [("%Q", "")] "%Q"
110− go [("%1Q", "")] "%1Q"
111− go [("%1", "")] "%1"
112− go [("/", "")] "%2F"
113− go [("/", "")] "%2f"
114− go [("foo bar", "")] "foo+bar"
115−
116−caseParseHttpAccept :: Assertion
117−caseParseHttpAccept = do
118− 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"
119− expected = ["text/html;charset=utf-8", "text/x-c", "text/x-dvi", "text/*", "text/plain"]
120− expected @=? parseHttpAccept input
121−
122−parseRequestBody' :: BackEnd file
123− -> SRequest
124− -> IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo file)])
125−parseRequestBody' sink (SRequest req bod) =
126− case getRequestBodyType req of
127− Nothing -> return ([], [])
128− Just rbt -> do
129− ref <- I.newIORef $ L.toChunks bod
130− let rb = I.atomicModifyIORef ref $ \chunks ->
131− case chunks of
132− [] -> ([], S.empty)
133− x:y -> (y, x)
134− sinkRequestBody sink rbt rb
135−
136−caseParseRequestBody :: Assertion
137−caseParseRequestBody =
138− t
139− where
140− content2 = S8.pack $
141− "--AaB03x\n" ++
142− "Content-Disposition: form-data; name=\"document\"; filename=\"b.txt\"\n" ++
143− "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
144− "This is a file.\n" ++
145− "It has two lines.\n" ++
146− "--AaB03x\n" ++
147− "Content-Disposition: form-data; name=\"title\"\n" ++
148− "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
149− "A File\n" ++
150− "--AaB03x\n" ++
151− "Content-Disposition: form-data; name=\"summary\"\n" ++
152− "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
153− "This is my file\n" ++
154− "file test\n" ++
155− "--AaB03x--"
156− 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"
157− t = do
158− let content1 = "foo=bar&baz=bin"
159− let ctype1 = "application/x-www-form-urlencoded"
160− result1 <- parseRequestBody' lbsBackEnd $ toRequest ctype1 content1
161− liftIO $ assertEqual "parsing post x-www-form-urlencoded"
162− (map (S8.pack *** S8.pack) [("foo", "bar"), ("baz", "bin")], [])
163− result1
164−
165− let ctype2 = "multipart/form-data; boundary=AaB03x"
166− result2 <- parseRequestBody' lbsBackEnd $ toRequest ctype2 content2
167− let expectedsmap2 =
168− [ ("title", "A File")
169− , ("summary", "This is my file\nfile test")
170− ]
171− let textPlain = S8.pack $ "text/plain; charset=iso-8859-1"
172− let expectedfile2 =
173− [(S8.pack "document", FileInfo (S8.pack "b.txt") textPlain $ L8.pack
174− "This is a file.\nIt has two lines.")]
175− let expected2 = (map (S8.pack *** S8.pack) expectedsmap2, expectedfile2)
176− liftIO $ assertEqual "parsing post multipart/form-data"
177− expected2
178− result2
179−
180− let ctype3 = "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh"
181− result3 <- parseRequestBody' lbsBackEnd $ toRequest ctype3 content3
182− let expectedsmap3 = []
183− let expectedfile3 = [(S8.pack "yaml", FileInfo (S8.pack "README") (S8.pack "application/octet-stream") $
184− L8.pack "Photo blog using Hack.\n")]
185− let expected3 = (expectedsmap3, expectedfile3)
186− liftIO $ assertEqual "parsing actual post multipart/form-data"
187− expected3
188− result3
189−
190− result2' <- parseRequestBody' lbsBackEnd $ toRequest' ctype2 content2
191− liftIO $ assertEqual "parsing post multipart/form-data 2"
192− expected2
193− result2'
194−
195− result3' <- parseRequestBody' lbsBackEnd $ toRequest' ctype3 content3
196− liftIO $ assertEqual "parsing actual post multipart/form-data 2"
197− expected3
198− result3'
199−
200−caseMultipartPlus :: Assertion
201−caseMultipartPlus = do
202− result <- parseRequestBody' lbsBackEnd $ toRequest ctype content
203− liftIO $ result @?= ([("email", "has+plus")], [])
204− where
205− content = S8.pack $
206− "--AaB03x\n" ++
207− "Content-Disposition: form-data; name=\"email\"\n" ++
208− "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
209− "has+plus\n" ++
210− "--AaB03x--"
211− ctype = "multipart/form-data; boundary=AaB03x"
212−
213−caseMultipartAttrs :: Assertion
214−caseMultipartAttrs = do
215− result <- parseRequestBody' lbsBackEnd $ toRequest ctype content
216− liftIO $ result @?= ([("email", "has+plus")], [])
217− where
218− content = S8.pack $
219− "--AaB03x\n" ++
220− "Content-Disposition: form-data; name=\"email\"\n" ++
221− "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
222− "has+plus\n" ++
223− "--AaB03x--"
224− ctype = "multipart/form-data; charset=UTF-8; boundary=AaB03x"
225−
226−caseUrlEncPlus :: Assertion
227−caseUrlEncPlus = do
228− result <- runResourceT $ withInternalState $ \state ->
229− parseRequestBody' (tempFileBackEnd state) $ toRequest ctype content
230− liftIO $ result @?= ([("email", "has+plus")], [])
231− where
232− content = S8.pack $ "email=has%2Bplus"
233− ctype = "application/x-www-form-urlencoded"
234−
23561toRequest :: S8.ByteString -> S8.ByteString -> SRequest
23662toRequest ctype content = SRequest defaultRequest
23763 { requestHeaders = [("Content-Type", ctype)]
@@ -241,28 +67,23 @@ toRequest ctype content = SRequest defaultRequest
24167 , queryString = []
24268 } (L.fromChunks [content])
24369
244−toRequest' :: S8.ByteString -> S8.ByteString -> SRequest
245−toRequest' ctype content = SRequest defaultRequest
246− { requestHeaders = [("Content-Type", ctype)]
247− } (L.fromChunks $ map S.singleton $ S.unpack content)
248−
24970{-
25071caseFindBound :: Assertion
25172caseFindBound = do
252− findBound (S8.pack "def") (S8.pack "abcdefghi") @?=
253− FoundBound (S8.pack "abc") (S8.pack "ghi")
254− findBound (S8.pack "def") (S8.pack "ABC") @?= NoBound
255− findBound (S8.pack "def") (S8.pack "abcd") @?= PartialBound
256− findBound (S8.pack "def") (S8.pack "abcdE") @?= NoBound
257− findBound (S8.pack "def") (S8.pack "abcdEdef") @?=
258− FoundBound (S8.pack "abcdE") (S8.pack "")
73+ findBound "def" "abcdefghi" @?=
74+ FoundBound "abc" "ghi"
75+ findBound "def" "ABC" @?= NoBound
76+ findBound "def" "abcd" @?= PartialBound
77+ findBound "def" "abcdE" @?= NoBound
78+ findBound "def" "abcdEdef" @?=
79+ FoundBound "abcdE" ""
25980
26081caseSinkTillBound :: Assertion
26182caseSinkTillBound = do
26283 let iter () _ = return ()
263− let src = S8.pack "this is some text"
264− bound1 = S8.pack "some"
265− bound2 = S8.pack "some!"
84+ let src = "this is some text"
85+ bound1 = "some"
86+ bound2 = "some!"
26687 let enum = enumList 1 [src]
26788 let helper _ _ = return ()
26889 (_, res1) <- run_ $ enum $$ sinkTillBound bound1 helper ()
@@ -494,41 +315,6 @@ caseAcceptOverride = flip runSession aoApp $ do
494315 }
495316 assertHeader "Accept" "baz" sres3
496317
497−dalvikHelper :: Bool -> Assertion
498−dalvikHelper includeLength = do
499− let headers' =
500− [ ("content-type", "multipart/form-data;boundary=*****")
501− , ("GATEWAY_INTERFACE", "CGI/1.1")
502− , ("PATH_INFO", "/")
503− , ("QUERY_STRING", "")
504− , ("REMOTE_ADDR", "192.168.1.115")
505− , ("REMOTE_HOST", "ganjizza")
506− , ("REQUEST_URI", "http://192.168.1.115:3000/")
507− , ("REQUEST_METHOD", "POST")
508− , ("HTTP_CONNECTION", "Keep-Alive")
509− , ("HTTP_COOKIE", "_SESSION=fgUGM5J/k6mGAAW+MMXIJZCJHobw/oEbb6T17KQN0p9yNqiXn/m/ACrsnRjiCEgqtG4fogMUDI+jikoFGcwmPjvuD5d+MDz32iXvDdDJsFdsFMfivuey2H+n6IF6yFGD")
510− , ("HTTP_USER_AGENT", "Dalvik/1.1.0 (Linux; U; Android 2.1-update1; sdk Build/ECLAIR)")
511− , ("HTTP_HOST", "192.168.1.115:3000")
512− , ("HTTP_ACCEPT", "*, */*")
513− , ("HTTP_VERSION", "HTTP/1.1")
514− , ("REQUEST_PATH", "/")
515− ]
516− headers
517− | includeLength = ("content-length", "12098") : headers'
518− | otherwise = headers'
519− let request' = defaultRequest
520− { requestHeaders = headers
521− }
522− (params, files) <-
523− case getRequestBodyType request' of
524− Nothing -> return ([], [])
525− Just rbt -> withFile "test/requests/dalvik-request" ReadMode $ \h ->
526− sinkRequestBody lbsBackEnd rbt $ S.hGetSome h 2048
527− lookup "scannedTime" params @?= Just "1.298590056748E9"
528− lookup "geoLong" params @?= Just "0"
529− lookup "geoLat" params @?= Just "0"
530− length files @?= 1
531−
532318caseDebugRequestBody :: Assertion
533319caseDebugRequestBody = do
534320 flip runSession (debugApp postOutput) $ do