1{-# LANGUAGE ImplicitParams, ViewPatterns, NoMonomorphismRestriction, CPP #-} 2import Control.Concurrent 3 4import Control.Applicative ((<$)) 5import Control.Concurrent (threadDelay) 6import Control.Exception (try) 7import qualified Data.ByteString.Lazy.Char8 as BL (pack) 8import Data.Char (isSpace) 9import qualified Data.Digest.Pure.MD5 as MD5 (md5) 10import Data.List.Split (splitOn) 11import Data.Maybe (fromJust) 12import System.IO.Error (userError) 13 14import qualified Httpd 15import qualified UnitTests 16 17import Network.Browser 18import Network.HTTP 19import Network.HTTP.Base 20import Network.HTTP.Auth 21import Network.HTTP.Headers 22import Network.Stream (Result) 23import Network.URI (uriPath, parseURI) 24 25import System.Environment (getArgs) 26import System.Info (os) 27import System.IO (getChar) 28 29import Test.Framework (defaultMainWithArgs, testGroup) 30import Test.Framework.Providers.HUnit 31import Test.HUnit 32 33 34basicGetRequest :: (?testUrl :: ServerAddress) => Assertion 35basicGetRequest = do 36 response <- simpleHTTP (getRequest (?testUrl "/basic/get")) 37 code <- getResponseCode response 38 assertEqual "HTTP status code" (2, 0, 0) code 39 body <- getResponseBody response 40 assertEqual "Receiving expected response" "It works." body 41 42basicGetRequestLBS :: (?testUrl :: ServerAddress) => Assertion 43basicGetRequestLBS = do 44 response <- simpleHTTP (mkRequest GET (fromJust (parseURI (?testUrl ("/basic/get"))))) 45 code <- getResponseCode response 46 assertEqual "HTTP status code" (2, 0, 0) code 47 body <- getResponseBody response 48 assertEqual "Receiving expected response" (BL.pack "It works.") body 49 50basicHeadRequest :: (?testUrl :: ServerAddress) => Assertion 51basicHeadRequest = do 52 response <- simpleHTTP (headRequest (?testUrl "/basic/head")) 53 code <- getResponseCode response 54 assertEqual "HTTP status code" (2, 0, 0) code 55 body <- getResponseBody response 56 -- the body should be empty, since this is a HEAD request 57 assertEqual "Receiving expected response" "" body 58 59basicExample :: (?testUrl :: ServerAddress) => Assertion 60basicExample = do 61 result <- 62 -- sample code from Network.HTTP haddock, with URL changed 63 -- Note there's also a copy of the example in the .cabal file 64 simpleHTTP (getRequest (?testUrl "/basic/example")) >>= fmap (take 100) . getResponseBody 65 assertEqual "Receiving expected response" (take 100 haskellOrgText) result 66 67secureGetRequest :: (?secureTestUrl :: ServerAddress) => Assertion 68secureGetRequest = do 69 response <- try $ simpleHTTP (getRequest (?secureTestUrl "/anything")) 70 assertEqual "Threw expected exception" 71 (Left (userError "https not supported")) 72 (fmap show response) -- fmap show because Response isn't in Eq 73 74basicPostRequest :: (?testUrl :: ServerAddress) => Assertion 75basicPostRequest = do 76 let sendBody = "body" 77 response <- simpleHTTP $ postRequestWithBody (?testUrl "/basic/post") 78 "text/plain" 79 sendBody 80 code <- getResponseCode response 81 assertEqual "HTTP status code" (2, 0, 0) code 82 body <- getResponseBody response 83 assertEqual "Receiving expected response" 84 (show (Just "text/plain", Just "4", sendBody)) 85 body 86 87userpwAuthFailure :: (?baduserpwUrl :: ServerAddress) => Assertion 88userpwAuthFailure = do 89 response <- simpleHTTP (getRequest (?baduserpwUrl "/auth/basic")) 90 code <- getResponseCode response 91 body <- getResponseBody response 92 assertEqual "HTTP status code" ((4, 0, 1), 93 "Just \"Basic dGVzdDp3cm9uZ3B3ZA==\"") (code, body) 94 -- in case of 401, the server returns the contents of the Authz header 95 96userpwAuthSuccess :: (?userpwUrl :: ServerAddress) => Assertion 97userpwAuthSuccess = do 98 response <- simpleHTTP (getRequest (?userpwUrl "/auth/basic")) 99 code <- getResponseCode response 100 body <- getResponseBody response 101 assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body) 102 103basicAuthFailure :: (?testUrl :: ServerAddress) => Assertion 104basicAuthFailure = do 105 response <- simpleHTTP (getRequest (?testUrl "/auth/basic")) 106 code <- getResponseCode response 107 body <- getResponseBody response 108 assertEqual "HTTP status code" ((4, 0, 1), "Nothing") (code, body) 109 110credentialsBasic :: (?testUrl :: ServerAddress) => Authority 111credentialsBasic = AuthBasic "Testing realm" "test" "password" 112 (fromJust . parseURI . ?testUrl $ "/auth/basic") 113 114basicAuthSuccess :: (?testUrl :: ServerAddress) => Assertion 115basicAuthSuccess = do 116 let req = getRequest (?testUrl "/auth/basic") 117 let authString = withAuthority credentialsBasic req 118 let reqWithAuth = req { rqHeaders = mkHeader HdrAuthorization authString:rqHeaders req } 119 response <- simpleHTTP reqWithAuth 120 code <- getResponseCode response 121 body <- getResponseBody response 122 assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body) 123 124utf8URLEncode :: Assertion 125utf8URLEncode = do 126 assertEqual "Normal URL" (urlEncode "what-a_mess.com") "what-a_mess.com" 127 assertEqual "Chinese URL" (urlEncode "好") "%E5%A5%BD" 128 assertEqual "Russian URL" (urlEncode "ололо") "%D0%BE%D0%BB%D0%BE%D0%BB%D0%BE" 129 130utf8URLDecode :: Assertion 131utf8URLDecode = do 132 assertEqual "Normal URL" (urlDecode "what-a_mess.com") "what-a_mess.com" 133 assertEqual "Mixed URL" (urlDecode "UTFin进入-wow") "UTFin进入-wow" 134 assertEqual "Chinese URL" (urlDecode "%E5%A5%BD") "好" 135 assertEqual "Russian URL" (urlDecode "%D0%BE%D0%BB%D0%BE%D0%BB%D0%BE") "ололо" 136 137browserExample :: (?testUrl :: ServerAddress) => Assertion 138browserExample = do 139 result <- 140 -- sample code from Network.Browser haddock, with URL changed 141 -- Note there's also a copy of the example in the .cabal file 142 do 143 (_, rsp) 144 <- Network.Browser.browse $ do 145 setAllowRedirects True -- handle HTTP redirects 146 request $ getRequest (?testUrl "/browser/example") 147 return (take 100 (rspBody rsp)) 148 assertEqual "Receiving expected response" (take 100 haskellOrgText) result 149 150-- A vanilla HTTP request using Browser shouln't send a cookie header 151browserNoCookie :: (?testUrl :: ServerAddress) => Assertion 152browserNoCookie = do 153 (_, response) <- browse $ do 154 setOutHandler (const $ return ()) 155 request $ getRequest (?testUrl "/browser/no-cookie") 156 let code = rspCode response 157 assertEqual "HTTP status code" (2, 0, 0) code 158 159 160-- Regression test 161-- * Browser sends vanilla request to server 162-- * Server sets one cookie "hello=world" 163-- * Browser sends a second request 164-- 165-- Expected: Server gets single cookie with "hello=world" 166-- Actual: Server gets 3 extra cookies, which are actually cookie attributes: 167-- "$Version=0;hello=world;$Domain=localhost:8080\r" 168browserOneCookie :: (?testUrl :: ServerAddress) => Assertion 169browserOneCookie = do 170 (_, response) <- browse $ do 171 setOutHandler (const $ return ()) 172 -- This first requests returns a single Set-Cookie: hello=world 173 _ <- request $ getRequest (?testUrl "/browser/one-cookie/1") 174 175 -- This second request should send a single Cookie: hello=world 176 request $ getRequest (?testUrl "/browser/one-cookie/2") 177 let body = rspBody response 178 assertEqual "Receiving expected response" "" body 179 let code = rspCode response 180 assertEqual "HTTP status code" (2, 0, 0) code 181 182browserTwoCookies :: (?testUrl :: ServerAddress) => Assertion 183browserTwoCookies = do 184 (_, response) <- browse $ do 185 setOutHandler (const $ return ()) 186 -- This first request returns two cookies 187 _ <- request $ getRequest (?testUrl "/browser/two-cookies/1") 188 189 -- This second request should send them back 190 request $ getRequest (?testUrl "/browser/two-cookies/2") 191 let body = rspBody response 192 assertEqual "Receiving expected response" "" body 193 let code = rspCode response 194 assertEqual "HTTP status code" (2, 0, 0) code 195 196 197browserFollowsRedirect :: (?testUrl :: ServerAddress) => Int -> Assertion 198browserFollowsRedirect n = do 199 (_, response) <- browse $ do 200 setOutHandler (const $ return ()) 201 request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get") 202 assertEqual "Receiving expected response from server" 203 ((2, 0, 0), "It works.") 204 (rspCode response, rspBody response) 205 206browserReturnsRedirect :: (?testUrl :: ServerAddress) => Int -> Assertion 207browserReturnsRedirect n = do 208 (_, response) <- browse $ do 209 setOutHandler (const $ return ()) 210 request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get") 211 assertEqual "Receiving expected response from server" 212 ((n `div` 100, n `mod` 100 `div` 10, n `mod` 10), "") 213 (rspCode response, rspBody response) 214 215authGenBasic _ "Testing realm" = return $ Just ("test", "password") 216authGenBasic _ realm = fail $ "Unexpected realm " ++ realm 217 218browserBasicAuth :: (?testUrl :: ServerAddress) => Assertion 219browserBasicAuth = do 220 (_, response) <- browse $ do 221 setOutHandler (const $ return ()) 222 223 setAuthorityGen authGenBasic 224 225 request $ getRequest (?testUrl "/auth/basic") 226 227 assertEqual "Receiving expected response from server" 228 ((2, 0, 0), "Here's the secret") 229 (rspCode response, rspBody response) 230 231authGenDigest _ "Digest testing realm" = return $ Just ("test", "digestpassword") 232authGenDigest _ realm = fail $ "Unexpected digest realm " ++ realm 233 234browserDigestAuth :: (?testUrl :: ServerAddress) => Assertion 235browserDigestAuth = do 236 (_, response) <- browse $ do 237 setOutHandler (const $ return ()) 238 239 setAuthorityGen authGenDigest 240 241 request $ getRequest (?testUrl "/auth/digest") 242 243 assertEqual "Receiving expected response from server" 244 ((2, 0, 0), "Here's the digest secret") 245 (rspCode response, rspBody response) 246 247 248 249browserAlt :: (?altTestUrl :: ServerAddress) => Assertion 250browserAlt = do 251 (response) <- browse $ do 252 253 setOutHandler (const $ return ()) 254 255 (_, response1) <- request $ getRequest (?altTestUrl "/basic/get") 256 257 return response1 258 259 assertEqual "Receiving expected response from alternate server" 260 ((2, 0, 0), "This is the alternate server.") 261 (rspCode response, rspBody response) 262 263-- test that requests to multiple servers on the same host 264-- don't get confused with each other 265browserBoth :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion 266browserBoth = do 267 (response1, response2) <- browse $ do 268 setOutHandler (const $ return ()) 269 270 (_, response1) <- request $ getRequest (?testUrl "/basic/get") 271 (_, response2) <- request $ getRequest (?altTestUrl "/basic/get") 272 273 return (response1, response2) 274 275 assertEqual "Receiving expected response from main server" 276 ((2, 0, 0), "It works.") 277 (rspCode response1, rspBody response1) 278 279 assertEqual "Receiving expected response from alternate server" 280 ((2, 0, 0), "This is the alternate server.") 281 (rspCode response2, rspBody response2) 282 283-- test that requests to multiple servers on the same host 284-- don't get confused with each other 285browserBothReversed :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion 286browserBothReversed = do 287 (response1, response2) <- browse $ do 288 setOutHandler (const $ return ()) 289 290 (_, response2) <- request $ getRequest (?altTestUrl "/basic/get") 291 (_, response1) <- request $ getRequest (?testUrl "/basic/get") 292 293 return (response1, response2) 294 295 assertEqual "Receiving expected response from main server" 296 ((2, 0, 0), "It works.") 297 (rspCode response1, rspBody response1) 298 299 assertEqual "Receiving expected response from alternate server" 300 ((2, 0, 0), "This is the alternate server.") 301 (rspCode response2, rspBody response2) 302 303browserSecureRequest :: (?secureTestUrl :: ServerAddress) => Assertion 304browserSecureRequest = do 305 res <- try $ browse $ do 306 setOutHandler (const $ return ()) 307 308 request $ getRequest (?secureTestUrl "/anything") 309 310 assertEqual "Threw expected exception" 311 (Left (userError "https not supported")) 312 (fmap show res) -- fmap show because Response isn't in Eq 313 314-- in case it tries to reuse the connection 315browserSecureRequestAfterInsecure :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Assertion 316browserSecureRequestAfterInsecure = do 317 res <- try $ browse $ do 318 setOutHandler (const $ return ()) 319 320 request $ getRequest (?testUrl "/basic/get") 321 request $ getRequest (?secureTestUrl "/anything") 322 323 assertEqual "Threw expected exception" 324 (Left (userError "https not supported")) 325 (fmap show res) -- fmap show because Response isn't in Eq 326 327browserRedirectToSecure :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Assertion 328browserRedirectToSecure = do 329 res <- try $ browse $ do 330 setOutHandler (const $ return ()) 331 setErrHandler fail 332 333 request $ getRequest (?testUrl "/browser/redirect/secure/301/anything") 334 335 assertEqual "Threw expected exception" 336 (Left (userError $ "Unable to handle redirect, unsupported scheme: " ++ ?secureTestUrl "/anything")) 337 (fmap show res) -- fmap show because Response isn't in Eq 338 339browserTwoRequests :: (?testUrl :: ServerAddress) => Assertion 340browserTwoRequests = do 341 (response1, response2) <- browse $ do 342 setOutHandler (const $ return ()) 343 344 (_, response1) <- request $ getRequest (?testUrl "/basic/get") 345 (_, response2) <- request $ getRequest (?testUrl "/basic/get2") 346 347 return (response1, response2) 348 349 assertEqual "Receiving expected response from main server" 350 ((2, 0, 0), "It works.") 351 (rspCode response1, rspBody response1) 352 353 assertEqual "Receiving expected response from main server" 354 ((2, 0, 0), "It works (2).") 355 (rspCode response2, rspBody response2) 356 357 358browserTwoRequestsAlt :: (?altTestUrl :: ServerAddress) => Assertion 359browserTwoRequestsAlt = do 360 (response1, response2) <- browse $ do 361 362 setOutHandler (const $ return ()) 363 364 (_, response1) <- request $ getRequest (?altTestUrl "/basic/get") 365 (_, response2) <- request $ getRequest (?altTestUrl "/basic/get2") 366 367 return (response1, response2) 368 369 assertEqual "Receiving expected response from alternate server" 370 ((2, 0, 0), "This is the alternate server.") 371 (rspCode response1, rspBody response1) 372 373 assertEqual "Receiving expected response from alternate server" 374 ((2, 0, 0), "This is the alternate server (2).") 375 (rspCode response2, rspBody response2) 376 377browserTwoRequestsBoth :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion 378browserTwoRequestsBoth = do 379 (response1, response2, response3, response4) <- browse $ do 380 setOutHandler (const $ return ()) 381 382 (_, response1) <- request $ getRequest (?testUrl "/basic/get") 383 (_, response2) <- request $ getRequest (?altTestUrl "/basic/get") 384 (_, response3) <- request $ getRequest (?testUrl "/basic/get2") 385 (_, response4) <- request $ getRequest (?altTestUrl "/basic/get2") 386 387 return (response1, response2, response3, response4) 388 389 assertEqual "Receiving expected response from main server" 390 ((2, 0, 0), "It works.") 391 (rspCode response1, rspBody response1) 392 393 assertEqual "Receiving expected response from alternate server" 394 ((2, 0, 0), "This is the alternate server.") 395 (rspCode response2, rspBody response2) 396 397 assertEqual "Receiving expected response from main server" 398 ((2, 0, 0), "It works (2).") 399 (rspCode response3, rspBody response3) 400 401 assertEqual "Receiving expected response from alternate server" 402 ((2, 0, 0), "This is the alternate server (2).") 403 (rspCode response4, rspBody response4) 404 405hasPrefix :: String -> String -> Maybe String 406hasPrefix [] ys = Just ys 407hasPrefix (x:xs) (y:ys) | x == y = hasPrefix xs ys 408hasPrefix _ _ = Nothing 409 410maybeRead :: Read a => String -> Maybe a 411maybeRead s = 412 case reads s of 413 [(v, "")] -> Just v 414 _ -> Nothing 415 416splitFields = map (toPair '=' . trim isSpace) . splitOn "," 417 418toPair c str = case break (==c) str of 419 (left, _:right) -> (left, right) 420 _ -> error $ "No " ++ show c ++ " in " ++ str 421trim f = dropWhile f . reverse . dropWhile f . reverse 422 423isSubsetOf xs ys = all (`elem` ys) xs 424 425-- first bits of result text from haskell.org (just to give some representative text) 426haskellOrgText = 427 "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">\ 428\\t<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\" dir=\"ltr\">\ 429\\t<head>\ 430\\t\t<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />\ 431\\t\t\t\t<meta name=\"keywords\" content=\"Haskell,Applications and libraries,Books,Foreign Function Interface,Functional programming,Hac Boston,HakkuTaikai,HaskellImplementorsWorkshop/2011,Haskell Communities and Activities Report,Haskell in education,Haskell in industry\" />" 432 433digestMatch 434 username realm password 435 nonce opaque 436 method relativeURI makeAbsolute 437 headers 438 = 439 common `isSubsetOf` headers && (relative `isSubsetOf` headers || absolute `isSubsetOf` headers) 440 where 441 common = [("username", show username), ("realm", show realm), ("nonce", show nonce), 442 ("opaque", show opaque)] 443 md5 = show . MD5.md5 . BL.pack 444 ha1 = md5 (username++":"++realm++":"++password) 445 ha2 uri = md5 (method++":"++uri) 446 response uri = md5 (ha1 ++ ":" ++ nonce ++ ":" ++ ha2 uri) 447 mkUncommon uri hash = [("uri", show uri), ("response", show hash)] 448 relative = mkUncommon relativeURI (response relativeURI) 449 absoluteURI = makeAbsolute relativeURI 450 absolute = mkUncommon absoluteURI (response absoluteURI) 451 452processRequest :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) 453 => Httpd.Request 454 -> IO Httpd.Response 455processRequest req = do 456 case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of 457 ("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "It works." 458 ("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "It works (2)." 459 ("GET", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head." 460 ("HEAD", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head." 461 ("POST", "/basic/post") -> 462 let typ = lookup "Content-Type" (Httpd.reqHeaders req) 463 len = lookup "Content-Length" (Httpd.reqHeaders req) 464 body = Httpd.reqBody req 465 in return $ Httpd.mkResponse 200 [] (show (typ, len, body)) 466 467 ("GET", "/basic/example") -> 468 return $ Httpd.mkResponse 200 [] haskellOrgText 469 470 ("GET", "/auth/basic") -> 471 case lookup "Authorization" (Httpd.reqHeaders req) of 472 Just "Basic dGVzdDpwYXNzd29yZA==" -> return $ Httpd.mkResponse 200 [] "Here's the secret" 473 x -> return $ Httpd.mkResponse 401 [("WWW-Authenticate", "Basic realm=\"Testing realm\"")] (show x) 474 475 ("GET", "/auth/digest") -> 476 case lookup "Authorization" (Httpd.reqHeaders req) of 477 Just (hasPrefix "Digest " -> Just (splitFields -> items)) 478 | digestMatch "test" "Digest testing realm" "digestpassword" 479 "87e4" "057d" 480 "GET" "/auth/digest" ?testUrl 481 items 482 -> return $ Httpd.mkResponse 200 [] "Here's the digest secret" 483 x -> return $ Httpd.mkResponse 484 401 485 [("WWW-Authenticate", 486 "Digest realm=\"Digest testing realm\", opaque=\"057d\", nonce=\"87e4\"")] 487 (show x) 488 489 ("GET", "/browser/example") -> 490 return $ Httpd.mkResponse 200 [] haskellOrgText 491 ("GET", "/browser/no-cookie") -> 492 case lookup "Cookie" (Httpd.reqHeaders req) of 493 Nothing -> return $ Httpd.mkResponse 200 [] "" 494 Just s -> return $ Httpd.mkResponse 500 [] s 495 ("GET", "/browser/one-cookie/1") -> 496 return $ Httpd.mkResponse 200 [("Set-Cookie", "hello=world")] "" 497 ("GET", "/browser/one-cookie/2") -> 498 case lookup "Cookie" (Httpd.reqHeaders req) of 499 Just "hello=world" -> return $ Httpd.mkResponse 200 [] "" 500 Just s -> return $ Httpd.mkResponse 500 [] s 501 Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req) 502 ("GET", "/browser/two-cookies/1") -> 503 return $ Httpd.mkResponse 200 504 [("Set-Cookie", "hello=world") 505 ,("Set-Cookie", "goodbye=cruelworld")] 506 "" 507 ("GET", "/browser/two-cookies/2") -> 508 case lookup "Cookie" (Httpd.reqHeaders req) of 509 -- TODO generalise the cookie parsing to allow for whitespace/ordering variations 510 Just "goodbye=cruelworld; hello=world" -> return $ Httpd.mkResponse 200 [] "" 511 Just s -> return $ Httpd.mkResponse 500 [] s 512 Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req) 513 ("GET", hasPrefix "/browser/redirect/relative/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> 514 return $ Httpd.mkResponse n [("Location", rest)] "" 515 ("GET", hasPrefix "/browser/redirect/absolute/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> 516 return $ Httpd.mkResponse n [("Location", ?testUrl rest)] "" 517 ("GET", hasPrefix "/browser/redirect/secure/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> 518 return $ Httpd.mkResponse n [("Location", ?secureTestUrl rest)] "" 519 _ -> return $ Httpd.mkResponse 500 [] "Unknown request" 520 521altProcessRequest :: Httpd.Request -> IO Httpd.Response 522altProcessRequest req = do 523 case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of 524 ("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "This is the alternate server." 525 ("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "This is the alternate server (2)." 526 _ -> return $ Httpd.mkResponse 500 [] "Unknown request" 527 528maybeTestGroup True name xs = testGroup name xs 529maybeTestGroup False name _ = testGroup name [] 530 531basicTests = 532 testGroup "Basic tests" 533 [ testCase "Basic GET request" basicGetRequest 534 , testCase "Basic GET request (lazy bytestring)" basicGetRequestLBS 535 , testCase "Network.HTTP example code" basicExample 536 , testCase "Secure GET request" secureGetRequest 537 , testCase "Basic POST request" basicPostRequest 538 , testCase "Basic HEAD request" basicHeadRequest 539 , testCase "URI user:pass Auth failure" userpwAuthFailure 540 , testCase "URI user:pass Auth success" userpwAuthSuccess 541 , testCase "Basic Auth failure" basicAuthFailure 542 , testCase "Basic Auth success" basicAuthSuccess 543 , testCase "UTF-8 urlEncode" utf8URLEncode 544 , testCase "UTF-8 urlDecode" utf8URLDecode 545 ] 546 547browserTests = 548 testGroup "Browser tests" 549 [ testGroup "Basic" 550 [ 551 testCase "Network.Browser example code" browserExample 552 , testCase "Two requests" browserTwoRequests 553 ] 554 , testGroup "Secure" 555 [ 556 testCase "Secure request" browserSecureRequest 557 , testCase "After insecure" browserSecureRequestAfterInsecure 558 , testCase "Redirection" browserRedirectToSecure 559 ] 560 , testGroup "Cookies" 561 [ testCase "No cookie header" browserNoCookie 562 , testCase "One cookie" browserOneCookie 563 , testCase "Two cookies" browserTwoCookies 564 ] 565 , testGroup "Redirection" 566 [ -- See http://en.wikipedia.org/wiki/List_of_HTTP_status_codes#3xx_Redirection 567 -- 300 Multiple Choices: client has to handle this 568 testCase "300" (browserReturnsRedirect 300) 569 -- 301 Moved Permanently: should follow 570 , testCase "301" (browserFollowsRedirect 301) 571 -- 302 Found: should follow 572 , testCase "302" (browserFollowsRedirect 302) 573 -- 303 See Other: should follow (directly for GETs) 574 , testCase "303" (browserFollowsRedirect 303) 575 -- 304 Not Modified: maybe Browser could do something intelligent based on 576 -- being given locally cached content and sending If-Modified-Since, but it 577 -- doesn't at the moment 578 , testCase "304" (browserReturnsRedirect 304) 579 -- 305 Use Proxy: test harness doesn't have a proxy (yet) 580 -- 306 Switch Proxy: obsolete 581 -- 307 Temporary Redirect: should follow 582 , testCase "307" (browserFollowsRedirect 307) 583 -- 308 Resume Incomplete: no support for Resumable HTTP so client has to handle this 584 , testCase "308" (browserReturnsRedirect 308) 585 ] 586 , testGroup "Authentication" 587 [ testCase "Basic" browserBasicAuth 588 , testCase "Digest" browserDigestAuth 589 ] 590 ] 591 592port80Tests = 593 testGroup "Multiple servers" 594 [ testCase "Alternate server" browserAlt 595 , testCase "Both servers" browserBoth 596 , testCase "Both servers (reversed)" browserBothReversed 597 , testCase "Two requests - alternate server" browserTwoRequestsAlt 598 , testCase "Two requests - both servers" browserTwoRequestsBoth 599 ] 600 601data InetFamily = IPv4 | IPv6 602 603familyToLocalhost :: InetFamily -> String 604familyToLocalhost IPv4 = "127.0.0.1" 605familyToLocalhost IPv6 = "[::1]" 606 607urlRoot :: InetFamily -> String -> Int -> String 608urlRoot fam userpw 80 = "http://" ++ userpw ++ familyToLocalhost fam 609urlRoot fam userpw n = "http://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n 610 611secureRoot :: InetFamily -> String -> Int -> String 612secureRoot fam userpw 443 = "https://" ++ userpw ++ familyToLocalhost fam 613secureRoot fam userpw n = "https://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n 614 615type ServerAddress = String -> String 616 617httpAddress, httpsAddress :: InetFamily -> String -> Int -> ServerAddress 618httpAddress fam userpw port p = urlRoot fam userpw port ++ p 619httpsAddress fam userpw port p = secureRoot fam userpw port ++ p 620 621main :: IO () 622main = do 623 args <- getArgs 624 625 let servers = 626 [ ("httpd-shed", Httpd.shed, IPv4) 627#ifdef WARP_TESTS 628 , ("warp.v6", Httpd.warp True, IPv6) 629 , ("warp.v4", Httpd.warp False, IPv4) 630#endif 631 ] 632 basePortNum, altPortNum :: Int 633 basePortNum = 5812 634 altPortNum = 80 635 numberedServers = zip [basePortNum..] servers 636 637 let setupNormalTests = do 638 flip mapM numberedServers $ \(portNum, (serverName, server, family)) -> do 639 let ?testUrl = httpAddress family "" portNum 640 ?userpwUrl = httpAddress family "test:password@" portNum 641 ?baduserpwUrl = httpAddress family "test:wrongpwd@" portNum 642 ?secureTestUrl = httpsAddress family "" portNum 643 _ <- forkIO $ server portNum processRequest 644 return $ testGroup serverName [basicTests, browserTests] 645 646 let setupAltTests = do 647 let (portNum, (_, server,family)) = head numberedServers 648 let ?testUrl = httpAddress family "" portNum 649 ?altTestUrl = httpAddress family "" altPortNum 650 _ <- forkIO $ server altPortNum altProcessRequest 651 return port80Tests 652 653 case args of 654 ["server"] -> do -- run only the harness servers for diagnostic/debug purposes 655 -- halt on any keypress 656 _ <- setupNormalTests 657 _ <- setupAltTests 658 _ <- getChar 659 return () 660 ("--withport80":args) -> do 661 normalTests <- setupNormalTests 662 altTests <- setupAltTests 663 _ <- threadDelay 1000000 -- Give the server time to start :-( 664 defaultMainWithArgs (UnitTests.unitTests ++ normalTests ++ [altTests]) args 665 args -> do -- run the test harness as normal 666 normalTests <- setupNormalTests 667 _ <- threadDelay 1000000 -- Give the server time to start :-( 668 defaultMainWithArgs (UnitTests.unitTests ++ normalTests) args 669