← Back to branch summary

~ubuntu-branches/ubuntu/saucy/haskell-wai-extra/saucy-proposed

« back to all changes in this revision

Viewing changes to test/WaiExtraTest.hs

  • Committer: Package Import Robot
  • Author(s): Joachim Breitner
  • Date: 2013-02-13 17:55:10 UTC
  • mfrom: (2.1.11 experimental)
  • Revision ID: package-import@ubuntu.com-20130213175510-ty5pd3iftubyyv9k
Tags: 1.3.2.1-2
Remove upper bound on hspec

Show diffs side-by-side

added added

removed removed

Lines of Context:
test/WaiExtraTest.hs
1
1
{-# LANGUAGE OverloadedStrings #-}
2
2
module WaiExtraTest (specs) where
3
3
 
4
 
import Test.Hspec.Monadic
5
 
import Test.Hspec.HUnit ()
 
4
import Test.Hspec
6
5
import Test.HUnit hiding (Test)
7
6
 
8
7
import Network.Wai
13
12
import qualified Data.ByteString.Lazy.Char8 as L8
14
13
import qualified Data.ByteString.Lazy as L
15
14
import qualified Data.Text.Lazy as T
 
15
import qualified Data.Text as TS
16
16
import qualified Data.Text.Encoding as TE
17
17
import Control.Arrow
18
18
 
23
23
import Network.Wai.Middleware.MethodOverride
24
24
import Network.Wai.Middleware.MethodOverridePost
25
25
import Network.Wai.Middleware.AcceptOverride
26
 
import Network.Wai.Middleware.RequestLogger (logCallback)
 
26
import Network.Wai.Middleware.RequestLogger
27
27
import Codec.Compression.GZip (decompress)
28
28
 
29
29
import qualified Data.Conduit as C
32
32
import Control.Monad.IO.Class (liftIO)
33
33
import Data.Maybe (fromMaybe)
34
34
import Network.HTTP.Types (parseSimpleQuery, status200)
35
 
 
36
 
specs :: Specs
 
35
import System.Log.FastLogger
 
36
 
 
37
import qualified Data.IORef as I
 
38
 
 
39
specs :: Spec
37
40
specs = do
38
41
  describe "Network.Wai.Parse" $ do
 
42
    describe "parseContentType" $ do
 
43
        let go (x, y, z) = it (TS.unpack $ TE.decodeUtf8 x) $ parseContentType x `shouldBe` (y, z)
 
44
        mapM_ go
 
45
            [ ("text/plain", "text/plain", [])
 
46
            , ("text/plain; charset=UTF-8 ", "text/plain", [("charset", "UTF-8")])
 
47
            , ("text/plain; charset=UTF-8 ; boundary = foo", "text/plain", [("charset", "UTF-8"), ("boundary", "foo")])
 
48
            ]
39
49
    it "parseQueryString" caseParseQueryString
40
50
    it "parseQueryString with question mark" caseParseQueryStringQM
41
51
    it "parseHttpAccept" caseParseHttpAccept
42
52
    it "parseRequestBody" caseParseRequestBody
 
53
    it "multipart with plus" caseMultipartPlus
 
54
    it "multipart with multiple attributes" caseMultipartAttrs
 
55
    it "urlencoded with plus" caseUrlEncPlus
43
56
    {-
44
57
    , it "findBound" caseFindBound
45
58
    , it "sinkTillBound" caseSinkTillBound
55
68
    it "method override" caseMethodOverride
56
69
    it "method override post" caseMethodOverridePost
57
70
    it "accept override" caseAcceptOverride
58
 
    it "dalvik multipart" caseDalvikMultipart
 
71
    describe "dalvik multipart" $ do
 
72
        it "non-chunked" $ dalvikHelper True
 
73
        it "chunked" $ dalvikHelper False
59
74
    it "debug request body" caseDebugRequestBody
60
75
 
61
76
caseParseQueryString :: Assertion
93
108
 
94
109
caseParseHttpAccept :: Assertion
95
110
caseParseHttpAccept = do
96
 
    let input = "text/plain; q=0.5, text/html, text/x-dvi; q=0.8, text/x-c"
97
 
        expected = ["text/html", "text/x-c", "text/x-dvi", "text/plain"]
 
111
    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"
 
112
        expected = ["text/html;charset=utf-8", "text/x-c", "text/x-dvi", "text/*", "text/plain"]
98
113
    expected @=? parseHttpAccept input
99
114
 
100
115
parseRequestBody' :: BackEnd L.ByteString
169
184
                    expected3
170
185
                    result3'
171
186
 
 
187
caseMultipartPlus :: Assertion
 
188
caseMultipartPlus = do
 
189
    result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content
 
190
    liftIO $ result @?= ([("email", "has+plus")], [])
 
191
  where
 
192
    content = S8.pack $
 
193
        "--AaB03x\n" ++
 
194
        "Content-Disposition: form-data; name=\"email\"\n" ++
 
195
        "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
 
196
        "has+plus\n" ++
 
197
        "--AaB03x--"
 
198
    ctype = "multipart/form-data; boundary=AaB03x"
 
199
 
 
200
caseMultipartAttrs :: Assertion
 
201
caseMultipartAttrs = do
 
202
    result <- C.runResourceT $ 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; charset=UTF-8; boundary=AaB03x"
 
212
 
 
213
caseUrlEncPlus :: Assertion
 
214
caseUrlEncPlus = do
 
215
    result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content
 
216
    liftIO $ result @?= ([("email", "has+plus")], [])
 
217
  where
 
218
    content = S8.pack $ "email=has%2Bplus"
 
219
    ctype = "application/x-www-form-urlencoded"
 
220
 
172
221
toRequest :: S8.ByteString -> S8.ByteString -> SRequest
173
222
toRequest ctype content = SRequest defaultRequest
174
223
    { requestHeaders = [("Content-Type", ctype)]
405
454
                }
406
455
    assertHeader "Accept" "baz" sres3
407
456
 
408
 
caseDalvikMultipart :: Assertion
409
 
caseDalvikMultipart = do
410
 
    let headers =
411
 
            [ ("content-length", "12098")
412
 
            , ("content-type", "multipart/form-data;boundary=*****")
 
457
dalvikHelper :: Bool -> Assertion
 
458
dalvikHelper includeLength = do
 
459
    let headers' =
 
460
            [ ("content-type", "multipart/form-data;boundary=*****")
413
461
            , ("GATEWAY_INTERFACE", "CGI/1.1")
414
462
            , ("PATH_INFO", "/")
415
463
            , ("QUERY_STRING", "")
425
473
            , ("HTTP_VERSION", "HTTP/1.1")
426
474
            , ("REQUEST_PATH", "/")
427
475
            ]
 
476
        headers
 
477
            | includeLength = ("content-length", "12098") : headers'
 
478
            | otherwise = headers'
428
479
    let request' = defaultRequest
429
480
            { requestHeaders = headers
430
481
            }
446
497
        assertStatus 200 res
447
498
 
448
499
    let qs = "?foo=bar&baz=bin"
449
 
    flip runSession (debugApp $ getOutput qs) $ do
 
500
    flip runSession (debugApp $ getOutput params) $ do
450
501
        assertStatus 200 =<< request defaultRequest
451
502
                { requestMethod = "GET"
452
503
                , queryString = map (\(k,v) -> (k, Just v)) params
457
508
  where
458
509
    params = [("foo", "bar"), ("baz", "bin")]
459
510
    -- FIXME change back once we include post parameter output in logging postOutput = T.pack $ "POST \nAccept: \nPOST " ++ (show params)
460
 
    postOutput = T.pack $ "POST / Accept: \nStatus: 200 OK"
461
 
    -- FIXME getOutput _qs = T.pack $ "GET /location" ++ "\nAccept: \nGET " ++ (show params) -- \nAccept: \n" ++ (show params)
462
 
    getOutput _qs = T.pack $ "GET /location?foo=bar&baz=bin Accept: \nStatus: 200 OK"
 
511
    postOutput = T.pack $ "POST /\nAccept: \nStatus: 200 OK. /\n"
 
512
    getOutput params' = T.pack $ "GET /location\nAccept: \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n"
463
513
 
464
 
    debugApp output' = logCallback (\t -> liftIO $ assertEqual "debug" output t) $ \_req -> do
465
 
        return $ responseLBS status200 [ ] ""
 
514
    debugApp output' req = do
 
515
        iactual <- liftIO $ I.newIORef []
 
516
        middleware <- liftIO $ mkRequestLogger def
 
517
            { destination = Callback $ \strs -> I.modifyIORef iactual $ (++ strs)
 
518
            , outputFormat = Detailed False
 
519
            }
 
520
        res <- middleware (\_req -> return $ responseLBS status200 [ ] "") req
 
521
        actual <- liftIO $ I.readIORef iactual
 
522
        liftIO $ assertEqual "debug" output $ logsToBs actual
 
523
        return res
466
524
      where
467
525
        output = TE.encodeUtf8 $ T.toStrict output'
 
526
        logsToBs = S.concat . map logToBs
 
527
 
 
528
        logToBs (LB bs) = bs
 
529
        logToBs (LS s) = S8.pack s
 
530
 
468
531
    {-debugApp = debug $ \req -> do-}
469
532
        {-return $ responseLBS status200 [ ] ""-}