snap-server-1.1.2.1: test/Test/Blackbox.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Blackbox
( tests
, haTests
, ssltests
, startTestServers
) where
--------------------------------------------------------------------------------
import Control.Applicative ((<$>))
import Control.Arrow (first)
import Control.Concurrent (MVar, ThreadId, forkIO, forkIOWithUnmask, killThread, newEmptyMVar, putMVar, takeMVar, threadDelay, tryPutMVar)
import Control.Exception (bracket, bracketOnError, finally, mask_)
import Control.Monad (forM_, forever, void, when)
import qualified Data.ByteString.Base16 as B16
import Data.ByteString.Builder (byteString)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.List (sort)
import Data.Monoid (Monoid (mconcat, mempty))
import qualified Network.Http.Client as HTTP
import qualified Network.Http.Types as HTTP
import qualified Network.Socket as N
import qualified Network.Socket.ByteString as NB
import 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, ($), ($!), (*), (++), (.), (^))
import qualified Prelude
------------------------------------------------------------------------------
#ifdef OPENSSL
import qualified OpenSSL.Session as SSL
#endif
import qualified System.IO.Streams as Streams
import System.Timeout (timeout)
import Test.Framework (Test, TestOptions' (topt_maximum_generated_tests), plusTestOptions)
import Test.Framework.Providers.HUnit (testCase)
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.HUnit hiding (Test, path)
import Test.QuickCheck (Arbitrary (arbitrary))
import Test.QuickCheck.Monadic (forAllM, monadicIO)
import qualified Test.QuickCheck.Monadic as QC
import qualified Test.QuickCheck.Property as QC
------------------------------------------------------------------------------
import Snap.Internal.Debug (debug)
import Snap.Internal.Http.Server.Session (httpAcceptLoop, snapToServerHandler)
import qualified Snap.Internal.Http.Server.Socket as Sock
import qualified Snap.Internal.Http.Server.TLS as TLS
import qualified Snap.Internal.Http.Server.Types as Types
import Snap.Test.Common (ditchHeaders, eatException, expectExceptionBeforeTimeout, recvAll, timeoutIn, withSock)
import Test.Common.Rot13 (rot13)
import Test.Common.TestHandler (testHandler)
------------------------------------------------------------------------------
tests :: Int -> [Test]
tests port = map (\f -> f False port "") testFunctions
ssltests :: Maybe Int -> [Test]
ssltests = maybe [] httpsTests
where httpsTests port = map (\f -> f True port sslname) testFunctions
sslname = "ssl/"
haTests :: Int -> [Test]
haTests port = [ testHaProxy port
, testHaProxyLocal port
, testHaProxyFileServe port
]
testFunctions :: [Bool -> Int -> String -> Test]
testFunctions = [ testPong
-- FIXME: waiting on http-enumerator patch for HEAD behaviour
-- , testHeadPong
, testEcho
, testRot13
, testSlowLoris
, testBlockingRead
, testBigResponse
, testPartial
, testFileUpload
, testTimeoutTickle
, testHasDateHeader
, testServerHeader
, testFileServe
, testTimelyRedirect
, testChunkedHead
]
------------------------------------------------------------------------------
startServer :: Types.ServerConfig hookState
-> IO a
-> (a -> N.Socket)
-> (a -> Types.AcceptFunc)
-> IO (ThreadId, Int, MVar ())
startServer config bind projSock afunc =
bracketOnError bind (N.close . projSock) forkServer
where
forkServer a = do
mv <- newEmptyMVar
port <- fromIntegral <$> N.socketPort (projSock a)
tid <- forkIO $
eatException $
(httpAcceptLoop (snapToServerHandler testHandler)
config
(afunc a)
`finally` putMVar mv ())
return (tid, port, mv)
------------------------------------------------------------------------------
-- | Returns the thread the server is running in as well as the port it is
-- listening on.
data TestServerType = NormalTest | ProxyTest | SSLTest
deriving (Show)
startTestSocketServer :: TestServerType -> IO (ThreadId, Int, MVar ())
startTestSocketServer serverType = do
putStrLn $ "Blackbox: starting " ++ show serverType ++ " server"
case serverType of
NormalTest -> startServer emptyServerConfig bindSock id Sock.httpAcceptFunc
ProxyTest -> startServer emptyServerConfig bindSock id Sock.haProxyAcceptFunc
SSLTest -> startServer emptyServerConfig bindSSL fst
(uncurry TLS.httpsAcceptFunc)
where
#if MIN_VERSION_network(2,7,0)
anyport = N.defaultPort
#else
anyport = N.aNY_PORT
#endif
bindSSL = do
sockCtx <- TLS.bindHttps "127.0.0.1"
(fromIntegral anyport)
"test/cert.pem"
False
"test/key.pem"
#ifdef OPENSSL
-- Set client code not to verify
HTTP.modifyContextSSL $ \ctx -> do
SSL.contextSetVerificationMode ctx SSL.VerifyNone
return ctx
#endif
return sockCtx
bindSock = Sock.bindSocket "127.0.0.1" (fromIntegral anyport)
logAccess !_ !_ !_ = return ()
logError !_ = return ()
onStart !_ = return ()
onParse !_ !_ = return ()
onUserHandlerFinished !_ !_ !_ = return ()
onDataFinished !_ !_ !_ = return ()
onExceptionHook !_ !_ = return ()
onEscape !_ = return ()
emptyServerConfig = Types.ServerConfig logAccess
logError
onStart
onParse
onUserHandlerFinished
onDataFinished
onExceptionHook
onEscape
"localhost"
6
False
1
------------------------------------------------------------------------------
waitabit :: IO ()
waitabit = threadDelay $ 2*seconds
------------------------------------------------------------------------------
seconds :: Int
seconds = (10::Int) ^ (6::Int)
------------------------------------------------------------------------------
fetch :: ByteString -> IO ByteString
fetch url = HTTP.get url HTTP.concatHandler'
------------------------------------------------------------------------------
fetchWithHeaders :: ByteString
-> IO (ByteString, [(CI ByteString, ByteString)])
fetchWithHeaders url = HTTP.get url h
where
h resp is = do
let hdrs = map (first CI.mk) $ HTTP.retrieveHeaders $ HTTP.getHeaders resp
body <- HTTP.concatHandler' resp is
return (body, hdrs)
------------------------------------------------------------------------------
slowTestOptions :: Bool -> TestOptions' Maybe
slowTestOptions ssl =
if ssl
then mempty { topt_maximum_generated_tests = Just 75 }
else mempty { topt_maximum_generated_tests = Just 300 }
------------------------------------------------------------------------------
-- 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")
-- ++ "://127.0.0.1:" ++ 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
------------------------------------------------------------------------------
-- 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
------------------------------------------------------------------------------
-- 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
NB.sendAll sock "GET /"
waitabit
NB.sendAll sock "pong HTTP/1.1\r\n"
NB.sendAll sock "Host: 127.0.0.1\r\n"
NB.sendAll sock "Content-Length: 0\r\n"
NB.sendAll sock "Connection: close\r\n\r\n"
resp <- recvAll sock
let s = head $ ditchHeaders $ S.lines resp
assertEqual "pong response" "PONG" s
------------------------------------------------------------------------------
-- 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
NB.sendAll sock "POST /echo HTTP/1.1\r\n"
NB.sendAll sock "Host: 127.0.0.1\r\n"
NB.sendAll sock "Content-Length: 2500000\r\n"
NB.sendAll sock "Connection: close\r\n\r\n"
b <- expectExceptionBeforeTimeout (loris sock) 30
assertBool "didn't catch slow loris attack" b
loris sock = forever $ do
NB.sendAll sock "."
waitabit
------------------------------------------------------------------------------
testRot13 :: Bool -> Int -> String -> Test
testRot13 ssl port name =
plusTestOptions (slowTestOptions ssl) $
testProperty (name ++ "blackbox/rot13") $
monadicIO $ forAllM arbitrary prop
where
prop txt = do
let uri = (if ssl then "https" else "http")
++ "://127.0.0.1:" ++ show port ++ "/rot13"
doc <- QC.run $ HTTP.post (S.pack uri) "text/plain"
(Streams.write (Just $ byteString txt))
HTTP.concatHandler'
QC.assert $ txt == rot13 doc
------------------------------------------------------------------------------
doPong :: Bool -> Int -> IO ByteString
doPong ssl port = do
debug "getting URI"
let !uri = (if ssl then "https" else "http")
++ "://127.0.0.1:" ++ show port ++ "/pong"
debug $ "URI is: '" ++ uri ++ "', calling simpleHttp"
rsp <- fetch $ S.pack uri
debug $ "response was " ++ show rsp
return rsp
------------------------------------------------------------------------------
testPong :: Bool -> Int -> String -> Test
testPong ssl port name = testCase (name ++ "blackbox/pong") $ do
doc <- doPong ssl port
assertEqual "pong response" "PONG" doc
------------------------------------------------------------------------------
testHasDateHeader :: Bool -> Int -> String -> Test
testHasDateHeader ssl port name = testCase (name ++ "blackbox/hasDateHdr") $ do
let !url = (if ssl then "https" else "http") ++ "://127.0.0.1:" ++ show port
++ "/pong"
(rsp, hdrs) <- fetchWithHeaders $ S.pack url
let hasDate = "date" `elem` map fst hdrs
when (not hasDate) $ do
putStrLn "server not sending dates:"
forM_ hdrs $ \(k,v) -> S.putStrLn $ S.concat [CI.original k, ": ", v]
assertBool "has date" hasDate
assertEqual "pong response" "PONG" rsp
------------------------------------------------------------------------------
testChunkedHead :: Bool -> Int -> String -> Test
testChunkedHead ssl port name = testCase (name ++ "blackbox/chunkedHead") $
if ssl then return () else withSock port go
where
go sock = do
NB.sendAll sock $ S.concat [ "HEAD /chunked HTTP/1.1\r\n"
, "Host: localhost\r\n"
, "\r\n"
]
s <- NB.recv sock 4096
assertBool (concat [ "no body: received '"
, S.unpack s
, "'" ]) $ isOK s
split x l | S.null x = reverse l
| otherwise = let (a, b) = S.break (== '\r') x
b' = S.drop 2 b
in split b' (a : l)
isOK s = let lns = split s []
lns' = Prelude.drop 1 $ dropWhile (not . S.null) lns
in null lns'
------------------------------------------------------------------------------
-- 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 ->
NB.sendAll sock "GET /pong HTTP/1.1\r\n"
doc <- doPong ssl port
assertEqual "pong response" "PONG" doc
------------------------------------------------------------------------------
-- TODO: no ssl here
-- test server's ability to trap/recover from IO errors
testTimelyRedirect :: Bool -> Int -> String -> Test
testTimelyRedirect ssl port name =
testCase (name ++ "blackbox/testTimelyRedirect") $
if ssl then return () else runIt
where
runIt = do
m <- timeout (5*seconds) go
maybe (assertFailure "timeout")
(const $ return ())
m
go = do
withSock port $ \sock -> do
NB.sendAll sock $ S.concat [ "GET /redirect HTTP/1.1\r\n"
, "Host: localhost\r\n\r\n" ]
resp <- NB.recv sock 100000
assertBool "wasn't code 302" $ S.isInfixOf "302" resp
assertBool "didn't have content length" $
S.isInfixOf "content-length: 0" resp
------------------------------------------------------------------------------
-- 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
NB.sendAll sock "GET /bigresponse HTTP/1.1\r\n"
NB.sendAll sock "Host: 127.0.0.1\r\n"
NB.sendAll sock "Content-Length: 0\r\n"
NB.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
------------------------------------------------------------------------------
testHaProxy :: Int -> Test
testHaProxy port = testCase "blackbox/haProxy" runIt
where
runIt = withSock port $ \sock -> do
m <- timeout (120*seconds) $ go sock
maybe (assertFailure "timeout")
(const $ return ())
m
go sock = do
NB.sendAll sock $ S.concat
[ "PROXY TCP4 1.2.3.4 5.6.7.8 1234 5678\r\n"
, "GET /remoteAddrPort HTTP/1.1\r\n"
, "Host: 127.0.0.1\r\n"
, "Content-Length: 0\r\n"
, "Connection: close\r\n\r\n"
]
resp <- recvAll sock
let s = head $ ditchHeaders $ S.lines resp
when (s /= "1.2.3.4:1234") $ S.putStrLn s
assertEqual "haproxy response" "1.2.3.4:1234" s
------------------------------------------------------------------------------
testHaProxyFileServe :: Int -> Test
testHaProxyFileServe port = testCase "blackbox/haProxyFileServe" runIt
where
runIt = withSock port $ \sock -> do
m <- timeout (120*seconds) $ go sock
maybe (assertFailure "timeout")
(const $ return ())
m
go sock = do
NB.sendAll sock $ S.concat
[ "PROXY UNKNOWN\r\n"
, "GET /fileserve/hello.txt HTTP/1.1\r\n"
, "Host: 127.0.0.1\r\n"
, "Content-Length: 0\r\n"
, "Connection: close\r\n\r\n"
]
resp <- recvAll sock
let s = head $ ditchHeaders $ S.lines resp
assertEqual "haproxy response" "hello world" s
------------------------------------------------------------------------------
testHaProxyLocal :: Int -> Test
testHaProxyLocal port = testCase "blackbox/haProxyLocal" runIt
where
#if MIN_VERSION_network(2,7,0)
anyport = N.defaultPort
#else
anyport = N.aNY_PORT
#endif
remoteAddrServer :: N.Socket
-> MVar (Maybe String)
-> (forall a . IO a -> IO a)
-> IO ()
remoteAddrServer ssock mvar restore =
timeoutIn 10 $
flip finally (tryPutMVar mvar Nothing) $
bracket (restore $ N.accept ssock)
(eatException . N.close . fst)
(\(_, peer) -> putMVar mvar $! Just $! show peer)
slurp p input = timeoutIn 10 $ withSock p
$ \sock -> do NB.sendAll sock input
recvAll sock
determineSourceInterfaceAddr =
timeoutIn 10 $
bracket
(Sock.bindSocket "127.0.0.1" (fromIntegral anyport))
(eatException . N.close)
(\ssock -> do
mv <- newEmptyMVar
svrPort <- fromIntegral <$> N.socketPort ssock
bracket (mask_ $ forkIOWithUnmask $ remoteAddrServer ssock mv)
(eatException . killThread)
(const $ do void $ slurp svrPort ""
(Just s) <- takeMVar mv
return $! fst $ S.breakEnd (==':') $ S.pack s))
runIt = do
saddr <- determineSourceInterfaceAddr
resp <- slurp port $ S.concat
[ "PROXY UNKNOWN\r\n"
, "GET /remoteAddrPort HTTP/1.1\r\n"
, "Host: 127.0.0.1\r\n"
, "Content-Length: 0\r\n"
, "Connection: close\r\n\r\n"
]
let s = head $ ditchHeaders $ S.lines resp
when (not $ S.isPrefixOf saddr s) $ S.putStrLn s
assertBool "haproxy response" $ S.isPrefixOf saddr s
------------------------------------------------------------------------------
-- This test checks two things:
--
-- 1. that the timeout tickling logic works
-- 2. that "flush" is passed along through a gzip operation.
testTimeoutTickle :: Bool -> Int -> String -> Test
testTimeoutTickle ssl port name =
testCase (name ++ "blackbox/timeout/tickle") $ do
let uri = (if ssl then "https" else "http")
++ "://127.0.0.1:" ++ show port ++ "/timeout/tickle"
doc <- fetch $ S.pack uri
let expected = S.concat $ replicate 10 ".\n"
assertEqual "response equal" expected doc
------------------------------------------------------------------------------
testFileServe :: Bool -> Int -> String -> Test
testFileServe ssl port name =
testCase (name ++ "blackbox/fileserve") $ do
let uri = (if ssl then "https" else "http")
++ "://127.0.0.1:" ++ show port ++ "/fileserve/hello.txt"
doc <- fetch $ S.pack uri
let expected = "hello world\n"
assertEqual "response equal" expected doc
------------------------------------------------------------------------------
testFileUpload :: Bool -> Int -> String -> Test
testFileUpload ssl port name =
plusTestOptions (slowTestOptions ssl) $
testProperty (name ++ "blackbox/upload") $
QC.mapSize (if ssl then min 100 else min 300) $
monadicIO $
forAllM arbitrary prop
where
boundary = "boundary-jdsklfjdsalkfjadlskfjldskjfldskjfdsfjdsklfldksajfl"
prefix = [ "--"
, boundary
, "\r\n"
, "content-disposition: form-data; name=\"submit\"\r\n"
, "\r\nSubmit\r\n" ]
body kvps = L.concat $ prefix ++ concatMap part kvps ++ suffix
where
part (k,v) = [ "--"
, boundary
, "\r\ncontent-disposition: attachment; filename=\""
, k
, "\"\r\nContent-Type: text/plain\r\n\r\n"
, v
, "\r\n" ]
suffix = [ "--", boundary, "--\r\n" ]
hdrs = [ ("Content-type", S.concat $ [ "multipart/form-data; boundary=" ]
++ L.toChunks boundary) ]
b16 (k,v) = (ne $ e k, e v)
where
ne s = if L.null s then "file" else s
e s = L.fromChunks [ B16.encode $ S.concat $ L.toChunks s ]
response kvps = L.concat $ [ "Param:\n"
, "submit\n"
, "Value:\n"
, "Submit\n\n" ] ++ concatMap responseKVP kvps
responseKVP (k,v) = [ "File:\n"
, k
, "\nValue:\n"
, v
, "\n\n" ]
prop kvps' = do
let kvps = sort $ map b16 kvps'
let uri = S.pack $ concat [ if ssl then "https" else "http"
, "://127.0.0.1:"
, show port
, "/upload/handle" ]
let txt = response kvps
doc0 <- QC.run
$ HTTP.withConnection (HTTP.establishConnection uri)
$ \conn -> do
req <- HTTP.buildRequest $ do
HTTP.http HTTP.POST uri
mapM_ (uncurry HTTP.setHeader) hdrs
HTTP.sendRequest conn req (Streams.write $ Just
$ mconcat
$ map byteString
$ L.toChunks
$ body kvps)
HTTP.receiveResponse conn HTTP.concatHandler'
let doc = L.fromChunks [doc0]
when (txt /= doc) $ QC.run $ do
L.putStrLn "expected:"
L.putStrLn "----------------------------------------"
L.putStrLn txt
L.putStrLn "----------------------------------------"
L.putStrLn "\ngot:"
L.putStrLn "----------------------------------------"
L.putStrLn doc
L.putStrLn "----------------------------------------"
QC.assert $ txt == doc
------------------------------------------------------------------------------
testEcho :: Bool -> Int -> String -> Test
testEcho ssl port name =
plusTestOptions (slowTestOptions ssl) $
testProperty (name ++ "blackbox/echo") $
QC.mapSize (if ssl then min 100 else min 300) $
monadicIO $ forAllM arbitrary prop
where
prop txt = do
let uri = (if ssl then "https" else "http")
++ "://127.0.0.1:" ++ show port ++ "/echo"
doc <- QC.run $ HTTP.post (S.pack uri) "text/plain"
(Streams.write (Just $ byteString txt))
HTTP.concatHandler'
QC.assert $ txt == doc
------------------------------------------------------------------------------
testServerHeader :: Bool -> Int -> String -> Test
testServerHeader ssl port name =
testCase (name ++ "blackbox/server-header") $ do
let uri = (if ssl then "https" else "http")
++ "://127.0.0.1:" ++ show port ++ "/server-header"
HTTP.get (S.pack uri) $ \resp _ -> do
let serverHeader = HTTP.getHeader resp "server"
assertEqual "server header" (Just "foo") serverHeader
------------------------------------------------------------------------------
startTestServers :: IO ((ThreadId, Int, MVar ()),
(ThreadId, Int, MVar ()),
Maybe (ThreadId, Int, MVar ()))
startTestServers = do
x <- startTestSocketServer NormalTest
y <- startTestSocketServer ProxyTest
#ifdef OPENSSL
z <- startTestSocketServer SSLTest
return (x, y, Just z)
#else
return (x, y, Nothing)
#endif