snap-server 0.2.12 → 0.2.13
raw patch · 7 files changed
+219/−110 lines, 7 filesdep ~snap-core
Dependency ranges changed: snap-core
Files
- snap-server.cabal +2/−2
- src/Snap/Internal/Http/Server.hs +40/−26
- src/Snap/Internal/Http/Server/LibevBackend.hs +4/−9
- src/Snap/Internal/Http/Server/SimpleBackend.hs +5/−5
- test/runTestsAndCoverage.sh +1/−1
- test/suite/Snap/Internal/Http/Server/Tests.hs +94/−45
- test/suite/Test/Blackbox.hs +73/−22
snap-server.cabal view
@@ -1,5 +1,5 @@ name: snap-server-version: 0.2.12+version: 0.2.13 synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework description: This is the first developer prerelease of the Snap framework. Snap is a@@ -122,7 +122,7 @@ murmur-hash >= 0.1 && < 0.2, network == 2.2.1.*, old-locale,- snap-core >= 0.2.12 && <0.3,+ snap-core >= 0.2.13 && <0.3, template-haskell, time, transformers,
src/Snap/Internal/Http/Server.hs view
@@ -280,7 +280,8 @@ -> Maybe Logger -- ^ error logger -> Enumerator IO () -- ^ read end of socket -> Iteratee IO () -- ^ write end of socket- -> (FilePath -> Int64 -> IO ()) -- ^ sendfile end+ -> (FilePath -> Int64 -> Int64 -> IO ())+ -- ^ sendfile end -> IO () -- ^ timeout tickler -> ServerHandler -- ^ handler procedure -> IO ()@@ -330,7 +331,8 @@ -- | Runs an HTTP session. httpSession :: Iteratee IO () -- ^ write end of socket -> ForeignPtr CChar -- ^ iteratee buffer- -> (FilePath -> Int64 -> IO ()) -- ^ sendfile continuation+ -> (FilePath -> Int64 -> Int64 -> IO ())+ -- ^ sendfile continuation -> IO () -- ^ timeout tickler -> ServerHandler -- ^ handler procedure -> ServerMonad ()@@ -384,7 +386,7 @@ date <- liftIO getDateString let ins = Map.insert "Date" [date] . Map.insert "Server" sERVER_HEADER let rsp' = updateHeaders ins rsp- (bytesSent,_) <- sendResponse rsp' writeEnd onSendFile+ (bytesSent,_) <- sendResponse req rsp' writeEnd onSendFile liftIO . debug $ "Server.httpSession: sent " ++ (Prelude.show bytesSent) ++ " bytes"@@ -604,17 +606,21 @@ ------------------------------------------------------------------------------ -- Response must be well-formed here-sendResponse :: forall a . Response+sendResponse :: forall a . Request+ -> Response -> Iteratee IO a- -> (FilePath -> Int64 -> IO a)+ -> (FilePath -> Int64 -> Int64 -> IO a) -> ServerMonad (Int64, a)-sendResponse rsp' writeEnd onSendFile = do+sendResponse req rsp' writeEnd onSendFile = do rsp <- fixupResponse rsp' let !headerString = mkHeaderString rsp (!x,!bs) <- case (rspBody rsp) of- (Enum e) -> lift $ whenEnum headerString rsp e- (SendFile f) -> lift $ whenSendFile headerString rsp f+ (Enum e) -> lift $ whenEnum headerString rsp e+ (SendFile f Nothing) -> lift $+ whenSendFile headerString rsp f 0+ (SendFile f (Just (st,_))) ->+ lift $ whenSendFile headerString rsp f st return $! (bs,x) @@ -636,12 +642,12 @@ --------------------------------------------------------------------------- whenSendFile hs r f = do+ whenSendFile hs r f start = do -- guaranteed to have a content length here. joinIM $ (enumBS hs >. enumEof) writeEnd let !cl = fromJust $ rspContentLength r- x <- liftIO $ onSendFile f cl+ x <- liftIO $ onSendFile f start cl return (x, cl) @@ -692,8 +698,8 @@ -- set the content-length header let r' = setHeader "Content-Length" (l2s $ show cl) r let b = case (rspBody r') of- (Enum e) -> Enum (i e)- (SendFile f) -> SendFile f+ (Enum e) -> Enum (i e)+ (SendFile f m) -> SendFile f m return $ r' { rspBody = b } @@ -720,23 +726,31 @@ -------------------------------------------------------------------------- fixupResponse :: Response -> ServerMonad Response- fixupResponse r =- {-# SCC "fixupResponse" #-}- do- let r' = updateHeaders (Map.delete "Content-Length") r+ fixupResponse r = {-# SCC "fixupResponse" #-} do+ let r' = deleteHeader "Content-Length" r - let code = rspStatus r'+ let code = rspStatus r' - let r'' = if code == 204 || code == 304- then handle304 r'- else r'+ let r'' = if code == 204 || code == 304+ then handle304 r'+ else r' - r''' <- case (rspBody r'') of- (Enum _) -> return r''- (SendFile f) -> setFileSize f r''- case (rspContentLength r''') of- Nothing -> noCL r'''- (Just sz) -> hasCL sz r'''+ r''' <- do+ z <- case (rspBody r'') of+ (Enum _) -> return r''+ (SendFile f Nothing) -> setFileSize f r''+ (SendFile _ (Just (s,e))) -> return $+ setContentLength (e-s) r''++ case (rspContentLength z) of+ Nothing -> noCL z+ (Just sz) -> hasCL sz z++ -- HEAD requests cannot have bodies per RFC 2616 sec. 9.4+ if rqMethod req == HEAD+ then return $ deleteHeader "Transfer-Encoding"+ $ r''' { rspBody = Enum $ enumBS "" }+ else return r''' --------------------------------------------------------------------------
src/Snap/Internal/Http/Server/LibevBackend.hs view
@@ -112,12 +112,8 @@ name = "libev" -sendFile :: Connection -> FilePath -> Int64 -> IO ()-#if defined(HAS_SENDFILE)-sendFile c fp sz = do-#else-sendFile c fp _ = do-#endif+sendFile :: Connection -> FilePath -> Int64 -> Int64 -> IO ()+sendFile c fp start sz = do withMVar lock $ \_ -> do act <- readIORef $ _writeActive c when act $ evIoStop loop io@@ -127,10 +123,9 @@ #if defined(HAS_SENDFILE) bracket (openFd fp ReadOnly Nothing defaultFileFlags) (closeFd)- (go 0 sz)+ (go start sz) #else- -- no need to count bytes- enumFile fp (getWriteEnd c) >>= run+ enumFilePartial fp (start,start+sz) (getWriteEnd c) >>= run return () #endif
src/Snap/Internal/Http/Server/SimpleBackend.hs view
@@ -97,12 +97,12 @@ name = "simple" -sendFile :: Connection -> FilePath -> Int64 -> IO ()+sendFile :: Connection -> FilePath -> Int64 -> Int64 -> IO () #if defined(HAS_SENDFILE)-sendFile c fp sz = do+sendFile c fp start sz = do bracket (openFd fp ReadOnly Nothing defaultFileFlags) (closeFd)- (go 0 sz)+ (go start sz) where go off bytes fd | bytes == 0 = return ()@@ -114,9 +114,9 @@ sfd = Fd . fdSocket $ _socket c #else-sendFile c fp _ = do+sendFile c fp start sz = do -- no need to count bytes- enumFile fp (getWriteEnd c) >>= run+ enumFilePartial fp (start,start+sz) (getWriteEnd c) >>= run return () #endif
test/runTestsAndCoverage.sh view
@@ -2,7 +2,7 @@ set -e -if [ "x$DEBUG" == "x" ]; then+if [ -z "$DEBUG" ]; then export DEBUG=testsuite fi
test/suite/Snap/Internal/Http/Server/Tests.hs view
@@ -7,14 +7,14 @@ ( tests ) where import Control.Concurrent-import Control.Exception (try, throwIO, SomeException)+import Control.Exception (try, throwIO, bracket, SomeException) import Control.Monad import "monads-fd" Control.Monad.Trans import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import Data.ByteString (ByteString)-import Data.ByteString.Internal (c2w, w2c)+import Data.ByteString.Internal (c2w) import Data.Char import Data.Int import Data.IORef@@ -29,6 +29,7 @@ import qualified Network.Socket.ByteString as N import Prelude hiding (take) import qualified Prelude+import System.Timeout import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, path)@@ -148,6 +149,12 @@ step acc str = return $ Done acc str +mkRequest :: ByteString -> IO Request+mkRequest s = do+ iter <- enumBS s $ liftM fromJust $ rsm receiveRequest+ run iter++ testHttpRequest1 :: Test testHttpRequest1 = testCase "server/HttpRequest1" $ do@@ -239,7 +246,7 @@ expectException m = do e <- try m case e of- Left (z::SomeException) -> return ()+ Left (_::SomeException) -> return () Right _ -> assertFailure "expected exception, didn't get it" @@ -381,10 +388,14 @@ testHttpResponse1 :: Test testHttpResponse1 = testCase "server/HttpResponse1" $ do- let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run+ let onSendFile = \f start sz ->+ enumFilePartial f (start,start+sz) copyingStream2stream+ >>= run + req <- mkRequest sampleRequest+ b <- run $ rsm $- sendResponse rsp1 copyingStream2stream onSendFile >>=+ sendResponse req rsp1 copyingStream2stream onSendFile >>= return . fromWrap . snd assertEqual "http response" (L.concat [@@ -405,10 +416,13 @@ testHttpResponse2 :: Test testHttpResponse2 = testCase "server/HttpResponse2" $ do- let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run+ let onSendFile = \f st sz ->+ enumFilePartial f (st,st+sz) copyingStream2stream >>= run + req <- mkRequest sampleRequest+ b2 <- run $ rsm $- sendResponse rsp2 copyingStream2stream onSendFile >>=+ sendResponse req rsp2 copyingStream2stream onSendFile >>= return . fromWrap . snd assertEqual "http response" (L.concat [@@ -429,10 +443,13 @@ testHttpResponse3 :: Test testHttpResponse3 = testCase "server/HttpResponse3" $ do- let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run+ let onSendFile = \f st sz ->+ enumFilePartial f (st,st+sz) copyingStream2stream >>= run + req <- mkRequest sampleRequest+ b3 <- run $ rsm $- sendResponse rsp3 copyingStream2stream onSendFile >>=+ sendResponse req rsp3 copyingStream2stream onSendFile >>= return . fromWrap . snd assertEqual "http response" b3 $ L.concat [@@ -459,10 +476,13 @@ testHttpResponse4 :: Test testHttpResponse4 = testCase "server/HttpResponse4" $ do- let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run+ let onSendFile = \f st sz ->+ enumFilePartial f (st,st+sz) copyingStream2stream >>= run + req <- mkRequest sampleRequest+ b <- run $ rsm $- sendResponse rsp1 copyingStream2stream onSendFile >>=+ sendResponse req rsp1 copyingStream2stream onSendFile >>= return . fromWrap . snd assertEqual "http response" (L.concat [@@ -540,14 +560,15 @@ assertBool "pipelined responses" ok -mkIter :: IORef L.ByteString -> (Iteratee IO (), FilePath -> Int64 -> IO ())-mkIter ref = (iter, \f _ -> onF f iter)+mkIter :: IORef L.ByteString+ -> (Iteratee IO (), FilePath -> Int64 -> Int64 -> IO ())+mkIter ref = (iter, \f st sz -> onF f st sz iter) where iter = do x <- copyingStream2stream liftIO $ modifyIORef ref $ \s -> L.append s (fromWrap x) - onF f i = enumFile f i >>= run+ onF f st sz i = enumFilePartial f (st,st+sz) i >>= run testChunkOn1_0 :: Test@@ -726,47 +747,68 @@ testSendFile :: Test testSendFile = testCase "server/sendFile" $ do- tid <- forkIO $ httpServe "*" port "localhost"- Nothing Nothing $- runSnap sendFileFoo- waitabit+ bracket (forkIO $ httpServe "*" port "localhost"+ Nothing Nothing+ $ runSnap sendFileFoo)+ (killThread)+ (\tid -> do+ m <- timeout (120 * seconds) $ go tid + maybe (assertFailure "timeout")+ (const $ return ())+ m) - rsp <- HTTP.simpleHTTP (HTTP.getRequest "http://localhost:8123/")- doc <- HTTP.getResponseBody rsp+ where+ go tid = do+ waitabit+ + rsp <- HTTP.simpleHTTP (HTTP.getRequest "http://localhost:8123/")+ doc <- HTTP.getResponseBody rsp+ + killThread tid+ waitabit+ + assertEqual "sendFile" "FOO\n" doc - killThread tid- waitabit - assertEqual "sendFile" "FOO\n" doc-- where waitabit = threadDelay $ ((10::Int)^(6::Int))+ port = 8123 testServerStartupShutdown :: Test testServerStartupShutdown = testCase "server/startup/shutdown" $ do- tid <- forkIO $- httpServe "*"- port- "localhost"- (Just "test-access.log")- (Just "test-error.log")- (runSnap pongServer)- waitabit+ bracket (forkIO $+ httpServe "*"+ port+ "localhost"+ (Just "test-access.log")+ (Just "test-error.log")+ (runSnap pongServer))+ (killThread)+ (\tid -> do+ m <- timeout (120 * seconds) $ go tid + maybe (assertFailure "timeout")+ (const $ return ())+ m) - rsp <- HTTP.simpleHTTP (HTTP.getRequest "http://localhost:8145/")- doc <- HTTP.getResponseBody rsp- assertEqual "server" "PONG" doc - killThread tid- waitabit+ where+ go tid = do+ waitabit - expectException $ HTTP.simpleHTTP (HTTP.getRequest "http://localhost:8145/")+ rsp <- HTTP.simpleHTTP (HTTP.getRequest "http://localhost:8145/")+ doc <- HTTP.getResponseBody rsp+ assertEqual "server" "PONG" doc - return ()- where+ killThread tid+ waitabit++ expectException $ HTTP.simpleHTTP+ $ HTTP.getRequest "http://localhost:8145/"+ return ()+ waitabit = threadDelay $ 2*((10::Int)^(6::Int))+ port = 8145 @@ -803,14 +845,21 @@ putMVar result e - r <- takeMVar result+ e <- timeout (75*seconds) $ takeMVar result - case r of- (Left (_::SomeException)) -> return ()- (Right _) -> assertFailure "socket didn't get killed"+ case e of+ Nothing -> killThread tid >> assertFailure "timeout"+ (Just r) ->+ case r of+ (Left (_::SomeException)) -> return ()+ (Right _) -> assertFailure "socket didn't get killed" where waitabit = threadDelay $ 2*((10::Int)^(6::Int)) port = 8146 +++seconds :: Int+seconds = (10::Int) ^ (6::Int)
test/suite/Test/Blackbox.hs view
@@ -20,6 +20,7 @@ import Network.Socket import qualified Network.Socket.ByteString as N import Prelude hiding (take)+import System.Timeout import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2@@ -37,6 +38,7 @@ tests :: Int -> [Test] tests port = map ($ port) [ testPong+ , testHeadPong , testEcho , testRot13 , testSlowLoris@@ -71,12 +73,29 @@ HTTP.getResponseBody rsp +headPong :: Int -> IO String+headPong port = do+ let req = (HTTP.getRequest $ + "http://localhost:" ++ show port ++ "/pong")+ { HTTP.rqMethod = HTTP.HEAD }++ rsp <- HTTP.simpleHTTP req++ HTTP.getResponseBody rsp++ testPong :: Int -> Test testPong port = testCase "blackbox/pong" $ do doc <- doPong port assertEqual "pong response" "PONG" doc +testHeadPong :: Int -> Test+testHeadPong port = testCase "blackbox/pong/HEAD" $ do+ doc <- headPong port+ assertEqual "pong HEAD response" "" doc++ testEcho :: Int -> Test testEcho port = testProperty "blackbox/echo" $ monadicIO $ forAllM arbitrary prop@@ -122,6 +141,12 @@ 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"@@ -140,46 +165,72 @@ testBlockingRead :: Int -> Test testBlockingRead port = testCase "blackbox/testBlockingRead" $ withSock port $ \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"+ m <- timeout (60*seconds) $ go sock+ maybe (assertFailure "timeout")+ (const $ return ())+ m - resp <- recvAll sock+ where+ 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" - let s = head $ ditchHeaders $ S.lines resp+ resp <- recvAll sock - assertEqual "pong response" "PONG" s+ let s = head $ ditchHeaders $ S.lines resp + assertEqual "pong response" "PONG" s + -- test server's ability to trap/recover from IO errors testPartial :: Int -> Test testPartial port = testCase "blackbox/testPartial" $ do- withSock port $ \sock ->- N.sendAll sock "GET /pong HTTP/1.1\r\n"+ m <- timeout (60*seconds) go+ maybe (assertFailure "timeout")+ (const $ return ())+ m - doc <- doPong port- assertEqual "pong response" "PONG" doc + where+ go = do+ withSock port $ \sock ->+ N.sendAll sock "GET /pong HTTP/1.1\r\n" + doc <- doPong port+ assertEqual "pong response" "PONG" doc++ testBigResponse :: Int -> Test testBigResponse port = testCase "blackbox/testBigResponse" $ withSock port $ \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"+ m <- timeout (120*seconds) $ go sock+ maybe (assertFailure "timeout")+ (const $ return ())+ m+ + where+ 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 body = S.replicate 4000000 '.'+ resp <- recvAll sock - let s = head $ ditchHeaders $ S.lines resp+ let s = head $ ditchHeaders $ S.lines resp - assertBool "big response" $ body == s+ assertBool "big response" $ body == s ------------------------------------------------------------------------------ waitabit :: IO ()-waitabit = threadDelay $ 2*((10::Int)^(6::Int))+waitabit = threadDelay $ 2*seconds+++seconds :: Int+seconds = (10::Int) ^ (6::Int)