Tests are passing.

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=""

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

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

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)
 

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                        )

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

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 ()
+

testserver/static/hello.txt

@@ -0,0 +1 @@
+hello world