{-# LANGUAGE ImplicitParams, ViewPatterns, NoMonomorphismRestriction, CPP #-}

import Control.Concurrent

import Control.Applicative ((<$))

import Control.Concurrent (threadDelay)

import Control.Exception (try)

import qualified Data.ByteString.Lazy.Char8 as BL (pack)

import Data.Char (isSpace)

import qualified Data.Digest.Pure.MD5 as MD5 (md5)

import Data.List.Split (splitOn)

import Data.Maybe (fromJust)

import System.IO.Error (userError)

import qualified Httpd

import qualified UnitTests

import Network.Browser

import Network.HTTP

import Network.HTTP.Base

import Network.HTTP.Auth

import Network.HTTP.Headers

import Network.Stream (Result)

import Network.URI (uriPath, parseURI)

import System.Environment (getArgs)

import System.Info (os)

import System.IO (getChar)

import Test.Framework (defaultMainWithArgs, testGroup)

import Test.Framework.Providers.HUnit

import Test.HUnit

basicGetRequest :: (?testUrl :: ServerAddress) => Assertion

basicGetRequest = do

  response <- simpleHTTP (getRequest (?testUrl "/basic/get"))

  code <- getResponseCode response

  assertEqual "HTTP status code" (2, 0, 0) code

  body <- getResponseBody response

  assertEqual "Receiving expected response" "It works." body

basicGetRequestLBS :: (?testUrl :: ServerAddress) => Assertion

basicGetRequestLBS = do

  response <- simpleHTTP (mkRequest GET (fromJust (parseURI (?testUrl ("/basic/get")))))

  code <- getResponseCode response

  assertEqual "HTTP status code" (2, 0, 0) code

  body <- getResponseBody response

  assertEqual "Receiving expected response" (BL.pack "It works.") body

basicHeadRequest :: (?testUrl :: ServerAddress) => Assertion

basicHeadRequest = do

  response <- simpleHTTP (headRequest (?testUrl "/basic/head"))

  code <- getResponseCode response

  assertEqual "HTTP status code" (2, 0, 0) code

  body <- getResponseBody response

  -- the body should be empty, since this is a HEAD request

  assertEqual "Receiving expected response" "" body

basicExample :: (?testUrl :: ServerAddress) => Assertion

basicExample = do

  result <-

    -- sample code from Network.HTTP haddock, with URL changed

    -- Note there's also a copy of the example in the .cabal file

    simpleHTTP (getRequest (?testUrl "/basic/example")) >>= fmap (take 100) . getResponseBody

  assertEqual "Receiving expected response" (take 100 haskellOrgText) result

secureGetRequest :: (?secureTestUrl :: ServerAddress) => Assertion

secureGetRequest = do

  response <- try $ simpleHTTP (getRequest (?secureTestUrl "/anything"))

  assertEqual "Threw expected exception"

              (Left (userError "https not supported"))

              (fmap show response) -- fmap show because Response isn't in Eq

basicPostRequest :: (?testUrl :: ServerAddress) => Assertion

basicPostRequest = do

  let sendBody = "body"

  response <- simpleHTTP $ postRequestWithBody (?testUrl "/basic/post")

                                               "text/plain"

                                               sendBody

  code <- getResponseCode response

  assertEqual "HTTP status code" (2, 0, 0) code

  body <- getResponseBody response

  assertEqual "Receiving expected response"

              (show (Just "text/plain", Just "4", sendBody))

              body

userpwAuthFailure :: (?baduserpwUrl :: ServerAddress) => Assertion

userpwAuthFailure = do

  response <- simpleHTTP (getRequest (?baduserpwUrl "/auth/basic"))

  code <- getResponseCode response

  body <- getResponseBody response

  assertEqual "HTTP status code" ((4, 0, 1),

                "Just \"Basic dGVzdDp3cm9uZ3B3ZA==\"") (code, body)

  -- in case of 401, the server returns the contents of the Authz header

userpwAuthSuccess :: (?userpwUrl :: ServerAddress) => Assertion

userpwAuthSuccess = do

  response <- simpleHTTP (getRequest (?userpwUrl "/auth/basic"))

  code <- getResponseCode response

  body <- getResponseBody response

  assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body)

