|
Packit |
acf257 |
{-# LANGUAGE ImplicitParams, ViewPatterns, NoMonomorphismRestriction, CPP #-}
|
|
Packit |
acf257 |
import Control.Concurrent
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
import Control.Applicative ((<$))
|
|
Packit |
acf257 |
import Control.Concurrent (threadDelay)
|
|
Packit |
acf257 |
import Control.Exception (try)
|
|
Packit |
acf257 |
import qualified Data.ByteString.Lazy.Char8 as BL (pack)
|
|
Packit |
acf257 |
import Data.Char (isSpace)
|
|
Packit |
acf257 |
import qualified Data.Digest.Pure.MD5 as MD5 (md5)
|
|
Packit |
acf257 |
import Data.List.Split (splitOn)
|
|
Packit |
acf257 |
import Data.Maybe (fromJust)
|
|
Packit |
acf257 |
import System.IO.Error (userError)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
import qualified Httpd
|
|
Packit |
acf257 |
import qualified UnitTests
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
import Network.Browser
|
|
Packit |
acf257 |
import Network.HTTP
|
|
Packit |
acf257 |
import Network.HTTP.Base
|
|
Packit |
acf257 |
import Network.HTTP.Auth
|
|
Packit |
acf257 |
import Network.HTTP.Headers
|
|
Packit |
acf257 |
import Network.Stream (Result)
|
|
Packit |
acf257 |
import Network.URI (uriPath, parseURI)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
import System.Environment (getArgs)
|
|
Packit |
acf257 |
import System.Info (os)
|
|
Packit |
acf257 |
import System.IO (getChar)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
import Test.Framework (defaultMainWithArgs, testGroup)
|
|
Packit |
acf257 |
import Test.Framework.Providers.HUnit
|
|
Packit |
acf257 |
import Test.HUnit
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
basicGetRequest :: (?testUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
basicGetRequest = do
|
|
Packit |
acf257 |
response <- simpleHTTP (getRequest (?testUrl "/basic/get"))
|
|
Packit |
acf257 |
code <- getResponseCode response
|
|
Packit |
acf257 |
assertEqual "HTTP status code" (2, 0, 0) code
|
|
Packit |
acf257 |
body <- getResponseBody response
|
|
Packit |
acf257 |
assertEqual "Receiving expected response" "It works." body
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
basicGetRequestLBS :: (?testUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
basicGetRequestLBS = do
|
|
Packit |
acf257 |
response <- simpleHTTP (mkRequest GET (fromJust (parseURI (?testUrl ("/basic/get")))))
|
|
Packit |
acf257 |
code <- getResponseCode response
|
|
Packit |
acf257 |
assertEqual "HTTP status code" (2, 0, 0) code
|
|
Packit |
acf257 |
body <- getResponseBody response
|
|
Packit |
acf257 |
assertEqual "Receiving expected response" (BL.pack "It works.") body
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
basicHeadRequest :: (?testUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
basicHeadRequest = do
|
|
Packit |
acf257 |
response <- simpleHTTP (headRequest (?testUrl "/basic/head"))
|
|
Packit |
acf257 |
code <- getResponseCode response
|
|
Packit |
acf257 |
assertEqual "HTTP status code" (2, 0, 0) code
|
|
Packit |
acf257 |
body <- getResponseBody response
|
|
Packit |
acf257 |
-- the body should be empty, since this is a HEAD request
|
|
Packit |
acf257 |
assertEqual "Receiving expected response" "" body
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
basicExample :: (?testUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
basicExample = do
|
|
Packit |
acf257 |
result <-
|
|
Packit |
acf257 |
-- sample code from Network.HTTP haddock, with URL changed
|
|
Packit |
acf257 |
-- Note there's also a copy of the example in the .cabal file
|
|
Packit |
acf257 |
simpleHTTP (getRequest (?testUrl "/basic/example")) >>= fmap (take 100) . getResponseBody
|
|
Packit |
acf257 |
assertEqual "Receiving expected response" (take 100 haskellOrgText) result
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
secureGetRequest :: (?secureTestUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
secureGetRequest = do
|
|
Packit |
acf257 |
response <- try $ simpleHTTP (getRequest (?secureTestUrl "/anything"))
|
|
Packit |
acf257 |
assertEqual "Threw expected exception"
|
|
Packit |
acf257 |
(Left (userError "https not supported"))
|
|
Packit |
acf257 |
(fmap show response) -- fmap show because Response isn't in Eq
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
basicPostRequest :: (?testUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
basicPostRequest = do
|
|
Packit |
acf257 |
let sendBody = "body"
|
|
Packit |
acf257 |
response <- simpleHTTP $ postRequestWithBody (?testUrl "/basic/post")
|
|
Packit |
acf257 |
"text/plain"
|
|
Packit |
acf257 |
sendBody
|
|
Packit |
acf257 |
code <- getResponseCode response
|
|
Packit |
acf257 |
assertEqual "HTTP status code" (2, 0, 0) code
|
|
Packit |
acf257 |
body <- getResponseBody response
|
|
Packit |
acf257 |
assertEqual "Receiving expected response"
|
|
Packit |
acf257 |
(show (Just "text/plain", Just "4", sendBody))
|
|
Packit |
acf257 |
body
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
userpwAuthFailure :: (?baduserpwUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
userpwAuthFailure = do
|
|
Packit |
acf257 |
response <- simpleHTTP (getRequest (?baduserpwUrl "/auth/basic"))
|
|
Packit |
acf257 |
code <- getResponseCode response
|
|
Packit |
acf257 |
body <- getResponseBody response
|
|
Packit |
acf257 |
assertEqual "HTTP status code" ((4, 0, 1),
|
|
Packit |
acf257 |
"Just \"Basic dGVzdDp3cm9uZ3B3ZA==\"") (code, body)
|
|
Packit |
acf257 |
-- in case of 401, the server returns the contents of the Authz header
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
userpwAuthSuccess :: (?userpwUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
userpwAuthSuccess = do
|
|
Packit |
acf257 |
response <- simpleHTTP (getRequest (?userpwUrl "/auth/basic"))
|
|
Packit |
acf257 |
code <- getResponseCode response
|
|
Packit |
acf257 |
body <- getResponseBody response
|
|
Packit |
acf257 |
assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
basicAuthFailure :: (?testUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
basicAuthFailure = do
|
|
Packit |
acf257 |
response <- simpleHTTP (getRequest (?testUrl "/auth/basic"))
|
|
Packit |
acf257 |
code <- getResponseCode response
|
|
Packit |
acf257 |
body <- getResponseBody response
|
|
Packit |
acf257 |
assertEqual "HTTP status code" ((4, 0, 1), "Nothing") (code, body)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
credentialsBasic :: (?testUrl :: ServerAddress) => Authority
|
|
Packit |
acf257 |
credentialsBasic = AuthBasic "Testing realm" "test" "password"
|
|
Packit |
acf257 |
(fromJust . parseURI . ?testUrl $ "/auth/basic")
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
basicAuthSuccess :: (?testUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
basicAuthSuccess = do
|
|
Packit |
acf257 |
let req = getRequest (?testUrl "/auth/basic")
|
|
Packit |
acf257 |
let authString = withAuthority credentialsBasic req
|
|
Packit |
acf257 |
let reqWithAuth = req { rqHeaders = mkHeader HdrAuthorization authString:rqHeaders req }
|
|
Packit |
acf257 |
response <- simpleHTTP reqWithAuth
|
|
Packit |
acf257 |
code <- getResponseCode response
|
|
Packit |
acf257 |
body <- getResponseBody response
|
|
Packit |
acf257 |
assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
utf8URLEncode :: Assertion
|
|
Packit |
acf257 |
utf8URLEncode = do
|
|
Packit |
acf257 |
assertEqual "Normal URL" (urlEncode "what-a_mess.com") "what-a_mess.com"
|
|
Packit |
acf257 |
assertEqual "Chinese URL" (urlEncode "好") "%E5%A5%BD"
|
|
Packit |
acf257 |
assertEqual "Russian URL" (urlEncode "ололо") "%D0%BE%D0%BB%D0%BE%D0%BB%D0%BE"
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
utf8URLDecode :: Assertion
|
|
Packit |
acf257 |
utf8URLDecode = do
|
|
Packit |
acf257 |
assertEqual "Normal URL" (urlDecode "what-a_mess.com") "what-a_mess.com"
|
|
Packit |
acf257 |
assertEqual "Mixed URL" (urlDecode "UTFin进入-wow") "UTFin进入-wow"
|
|
Packit |
acf257 |
assertEqual "Chinese URL" (urlDecode "%E5%A5%BD") "好"
|
|
Packit |
acf257 |
assertEqual "Russian URL" (urlDecode "%D0%BE%D0%BB%D0%BE%D0%BB%D0%BE") "ололо"
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
browserExample :: (?testUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
browserExample = do
|
|
Packit |
acf257 |
result <-
|
|
Packit |
acf257 |
-- sample code from Network.Browser haddock, with URL changed
|
|
Packit |
acf257 |
-- Note there's also a copy of the example in the .cabal file
|
|
Packit |
acf257 |
do
|
|
Packit |
acf257 |
(_, rsp)
|
|
Packit |
acf257 |
<- Network.Browser.browse $ do
|
|
Packit |
acf257 |
setAllowRedirects True -- handle HTTP redirects
|
|
Packit |
acf257 |
request $ getRequest (?testUrl "/browser/example")
|
|
Packit |
acf257 |
return (take 100 (rspBody rsp))
|
|
Packit |
acf257 |
assertEqual "Receiving expected response" (take 100 haskellOrgText) result
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
-- A vanilla HTTP request using Browser shouln't send a cookie header
|
|
Packit |
acf257 |
browserNoCookie :: (?testUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
browserNoCookie = do
|
|
Packit |
acf257 |
(_, response) <- browse $ do
|
|
Packit |
acf257 |
setOutHandler (const $ return ())
|
|
Packit |
acf257 |
request $ getRequest (?testUrl "/browser/no-cookie")
|
|
Packit |
acf257 |
let code = rspCode response
|
|
Packit |
acf257 |
assertEqual "HTTP status code" (2, 0, 0) code
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
-- Regression test
|
|
Packit |
acf257 |
-- * Browser sends vanilla request to server
|
|
Packit |
acf257 |
-- * Server sets one cookie "hello=world"
|
|
Packit |
acf257 |
-- * Browser sends a second request
|
|
Packit |
acf257 |
--
|
|
Packit |
acf257 |
-- Expected: Server gets single cookie with "hello=world"
|
|
Packit |
acf257 |
-- Actual: Server gets 3 extra cookies, which are actually cookie attributes:
|
|
Packit |
acf257 |
-- "$Version=0;hello=world;$Domain=localhost:8080\r"
|
|
Packit |
acf257 |
browserOneCookie :: (?testUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
browserOneCookie = do
|
|
Packit |
acf257 |
(_, response) <- browse $ do
|
|
Packit |
acf257 |
setOutHandler (const $ return ())
|
|
Packit |
acf257 |
-- This first requests returns a single Set-Cookie: hello=world
|
|
Packit |
acf257 |
_ <- request $ getRequest (?testUrl "/browser/one-cookie/1")
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
-- This second request should send a single Cookie: hello=world
|
|
Packit |
acf257 |
request $ getRequest (?testUrl "/browser/one-cookie/2")
|
|
Packit |
acf257 |
let body = rspBody response
|
|
Packit |
acf257 |
assertEqual "Receiving expected response" "" body
|
|
Packit |
acf257 |
let code = rspCode response
|
|
Packit |
acf257 |
assertEqual "HTTP status code" (2, 0, 0) code
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
browserTwoCookies :: (?testUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
browserTwoCookies = do
|
|
Packit |
acf257 |
(_, response) <- browse $ do
|
|
Packit |
acf257 |
setOutHandler (const $ return ())
|
|
Packit |
acf257 |
-- This first request returns two cookies
|
|
Packit |
acf257 |
_ <- request $ getRequest (?testUrl "/browser/two-cookies/1")
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
-- This second request should send them back
|
|
Packit |
acf257 |
request $ getRequest (?testUrl "/browser/two-cookies/2")
|
|
Packit |
acf257 |
let body = rspBody response
|
|
Packit |
acf257 |
assertEqual "Receiving expected response" "" body
|
|
Packit |
acf257 |
let code = rspCode response
|
|
Packit |
acf257 |
assertEqual "HTTP status code" (2, 0, 0) code
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
browserFollowsRedirect :: (?testUrl :: ServerAddress) => Int -> Assertion
|
|
Packit |
acf257 |
browserFollowsRedirect n = do
|
|
Packit |
acf257 |
(_, response) <- browse $ do
|
|
Packit |
acf257 |
setOutHandler (const $ return ())
|
|
Packit |
acf257 |
request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get")
|
|
Packit |
acf257 |
assertEqual "Receiving expected response from server"
|
|
Packit |
acf257 |
((2, 0, 0), "It works.")
|
|
Packit |
acf257 |
(rspCode response, rspBody response)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
browserReturnsRedirect :: (?testUrl :: ServerAddress) => Int -> Assertion
|
|
Packit |
acf257 |
browserReturnsRedirect n = do
|
|
Packit |
acf257 |
(_, response) <- browse $ do
|
|
Packit |
acf257 |
setOutHandler (const $ return ())
|
|
Packit |
acf257 |
request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get")
|
|
Packit |
acf257 |
assertEqual "Receiving expected response from server"
|
|
Packit |
acf257 |
((n `div` 100, n `mod` 100 `div` 10, n `mod` 10), "")
|
|
Packit |
acf257 |
(rspCode response, rspBody response)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
authGenBasic _ "Testing realm" = return $ Just ("test", "password")
|
|
Packit |
acf257 |
authGenBasic _ realm = fail $ "Unexpected realm " ++ realm
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
browserBasicAuth :: (?testUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
browserBasicAuth = do
|
|
Packit |
acf257 |
(_, response) <- browse $ do
|
|
Packit |
acf257 |
setOutHandler (const $ return ())
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
setAuthorityGen authGenBasic
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
request $ getRequest (?testUrl "/auth/basic")
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
assertEqual "Receiving expected response from server"
|
|
Packit |
acf257 |
((2, 0, 0), "Here's the secret")
|
|
Packit |
acf257 |
(rspCode response, rspBody response)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
authGenDigest _ "Digest testing realm" = return $ Just ("test", "digestpassword")
|
|
Packit |
acf257 |
authGenDigest _ realm = fail $ "Unexpected digest realm " ++ realm
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
browserDigestAuth :: (?testUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
browserDigestAuth = do
|
|
Packit |
acf257 |
(_, response) <- browse $ do
|
|
Packit |
acf257 |
setOutHandler (const $ return ())
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
setAuthorityGen authGenDigest
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
request $ getRequest (?testUrl "/auth/digest")
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
assertEqual "Receiving expected response from server"
|
|
Packit |
acf257 |
((2, 0, 0), "Here's the digest secret")
|
|
Packit |
acf257 |
(rspCode response, rspBody response)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
browserAlt :: (?altTestUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
browserAlt = do
|
|
Packit |
acf257 |
(response) <- browse $ do
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
setOutHandler (const $ return ())
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
(_, response1) <- request $ getRequest (?altTestUrl "/basic/get")
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
return response1
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
assertEqual "Receiving expected response from alternate server"
|
|
Packit |
acf257 |
((2, 0, 0), "This is the alternate server.")
|
|
Packit |
acf257 |
(rspCode response, rspBody response)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
-- test that requests to multiple servers on the same host
|
|
Packit |
acf257 |
-- don't get confused with each other
|
|
Packit |
acf257 |
browserBoth :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
browserBoth = do
|
|
Packit |
acf257 |
(response1, response2) <- browse $ do
|
|
Packit |
acf257 |
setOutHandler (const $ return ())
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
(_, response1) <- request $ getRequest (?testUrl "/basic/get")
|
|
Packit |
acf257 |
(_, response2) <- request $ getRequest (?altTestUrl "/basic/get")
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
return (response1, response2)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
assertEqual "Receiving expected response from main server"
|
|
Packit |
acf257 |
((2, 0, 0), "It works.")
|
|
Packit |
acf257 |
(rspCode response1, rspBody response1)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
assertEqual "Receiving expected response from alternate server"
|
|
Packit |
acf257 |
((2, 0, 0), "This is the alternate server.")
|
|
Packit |
acf257 |
(rspCode response2, rspBody response2)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
-- test that requests to multiple servers on the same host
|
|
Packit |
acf257 |
-- don't get confused with each other
|
|
Packit |
acf257 |
browserBothReversed :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
browserBothReversed = do
|
|
Packit |
acf257 |
(response1, response2) <- browse $ do
|
|
Packit |
acf257 |
setOutHandler (const $ return ())
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
(_, response2) <- request $ getRequest (?altTestUrl "/basic/get")
|
|
Packit |
acf257 |
(_, response1) <- request $ getRequest (?testUrl "/basic/get")
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
return (response1, response2)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
assertEqual "Receiving expected response from main server"
|
|
Packit |
acf257 |
((2, 0, 0), "It works.")
|
|
Packit |
acf257 |
(rspCode response1, rspBody response1)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
assertEqual "Receiving expected response from alternate server"
|
|
Packit |
acf257 |
((2, 0, 0), "This is the alternate server.")
|
|
Packit |
acf257 |
(rspCode response2, rspBody response2)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
browserSecureRequest :: (?secureTestUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
browserSecureRequest = do
|
|
Packit |
acf257 |
res <- try $ browse $ do
|
|
Packit |
acf257 |
setOutHandler (const $ return ())
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
request $ getRequest (?secureTestUrl "/anything")
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
assertEqual "Threw expected exception"
|
|
Packit |
acf257 |
(Left (userError "https not supported"))
|
|
Packit |
acf257 |
(fmap show res) -- fmap show because Response isn't in Eq
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
-- in case it tries to reuse the connection
|
|
Packit |
acf257 |
browserSecureRequestAfterInsecure :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
browserSecureRequestAfterInsecure = do
|
|
Packit |
acf257 |
res <- try $ browse $ do
|
|
Packit |
acf257 |
setOutHandler (const $ return ())
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
request $ getRequest (?testUrl "/basic/get")
|
|
Packit |
acf257 |
request $ getRequest (?secureTestUrl "/anything")
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
assertEqual "Threw expected exception"
|
|
Packit |
acf257 |
(Left (userError "https not supported"))
|
|
Packit |
acf257 |
(fmap show res) -- fmap show because Response isn't in Eq
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
browserRedirectToSecure :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
browserRedirectToSecure = do
|
|
Packit |
acf257 |
res <- try $ browse $ do
|
|
Packit |
acf257 |
setOutHandler (const $ return ())
|
|
Packit |
acf257 |
setErrHandler fail
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
request $ getRequest (?testUrl "/browser/redirect/secure/301/anything")
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
assertEqual "Threw expected exception"
|
|
Packit |
acf257 |
(Left (userError $ "Unable to handle redirect, unsupported scheme: " ++ ?secureTestUrl "/anything"))
|
|
Packit |
acf257 |
(fmap show res) -- fmap show because Response isn't in Eq
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
browserTwoRequests :: (?testUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
browserTwoRequests = do
|
|
Packit |
acf257 |
(response1, response2) <- browse $ do
|
|
Packit |
acf257 |
setOutHandler (const $ return ())
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
(_, response1) <- request $ getRequest (?testUrl "/basic/get")
|
|
Packit |
acf257 |
(_, response2) <- request $ getRequest (?testUrl "/basic/get2")
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
return (response1, response2)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
assertEqual "Receiving expected response from main server"
|
|
Packit |
acf257 |
((2, 0, 0), "It works.")
|
|
Packit |
acf257 |
(rspCode response1, rspBody response1)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
assertEqual "Receiving expected response from main server"
|
|
Packit |
acf257 |
((2, 0, 0), "It works (2).")
|
|
Packit |
acf257 |
(rspCode response2, rspBody response2)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
browserTwoRequestsAlt :: (?altTestUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
browserTwoRequestsAlt = do
|
|
Packit |
acf257 |
(response1, response2) <- browse $ do
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
setOutHandler (const $ return ())
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
(_, response1) <- request $ getRequest (?altTestUrl "/basic/get")
|
|
Packit |
acf257 |
(_, response2) <- request $ getRequest (?altTestUrl "/basic/get2")
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
return (response1, response2)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
assertEqual "Receiving expected response from alternate server"
|
|
Packit |
acf257 |
((2, 0, 0), "This is the alternate server.")
|
|
Packit |
acf257 |
(rspCode response1, rspBody response1)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
assertEqual "Receiving expected response from alternate server"
|
|
Packit |
acf257 |
((2, 0, 0), "This is the alternate server (2).")
|
|
Packit |
acf257 |
(rspCode response2, rspBody response2)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
browserTwoRequestsBoth :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion
|
|
Packit |
acf257 |
browserTwoRequestsBoth = do
|
|
Packit |
acf257 |
(response1, response2, response3, response4) <- browse $ do
|
|
Packit |
acf257 |
setOutHandler (const $ return ())
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
(_, response1) <- request $ getRequest (?testUrl "/basic/get")
|
|
Packit |
acf257 |
(_, response2) <- request $ getRequest (?altTestUrl "/basic/get")
|
|
Packit |
acf257 |
(_, response3) <- request $ getRequest (?testUrl "/basic/get2")
|
|
Packit |
acf257 |
(_, response4) <- request $ getRequest (?altTestUrl "/basic/get2")
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
return (response1, response2, response3, response4)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
assertEqual "Receiving expected response from main server"
|
|
Packit |
acf257 |
((2, 0, 0), "It works.")
|
|
Packit |
acf257 |
(rspCode response1, rspBody response1)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
assertEqual "Receiving expected response from alternate server"
|
|
Packit |
acf257 |
((2, 0, 0), "This is the alternate server.")
|
|
Packit |
acf257 |
(rspCode response2, rspBody response2)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
assertEqual "Receiving expected response from main server"
|
|
Packit |
acf257 |
((2, 0, 0), "It works (2).")
|
|
Packit |
acf257 |
(rspCode response3, rspBody response3)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
assertEqual "Receiving expected response from alternate server"
|
|
Packit |
acf257 |
((2, 0, 0), "This is the alternate server (2).")
|
|
Packit |
acf257 |
(rspCode response4, rspBody response4)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
hasPrefix :: String -> String -> Maybe String
|
|
Packit |
acf257 |
hasPrefix [] ys = Just ys
|
|
Packit |
acf257 |
hasPrefix (x:xs) (y:ys) | x == y = hasPrefix xs ys
|
|
Packit |
acf257 |
hasPrefix _ _ = Nothing
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
maybeRead :: Read a => String -> Maybe a
|
|
Packit |
acf257 |
maybeRead s =
|
|
Packit |
acf257 |
case reads s of
|
|
Packit |
acf257 |
[(v, "")] -> Just v
|
|
Packit |
acf257 |
_ -> Nothing
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
splitFields = map (toPair '=' . trim isSpace) . splitOn ","
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
toPair c str = case break (==c) str of
|
|
Packit |
acf257 |
(left, _:right) -> (left, right)
|
|
Packit |
acf257 |
_ -> error $ "No " ++ show c ++ " in " ++ str
|
|
Packit |
acf257 |
trim f = dropWhile f . reverse . dropWhile f . reverse
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
isSubsetOf xs ys = all (`elem` ys) xs
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
-- first bits of result text from haskell.org (just to give some representative text)
|
|
Packit |
acf257 |
haskellOrgText =
|
|
Packit |
acf257 |
"\
|
|
Packit |
acf257 |
\\t<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\" dir=\"ltr\">\
|
|
Packit |
acf257 |
\\t<head>\
|
|
Packit |
acf257 |
\\t\t<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />\
|
|
Packit |
acf257 |
\\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\" />"
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
digestMatch
|
|
Packit |
acf257 |
username realm password
|
|
Packit |
acf257 |
nonce opaque
|
|
Packit |
acf257 |
method relativeURI makeAbsolute
|
|
Packit |
acf257 |
headers
|
|
Packit |
acf257 |
=
|
|
Packit |
acf257 |
common `isSubsetOf` headers && (relative `isSubsetOf` headers || absolute `isSubsetOf` headers)
|
|
Packit |
acf257 |
where
|
|
Packit |
acf257 |
common = [("username", show username), ("realm", show realm), ("nonce", show nonce),
|
|
Packit |
acf257 |
("opaque", show opaque)]
|
|
Packit |
acf257 |
md5 = show . MD5.md5 . BL.pack
|
|
Packit |
acf257 |
ha1 = md5 (username++":"++realm++":"++password)
|
|
Packit |
acf257 |
ha2 uri = md5 (method++":"++uri)
|
|
Packit |
acf257 |
response uri = md5 (ha1 ++ ":" ++ nonce ++ ":" ++ ha2 uri)
|
|
Packit |
acf257 |
mkUncommon uri hash = [("uri", show uri), ("response", show hash)]
|
|
Packit |
acf257 |
relative = mkUncommon relativeURI (response relativeURI)
|
|
Packit |
acf257 |
absoluteURI = makeAbsolute relativeURI
|
|
Packit |
acf257 |
absolute = mkUncommon absoluteURI (response absoluteURI)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
processRequest :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress)
|
|
Packit |
acf257 |
=> Httpd.Request
|
|
Packit |
acf257 |
-> IO Httpd.Response
|
|
Packit |
acf257 |
processRequest req = do
|
|
Packit |
acf257 |
case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of
|
|
Packit |
acf257 |
("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "It works."
|
|
Packit |
acf257 |
("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "It works (2)."
|
|
Packit |
acf257 |
("GET", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head."
|
|
Packit |
acf257 |
("HEAD", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head."
|
|
Packit |
acf257 |
("POST", "/basic/post") ->
|
|
Packit |
acf257 |
let typ = lookup "Content-Type" (Httpd.reqHeaders req)
|
|
Packit |
acf257 |
len = lookup "Content-Length" (Httpd.reqHeaders req)
|
|
Packit |
acf257 |
body = Httpd.reqBody req
|
|
Packit |
acf257 |
in return $ Httpd.mkResponse 200 [] (show (typ, len, body))
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
("GET", "/basic/example") ->
|
|
Packit |
acf257 |
return $ Httpd.mkResponse 200 [] haskellOrgText
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
("GET", "/auth/basic") ->
|
|
Packit |
acf257 |
case lookup "Authorization" (Httpd.reqHeaders req) of
|
|
Packit |
acf257 |
Just "Basic dGVzdDpwYXNzd29yZA==" -> return $ Httpd.mkResponse 200 [] "Here's the secret"
|
|
Packit |
acf257 |
x -> return $ Httpd.mkResponse 401 [("WWW-Authenticate", "Basic realm=\"Testing realm\"")] (show x)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
("GET", "/auth/digest") ->
|
|
Packit |
acf257 |
case lookup "Authorization" (Httpd.reqHeaders req) of
|
|
Packit |
acf257 |
Just (hasPrefix "Digest " -> Just (splitFields -> items))
|
|
Packit |
acf257 |
| digestMatch "test" "Digest testing realm" "digestpassword"
|
|
Packit |
acf257 |
"87e4" "057d"
|
|
Packit |
acf257 |
"GET" "/auth/digest" ?testUrl
|
|
Packit |
acf257 |
items
|
|
Packit |
acf257 |
-> return $ Httpd.mkResponse 200 [] "Here's the digest secret"
|
|
Packit |
acf257 |
x -> return $ Httpd.mkResponse
|
|
Packit |
acf257 |
401
|
|
Packit |
acf257 |
[("WWW-Authenticate",
|
|
Packit |
acf257 |
"Digest realm=\"Digest testing realm\", opaque=\"057d\", nonce=\"87e4\"")]
|
|
Packit |
acf257 |
(show x)
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
("GET", "/browser/example") ->
|
|
Packit |
acf257 |
return $ Httpd.mkResponse 200 [] haskellOrgText
|
|
Packit |
acf257 |
("GET", "/browser/no-cookie") ->
|
|
Packit |
acf257 |
case lookup "Cookie" (Httpd.reqHeaders req) of
|
|
Packit |
acf257 |
Nothing -> return $ Httpd.mkResponse 200 [] ""
|
|
Packit |
acf257 |
Just s -> return $ Httpd.mkResponse 500 [] s
|
|
Packit |
acf257 |
("GET", "/browser/one-cookie/1") ->
|
|
Packit |
acf257 |
return $ Httpd.mkResponse 200 [("Set-Cookie", "hello=world")] ""
|
|
Packit |
acf257 |
("GET", "/browser/one-cookie/2") ->
|
|
Packit |
acf257 |
case lookup "Cookie" (Httpd.reqHeaders req) of
|
|
Packit |
acf257 |
Just "hello=world" -> return $ Httpd.mkResponse 200 [] ""
|
|
Packit |
acf257 |
Just s -> return $ Httpd.mkResponse 500 [] s
|
|
Packit |
acf257 |
Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req)
|
|
Packit |
acf257 |
("GET", "/browser/two-cookies/1") ->
|
|
Packit |
acf257 |
return $ Httpd.mkResponse 200
|
|
Packit |
acf257 |
[("Set-Cookie", "hello=world")
|
|
Packit |
acf257 |
,("Set-Cookie", "goodbye=cruelworld")]
|
|
Packit |
acf257 |
""
|
|
Packit |
acf257 |
("GET", "/browser/two-cookies/2") ->
|
|
Packit |
acf257 |
case lookup "Cookie" (Httpd.reqHeaders req) of
|
|
Packit |
acf257 |
-- TODO generalise the cookie parsing to allow for whitespace/ordering variations
|
|
Packit |
acf257 |
Just "goodbye=cruelworld; hello=world" -> return $ Httpd.mkResponse 200 [] ""
|
|
Packit |
acf257 |
Just s -> return $ Httpd.mkResponse 500 [] s
|
|
Packit |
acf257 |
Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req)
|
|
Packit |
acf257 |
("GET", hasPrefix "/browser/redirect/relative/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) ->
|
|
Packit |
acf257 |
return $ Httpd.mkResponse n [("Location", rest)] ""
|
|
Packit |
acf257 |
("GET", hasPrefix "/browser/redirect/absolute/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) ->
|
|
Packit |
acf257 |
return $ Httpd.mkResponse n [("Location", ?testUrl rest)] ""
|
|
Packit |
acf257 |
("GET", hasPrefix "/browser/redirect/secure/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) ->
|
|
Packit |
acf257 |
return $ Httpd.mkResponse n [("Location", ?secureTestUrl rest)] ""
|
|
Packit |
acf257 |
_ -> return $ Httpd.mkResponse 500 [] "Unknown request"
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
altProcessRequest :: Httpd.Request -> IO Httpd.Response
|
|
Packit |
acf257 |
altProcessRequest req = do
|
|
Packit |
acf257 |
case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of
|
|
Packit |
acf257 |
("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "This is the alternate server."
|
|
Packit |
acf257 |
("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "This is the alternate server (2)."
|
|
Packit |
acf257 |
_ -> return $ Httpd.mkResponse 500 [] "Unknown request"
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
maybeTestGroup True name xs = testGroup name xs
|
|
Packit |
acf257 |
maybeTestGroup False name _ = testGroup name []
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
basicTests =
|
|
Packit |
acf257 |
testGroup "Basic tests"
|
|
Packit |
acf257 |
[ testCase "Basic GET request" basicGetRequest
|
|
Packit |
acf257 |
, testCase "Basic GET request (lazy bytestring)" basicGetRequestLBS
|
|
Packit |
acf257 |
, testCase "Network.HTTP example code" basicExample
|
|
Packit |
acf257 |
, testCase "Secure GET request" secureGetRequest
|
|
Packit |
acf257 |
, testCase "Basic POST request" basicPostRequest
|
|
Packit |
acf257 |
, testCase "Basic HEAD request" basicHeadRequest
|
|
Packit |
acf257 |
, testCase "URI user:pass Auth failure" userpwAuthFailure
|
|
Packit |
acf257 |
, testCase "URI user:pass Auth success" userpwAuthSuccess
|
|
Packit |
acf257 |
, testCase "Basic Auth failure" basicAuthFailure
|
|
Packit |
acf257 |
, testCase "Basic Auth success" basicAuthSuccess
|
|
Packit |
acf257 |
, testCase "UTF-8 urlEncode" utf8URLEncode
|
|
Packit |
acf257 |
, testCase "UTF-8 urlDecode" utf8URLDecode
|
|
Packit |
acf257 |
]
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
browserTests =
|
|
Packit |
acf257 |
testGroup "Browser tests"
|
|
Packit |
acf257 |
[ testGroup "Basic"
|
|
Packit |
acf257 |
[
|
|
Packit |
acf257 |
testCase "Network.Browser example code" browserExample
|
|
Packit |
acf257 |
, testCase "Two requests" browserTwoRequests
|
|
Packit |
acf257 |
]
|
|
Packit |
acf257 |
, testGroup "Secure"
|
|
Packit |
acf257 |
[
|
|
Packit |
acf257 |
testCase "Secure request" browserSecureRequest
|
|
Packit |
acf257 |
, testCase "After insecure" browserSecureRequestAfterInsecure
|
|
Packit |
acf257 |
, testCase "Redirection" browserRedirectToSecure
|
|
Packit |
acf257 |
]
|
|
Packit |
acf257 |
, testGroup "Cookies"
|
|
Packit |
acf257 |
[ testCase "No cookie header" browserNoCookie
|
|
Packit |
acf257 |
, testCase "One cookie" browserOneCookie
|
|
Packit |
acf257 |
, testCase "Two cookies" browserTwoCookies
|
|
Packit |
acf257 |
]
|
|
Packit |
acf257 |
, testGroup "Redirection"
|
|
Packit |
acf257 |
[ -- See http://en.wikipedia.org/wiki/List_of_HTTP_status_codes#3xx_Redirection
|
|
Packit |
acf257 |
-- 300 Multiple Choices: client has to handle this
|
|
Packit |
acf257 |
testCase "300" (browserReturnsRedirect 300)
|
|
Packit |
acf257 |
-- 301 Moved Permanently: should follow
|
|
Packit |
acf257 |
, testCase "301" (browserFollowsRedirect 301)
|
|
Packit |
acf257 |
-- 302 Found: should follow
|
|
Packit |
acf257 |
, testCase "302" (browserFollowsRedirect 302)
|
|
Packit |
acf257 |
-- 303 See Other: should follow (directly for GETs)
|
|
Packit |
acf257 |
, testCase "303" (browserFollowsRedirect 303)
|
|
Packit |
acf257 |
-- 304 Not Modified: maybe Browser could do something intelligent based on
|
|
Packit |
acf257 |
-- being given locally cached content and sending If-Modified-Since, but it
|
|
Packit |
acf257 |
-- doesn't at the moment
|
|
Packit |
acf257 |
, testCase "304" (browserReturnsRedirect 304)
|
|
Packit |
acf257 |
-- 305 Use Proxy: test harness doesn't have a proxy (yet)
|
|
Packit |
acf257 |
-- 306 Switch Proxy: obsolete
|
|
Packit |
acf257 |
-- 307 Temporary Redirect: should follow
|
|
Packit |
acf257 |
, testCase "307" (browserFollowsRedirect 307)
|
|
Packit |
acf257 |
-- 308 Resume Incomplete: no support for Resumable HTTP so client has to handle this
|
|
Packit |
acf257 |
, testCase "308" (browserReturnsRedirect 308)
|
|
Packit |
acf257 |
]
|
|
Packit |
acf257 |
, testGroup "Authentication"
|
|
Packit |
acf257 |
[ testCase "Basic" browserBasicAuth
|
|
Packit |
acf257 |
, testCase "Digest" browserDigestAuth
|
|
Packit |
acf257 |
]
|
|
Packit |
acf257 |
]
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
port80Tests =
|
|
Packit |
acf257 |
testGroup "Multiple servers"
|
|
Packit |
acf257 |
[ testCase "Alternate server" browserAlt
|
|
Packit |
acf257 |
, testCase "Both servers" browserBoth
|
|
Packit |
acf257 |
, testCase "Both servers (reversed)" browserBothReversed
|
|
Packit |
acf257 |
, testCase "Two requests - alternate server" browserTwoRequestsAlt
|
|
Packit |
acf257 |
, testCase "Two requests - both servers" browserTwoRequestsBoth
|
|
Packit |
acf257 |
]
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
data InetFamily = IPv4 | IPv6
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
familyToLocalhost :: InetFamily -> String
|
|
Packit |
acf257 |
familyToLocalhost IPv4 = "127.0.0.1"
|
|
Packit |
acf257 |
familyToLocalhost IPv6 = "[::1]"
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
urlRoot :: InetFamily -> String -> Int -> String
|
|
Packit |
acf257 |
urlRoot fam userpw 80 = "http://" ++ userpw ++ familyToLocalhost fam
|
|
Packit |
acf257 |
urlRoot fam userpw n = "http://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
secureRoot :: InetFamily -> String -> Int -> String
|
|
Packit |
acf257 |
secureRoot fam userpw 443 = "https://" ++ userpw ++ familyToLocalhost fam
|
|
Packit |
acf257 |
secureRoot fam userpw n = "https://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
type ServerAddress = String -> String
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
httpAddress, httpsAddress :: InetFamily -> String -> Int -> ServerAddress
|
|
Packit |
acf257 |
httpAddress fam userpw port p = urlRoot fam userpw port ++ p
|
|
Packit |
acf257 |
httpsAddress fam userpw port p = secureRoot fam userpw port ++ p
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
main :: IO ()
|
|
Packit |
acf257 |
main = do
|
|
Packit |
acf257 |
args <- getArgs
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
let servers =
|
|
Packit |
acf257 |
[ ("httpd-shed", Httpd.shed, IPv4)
|
|
Packit |
acf257 |
#ifdef WARP_TESTS
|
|
Packit |
acf257 |
, ("warp.v6", Httpd.warp True, IPv6)
|
|
Packit |
acf257 |
, ("warp.v4", Httpd.warp False, IPv4)
|
|
Packit |
acf257 |
#endif
|
|
Packit |
acf257 |
]
|
|
Packit |
acf257 |
basePortNum, altPortNum :: Int
|
|
Packit |
acf257 |
basePortNum = 5812
|
|
Packit |
acf257 |
altPortNum = 80
|
|
Packit |
acf257 |
numberedServers = zip [basePortNum..] servers
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
let setupNormalTests = do
|
|
Packit |
acf257 |
flip mapM numberedServers $ \(portNum, (serverName, server, family)) -> do
|
|
Packit |
acf257 |
let ?testUrl = httpAddress family "" portNum
|
|
Packit |
acf257 |
?userpwUrl = httpAddress family "test:password@" portNum
|
|
Packit |
acf257 |
?baduserpwUrl = httpAddress family "test:wrongpwd@" portNum
|
|
Packit |
acf257 |
?secureTestUrl = httpsAddress family "" portNum
|
|
Packit |
acf257 |
_ <- forkIO $ server portNum processRequest
|
|
Packit |
acf257 |
return $ testGroup serverName [basicTests, browserTests]
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
let setupAltTests = do
|
|
Packit |
acf257 |
let (portNum, (_, server,family)) = head numberedServers
|
|
Packit |
acf257 |
let ?testUrl = httpAddress family "" portNum
|
|
Packit |
acf257 |
?altTestUrl = httpAddress family "" altPortNum
|
|
Packit |
acf257 |
_ <- forkIO $ server altPortNum altProcessRequest
|
|
Packit |
acf257 |
return port80Tests
|
|
Packit |
acf257 |
|
|
Packit |
acf257 |
case args of
|
|
Packit |
acf257 |
["server"] -> do -- run only the harness servers for diagnostic/debug purposes
|
|
Packit |
acf257 |
-- halt on any keypress
|
|
Packit |
acf257 |
_ <- setupNormalTests
|
|
Packit |
acf257 |
_ <- setupAltTests
|
|
Packit |
acf257 |
_ <- getChar
|
|
Packit |
acf257 |
return ()
|
|
Packit |
acf257 |
("--withport80":args) -> do
|
|
Packit |
acf257 |
normalTests <- setupNormalTests
|
|
Packit |
acf257 |
altTests <- setupAltTests
|
|
Packit |
acf257 |
_ <- threadDelay 1000000 -- Give the server time to start :-(
|
|
Packit |
acf257 |
defaultMainWithArgs (UnitTests.unitTests ++ normalTests ++ [altTests]) args
|
|
Packit |
acf257 |
args -> do -- run the test harness as normal
|
|
Packit |
acf257 |
normalTests <- setupNormalTests
|
|
Packit |
acf257 |
_ <- threadDelay 1000000 -- Give the server time to start :-(
|
|
Packit |
acf257 |
defaultMainWithArgs (UnitTests.unitTests ++ normalTests) args
|