snap-server-0.3.0: test/suite/Test/Blackbox.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PackageImports #-}
module Test.Blackbox
( tests
, ssltests
, startTestServer ) where
------------------------------------------------------------------------------
import Control.Concurrent
import Control.Exception (SomeException, catch)
import Control.Monad
import qualified Data.ByteString.Char8 as S
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Int
import qualified Network.HTTP.Enumerator as HTTP
import qualified Network.Socket.ByteString as N
import Prelude hiding (catch, take)
import System.Timeout
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
import Test.HUnit hiding (Test, path)
import Test.QuickCheck
import qualified Test.QuickCheck.Monadic as QC
import Test.QuickCheck.Monadic hiding (run, assert)
------------------------------------------------------------------------------
import Snap.Http.Server
import Snap.Test.Common
import Test.Common.Rot13
import Test.Common.TestHandler
------------------------------------------------------------------------------
testFunctions :: [Bool -> Int -> String -> Test]
testFunctions = [ testPong
-- FIXME: waiting on http-enumerator patch for HEAD behaviour
-- , testHeadPong
, testEcho
, testRot13
, testSlowLoris
, testBlockingRead
, testBigResponse
, testPartial
]
------------------------------------------------------------------------------
tests :: Int -> String -> [Test]
tests port name = map (\f -> f False port name) testFunctions
------------------------------------------------------------------------------
ssltests :: String -> Maybe Int -> [Test]
ssltests name = maybe [] httpsTests
where httpsTests port = map (\f -> f True port sslname) testFunctions
sslname = "ssl/" ++ name
------------------------------------------------------------------------------
startTestServer :: Int
-> Maybe Int
-> ConfigBackend
-> IO (ThreadId, MVar ())
startTestServer port sslport backend = do
let cfg = setAccessLog (Just $ "ts-access." ++ show backend ++ ".log") .
setErrorLog (Just $ "ts-error." ++ show backend ++ ".log") .
addListen (ListenHttp "*" port) .
setBackend backend .
setVerbose False $
defaultConfig
let cfg' = case sslport of
Nothing -> cfg
Just p -> addListen
(ListenHttps "*" p "cert.pem" "key.pem")
cfg
mvar <- newEmptyMVar
tid <- forkIO $ do
(httpServe cfg' testHandler)
`catch` \(_::SomeException) -> return ()
putMVar mvar ()
waitabit
return (tid,mvar)
------------------------------------------------------------------------------
doPong :: Bool -> Int -> IO ByteString
doPong ssl port = do
let uri = (if ssl then "https" else "http")
++ "://localhost:" ++ show port ++ "/pong"
rsp <- HTTP.simpleHttp uri
return $ S.concat $ L.toChunks rsp
------------------------------------------------------------------------------
-- FIXME: waiting on http-enumerator patch for HEAD behaviour
-- headPong :: Bool -> Int -> IO ByteString
-- headPong ssl port = do
-- let uri = (if ssl then "https" else "http")
-- ++ "://localhost:" ++ show port ++ "/echo"
-- req0 <- HTTP.parseUrl uri
-- let req = req0 { HTTP.method = "HEAD" }
-- rsp <- HTTP.httpLbs req
-- return $ S.concat $ L.toChunks $ HTTP.responseBody rsp
------------------------------------------------------------------------------
testPong :: Bool -> Int -> String -> Test
testPong ssl port name = testCase (name ++ "/blackbox/pong") $ do
doc <- doPong ssl port
assertEqual "pong response" "PONG" doc
------------------------------------------------------------------------------
-- FIXME: waiting on http-enumerator patch for HEAD behaviour
-- testHeadPong :: Bool -> Int -> String -> Test
-- testHeadPong ssl port name = testCase (name ++ "/blackbox/pong/HEAD") $ do
-- doc <- headPong ssl port
-- assertEqual "pong HEAD response" "" doc
------------------------------------------------------------------------------
testEcho :: Bool -> Int -> String -> Test
testEcho ssl port name = testProperty (name ++ "/blackbox/echo") $
monadicIO $ forAllM arbitrary prop
where
prop txt = do
let uri = (if ssl then "https" else "http")
++ "://localhost:" ++ show port ++ "/echo"
req0 <- QC.run $ HTTP.parseUrl uri
let req = req0 { HTTP.requestBody = txt
, HTTP.method = "POST" }
rsp <- QC.run $ HTTP.httpLbs req
let doc = HTTP.responseBody rsp
QC.assert $ txt == doc
------------------------------------------------------------------------------
testRot13 :: Bool -> Int -> String -> Test
testRot13 ssl port name = testProperty (name ++ "/blackbox/rot13") $
monadicIO $ forAllM arbitrary prop
where
prop txt = do
let uri = (if ssl then "https" else "http")
++ "://localhost:" ++ show port ++ "/rot13"
req0 <- QC.run $ HTTP.parseUrl uri
let req = req0 { HTTP.requestBody = L.fromChunks [txt]
, HTTP.method = "POST" }
rsp <- QC.run $ HTTP.httpLbs req
let doc = S.concat $ L.toChunks $ HTTP.responseBody rsp
QC.assert $ txt == rot13 doc
------------------------------------------------------------------------------
-- TODO: this one doesn't work w/ SSL
testSlowLoris :: Bool -> Int -> String -> Test
testSlowLoris ssl port name = testCase (name ++ "/blackbox/slowloris") $
if ssl then return () else withSock port go
where
go sock = do
m <- timeout (120*seconds) $ go' sock
maybe (assertFailure "slowloris: timeout")
(const $ return ())
m
go' sock = do
N.sendAll sock "POST /echo HTTP/1.1\r\n"
N.sendAll sock "Host: 127.0.0.1\r\n"
N.sendAll sock "Content-Length: 2500000\r\n"
N.sendAll sock "Connection: close\r\n\r\n"
b <- expectExceptionBeforeTimeout (loris sock) 60
assertBool "didn't catch slow loris attack" b
loris sock = do
N.sendAll sock "."
waitabit
loris sock
------------------------------------------------------------------------------
-- TODO: doesn't work w/ ssl
testBlockingRead :: Bool -> Int -> String -> Test
testBlockingRead ssl port name =
testCase (name ++ "/blackbox/testBlockingRead") $
if ssl then return () else runIt
where
runIt = withSock port $ \sock -> do
m <- timeout (60*seconds) $ go sock
maybe (assertFailure "timeout")
(const $ return ())
m
go sock = do
N.sendAll sock "GET /"
waitabit
N.sendAll sock "pong HTTP/1.1\r\n"
N.sendAll sock "Host: 127.0.0.1\r\n"
N.sendAll sock "Content-Length: 0\r\n"
N.sendAll sock "Connection: close\r\n\r\n"
resp <- recvAll sock
let s = head $ ditchHeaders $ S.lines resp
assertEqual "pong response" "PONG" s
------------------------------------------------------------------------------
-- TODO: no ssl here
-- test server's ability to trap/recover from IO errors
testPartial :: Bool -> Int -> String -> Test
testPartial ssl port name =
testCase (name ++ "/blackbox/testPartial") $
if ssl then return () else runIt
where
runIt = do
m <- timeout (60*seconds) go
maybe (assertFailure "timeout")
(const $ return ())
m
go = do
withSock port $ \sock ->
N.sendAll sock "GET /pong HTTP/1.1\r\n"
doc <- doPong ssl port
assertEqual "pong response" "PONG" doc
------------------------------------------------------------------------------
-- TODO: no ssl
testBigResponse :: Bool -> Int -> String -> Test
testBigResponse ssl port name =
testCase (name ++ "/blackbox/testBigResponse") $
if ssl then return () else runIt
where
runIt = withSock port $ \sock -> do
m <- timeout (120*seconds) $ go sock
maybe (assertFailure "timeout")
(const $ return ())
m
go sock = do
N.sendAll sock "GET /bigresponse HTTP/1.1\r\n"
N.sendAll sock "Host: 127.0.0.1\r\n"
N.sendAll sock "Content-Length: 0\r\n"
N.sendAll sock "Connection: close\r\n\r\n"
let body = S.replicate 4000000 '.'
resp <- recvAll sock
let s = head $ ditchHeaders $ S.lines resp
assertBool "big response" $ body == s
------------------------------------------------------------------------------
waitabit :: IO ()
waitabit = threadDelay $ 2*seconds
------------------------------------------------------------------------------
seconds :: Int
seconds = (10::Int) ^ (6::Int)