basicAuthFailure :: (?testUrl :: ServerAddress) => Assertion

basicAuthFailure = do

  response <- simpleHTTP (getRequest (?testUrl "/auth/basic"))

  code <- getResponseCode response

  body <- getResponseBody response

  assertEqual "HTTP status code" ((4, 0, 1), "Nothing") (code, body)

credentialsBasic :: (?testUrl :: ServerAddress) => Authority

credentialsBasic = AuthBasic "Testing realm" "test" "password"

                             (fromJust . parseURI . ?testUrl $ "/auth/basic")

basicAuthSuccess :: (?testUrl :: ServerAddress) => Assertion

basicAuthSuccess = do

  let req = getRequest (?testUrl "/auth/basic")

  let authString = withAuthority credentialsBasic req

  let reqWithAuth = req { rqHeaders = mkHeader HdrAuthorization authString:rqHeaders req }

  response <- simpleHTTP reqWithAuth

  code <- getResponseCode response

  body <- getResponseBody response

  assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body)

utf8URLEncode :: Assertion

utf8URLEncode = do

  assertEqual "Normal URL" (urlEncode "what-a_mess.com") "what-a_mess.com"

  assertEqual "Chinese URL" (urlEncode "好") "%E5%A5%BD"

  assertEqual "Russian URL" (urlEncode "ололо") "%D0%BE%D0%BB%D0%BE%D0%BB%D0%BE"

utf8URLDecode :: Assertion

utf8URLDecode = do

  assertEqual "Normal URL" (urlDecode "what-a_mess.com") "what-a_mess.com"

  assertEqual "Mixed URL" (urlDecode "UTFin进入-wow") "UTFin进入-wow"

  assertEqual "Chinese URL" (urlDecode "%E5%A5%BD") "好"

  assertEqual "Russian URL" (urlDecode "%D0%BE%D0%BB%D0%BE%D0%BB%D0%BE") "ололо"

browserExample :: (?testUrl :: ServerAddress) => Assertion

browserExample = do

  result <-

    -- sample code from Network.Browser haddock, with URL changed

    -- Note there's also a copy of the example in the .cabal file

    do 

      (_, rsp)

         <- Network.Browser.browse $ do

               setAllowRedirects True -- handle HTTP redirects

               request $ getRequest (?testUrl "/browser/example")

      return (take 100 (rspBody rsp))

  assertEqual "Receiving expected response" (take 100 haskellOrgText) result

-- A vanilla HTTP request using Browser shouln't send a cookie header

browserNoCookie :: (?testUrl :: ServerAddress) => Assertion

browserNoCookie = do

  (_, response) <- browse $ do

    setOutHandler (const $ return ())

    request $ getRequest (?testUrl "/browser/no-cookie")

  let code = rspCode response

  assertEqual "HTTP status code" (2, 0, 0) code

-- Regression test

--  * Browser sends vanilla request to server

--  * Server sets one cookie "hello=world"

--  * Browser sends a second request

--

-- Expected: Server gets single cookie with "hello=world"

-- Actual:   Server gets 3 extra cookies, which are actually cookie attributes:

--           "$Version=0;hello=world;$Domain=localhost:8080\r"

browserOneCookie :: (?testUrl :: ServerAddress) => Assertion

browserOneCookie = do

  (_, response) <- browse $ do

    setOutHandler (const $ return ())

    -- This first requests returns a single Set-Cookie: hello=world

    _ <- request $ getRequest (?testUrl "/browser/one-cookie/1")

    -- This second request should send a single Cookie: hello=world

    request $ getRequest (?testUrl "/browser/one-cookie/2")

  let body = rspBody response

  assertEqual "Receiving expected response" "" body

  let code = rspCode response

  assertEqual "HTTP status code" (2, 0, 0) code

