← Back to branch summary

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

« back to all changes in this revision

Viewing changes to test/WaiExtraTest.hs

  • Committer: Package Import Robot
  • Author(s): Clint Adams
  • Date: 2012-05-15 00:58:38 UTC
  • mfrom: (2.1.7 sid)
  • Revision ID: package-import@ubuntu.com-20120515005838-zicbz35rrqbn305y
Tags: 1.2.0.4-1
New upstream version.

Show diffs side-by-side

added added

removed removed

Lines of Context:
test/WaiExtraTest.hs
21
21
import Network.Wai.Middleware.Vhost
22
22
import Network.Wai.Middleware.Autohead
23
23
import Network.Wai.Middleware.MethodOverride
 
24
import Network.Wai.Middleware.MethodOverridePost
24
25
import Network.Wai.Middleware.AcceptOverride
25
26
import Network.Wai.Middleware.RequestLogger (logCallback)
26
27
import Codec.Compression.GZip (decompress)
31
32
import Control.Monad.IO.Class (liftIO)
32
33
import Data.Maybe (fromMaybe)
33
34
import Network.HTTP.Types (parseSimpleQuery, status200)
34
 
import Data.Monoid (mappend)
35
35
 
36
36
specs :: Specs
37
37
specs = do
53
53
    it "vhost" caseVhost
54
54
    it "autohead" caseAutohead
55
55
    it "method override" caseMethodOverride
 
56
    it "method override post" caseMethodOverridePost
56
57
    it "accept override" caseAcceptOverride
57
58
    it "dalvik multipart" caseDalvikMultipart
58
59
    it "debug request body" caseDebugRequestBody
354
355
                }
355
356
    assertHeader "Method" "PUT" sres3
356
357
 
 
358
mopApp :: Application
 
359
mopApp = methodOverridePost $ \req -> return $ responseLBS status200 [("Method", requestMethod req)] ""
 
360
 
 
361
caseMethodOverridePost :: Assertion
 
362
caseMethodOverridePost = flip runSession mopApp $ do
 
363
 
 
364
    -- Get Request are unmodified
 
365
    sres1 <- let r = toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin"
 
366
                 s = simpleRequest r
 
367
                 m = s { requestMethod = "GET" }
 
368
                 b = r { simpleRequest = m }
 
369
             in srequest b
 
370
    assertHeader "Method" "GET" sres1
 
371
 
 
372
    -- Post requests are modified if _method comes first
 
373
    sres2 <- srequest $ toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin"
 
374
    assertHeader "Method" "PUT" sres2
 
375
 
 
376
    -- Post requests are unmodified if _method doesn't come first
 
377
    sres3 <- srequest $ toRequest "application/x-www-form-urlencoded" "foo=bar&_method=PUT&baz=bin"
 
378
    assertHeader "Method" "POST" sres3
 
379
 
 
380
    -- Post requests are unmodified if Content-Type header isn't set to "application/x-www-form-urlencoded"
 
381
    sres4 <- srequest $ toRequest "text/html; charset=utf-8" "foo=bar&_method=PUT&baz=bin"
 
382
    assertHeader "Method" "POST" sres4
 
383
 
357
384
aoApp :: Application
358
385
aoApp = acceptOverride $ \req -> return $ responseLBS status200
359
386
    [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] ""
430
457
  where
431
458
    params = [("foo", "bar"), ("baz", "bin")]
432
459
    -- FIXME change back once we include post parameter output in logging postOutput = T.pack $ "POST \nAccept: \nPOST " ++ (show params)
433
 
    postOutput = T.pack $ "POST / Accept: \n"
 
460
    postOutput = T.pack $ "POST / Accept: \nStatus: 200 OK"
434
461
    -- FIXME getOutput _qs = T.pack $ "GET /location" ++ "\nAccept: \nGET " ++ (show params) -- \nAccept: \n" ++ (show params)
435
 
    getOutput _qs = T.pack $ "GET /location?foo=bar&baz=bin Accept: \n"
 
462
    getOutput _qs = T.pack $ "GET /location?foo=bar&baz=bin Accept: \nStatus: 200 OK"
436
463
 
437
464
    debugApp output' = logCallback (\t -> liftIO $ assertEqual "debug" output t) $ \_req -> do
438
465
        return $ responseLBS status200 [ ] ""