1{-# LANGUAGE BangPatterns #-} 2{-# LANGUAGE CPP #-} 3{-# LANGUAGE OverloadedStrings #-} 4{-# LANGUAGE RankNTypes #-} 5{-# LANGUAGE ScopedTypeVariables #-} 6 7module Test.Blackbox 8 ( tests 9 , haTests 10 , ssltests 11 , startTestServers 12 ) where 13 14-------------------------------------------------------------------------------- 15import Control.Applicative ((<$>)) 16import Control.Arrow (first) 17import Control.Concurrent (MVar, ThreadId, forkIO, forkIOWithUnmask, killThread, newEmptyMVar, putMVar, takeMVar, threadDelay, tryPutMVar) 18import Control.Exception (bracket, bracketOnError, finally, mask_) 19import Control.Monad (forM_, forever, void, when) 20import qualified Data.ByteString.Base16 as B16 21import Data.ByteString.Builder (byteString) 22import Data.ByteString.Char8 (ByteString) 23import qualified Data.ByteString.Char8 as S 24import qualified Data.ByteString.Lazy.Char8 as L 25import Data.CaseInsensitive (CI) 26import qualified Data.CaseInsensitive as CI 27import Data.List (sort) 28import Data.Monoid (Monoid (mconcat, mempty)) 29import qualified Network.Http.Client as HTTP 30import qualified Network.Http.Types as HTTP 31import qualified Network.Socket as N 32import qualified Network.Socket.ByteString as NB 33import Prelude (Bool (..), Eq (..), IO, Int, Maybe (..), Show (..), String, concat, concatMap, const, dropWhile, elem, flip, fromIntegral, fst, head, id, map, mapM_, maybe, min, not, null, otherwise, putStrLn, replicate, return, reverse, uncurry, ($), ($!), (*), (++), (.), (^)) 34import qualified Prelude 35------------------------------------------------------------------------------ 36#ifdef OPENSSL 37import qualified OpenSSL.Session as SSL 38#endif 39import qualified System.IO.Streams as Streams 40import System.Timeout (timeout) 41import Test.Framework (Test, TestOptions' (topt_maximum_generated_tests), plusTestOptions) 42import Test.Framework.Providers.HUnit (testCase) 43import Test.Framework.Providers.QuickCheck2 (testProperty) 44import Test.HUnit hiding (Test, path) 45import Test.QuickCheck (Arbitrary (arbitrary)) 46import Test.QuickCheck.Monadic (forAllM, monadicIO) 47import qualified Test.QuickCheck.Monadic as QC 48import qualified Test.QuickCheck.Property as QC 49------------------------------------------------------------------------------ 50import Snap.Internal.Debug (debug) 51import Snap.Internal.Http.Server.Session (httpAcceptLoop, snapToServerHandler) 52import qualified Snap.Internal.Http.Server.Socket as Sock 53import qualified Snap.Internal.Http.Server.TLS as TLS 54import qualified Snap.Internal.Http.Server.Types as Types 55import Snap.Test.Common (ditchHeaders, eatException, expectExceptionBeforeTimeout, recvAll, timeoutIn, withSock) 56import Test.Common.Rot13 (rot13) 57import Test.Common.TestHandler (testHandler) 58 59 60------------------------------------------------------------------------------ 61tests :: Int -> [Test] 62tests port = map (\f -> f False port "") testFunctions 63 64ssltests :: Maybe Int -> [Test] 65ssltests = maybe [] httpsTests 66 where httpsTests port = map (\f -> f True port sslname) testFunctions 67 sslname = "ssl/" 68 69haTests :: Int -> [Test] 70haTests port = [ testHaProxy port 71 , testHaProxyLocal port 72 , testHaProxyFileServe port 73 ] 74 75testFunctions :: [Bool -> Int -> String -> Test] 76testFunctions = [ testPong 77-- FIXME: waiting on http-enumerator patch for HEAD behaviour 78-- , testHeadPong 79 , testEcho 80 , testRot13 81 , testSlowLoris 82 , testBlockingRead 83 , testBigResponse 84 , testPartial 85 , testFileUpload 86 , testTimeoutTickle 87 , testHasDateHeader 88 , testServerHeader 89 , testFileServe 90 , testTimelyRedirect 91 , testChunkedHead 92 ] 93 94------------------------------------------------------------------------------ 95startServer :: Types.ServerConfig hookState 96 -> IO a 97 -> (a -> N.Socket) 98 -> (a -> Types.AcceptFunc) 99 -> IO (ThreadId, Int, MVar ()) 100startServer config bind projSock afunc = 101 bracketOnError bind (N.close . projSock) forkServer 102 where 103 forkServer a = do 104 mv <- newEmptyMVar 105 port <- fromIntegral <$> N.socketPort (projSock a) 106 tid <- forkIO $ 107 eatException $ 108 (httpAcceptLoop (snapToServerHandler testHandler) 109 config 110 (afunc a) 111 `finally` putMVar mv ()) 112 return (tid, port, mv) 113 114 115------------------------------------------------------------------------------ 116-- | Returns the thread the server is running in as well as the port it is 117-- listening on. 118data TestServerType = NormalTest | ProxyTest | SSLTest 119 deriving (Show) 120 121startTestSocketServer :: TestServerType -> IO (ThreadId, Int, MVar ()) 122startTestSocketServer serverType = do 123 putStrLn $ "Blackbox: starting " ++ show serverType ++ " server" 124 case serverType of 125 NormalTest -> startServer emptyServerConfig bindSock id Sock.httpAcceptFunc 126 ProxyTest -> startServer emptyServerConfig bindSock id Sock.haProxyAcceptFunc 127 SSLTest -> startServer emptyServerConfig bindSSL fst 128 (uncurry TLS.httpsAcceptFunc) 129 where 130#if MIN_VERSION_network(2,7,0) 131 anyport = N.defaultPort 132#else 133 anyport = N.aNY_PORT 134#endif 135 136 bindSSL = do 137 sockCtx <- TLS.bindHttps "127.0.0.1" 138 (fromIntegral anyport) 139 "test/cert.pem" 140 False 141 "test/key.pem" 142#ifdef OPENSSL 143 -- Set client code not to verify 144 HTTP.modifyContextSSL $ \ctx -> do 145 SSL.contextSetVerificationMode ctx SSL.VerifyNone 146 return ctx 147#endif 148 return sockCtx 149 150 bindSock = Sock.bindSocket "127.0.0.1" (fromIntegral anyport) 151 152 logAccess !_ !_ !_ = return () 153 logError !_ = return () 154 onStart !_ = return () 155 onParse !_ !_ = return () 156 onUserHandlerFinished !_ !_ !_ = return () 157 onDataFinished !_ !_ !_ = return () 158 onExceptionHook !_ !_ = return () 159 onEscape !_ = return () 160 161 emptyServerConfig = Types.ServerConfig logAccess 162 logError 163 onStart 164 onParse 165 onUserHandlerFinished 166 onDataFinished 167 onExceptionHook 168 onEscape 169 "localhost" 170 6 171 False 172 1 173 174 175------------------------------------------------------------------------------ 176waitabit :: IO () 177waitabit = threadDelay $ 2*seconds 178 179 180------------------------------------------------------------------------------ 181seconds :: Int 182seconds = (10::Int) ^ (6::Int) 183 184 185------------------------------------------------------------------------------ 186fetch :: ByteString -> IO ByteString 187fetch url = HTTP.get url HTTP.concatHandler' 188 189 190------------------------------------------------------------------------------ 191fetchWithHeaders :: ByteString 192 -> IO (ByteString, [(CI ByteString, ByteString)]) 193fetchWithHeaders url = HTTP.get url h 194 where 195 h resp is = do 196 let hdrs = map (first CI.mk) $ HTTP.retrieveHeaders $ HTTP.getHeaders resp 197 body <- HTTP.concatHandler' resp is 198 return (body, hdrs) 199 200 201------------------------------------------------------------------------------ 202slowTestOptions :: Bool -> TestOptions' Maybe 203slowTestOptions ssl = 204 if ssl 205 then mempty { topt_maximum_generated_tests = Just 75 } 206 else mempty { topt_maximum_generated_tests = Just 300 } 207 208 209------------------------------------------------------------------------------ 210-- FIXME: waiting on http-enumerator patch for HEAD behaviour 211-- headPong :: Bool -> Int -> IO ByteString 212-- headPong ssl port = do 213-- let uri = (if ssl then "https" else "http") 214-- ++ "://127.0.0.1:" ++ show port ++ "/echo" 215 216-- req0 <- HTTP.parseUrl uri 217 218-- let req = req0 { HTTP.method = "HEAD" } 219-- rsp <- HTTP.httpLbs req 220-- return $ S.concat $ L.toChunks $ HTTP.responseBody rsp 221 222 223------------------------------------------------------------------------------ 224-- FIXME: waiting on http-enumerator patch for HEAD behaviour 225-- testHeadPong :: Bool -> Int -> String -> Test 226-- testHeadPong ssl port name = testCase (name ++ "blackbox/pong/HEAD") $ do 227-- doc <- headPong ssl port 228-- assertEqual "pong HEAD response" "" doc 229 230 231------------------------------------------------------------------------------ 232-- TODO: doesn't work w/ ssl 233testBlockingRead :: Bool -> Int -> String -> Test 234testBlockingRead ssl port name = 235 testCase (name ++ "blackbox/testBlockingRead") $ 236 if ssl then return () else runIt 237 238 where 239 runIt = withSock port $ \sock -> do 240 m <- timeout (60*seconds) $ go sock 241 maybe (assertFailure "timeout") 242 (const $ return ()) 243 m 244 245 go sock = do 246 NB.sendAll sock "GET /" 247 waitabit 248 NB.sendAll sock "pong HTTP/1.1\r\n" 249 NB.sendAll sock "Host: 127.0.0.1\r\n" 250 NB.sendAll sock "Content-Length: 0\r\n" 251 NB.sendAll sock "Connection: close\r\n\r\n" 252 253 resp <- recvAll sock 254 255 let s = head $ ditchHeaders $ S.lines resp 256 257 assertEqual "pong response" "PONG" s 258 259 260------------------------------------------------------------------------------ 261-- TODO: this one doesn't work w/ SSL 262testSlowLoris :: Bool -> Int -> String -> Test 263testSlowLoris ssl port name = testCase (name ++ "blackbox/slowloris") $ 264 if ssl then return () else withSock port go 265 266 where 267 go sock = do 268 NB.sendAll sock "POST /echo HTTP/1.1\r\n" 269 NB.sendAll sock "Host: 127.0.0.1\r\n" 270 NB.sendAll sock "Content-Length: 2500000\r\n" 271 NB.sendAll sock "Connection: close\r\n\r\n" 272 273 b <- expectExceptionBeforeTimeout (loris sock) 30 274 275 assertBool "didn't catch slow loris attack" b 276 277 loris sock = forever $ do 278 NB.sendAll sock "." 279 waitabit 280 281 282------------------------------------------------------------------------------ 283testRot13 :: Bool -> Int -> String -> Test 284testRot13 ssl port name = 285 plusTestOptions (slowTestOptions ssl) $ 286 testProperty (name ++ "blackbox/rot13") $ 287 monadicIO $ forAllM arbitrary prop 288 where 289 prop txt = do 290 let uri = (if ssl then "https" else "http") 291 ++ "://127.0.0.1:" ++ show port ++ "/rot13" 292 293 doc <- QC.run $ HTTP.post (S.pack uri) "text/plain" 294 (Streams.write (Just $ byteString txt)) 295 HTTP.concatHandler' 296 QC.assert $ txt == rot13 doc 297 298 299------------------------------------------------------------------------------ 300doPong :: Bool -> Int -> IO ByteString 301doPong ssl port = do 302 debug "getting URI" 303 let !uri = (if ssl then "https" else "http") 304 ++ "://127.0.0.1:" ++ show port ++ "/pong" 305 debug $ "URI is: '" ++ uri ++ "', calling simpleHttp" 306 307 rsp <- fetch $ S.pack uri 308 309 debug $ "response was " ++ show rsp 310 return rsp 311 312 313------------------------------------------------------------------------------ 314testPong :: Bool -> Int -> String -> Test 315testPong ssl port name = testCase (name ++ "blackbox/pong") $ do 316 doc <- doPong ssl port 317 assertEqual "pong response" "PONG" doc 318 319 320------------------------------------------------------------------------------ 321testHasDateHeader :: Bool -> Int -> String -> Test 322testHasDateHeader ssl port name = testCase (name ++ "blackbox/hasDateHdr") $ do 323 let !url = (if ssl then "https" else "http") ++ "://127.0.0.1:" ++ show port 324 ++ "/pong" 325 (rsp, hdrs) <- fetchWithHeaders $ S.pack url 326 327 let hasDate = "date" `elem` map fst hdrs 328 when (not hasDate) $ do 329 putStrLn "server not sending dates:" 330 forM_ hdrs $ \(k,v) -> S.putStrLn $ S.concat [CI.original k, ": ", v] 331 assertBool "has date" hasDate 332 assertEqual "pong response" "PONG" rsp 333 334 335------------------------------------------------------------------------------ 336testChunkedHead :: Bool -> Int -> String -> Test 337testChunkedHead ssl port name = testCase (name ++ "blackbox/chunkedHead") $ 338 if ssl then return () else withSock port go 339 where 340 go sock = do 341 NB.sendAll sock $ S.concat [ "HEAD /chunked HTTP/1.1\r\n" 342 , "Host: localhost\r\n" 343 , "\r\n" 344 ] 345 s <- NB.recv sock 4096 346 assertBool (concat [ "no body: received '" 347 , S.unpack s 348 , "'" ]) $ isOK s 349 350 split x l | S.null x = reverse l 351 | otherwise = let (a, b) = S.break (== '\r') x 352 b' = S.drop 2 b 353 in split b' (a : l) 354 355 isOK s = let lns = split s [] 356 lns' = Prelude.drop 1 $ dropWhile (not . S.null) lns 357 in null lns' 358 359 360------------------------------------------------------------------------------ 361-- TODO: no ssl here 362-- test server's ability to trap/recover from IO errors 363testPartial :: Bool -> Int -> String -> Test 364testPartial ssl port name = 365 testCase (name ++ "blackbox/testPartial") $ 366 if ssl then return () else runIt 367 368 where 369 runIt = do 370 m <- timeout (60*seconds) go 371 maybe (assertFailure "timeout") 372 (const $ return ()) 373 m 374 375 go = do 376 withSock port $ \sock -> 377 NB.sendAll sock "GET /pong HTTP/1.1\r\n" 378 379 doc <- doPong ssl port 380 assertEqual "pong response" "PONG" doc 381 382 383------------------------------------------------------------------------------ 384-- TODO: no ssl here 385-- test server's ability to trap/recover from IO errors 386testTimelyRedirect :: Bool -> Int -> String -> Test 387testTimelyRedirect ssl port name = 388 testCase (name ++ "blackbox/testTimelyRedirect") $ 389 if ssl then return () else runIt 390 391 where 392 runIt = do 393 m <- timeout (5*seconds) go 394 maybe (assertFailure "timeout") 395 (const $ return ()) 396 m 397 398 go = do 399 withSock port $ \sock -> do 400 NB.sendAll sock $ S.concat [ "GET /redirect HTTP/1.1\r\n" 401 , "Host: localhost\r\n\r\n" ] 402 resp <- NB.recv sock 100000 403 assertBool "wasn't code 302" $ S.isInfixOf "302" resp 404 assertBool "didn't have content length" $ 405 S.isInfixOf "content-length: 0" resp 406 407 408------------------------------------------------------------------------------ 409-- TODO: no ssl 410testBigResponse :: Bool -> Int -> String -> Test 411testBigResponse ssl port name = 412 testCase (name ++ "blackbox/testBigResponse") $ 413 if ssl then return () else runIt 414 where 415 runIt = withSock port $ \sock -> do 416 m <- timeout (120*seconds) $ go sock 417 maybe (assertFailure "timeout") 418 (const $ return ()) 419 m 420 421 go sock = do 422 NB.sendAll sock "GET /bigresponse HTTP/1.1\r\n" 423 NB.sendAll sock "Host: 127.0.0.1\r\n" 424 NB.sendAll sock "Content-Length: 0\r\n" 425 NB.sendAll sock "Connection: close\r\n\r\n" 426 427 let body = S.replicate 4000000 '.' 428 resp <- recvAll sock 429 430 let s = head $ ditchHeaders $ S.lines resp 431 432 assertBool "big response" $ body == s 433 434 435------------------------------------------------------------------------------ 436testHaProxy :: Int -> Test 437testHaProxy port = testCase "blackbox/haProxy" runIt 438 439 where 440 runIt = withSock port $ \sock -> do 441 m <- timeout (120*seconds) $ go sock 442 maybe (assertFailure "timeout") 443 (const $ return ()) 444 m 445 446 go sock = do 447 NB.sendAll sock $ S.concat 448 [ "PROXY TCP4 1.2.3.4 5.6.7.8 1234 5678\r\n" 449 , "GET /remoteAddrPort HTTP/1.1\r\n" 450 , "Host: 127.0.0.1\r\n" 451 , "Content-Length: 0\r\n" 452 , "Connection: close\r\n\r\n" 453 ] 454 455 resp <- recvAll sock 456 457 let s = head $ ditchHeaders $ S.lines resp 458 459 when (s /= "1.2.3.4:1234") $ S.putStrLn s 460 assertEqual "haproxy response" "1.2.3.4:1234" s 461 462 463------------------------------------------------------------------------------ 464testHaProxyFileServe :: Int -> Test 465testHaProxyFileServe port = testCase "blackbox/haProxyFileServe" runIt 466 where 467 runIt = withSock port $ \sock -> do 468 m <- timeout (120*seconds) $ go sock 469 maybe (assertFailure "timeout") 470 (const $ return ()) 471 m 472 473 go sock = do 474 NB.sendAll sock $ S.concat 475 [ "PROXY UNKNOWN\r\n" 476 , "GET /fileserve/hello.txt HTTP/1.1\r\n" 477 , "Host: 127.0.0.1\r\n" 478 , "Content-Length: 0\r\n" 479 , "Connection: close\r\n\r\n" 480 ] 481 482 resp <- recvAll sock 483 484 let s = head $ ditchHeaders $ S.lines resp 485 486 assertEqual "haproxy response" "hello world" s 487 488 489------------------------------------------------------------------------------ 490testHaProxyLocal :: Int -> Test 491testHaProxyLocal port = testCase "blackbox/haProxyLocal" runIt 492 493 where 494#if MIN_VERSION_network(2,7,0) 495 anyport = N.defaultPort 496#else 497 anyport = N.aNY_PORT 498#endif 499 500 remoteAddrServer :: N.Socket 501 -> MVar (Maybe String) 502 -> (forall a . IO a -> IO a) 503 -> IO () 504 remoteAddrServer ssock mvar restore = 505 timeoutIn 10 $ 506 flip finally (tryPutMVar mvar Nothing) $ 507 bracket (restore $ N.accept ssock) 508 (eatException . N.close . fst) 509 (\(_, peer) -> putMVar mvar $! Just $! show peer) 510 511 slurp p input = timeoutIn 10 $ withSock p 512 $ \sock -> do NB.sendAll sock input 513 recvAll sock 514 515 determineSourceInterfaceAddr = 516 timeoutIn 10 $ 517 bracket 518 (Sock.bindSocket "127.0.0.1" (fromIntegral anyport)) 519 (eatException . N.close) 520 (\ssock -> do 521 mv <- newEmptyMVar 522 svrPort <- fromIntegral <$> N.socketPort ssock 523 bracket (mask_ $ forkIOWithUnmask $ remoteAddrServer ssock mv) 524 (eatException . killThread) 525 (const $ do void $ slurp svrPort "" 526 (Just s) <- takeMVar mv 527 return $! fst $ S.breakEnd (==':') $ S.pack s)) 528 529 runIt = do 530 saddr <- determineSourceInterfaceAddr 531 resp <- slurp port $ S.concat 532 [ "PROXY UNKNOWN\r\n" 533 , "GET /remoteAddrPort HTTP/1.1\r\n" 534 , "Host: 127.0.0.1\r\n" 535 , "Content-Length: 0\r\n" 536 , "Connection: close\r\n\r\n" 537 ] 538 539 let s = head $ ditchHeaders $ S.lines resp 540 541 when (not $ S.isPrefixOf saddr s) $ S.putStrLn s 542 assertBool "haproxy response" $ S.isPrefixOf saddr s 543 544 545------------------------------------------------------------------------------ 546-- This test checks two things: 547-- 548-- 1. that the timeout tickling logic works 549-- 2. that "flush" is passed along through a gzip operation. 550testTimeoutTickle :: Bool -> Int -> String -> Test 551testTimeoutTickle ssl port name = 552 testCase (name ++ "blackbox/timeout/tickle") $ do 553 let uri = (if ssl then "https" else "http") 554 ++ "://127.0.0.1:" ++ show port ++ "/timeout/tickle" 555 doc <- fetch $ S.pack uri 556 let expected = S.concat $ replicate 10 ".\n" 557 assertEqual "response equal" expected doc 558 559 560------------------------------------------------------------------------------ 561testFileServe :: Bool -> Int -> String -> Test 562testFileServe ssl port name = 563 testCase (name ++ "blackbox/fileserve") $ do 564 let uri = (if ssl then "https" else "http") 565 ++ "://127.0.0.1:" ++ show port ++ "/fileserve/hello.txt" 566 doc <- fetch $ S.pack uri 567 let expected = "hello world\n" 568 assertEqual "response equal" expected doc 569 570 571------------------------------------------------------------------------------ 572testFileUpload :: Bool -> Int -> String -> Test 573testFileUpload ssl port name = 574 plusTestOptions (slowTestOptions ssl) $ 575 testProperty (name ++ "blackbox/upload") $ 576 QC.mapSize (if ssl then min 100 else min 300) $ 577 monadicIO $ 578 forAllM arbitrary prop 579 where 580 boundary = "boundary-jdsklfjdsalkfjadlskfjldskjfldskjfdsfjdsklfldksajfl" 581 582 prefix = [ "--" 583 , boundary 584 , "\r\n" 585 , "content-disposition: form-data; name=\"submit\"\r\n" 586 , "\r\nSubmit\r\n" ] 587 588 body kvps = L.concat $ prefix ++ concatMap part kvps ++ suffix 589 where 590 part (k,v) = [ "--" 591 , boundary 592 , "\r\ncontent-disposition: attachment; filename=\"" 593 , k 594 , "\"\r\nContent-Type: text/plain\r\n\r\n" 595 , v 596 , "\r\n" ] 597 598 suffix = [ "--", boundary, "--\r\n" ] 599 600 hdrs = [ ("Content-type", S.concat $ [ "multipart/form-data; boundary=" ] 601 ++ L.toChunks boundary) ] 602 603 b16 (k,v) = (ne $ e k, e v) 604 where 605 ne s = if L.null s then "file" else s 606 e s = L.fromChunks [ B16.encode $ S.concat $ L.toChunks s ] 607 608 response kvps = L.concat $ [ "Param:\n" 609 , "submit\n" 610 , "Value:\n" 611 , "Submit\n\n" ] ++ concatMap responseKVP kvps 612 613 responseKVP (k,v) = [ "File:\n" 614 , k 615 , "\nValue:\n" 616 , v 617 , "\n\n" ] 618 619 prop kvps' = do 620 let kvps = sort $ map b16 kvps' 621 622 let uri = S.pack $ concat [ if ssl then "https" else "http" 623 , "://127.0.0.1:" 624 , show port 625 , "/upload/handle" ] 626 627 let txt = response kvps 628 doc0 <- QC.run 629 $ HTTP.withConnection (HTTP.establishConnection uri) 630 $ \conn -> do 631 req <- HTTP.buildRequest $ do 632 HTTP.http HTTP.POST uri 633 mapM_ (uncurry HTTP.setHeader) hdrs 634 635 HTTP.sendRequest conn req (Streams.write $ Just 636 $ mconcat 637 $ map byteString 638 $ L.toChunks 639 $ body kvps) 640 HTTP.receiveResponse conn HTTP.concatHandler' 641 642 let doc = L.fromChunks [doc0] 643 when (txt /= doc) $ QC.run $ do 644 L.putStrLn "expected:" 645 L.putStrLn "----------------------------------------" 646 L.putStrLn txt 647 L.putStrLn "----------------------------------------" 648 L.putStrLn "\ngot:" 649 L.putStrLn "----------------------------------------" 650 L.putStrLn doc 651 L.putStrLn "----------------------------------------" 652 653 QC.assert $ txt == doc 654 655 656------------------------------------------------------------------------------ 657testEcho :: Bool -> Int -> String -> Test 658testEcho ssl port name = 659 plusTestOptions (slowTestOptions ssl) $ 660 testProperty (name ++ "blackbox/echo") $ 661 QC.mapSize (if ssl then min 100 else min 300) $ 662 monadicIO $ forAllM arbitrary prop 663 where 664 prop txt = do 665 let uri = (if ssl then "https" else "http") 666 ++ "://127.0.0.1:" ++ show port ++ "/echo" 667 668 doc <- QC.run $ HTTP.post (S.pack uri) "text/plain" 669 (Streams.write (Just $ byteString txt)) 670 HTTP.concatHandler' 671 QC.assert $ txt == doc 672 673 674------------------------------------------------------------------------------ 675testServerHeader :: Bool -> Int -> String -> Test 676testServerHeader ssl port name = 677 testCase (name ++ "blackbox/server-header") $ do 678 let uri = (if ssl then "https" else "http") 679 ++ "://127.0.0.1:" ++ show port ++ "/server-header" 680 HTTP.get (S.pack uri) $ \resp _ -> do 681 let serverHeader = HTTP.getHeader resp "server" 682 assertEqual "server header" (Just "foo") serverHeader 683 684 685------------------------------------------------------------------------------ 686startTestServers :: IO ((ThreadId, Int, MVar ()), 687 (ThreadId, Int, MVar ()), 688 Maybe (ThreadId, Int, MVar ())) 689startTestServers = do 690 x <- startTestSocketServer NormalTest 691 y <- startTestSocketServer ProxyTest 692#ifdef OPENSSL 693 z <- startTestSocketServer SSLTest 694 return (x, y, Just z) 695#else 696 return (x, y, Nothing) 697#endif 698