browserTwoCookies :: (?testUrl :: ServerAddress) => Assertion

browserTwoCookies = do

  (_, response) <- browse $ do

    setOutHandler (const $ return ())

    -- This first request returns two cookies

    _ <- request $ getRequest (?testUrl "/browser/two-cookies/1")

    -- This second request should send them back

    request $ getRequest (?testUrl "/browser/two-cookies/2")

  let body = rspBody response

  assertEqual "Receiving expected response" "" body

  let code = rspCode response

  assertEqual "HTTP status code" (2, 0, 0) code

browserFollowsRedirect :: (?testUrl :: ServerAddress) => Int -> Assertion

browserFollowsRedirect n = do

  (_, response) <- browse $ do

    setOutHandler (const $ return ())

    request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get")

  assertEqual "Receiving expected response from server"

              ((2, 0, 0), "It works.")

              (rspCode response, rspBody response)

browserReturnsRedirect :: (?testUrl :: ServerAddress) => Int -> Assertion

browserReturnsRedirect n = do

  (_, response) <- browse $ do

    setOutHandler (const $ return ())

    request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get")

  assertEqual "Receiving expected response from server"

              ((n `div` 100, n `mod` 100 `div` 10, n `mod` 10), "")

              (rspCode response, rspBody response)

authGenBasic _ "Testing realm" = return $ Just ("test", "password")

authGenBasic _ realm = fail $ "Unexpected realm " ++ realm

browserBasicAuth :: (?testUrl :: ServerAddress) => Assertion

browserBasicAuth = do

  (_, response) <- browse $ do

    setOutHandler (const $ return ())

    setAuthorityGen authGenBasic

    request $ getRequest (?testUrl "/auth/basic")

  assertEqual "Receiving expected response from server"

              ((2, 0, 0), "Here's the secret")

              (rspCode response, rspBody response)

authGenDigest _ "Digest testing realm" = return $ Just ("test", "digestpassword")

authGenDigest _ realm = fail $ "Unexpected digest realm " ++ realm

browserDigestAuth :: (?testUrl :: ServerAddress) => Assertion

browserDigestAuth = do

  (_, response) <- browse $ do

    setOutHandler (const $ return ())

    setAuthorityGen authGenDigest

    request $ getRequest (?testUrl "/auth/digest")

  assertEqual "Receiving expected response from server"

              ((2, 0, 0), "Here's the digest secret")

              (rspCode response, rspBody response)

browserAlt :: (?altTestUrl :: ServerAddress) => Assertion

browserAlt = do

  (response) <- browse $ do

    setOutHandler (const $ return ())

    (_, response1) <- request $ getRequest (?altTestUrl "/basic/get")

    return response1

  assertEqual "Receiving expected response from alternate server"

              ((2, 0, 0), "This is the alternate server.")

              (rspCode response, rspBody response)

-- test that requests to multiple servers on the same host

-- don't get confused with each other

browserBoth :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion

browserBoth = do

  (response1, response2) <- browse $ do

    setOutHandler (const $ return ())

    (_, response1) <- request $ getRequest (?testUrl "/basic/get")

    (_, response2) <- request $ getRequest (?altTestUrl "/basic/get")

    return (response1, response2)

  assertEqual "Receiving expected response from main server"

              ((2, 0, 0), "It works.")

              (rspCode response1, rspBody response1)

  assertEqual "Receiving expected response from alternate server"

              ((2, 0, 0), "This is the alternate server.")

              (rspCode response2, rspBody response2)

-- test that requests to multiple servers on the same host

-- don't get confused with each other

browserBothReversed :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion

browserBothReversed = do

  (response1, response2) <- browse $ do

    setOutHandler (const $ return ())

    (_, response2) <- request $ getRequest (?altTestUrl "/basic/get")

    (_, response1) <- request $ getRequest (?testUrl "/basic/get")

    return (response1, response2)

  assertEqual "Receiving expected response from main server"

              ((2, 0, 0), "It works.")

              (rspCode response1, rspBody response1)

  assertEqual "Receiving expected response from alternate server"

              ((2, 0, 0), "This is the alternate server.")

              (rspCode response2, rspBody response2)

