From 6fe1d802a0c5e2a990d3358f7a8991779f770a14 Mon Sep 17 00:00:00 2001 From: Gregory Collins Date: Mon, 17 Jun 2013 01:50:33 +0200 Subject: [PATCH] Tests are passing. --- runTestsAndCoverage.sh | 5 +++- src/Snap/Internal/Http/Server/Session.hs | 11 +++++--- src/Snap/Internal/Http/Server/Socket.hs | 7 +---- test/Test/Blackbox.hs | 32 ++++++++++++--------- test/Test/Common/TestHandler.hs | 27 ++++-------------- test/TestSuite.hs | 5 ++-- testserver/Main.hs | 36 ++++++++++++++++++++++++ testserver/static/hello.txt | 1 + 8 files changed, 75 insertions(+), 49 deletions(-) create mode 100644 testserver/Main.hs create mode 100644 testserver/static/hello.txt diff --git a/runTestsAndCoverage.sh b/runTestsAndCoverage.sh index 85882219..dc0ece0d 100755 --- a/runTestsAndCoverage.sh +++ b/runTestsAndCoverage.sh @@ -15,11 +15,14 @@ rm -Rf $DIR mkdir -p $DIR EXCLUDES='Main +Paths_snap_server Snap.Internal.Http.Server.Parser.Tests Snap.Internal.Http.Server.Session.Tests Snap.Internal.Http.Server.TimeoutManager.Tests Snap.Test.Common -Paths_snap_server +Test.Blackbox +Test.Common.Rot13 +Test.Common.TestHandler ' EXCL="" diff --git a/src/Snap/Internal/Http/Server/Session.hs b/src/Snap/Internal/Http/Server/Session.hs index 549f53de..dd652f70 100644 --- a/src/Snap/Internal/Http/Server/Session.hs +++ b/src/Snap/Internal/Http/Server/Session.hs @@ -278,7 +278,7 @@ httpSession !buffer !serverHandler !config !sessionData = readEnd = _readEnd sessionData remoteAddress = _remoteAddress sessionData remotePort = _remotePort sessionData - tickle = _twiddleTimeout sessionData + tickle f = _twiddleTimeout sessionData f writeEnd = _writeEnd sessionData sendfileHandler = _sendfileHandler sessionData @@ -635,13 +635,16 @@ httpSession !buffer !serverHandler !config !sessionData = -- -- * "headerString" includes http status line. -- + -- If you're transforming the request body, you have to manage your own + -- timeouts. + let t = if rspTransformingRqBody rsp + then return $! () + else tickle $ max defaultTimeout writeEnd0 <- Streams.ignoreEof writeEnd (writeEnd1, getCount) <- Streams.countOutput writeEnd0 writeEnd2 <- limitRspBody hlen rsp writeEnd1 writeEndB <- Streams.unsafeBuilderStream (return buffer) writeEnd2 >>= - Streams.contramapM (\x -> do - tickle $ max defaultTimeout - return x) + Streams.contramapM (\x -> t >> return x) Streams.write (Just headerString) writeEndB writeEnd' <- body writeEndB diff --git a/src/Snap/Internal/Http/Server/Socket.hs b/src/Snap/Internal/Http/Server/Socket.hs index ec3c9658..65d5b000 100644 --- a/src/Snap/Internal/Http/Server/Socket.hs +++ b/src/Snap/Internal/Http/Server/Socket.hs @@ -53,11 +53,6 @@ getLocalAddress :: Socket -> IO ByteString getLocalAddress sock = getSocketName sock >>= liftM snd . getAddress ------------------------------------------------------------------------------- -sendfileHandler :: Socket -> SendFileHandler -sendfileHandler _ = error "not yet implemented" - - ------------------------------------------------------------------------------ httpAcceptFunc :: Socket -- ^ bound socket -> AcceptFunc @@ -66,7 +61,7 @@ httpAcceptFunc boundSocket restore = do localAddr <- getLocalAddress sock (remotePort, remoteHost) <- getAddress remoteAddr (readEnd, writeEnd) <- Streams.socketToStreams sock - return $! ( sendfileHandler sock + return $! ( sendFileFunc sock , localAddr , remoteHost , remotePort diff --git a/test/Test/Blackbox.hs b/test/Test/Blackbox.hs index a16e3316..83323325 100644 --- a/test/Test/Blackbox.hs +++ b/test/Test/Blackbox.hs @@ -64,6 +64,7 @@ ssltests = maybe [] httpsTests where httpsTests port = map (\f -> f True port sslname) testFunctions sslname = "ssl/" +testFunctions :: [Bool -> Int -> String -> Test] testFunctions = [ testPong -- FIXME: waiting on http-enumerator patch for HEAD behaviour -- , testHeadPong @@ -76,6 +77,7 @@ testFunctions = [ testPong , testFileUpload , testTimeoutTickle , testServerHeader + , testFileServe ] @@ -122,7 +124,7 @@ startTestSocketServer = bracketOnError getSock cleanup forkServer onEscape "localhost" 0 - 20 + 6 False 1 @@ -209,25 +211,18 @@ testSlowLoris ssl port name = testCase (name ++ "blackbox/slowloris") $ 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 + b <- expectExceptionBeforeTimeout (loris sock) 30 assertBool "didn't catch slow loris attack" b - loris sock = do + loris sock = forever $ do N.sendAll sock "." waitabit - loris sock ------------------------------------------------------------------------------ @@ -333,6 +328,17 @@ testTimeoutTickle ssl port name = 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 = @@ -448,10 +454,8 @@ testServerHeader ssl port name = ------------------------------------------------------------------------------ -startTestServers :: Int - -> Maybe Int - -> IO ((ThreadId, Int), Maybe (ThreadId, Int)) -startTestServers port sslport = do +startTestServers :: Bool -> IO ((ThreadId, Int), Maybe (ThreadId, Int)) +startTestServers _ = do x <- startTestSocketServer return (x, Nothing) diff --git a/test/Test/Common/TestHandler.hs b/test/Test/Common/TestHandler.hs index c61ede92..bc5ded43 100644 --- a/test/Test/Common/TestHandler.hs +++ b/test/Test/Common/TestHandler.hs @@ -70,27 +70,11 @@ echoUriHandler = do req <- getRequest writeBS $ rqURI req - -{- echoHandler :: Snap () -echoHandler = transformRequestBody returnI - +echoHandler = transformRequestBody return rot13Handler :: Snap () -rot13Handler = transformRequestBody f - where - f origStep = do - mbX <- I.head - maybe (enumEOF origStep) - (feedStep origStep) - mbX - - feedStep origStep b = do - let x = toByteString b - let e = enumBuilder $ fromByteString $ rot13 x - step <- lift $ runIteratee $ e origStep - f step --} +rot13Handler = transformRequestBody (Streams.map rot13) bigResponseHandler :: Snap () bigResponseHandler = do @@ -176,10 +160,11 @@ serverHeaderHandler = modifyResponse $ setHeader "Server" "foo" testHandler :: Snap () testHandler = withCompression $ route [ ("pong" , pongHandler ) --- , ("echo" , echoHandler ) --- , ("rot13" , rot13Handler ) + , ("echo" , echoHandler ) + , ("rot13" , rot13Handler ) , ("echoUri" , echoUriHandler ) --- , ("fileserve" , serveDirectory "testserver/static") + , ("fileserve" , noCompression >> + serveDirectory "testserver/static") , ("bigresponse" , bigResponseHandler ) , ("respcode/:code" , responseHandler ) , ("upload/form" , uploadForm ) diff --git a/test/TestSuite.hs b/test/TestSuite.hs index 7ffcbaac..d1837fa4 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -25,9 +25,8 @@ import qualified Test.Blackbox ------------------------------------------------------------------------------ main :: IO () main = withSocketsDo $ setupOpenSSL $ do - sp <- getStartPort - let (port, sslport) = ports sp - E.bracket (Test.Blackbox.startTestServers port sslport) + let doSSL = False + E.bracket (Test.Blackbox.startTestServers doSSL) cleanup (\tinfos -> do let blackboxTests = bbox tinfos diff --git a/testserver/Main.hs b/testserver/Main.hs new file mode 100644 index 00000000..c8fdd639 --- /dev/null +++ b/testserver/Main.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} + +module Main where + +import Control.Concurrent +import Control.Exception (finally) + +import Snap.Http.Server +import Test.Common.TestHandler + + +{- + +/pong +/fileserve +/echo +pipelined POST requests +slowloris attack / timeout test + +-} + + +main :: IO () +main = do + m <- newEmptyMVar + + forkIO $ go m + takeMVar m + + return () + + where + go m = quickHttpServe testHandler `finally` putMVar m () + diff --git a/testserver/static/hello.txt b/testserver/static/hello.txt new file mode 100644 index 00000000..3b18e512 --- /dev/null +++ b/testserver/static/hello.txt @@ -0,0 +1 @@ +hello world