browserSecureRequest :: (?secureTestUrl :: ServerAddress) => Assertion

browserSecureRequest = do

  res <- try $ browse $ do

    setOutHandler (const $ return ())

    request $ getRequest (?secureTestUrl "/anything")

  assertEqual "Threw expected exception"

              (Left (userError "https not supported"))

              (fmap show res) -- fmap show because Response isn't in Eq

-- in case it tries to reuse the connection

browserSecureRequestAfterInsecure :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Assertion

browserSecureRequestAfterInsecure = do

  res <- try $ browse $ do

    setOutHandler (const $ return ())

    request $ getRequest (?testUrl "/basic/get")

    request $ getRequest (?secureTestUrl "/anything")

  assertEqual "Threw expected exception"

              (Left (userError "https not supported"))

              (fmap show res) -- fmap show because Response isn't in Eq

browserRedirectToSecure :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Assertion

browserRedirectToSecure = do

  res <- try $ browse $ do

    setOutHandler (const $ return ())

    setErrHandler fail

    request $ getRequest (?testUrl "/browser/redirect/secure/301/anything")

  assertEqual "Threw expected exception"

              (Left (userError $ "Unable to handle redirect, unsupported scheme: " ++ ?secureTestUrl "/anything"))

              (fmap show res) -- fmap show because Response isn't in Eq

browserTwoRequests :: (?testUrl :: ServerAddress) => Assertion

browserTwoRequests = do

  (response1, response2) <- browse $ do

    setOutHandler (const $ return ())

    (_, response1) <- request $ getRequest (?testUrl "/basic/get")

    (_, response2) <- request $ getRequest (?testUrl "/basic/get2")

    return (response1, response2)

  assertEqual "Receiving expected response from main server"

              ((2, 0, 0), "It works.")

              (rspCode response1, rspBody response1)

  assertEqual "Receiving expected response from main server"

              ((2, 0, 0), "It works (2).")

              (rspCode response2, rspBody response2)

browserTwoRequestsAlt :: (?altTestUrl :: ServerAddress) => Assertion

browserTwoRequestsAlt = do

  (response1, response2) <- browse $ do

    setOutHandler (const $ return ())

    (_, response1) <- request $ getRequest (?altTestUrl "/basic/get")

    (_, response2) <- request $ getRequest (?altTestUrl "/basic/get2")

    return (response1, response2)

  assertEqual "Receiving expected response from alternate server"

              ((2, 0, 0), "This is the alternate server.")

              (rspCode response1, rspBody response1)

  assertEqual "Receiving expected response from alternate server"

              ((2, 0, 0), "This is the alternate server (2).")

              (rspCode response2, rspBody response2)

browserTwoRequestsBoth :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion

browserTwoRequestsBoth = do

  (response1, response2, response3, response4) <- browse $ do

    setOutHandler (const $ return ())

    (_, response1) <- request $ getRequest (?testUrl "/basic/get")

    (_, response2) <- request $ getRequest (?altTestUrl "/basic/get")

    (_, response3) <- request $ getRequest (?testUrl "/basic/get2")

    (_, response4) <- request $ getRequest (?altTestUrl "/basic/get2")

    return (response1, response2, response3, response4)

  assertEqual "Receiving expected response from main server"

              ((2, 0, 0), "It works.")

              (rspCode response1, rspBody response1)

  assertEqual "Receiving expected response from alternate server"

              ((2, 0, 0), "This is the alternate server.")

              (rspCode response2, rspBody response2)

  assertEqual "Receiving expected response from main server"

              ((2, 0, 0), "It works (2).")

              (rspCode response3, rspBody response3)

  assertEqual "Receiving expected response from alternate server"

              ((2, 0, 0), "This is the alternate server (2).")

              (rspCode response4, rspBody response4)

hasPrefix :: String -> String -> Maybe String

hasPrefix [] ys = Just ys

hasPrefix (x:xs) (y:ys) | x == y = hasPrefix xs ys

hasPrefix _ _ = Nothing

maybeRead :: Read a => String -> Maybe a

maybeRead s =

   case reads s of

     [(v, "")] -> Just v

     _ -> Nothing

splitFields = map (toPair '=' . trim isSpace) . splitOn ","

toPair c str = case break (==c) str of

                 (left, _:right) -> (left, right)

                 _ -> error $ "No " ++ show c ++ " in " ++ str

trim f = dropWhile f . reverse . dropWhile f . reverse

isSubsetOf xs ys = all (`elem` ys) xs

-- first bits of result text from haskell.org (just to give some representative text)

haskellOrgText =

  "\

\\t<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\" dir=\"ltr\">\

\\t<head>\

\\t\t<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />\

\\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\" />"

digestMatch

  username realm password

  nonce opaque

  method relativeURI makeAbsolute

  headers

  =

  common `isSubsetOf` headers && (relative `isSubsetOf` headers || absolute `isSubsetOf` headers)

 where

   common = [("username", show username), ("realm", show realm), ("nonce", show nonce),

             ("opaque", show opaque)]

   md5 = show . MD5.md5 . BL.pack

   ha1 = md5 (username++":"++realm++":"++password)

   ha2 uri = md5 (method++":"++uri)

   response uri = md5 (ha1 ++ ":" ++ nonce ++ ":" ++ ha2 uri)

   mkUncommon uri hash = [("uri", show uri), ("response", show hash)]

   relative = mkUncommon relativeURI (response relativeURI)

   absoluteURI = makeAbsolute relativeURI

   absolute = mkUncommon absoluteURI (response absoluteURI)

processRequest :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress)

               => Httpd.Request

               -> IO Httpd.Response

processRequest req = do

  case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of 

    ("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "It works."

    ("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "It works (2)."

    ("GET", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head."

    ("HEAD", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head."

    ("POST", "/basic/post") ->

        let typ = lookup "Content-Type" (Httpd.reqHeaders req)

            len = lookup "Content-Length" (Httpd.reqHeaders req)

            body = Httpd.reqBody req

        in return $ Httpd.mkResponse 200 [] (show (typ, len, body))

    ("GET", "/basic/example") ->

      return $ Httpd.mkResponse 200 [] haskellOrgText

    ("GET", "/auth/basic") ->

      case lookup "Authorization" (Httpd.reqHeaders req) of

        Just "Basic dGVzdDpwYXNzd29yZA==" -> return $ Httpd.mkResponse 200 [] "Here's the secret"

        x -> return $ Httpd.mkResponse 401 [("WWW-Authenticate", "Basic realm=\"Testing realm\"")] (show x)

    ("GET", "/auth/digest") ->

      case lookup "Authorization" (Httpd.reqHeaders req) of

        Just (hasPrefix "Digest " -> Just (splitFields -> items))

          | digestMatch "test" "Digest testing realm" "digestpassword"

                        "87e4" "057d"

                        "GET" "/auth/digest" ?testUrl

                        items

          -> return $ Httpd.mkResponse 200 [] "Here's the digest secret"

        x -> return $ Httpd.mkResponse

                        401

                        [("WWW-Authenticate",

                          "Digest realm=\"Digest testing realm\", opaque=\"057d\", nonce=\"87e4\"")]

                        (show x)

    ("GET", "/browser/example") ->

      return $ Httpd.mkResponse 200 [] haskellOrgText

    ("GET", "/browser/no-cookie") ->

      case lookup "Cookie" (Httpd.reqHeaders req) of

        Nothing -> return $ Httpd.mkResponse 200 [] ""

        Just s  -> return $ Httpd.mkResponse 500 [] s

    ("GET", "/browser/one-cookie/1") ->

      return $ Httpd.mkResponse 200 [("Set-Cookie", "hello=world")] ""

    ("GET", "/browser/one-cookie/2") ->

      case lookup "Cookie" (Httpd.reqHeaders req) of

        Just "hello=world" -> return $ Httpd.mkResponse 200 [] ""

        Just s               -> return $ Httpd.mkResponse 500 [] s

        Nothing              -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req)

    ("GET", "/browser/two-cookies/1") ->

      return $ Httpd.mkResponse 200

                              [("Set-Cookie", "hello=world")

                              ,("Set-Cookie", "goodbye=cruelworld")]

                              ""

    ("GET", "/browser/two-cookies/2") ->

      case lookup "Cookie" (Httpd.reqHeaders req) of

        -- TODO generalise the cookie parsing to allow for whitespace/ordering variations

        Just "goodbye=cruelworld; hello=world" -> return $ Httpd.mkResponse 200 [] ""

        Just s               -> return $ Httpd.mkResponse 500 [] s

        Nothing              -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req)

    ("GET", hasPrefix "/browser/redirect/relative/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) ->

      return $ Httpd.mkResponse n [("Location", rest)] ""

    ("GET", hasPrefix "/browser/redirect/absolute/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) ->

      return $ Httpd.mkResponse n [("Location", ?testUrl rest)] ""

    ("GET", hasPrefix "/browser/redirect/secure/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) ->

      return $ Httpd.mkResponse n [("Location", ?secureTestUrl rest)] ""

    _                     -> return $ Httpd.mkResponse 500 [] "Unknown request"

altProcessRequest :: Httpd.Request -> IO Httpd.Response

altProcessRequest req = do

  case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of 

    ("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "This is the alternate server."

    ("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "This is the alternate server (2)."

    _                     -> return $ Httpd.mkResponse 500 [] "Unknown request"

maybeTestGroup True name xs = testGroup name xs

maybeTestGroup False name _ = testGroup name []

basicTests =

    testGroup "Basic tests"

    [ testCase "Basic GET request" basicGetRequest

    , testCase "Basic GET request (lazy bytestring)" basicGetRequestLBS

    , testCase "Network.HTTP example code" basicExample

    , testCase "Secure GET request" secureGetRequest

    , testCase "Basic POST request" basicPostRequest

    , testCase "Basic HEAD request" basicHeadRequest

    , testCase "URI user:pass Auth failure" userpwAuthFailure

    , testCase "URI user:pass Auth success" userpwAuthSuccess

    , testCase "Basic Auth failure" basicAuthFailure

    , testCase "Basic Auth success" basicAuthSuccess

    , testCase "UTF-8 urlEncode" utf8URLEncode

    , testCase "UTF-8 urlDecode" utf8URLDecode

    ]

browserTests =

    testGroup "Browser tests"

    [ testGroup "Basic"

      [

        testCase "Network.Browser example code" browserExample

      , testCase "Two requests" browserTwoRequests

      ]

    , testGroup "Secure"

      [

        testCase "Secure request" browserSecureRequest

      , testCase "After insecure" browserSecureRequestAfterInsecure

      , testCase "Redirection" browserRedirectToSecure

      ]

    , testGroup "Cookies"

      [ testCase "No cookie header" browserNoCookie

      , testCase "One cookie" browserOneCookie

      , testCase "Two cookies" browserTwoCookies

      ]

    , testGroup "Redirection"

      [ -- See http://en.wikipedia.org/wiki/List_of_HTTP_status_codes#3xx_Redirection

        -- 300 Multiple Choices: client has to handle this

        testCase "300" (browserReturnsRedirect 300)

        -- 301 Moved Permanently: should follow

      , testCase "301" (browserFollowsRedirect 301)

        -- 302 Found: should follow

      , testCase "302" (browserFollowsRedirect 302)

        -- 303 See Other: should follow (directly for GETs)

      , testCase "303" (browserFollowsRedirect 303)

        -- 304 Not Modified: maybe Browser could do something intelligent based on

        -- being given locally cached content and sending If-Modified-Since, but it

        -- doesn't at the moment

      , testCase "304" (browserReturnsRedirect 304)

      -- 305 Use Proxy: test harness doesn't have a proxy (yet)

      -- 306 Switch Proxy: obsolete

      -- 307 Temporary Redirect: should follow

      , testCase "307" (browserFollowsRedirect 307)

      -- 308 Resume Incomplete: no support for Resumable HTTP so client has to handle this

      , testCase "308" (browserReturnsRedirect 308)

      ]

    , testGroup "Authentication"

      [ testCase "Basic" browserBasicAuth

      , testCase "Digest" browserDigestAuth

      ]

    ]

port80Tests =

    testGroup "Multiple servers"

    [ testCase "Alternate server" browserAlt

    , testCase "Both servers" browserBoth

    , testCase "Both servers (reversed)" browserBothReversed

    , testCase "Two requests - alternate server" browserTwoRequestsAlt

    , testCase "Two requests - both servers" browserTwoRequestsBoth

    ]

data InetFamily = IPv4 | IPv6

familyToLocalhost :: InetFamily -> String

familyToLocalhost IPv4 = "127.0.0.1"

familyToLocalhost IPv6 = "[::1]"

urlRoot :: InetFamily -> String -> Int -> String

urlRoot fam userpw 80 = "http://" ++ userpw ++ familyToLocalhost fam

urlRoot fam userpw n = "http://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n

secureRoot :: InetFamily -> String -> Int -> String

secureRoot fam userpw 443 = "https://" ++ userpw ++ familyToLocalhost fam

secureRoot fam userpw n = "https://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n

type ServerAddress = String -> String

httpAddress, httpsAddress :: InetFamily -> String -> Int -> ServerAddress

httpAddress fam userpw port p = urlRoot fam userpw port ++ p

httpsAddress fam userpw port p = secureRoot fam userpw port ++ p

main :: IO ()

main = do

  args <- getArgs

  let servers =

          [ ("httpd-shed", Httpd.shed, IPv4)

#ifdef WARP_TESTS

          , ("warp.v6", Httpd.warp True, IPv6)

          , ("warp.v4", Httpd.warp False, IPv4)

#endif

          ]

      basePortNum, altPortNum :: Int

      basePortNum = 5812

      altPortNum = 80

      numberedServers = zip [basePortNum..] servers

  let setupNormalTests = do

      flip mapM numberedServers $ \(portNum, (serverName, server, family)) -> do

         let ?testUrl = httpAddress family "" portNum

             ?userpwUrl = httpAddress family "test:password@" portNum

             ?baduserpwUrl = httpAddress family "test:wrongpwd@" portNum

             ?secureTestUrl = httpsAddress family "" portNum

         _ <- forkIO $ server portNum processRequest

         return $ testGroup serverName [basicTests, browserTests]

  let setupAltTests = do

      let (portNum, (_, server,family)) = head numberedServers

      let ?testUrl = httpAddress family "" portNum

          ?altTestUrl = httpAddress family "" altPortNum

      _ <- forkIO $ server altPortNum altProcessRequest

      return port80Tests

  case args of

     ["server"] -> do -- run only the harness servers for diagnostic/debug purposes

                      -- halt on any keypress

        _ <- setupNormalTests

        _ <- setupAltTests

        _ <- getChar

        return ()

     ("--withport80":args) -> do

        normalTests <- setupNormalTests

        altTests <- setupAltTests

        _ <- threadDelay 1000000 -- Give the server time to start :-(

        defaultMainWithArgs (UnitTests.unitTests ++ normalTests ++ [altTests]) args

     args -> do -- run the test harness as normal

        normalTests <- setupNormalTests

        _ <- threadDelay 1000000 -- Give the server time to start :-(

        defaultMainWithArgs (UnitTests.unitTests ++ normalTests) args