diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -1,6 +1,6 @@ Doug Beardsley Gregory Collins Shu-yu Guo -Carl Howells +Carl Howells James Sanders Jacob Stanley diff --git a/snap-server.cabal b/snap-server.cabal --- a/snap-server.cabal +++ b/snap-server.cabal @@ -1,5 +1,5 @@ name: snap-server -version: 0.2.6 +version: 0.2.7 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 @@ -111,8 +111,7 @@ monads-fd, network == 2.2.1.*, old-locale, - sendfile >= 0.6.1 && < 0.7, - snap-core >= 0.2.5 && <0.3, + snap-core >= 0.2.7 && <0.3, time, transformers, unix-compat, @@ -133,11 +132,23 @@ other-modules: Snap.Internal.Http.Server.SimpleBackend - if os(linux) - cpp-options: -DLINUX + if os(linux) && !flag(portable) + cpp-options: -DLINUX -DHAS_SENDFILE + other-modules: + System.SendFile, + System.SendFile.Linux - if os(darwin) - cpp-options: -DOSX + if os(darwin) && !flag(portable) + cpp-options: -DOSX -DHAS_SENDFILE + other-modules: + System.SendFile, + System.SendFile.Darwin + + if os(freebsd) && !flag(portable) + cpp-options: -DFREEBSD -DHAS_SENDFILE + other-modules: + System.SendFile, + System.SendFile.FreeBSD ghc-prof-options: -prof -auto-all diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs --- a/src/Snap/Internal/Http/Parser.hs +++ b/src/Snap/Internal/Http/Parser.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PackageImports #-} module Snap.Internal.Http.Parser ( IRequest(..) @@ -18,7 +19,7 @@ import Control.Applicative import Control.Arrow (second) import Control.Monad (liftM) -import Control.Monad.Trans +import "monads-fd" Control.Monad.Trans import Data.Attoparsec hiding (many, Result(..)) import Data.Attoparsec.Iteratee import Data.Bits @@ -30,6 +31,7 @@ import Data.Char import Data.List (foldl') import Data.Int +import Data.IORef import Data.Iteratee.WrappedByteString import Data.Map (Map) import qualified Data.Map as Map @@ -70,12 +72,13 @@ parseRequest = parserToIteratee pRequest -readChunkedTransferEncoding :: (Monad m) => Enumerator m a +readChunkedTransferEncoding :: (Monad m) => + Iteratee m a + -> m (Iteratee m a) readChunkedTransferEncoding iter = do - i <- chunkParserToEnumerator (parserToIteratee pGetTransferChunk) - iter - - return i + i <- chunkParserToEnumerator (parserToIteratee pGetTransferChunk) + iter + return i toHex :: Int64 -> ByteString @@ -110,37 +113,54 @@ -- > -- > Chunk "3\r\nfoo\r\n3\r\nbar\r\n4\r\nquux\r\n0\r\n\r\n" Empty -- + writeChunkedTransferEncoding :: ForeignPtr CChar -> Enumerator IO a -> Enumerator IO a -writeChunkedTransferEncoding _buf enum it = do - i' <- wrap it - --(i,_) <- unsafeBufferIterateeWithBuffer buf i' - (i,_) <- bufferIteratee i' - enum i +writeChunkedTransferEncoding buf enum it = do + killwrap <- newIORef False + --(out,_) <- bufferIteratee (ignoreEOF $ wrap killwrap it) + (out,_) <- unsafeBufferIterateeWithBuffer buf + (ignoreEOF $ wrap killwrap it) + i <- enum out + v <- runIter i (EOF Nothing) + j <- checkIfDone return v + writeIORef killwrap True + w <- runIter j (Chunk (WrapBS "0\r\n\r\n")) + checkIfDone return w where - wrap iter = return $ IterateeG $ \s -> + ignoreEOF iter = IterateeG $ \s -> case s of - (EOF Nothing) -> do - v <- runIter iter (Chunk $ toWrap "0\r\n\r\n") - i <- checkIfDone return v - runIter i (EOF Nothing) - (EOF e) -> return $ Cont undefined e - (Chunk (WrapBS x)) -> do - let n = S.length x - if n == 0 - then do - i' <- wrap iter - return $ Cont i' Nothing - else do - let o = S.concat [ toHex (toEnum n) - , "\r\n" - , x - , "\r\n" ] - v <- runIter iter (Chunk $ WrapBS o) - i <- checkIfDone wrap v - return $ Cont i Nothing + (EOF Nothing) -> return $ Cont iter Nothing + _ -> do + i <- runIter iter s >>= checkIfDone return + return $ Cont (ignoreEOF i) Nothing + + wrap killwrap iter = IterateeG $ \s -> do + quit <- readIORef killwrap + + if quit + then runIter iter s + else case s of + (EOF Nothing) -> do + --S.putStrLn "wrap: eof" + return $ Cont iter Nothing + + (EOF e) -> return $ Cont undefined e + (Chunk (WrapBS x)) -> do + --S.putStrLn $ S.concat ["wrap: got ", x] + let n = S.length x + if n == 0 + then do + return $ Cont iter Nothing + else do + let o = S.concat [ toHex (toEnum n) + , "\r\n" + , x + , "\r\n" ] + i <- liftM liftI $ runIter iter (Chunk $ WrapBS o) + return $ Cont (wrap killwrap i) Nothing chunkParserToEnumerator :: (Monad m) => diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs --- a/src/Snap/Internal/Http/Server.hs +++ b/src/Snap/Internal/Http/Server.hs @@ -18,6 +18,7 @@ import qualified Data.ByteString.Lazy as L import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Nums.Careless.Int as Cvt +import Data.Int import Data.IORef import Data.List (foldl') import qualified Data.Map as Map @@ -26,7 +27,6 @@ import Data.Version import Foreign.C.Types import Foreign.ForeignPtr -import Foreign.Ptr (nullPtr) import GHC.Conc import Prelude hiding (catch, show, Show) import qualified Prelude @@ -244,18 +244,18 @@ ------------------------------------------------------------------------------ -runHTTP :: ByteString -- ^ local host name - -> ByteString -- ^ local ip address - -> Int -- ^ local port - -> ByteString -- ^ remote ip address - -> Int -- ^ remote port - -> Maybe Logger -- ^ access logger - -> Maybe Logger -- ^ error logger - -> Enumerator IO () -- ^ read end of socket - -> Iteratee IO () -- ^ write end of socket - -> (FilePath -> IO ()) -- ^ sendfile end - -> IO () -- ^ timeout tickler - -> ServerHandler -- ^ handler procedure +runHTTP :: ByteString -- ^ local host name + -> ByteString -- ^ local ip address + -> Int -- ^ local port + -> ByteString -- ^ remote ip address + -> Int -- ^ remote port + -> Maybe Logger -- ^ access logger + -> Maybe Logger -- ^ error logger + -> Enumerator IO () -- ^ read end of socket + -> Iteratee IO () -- ^ write end of socket + -> (FilePath -> Int64 -> IO ()) -- ^ sendfile end + -> IO () -- ^ timeout tickler + -> ServerHandler -- ^ handler procedure -> IO () runHTTP lh lip lp rip rp alog elog readEnd writeEnd onSendFile tickle handler = @@ -271,8 +271,7 @@ logPrefix = S.concat [ "[", rip, "]: error: " ] go = do - --buf <- mkIterateeBuffer - buf <- newForeignPtr_ nullPtr + buf <- mkIterateeBuffer let iter = runServerMonad lh lip lp rip rp (logA alog) (logE elog) $ httpSession writeEnd buf onSendFile tickle handler @@ -296,18 +295,18 @@ ------------------------------------------------------------------------------ -- | Runs an HTTP session. -httpSession :: Iteratee IO () -- ^ write end of socket - -> ForeignPtr CChar -- ^ iteratee buffer - -> (FilePath -> IO ()) -- ^ sendfile continuation - -> IO () -- ^ timeout tickler - -> ServerHandler -- ^ handler procedure +httpSession :: Iteratee IO () -- ^ write end of socket + -> ForeignPtr CChar -- ^ iteratee buffer + -> (FilePath -> Int64 -> IO ()) -- ^ sendfile continuation + -> IO () -- ^ timeout tickler + -> ServerHandler -- ^ handler procedure -> ServerMonad () httpSession writeEnd' ibuf onSendFile tickle handler = do - -- (writeEnd, cancelBuffering) <- - -- liftIO $ I.unsafeBufferIterateeWithBuffer ibuf writeEnd' + (writeEnd, cancelBuffering) <- + liftIO $ I.unsafeBufferIterateeWithBuffer ibuf writeEnd' - (writeEnd, cancelBuffering) <- liftIO $ I.bufferIteratee writeEnd' + -- (writeEnd, cancelBuffering) <- liftIO $ I.bufferIteratee writeEnd' let killBuffer = writeIORef cancelBuffering True @@ -353,7 +352,7 @@ if cc then return () - else httpSession writeEnd ibuf onSendFile tickle handler + else httpSession writeEnd' ibuf onSendFile tickle handler Nothing -> return () @@ -420,7 +419,7 @@ doIt = mbCT == Just "application/x-www-form-urlencoded" mbCT = liftM head $ Map.lookup "content-type" (rqHeaders req) - maximumPOSTBodySize :: Int + maximumPOSTBodySize :: Int64 maximumPOSTBodySize = 10*1024*1024 getIt :: ServerMonad Request @@ -512,8 +511,8 @@ -> Iteratee IO a -> ForeignPtr CChar -> IO () - -> (FilePath -> IO a) - -> ServerMonad (Int,a) + -> (FilePath -> Int64 -> IO a) + -> ServerMonad (Int64, a) sendResponse rsp' writeEnd ibuf killBuffering onSendFile = do rsp <- fixupResponse rsp' let !headerString = mkHeaderString rsp @@ -527,7 +526,8 @@ where whenEnum hs e = do let enum = enumBS hs >. e - let hl = S.length hs + let hl = fromIntegral $ S.length hs + (x,bs) <- liftIO $ enum (countBytes writeEnd) >>= run return (x, bs-hl) @@ -537,7 +537,7 @@ enumBS hs writeEnd >>= run let !cl = fromJust $ rspContentLength r - x <- onSendFile f + x <- onSendFile f cl return (x, cl) (major,minor) = rspHttpVersion rsp' @@ -575,7 +575,7 @@ return $ setHeader "Connection" "close" r - hasCL :: Int -> Response -> ServerMonad Response + hasCL :: Int64 -> Response -> ServerMonad Response hasCL cl r = {-# SCC "hasCL" #-} do @@ -596,21 +596,33 @@ setFileSize fp r = {-# SCC "setFileSize" #-} do - fs <- liftM fromEnum $ liftIO $ getFileSize fp + fs <- liftM fromIntegral $ liftIO $ getFileSize fp return $ r { rspContentLength = Just fs } + handle304 :: Response -> Response + handle304 r = setResponseBody (enumBS "") $ + updateHeaders (Map.delete "Transfer-Encoding") $ + setContentLength 0 r + fixupResponse :: Response -> ServerMonad Response fixupResponse r = {-# SCC "fixupResponse" #-} do let r' = updateHeaders (Map.delete "Content-Length") 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'' + + let code = rspStatus 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''' bsshow = l2s . show diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs b/src/Snap/Internal/Http/Server/LibevBackend.hs --- a/src/Snap/Internal/Http/Server/LibevBackend.hs +++ b/src/Snap/Internal/Http/Server/LibevBackend.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PackageImports #-} module Snap.Internal.Http.Server.LibevBackend ( Backend @@ -31,51 +33,60 @@ --------------------------- ------------------------------------------------------------------------------ -import Control.Concurrent -import Control.Exception -import Control.Monad -import Control.Monad.Trans -import Data.ByteString (ByteString) -import Data.ByteString.Internal (c2w, w2c) -import qualified Data.ByteString.Unsafe as B -import qualified Data.ByteString as B -import Data.IORef -import Data.Iteratee.WrappedByteString -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Typeable -import Foreign hiding (new) -import Foreign.C.Error -import Foreign.C.Types -import GHC.Conc (forkOnIO) -import Network.Libev -import Network.Socket -import qualified Network.Socket.SendFile as SF -import Prelude hiding (catch) -import System.Timeout +import Control.Concurrent +import Control.Exception +import Control.Monad +import "monads-fd" Control.Monad.Trans +import Data.ByteString (ByteString) +import Data.ByteString.Internal (c2w, w2c) +import qualified Data.ByteString.Unsafe as B +import qualified Data.ByteString as B +import Data.DList (DList) +import qualified Data.DList as D +import Data.IORef +import Data.Iteratee.WrappedByteString +import qualified Data.List as List +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Typeable +import Foreign hiding (new) +import Foreign.C.Error +import Foreign.C.Types +import GHC.Conc (forkOnIO) +import Network.Libev +import Network.Socket +import Prelude hiding (catch) +import System.Timeout ------------------------------------------------------------------------------ -import Snap.Iteratee -import Snap.Internal.Debug +import Snap.Iteratee +import Snap.Internal.Debug +import Snap.Internal.Http.Server.Date +#if defined(HAS_SENDFILE) +import qualified System.SendFile as SF +import System.Posix.IO +import System.Posix.Types (Fd(..)) +#endif data Backend = Backend - { _acceptSocket :: Socket - , _acceptFd :: CInt - , _connectionQueue :: Chan CInt - , _evLoop :: EvLoopPtr - , _acceptIOCallback :: FunPtr IoCallback - , _acceptIOObj :: EvIoPtr - - -- FIXME: we don't need _loopThread - , _loopThread :: MVar ThreadId - , _mutexCallbacks :: (FunPtr MutexCallback, FunPtr MutexCallback) - , _loopLock :: MVar () - , _asyncCb :: FunPtr AsyncCallback - , _asyncObj :: EvAsyncPtr - , _killCb :: FunPtr AsyncCallback - , _killObj :: EvAsyncPtr - , _connectionThreads :: MVar (Set ThreadId) - , _backendCPU :: Int + { _acceptSocket :: !Socket + , _acceptFd :: !CInt + , _connectionQueue :: !(Chan CInt) + , _evLoop :: !EvLoopPtr + , _acceptIOCallback :: !(FunPtr IoCallback) + , _acceptIOObj :: !EvIoPtr + , _mutexCallbacks :: !(FunPtr MutexCallback, FunPtr MutexCallback) + , _loopLock :: !(MVar ()) + , _asyncCb :: !(FunPtr AsyncCallback) + , _asyncObj :: !EvAsyncPtr + , _killCb :: !(FunPtr AsyncCallback) + , _killObj :: !EvAsyncPtr + , _connectionThreads :: !(MVar (Set ThreadId)) + , _connThreadEdits :: !(IORef (DList (Set ThreadId -> Set ThreadId))) + , _connThreadId :: !(MVar ThreadId) + , _connThreadIsDone :: !(MVar ()) + , _threadActivity :: !(MVar ()) + , _backendCPU :: !Int } @@ -91,6 +102,7 @@ , _writeAvailable :: !(MVar ()) , _timerObj :: !EvTimerPtr , _timerCallback :: !(FunPtr TimerCallback) + , _timerTimeoutTime :: !(IORef CTime) , _readActive :: !(IORef Bool) , _writeActive :: !(IORef Bool) , _connReadIOObj :: !EvIoPtr @@ -105,15 +117,27 @@ name = "libev" -sendFile :: Connection -> FilePath -> IO () -sendFile c fp = do +sendFile :: Connection -> FilePath -> Int64 -> IO () +#if defined(HAS_SENDFILE) +sendFile c fp sz = do +#else +sendFile c fp _ = do +#endif withMVar lock $ \_ -> do act <- readIORef $ _writeActive c when act $ evIoStop loop io writeIORef (_writeActive c) False evAsyncSend loop asy - SF.sendFile s fp +#if defined(HAS_SENDFILE) + bracket (openFd fp ReadOnly Nothing defaultFileFlags) + (closeFd) + (go 0 sz) +#else + -- no need to count bytes + enumFile fp (getWriteEnd c) >>= run + return () +#endif withMVar lock $ \_ -> do tryTakeMVar $ _readAvailable c @@ -121,7 +145,17 @@ evAsyncSend loop asy where - s = _socket c +#if defined(HAS_SENDFILE) + go off bytes fd + | bytes == 0 = return () + | otherwise = do + sent <- SF.sendFile sfd fd off bytes + if sent < bytes + then tickleTimeout c >> go (off+sent) (bytes-sent) fd + else return () + + sfd = Fd $ _socketFd c +#endif io = _connWriteIOObj c b = _backend c loop = _evLoop b @@ -184,10 +218,12 @@ evIoInit accIO accCB sockFd ev_read evIoStart lp accIO - -- an MVar for the loop thread, and one to keep track of the set of active - -- threads - threadMVar <- newEmptyMVar - threadSetMVar <- newMVar Set.empty + -- thread set stuff + connThreadMVar <- newEmptyMVar + connSet <- newMVar Set.empty + editsRef <- newIORef D.empty + connThreadDone <- newEmptyMVar + threadActivity <- newMVar () let b = Backend sock sockFd @@ -195,19 +231,24 @@ lp accCB accIO - threadMVar (mc1,mc2) looplock asyncCB asyncObj killCB killObj - threadSetMVar + connSet + editsRef + connThreadMVar + connThreadDone + threadActivity cpu - tid <- forkOnIO cpu $ loopThread b - putMVar threadMVar tid + forkOnIO cpu $ loopThread b + conntid <- forkOnIO cpu $ connTableSeqThread b + putMVar connThreadMVar conntid + debug $ "Backend.new: loop spawned" return b @@ -229,7 +270,7 @@ acceptCallback :: CInt -> Chan CInt -> IoCallback acceptCallback accFd chan _loopPtr _ioPtr _ = do - debug "inside acceptCallback" + debug "inside acceptCallback" r <- c_accept accFd case r of @@ -292,7 +333,7 @@ debug $ "Backend.stop: waiting at most 10 seconds for connection threads to die" waitForThreads b $ seconds 10 - debug $ "Backend.stop: all threads dead, unlooping" + debug $ "Backend.stop: all threads presumed dead, unlooping" withMVar lock $ \_ -> do -- FIXME: hlibev should export EVUNLOOP_ALL @@ -335,17 +376,44 @@ -- | throw a timeout exception to the handling thread -- it'll clean up -- everything -timerCallback :: MVar ThreadId -> TimerCallback -timerCallback tmv _ _ _ = do - debug "timer callback" - tid <- readMVar tmv - throwTo tid TimeoutException +timerCallback :: MVar () -- ^ loop lock + -> EvLoopPtr -- ^ loop obj + -> EvTimerPtr -- ^ timer obj + -> IORef CTime -- ^ when to timeout? + -> MVar ThreadId -- ^ thread to kill + -> TimerCallback +timerCallback lock loop tmr ioref tmv _ _ _ = do + debug "Backend.timerCallback: entered" + now <- getCurrentDateTime + whenToDie <- readIORef ioref + if whenToDie < now + then do + debug "Backend.timerCallback: killing thread" + tid <- readMVar tmv + throwTo tid TimeoutException + + else withMVar lock $ \_ -> do -- re-arm the timer + -- fixme: should set repeat here, have to wait for an hlibev patch to + -- do it + evTimerAgain loop tmr + + +addThreadSetEdit :: Backend -> (Set ThreadId -> Set ThreadId) -> IO () +addThreadSetEdit backend edit = do + atomicModifyIORef (_connThreadEdits backend) $ \els -> + (D.snoc els edit, ()) + + tryPutMVar (_threadActivity backend) () + return () + + freeConnection :: Connection -> IO () freeConnection conn = ignoreException $ do withMVar loopLock $ \_ -> block $ do debug $ "freeConnection (" ++ show fd ++ ")" + c_close fd -- stop and free timer object @@ -362,24 +430,21 @@ freeEvIo ioRdObj freeIoCallback ioRdCb - -- remove the thread id from the backend set - tid <- readMVar threadMVar - modifyMVar_ tsetMVar $ \s -> do - let !s' = Set.delete tid s - return $! s' + tid <- readMVar $ _connThread conn + -- schedule the removal of the thread id from the backend set + addThreadSetEdit backend (Set.delete tid) + -- wake up the event loop so it can be apprised of the changes evAsyncSend loop asyncObj where backend = _backend conn - tsetMVar = _connectionThreads backend loop = _evLoop backend loopLock = _loopLock backend asyncObj = _asyncObj backend fd = _socketFd conn - threadMVar = _connThread conn ioWrObj = _connWriteIOObj conn ioWrCb = _connWriteIOCallback conn ioRdObj = _connReadIOObj conn @@ -392,18 +457,48 @@ ignoreException = handle (\(_::SomeException) -> return ()) +connTableSeqThread :: Backend -> IO () +connTableSeqThread backend = loop `finally` putMVar threadDone () + where + threadDone = _connThreadIsDone backend + editsRef = _connThreadEdits backend + table = _connectionThreads backend + activity = _threadActivity backend + + loop = do + takeMVar activity + + -- grab the edits + edits <- atomicModifyIORef editsRef $ \t -> (D.empty, D.toList t) + + -- apply the edits + modifyMVar_ table $ \t -> block $ do + let !t' = List.foldl' (flip ($)) t edits + return t' + + -- zzz + threadDelay 1000000 + loop + + freeBackend :: Backend -> IO () freeBackend backend = ignoreException $ block $ do -- note: we only get here after an unloop - withMVar tsetMVar $ \set -> do - mapM_ killThread $ Set.toList set + readMVar (_connThreadId backend) >>= killThread + takeMVar $ _connThreadIsDone backend - debug $ "Backend.freeBackend: wait at most 2 seconds for threads to die" - waitForThreads backend $ seconds 2 + -- read edits and obtain final thread table + threads <- withMVar (_connectionThreads backend) $ \table -> do + edits <- liftM D.toList $ + readIORef (_connThreadEdits backend) - debug $ "Backend.freeBackend: all threads dead" + let !t = List.foldl' (flip ($)) table edits + return $ Set.toList t + mapM_ killThread threads + + debug $ "Backend.freeBackend: all threads killed" debug $ "Backend.freeBackend: destroying resources" freeEvIo acceptObj freeIoCallback acceptCb @@ -427,7 +522,6 @@ fd = _acceptFd backend acceptObj = _acceptIOObj backend acceptCb = _acceptIOCallback backend - tsetMVar = _connectionThreads backend asyncObj = _asyncObj backend asyncCb = _asyncCb backend killObj = _killObj backend @@ -468,11 +562,23 @@ ra <- newMVar () wa <- newMVar () - tmr <- mkEvTimer - thrmv <- newEmptyMVar - tcb <- mkTimerCallback $ timerCallback thrmv + + ----------------- + -- setup timer -- + ----------------- + tmr <- mkEvTimer + thrmv <- newEmptyMVar + now <- getCurrentDateTime + timeoutTime <- newIORef $ now + 20 + tcb <- mkTimerCallback $ timerCallback (_loopLock backend) + lp + tmr + timeoutTime + thrmv + -- 20 second timeout evTimerInit tmr tcb 0 20.0 + readActive <- newIORef True writeActive <- newIORef True @@ -506,6 +612,7 @@ wa tmr tcb + timeoutTime readActive writeActive evioRead @@ -517,13 +624,10 @@ tid <- forkOnIO cpu $ threadProc conn - modifyMVar_ (_connectionThreads backend) $ ins tid + addThreadSetEdit backend (Set.insert tid) putMVar thrmv tid - where - ins !thr !s = let !r = Set.insert thr s in return (r `seq` r) - data BackendTerminatedException = BackendTerminatedException deriving (Typeable) @@ -592,12 +696,9 @@ tickleTimeout :: Connection -> IO () tickleTimeout conn = do debug "Backend.tickleTimeout" - withMVar (_loopLock bk) $ \_ -> evTimerAgain lp tmr + now <- getCurrentDateTime + writeIORef (_timerTimeoutTime conn) (now + 20) - where - bk = _backend conn - lp = _evLoop bk - tmr = _timerObj conn recvData :: Connection -> Int -> IO ByteString recvData conn n = do diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hs b/src/Snap/Internal/Http/Server/SimpleBackend.hs --- a/src/Snap/Internal/Http/Server/SimpleBackend.hs +++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs @@ -1,9 +1,11 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PackageImports #-} module Snap.Internal.Http.Server.SimpleBackend ( Backend @@ -27,13 +29,18 @@ ) where ------------------------------------------------------------------------------ +import "monads-fd" Control.Monad.Trans + import Control.Concurrent import Control.Exception -import Control.Monad.Trans import Data.ByteString (ByteString) import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString as B +import Data.DList (DList) +import qualified Data.DList as D +import Data.IORef import Data.Iteratee.WrappedByteString +import Data.List (foldl') import qualified Data.PSQueue as PSQ import Data.PSQueue (PSQ) import Data.Typeable @@ -42,14 +49,19 @@ import GHC.Conc (labelThread, forkOnIO) import Network.Socket import qualified Network.Socket.ByteString as SB -import qualified Network.Socket.SendFile as SF import Prelude hiding (catch) ------------------------------------------------------------------------------ import Snap.Internal.Debug import Snap.Internal.Http.Server.Date -import Snap.Iteratee +import Snap.Iteratee hiding (foldl') +#if defined(HAS_SENDFILE) +import qualified System.SendFile as SF +import System.Posix.IO +import System.Posix.Types (Fd(..)) +#endif + data BackendTerminatedException = BackendTerminatedException deriving (Typeable) @@ -58,10 +70,12 @@ instance Exception BackendTerminatedException +type TimeoutTable = PSQ ThreadId CTime + data Backend = Backend - { _acceptSocket :: Socket - , _timeoutTable :: MVar (PSQ ThreadId CTime) - , _timeoutThread :: MVar ThreadId } + { _acceptSocket :: !Socket + , _timeoutEdits :: !(IORef (DList (TimeoutTable -> TimeoutTable))) + , _timeoutThread :: !(MVar ThreadId) } data Connection = Connection { _backend :: Backend @@ -77,12 +91,30 @@ name = "simple" -sendFile :: Connection -> FilePath -> IO () -sendFile c fp = do - let s = _socket c - SF.sendFile s fp +sendFile :: Connection -> FilePath -> Int64 -> IO () +#if defined(HAS_SENDFILE) +sendFile c fp sz = do + bracket (openFd fp ReadOnly Nothing defaultFileFlags) + (closeFd) + (go 0 sz) + where + go off bytes fd + | bytes == 0 = return () + | otherwise = do + sent <- SF.sendFile sfd fd off bytes + if sent < bytes + then tickleTimeout c >> go (off+sent) (bytes-sent) fd + else return () + sfd = Fd . fdSocket $ _socket c +#else +sendFile c fp _ = do + -- no need to count bytes + enumFile fp (getWriteEnd c) >>= run + return () +#endif + bindIt :: ByteString -- ^ bind address, or \"*\" for all -> Int -- ^ port to bind to -> IO Socket @@ -101,29 +133,33 @@ new sock _ = do debug $ "Backend.new: listening" - mv <- newMVar PSQ.empty + ed <- newIORef D.empty t <- newEmptyMVar - let b = Backend sock mv t + let b = Backend sock ed t - tid <- forkIO $ timeoutThread b + tid <- forkIO $ timeoutThread b PSQ.empty putMVar t tid return b -timeoutThread :: Backend -> IO () +timeoutThread :: Backend -> TimeoutTable -> IO () timeoutThread backend = loop where - loop = do - killTooOld + loop tt = do + tt' <- killTooOld tt threadDelay (5000000) - loop + loop tt' - killTooOld = modifyMVar_ tmvar $ \table -> do - now <- getCurrentDateTime - !t' <- killOlderThan now table + killTooOld table = do + -- atomic swap edit list + now <- getCurrentDateTime + edits <- atomicModifyIORef tedits $ \t -> (D.empty, D.toList t) + + let table' = foldl' (flip ($)) table edits + !t' <- killOlderThan now table' return t' @@ -140,7 +176,7 @@ else return table) mmin - tmvar = _timeoutTable backend + tedits = _timeoutEdits backend stop :: Backend -> IO () @@ -201,8 +237,8 @@ thr <- readMVar tmvar -- remove thread from timeout table - modifyMVar_ (_timeoutTable backend) $ - return . PSQ.delete thr + atomicModifyIORef (_timeoutEdits backend) $ + \es -> (D.snoc es (PSQ.delete thr), ()) eatException $ shutdown sock ShutdownBoth eatException $ sClose sock ) @@ -265,14 +301,25 @@ tickleTimeout :: Connection -> IO () -tickleTimeout conn = modifyMVar_ ttmvar $ \t -> do +tickleTimeout conn = do + debug "Backend.tickleTimeout" now <- getCurrentDateTime tid <- readMVar $ _connTid conn - let !t' = PSQ.insert tid now t - return t' + atomicModifyIORef tedits $ \es -> (D.snoc es (PSQ.insert tid now), ()) + where - ttmvar = _timeoutTable $ _backend conn + tedits = _timeoutEdits $ _backend conn + + +cancelTimeout :: Connection -> IO () +cancelTimeout conn = do + tid <- readMVar $ _connTid conn + + atomicModifyIORef tedits $ \es -> (D.snoc es (PSQ.delete tid), ()) + + where + tedits = _timeoutEdits $ _backend conn timeoutRecv :: Connection -> Int -> IO ByteString diff --git a/src/System/FastLogger.hs b/src/System/FastLogger.hs --- a/src/System/FastLogger.hs +++ b/src/System/FastLogger.hs @@ -20,6 +20,7 @@ import Data.ByteString.Internal (c2w) import Data.DList (DList) import qualified Data.DList as D +import Data.Int import Data.IORef import Data.Maybe import Data.Serialize.Put @@ -74,7 +75,7 @@ -> ByteString -- ^ request line (up to you to ensure -- there are no quotes in here) -> Int -- ^ status code - -> Maybe Int -- ^ num bytes sent + -> Maybe Int64 -- ^ num bytes sent -> Maybe ByteString -- ^ referer (up to you to ensure -- there are no quotes in here) -> ByteString -- ^ user agent (up to you to ensure diff --git a/src/System/SendFile.hs b/src/System/SendFile.hs new file mode 100644 --- /dev/null +++ b/src/System/SendFile.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP #-} + +-- | Snap's unified interface to sendfile. +-- Modified from sendfile 0.6.1 + +module System.SendFile + ( sendFile + , sendFileMode + ) where + +#if defined(LINUX) +import System.SendFile.Linux (sendFile) + +sendFileMode :: String +sendFileMode = "LINUX_SENDFILE" +#elif defined(FREEBSD) +import System.SendFile.FreeBSD (sendFile) + +sendFileMode :: String +sendFileMode = "FREEBSD_SENDFILE" +#elif defined(OSX) +import System.SendFile.Darwin (sendFile) + +sendFileMode :: String +sendFileMode = "DARWIN_SENDFILE" +#endif diff --git a/src/System/SendFile/Darwin.hsc b/src/System/SendFile/Darwin.hsc new file mode 100644 --- /dev/null +++ b/src/System/SendFile/Darwin.hsc @@ -0,0 +1,41 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +-- | Darwin system-dependent code for 'sendfile'. +module System.SendFile.Darwin (sendFile) where + +import Data.Int +import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno) +import Foreign.C.Types (CInt) +import Foreign.Marshal (alloca) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (peek, poke) +import System.Posix.Types (Fd, COff) + +sendFile :: Fd -> Fd -> Int64 -> Int64 -> IO Int64 +sendFile out_fd in_fd off count + | count == 0 = return 0 + | otherwise = alloca $ \pbytes -> do + poke pbytes $ min maxBytes (fromIntegral count) + sbytes <- sendfile out_fd in_fd (fromIntegral off) pbytes + return $ fromIntegral sbytes + +sendfile :: Fd -> Fd -> COff -> Ptr COff -> IO COff +sendfile out_fd in_fd off pbytes = do + status <- c_sendfile out_fd in_fd off pbytes + nsent <- peek pbytes + if status == 0 + then return nsent + else do errno <- getErrno + if (errno == eAGAIN) || (errno == eINTR) + then return nsent + else throwErrno "System.SendFile.Darwin" + +-- max num of bytes in one send +maxBytes :: COff +maxBytes = maxBound :: COff + +-- in Darwin sendfile gives LFS support (no sendfile64 routine) +foreign import ccall unsafe "sys/uio.h sendfile" c_sendfile_darwin + :: Fd -> Fd -> COff -> Ptr COff -> Ptr () -> CInt -> IO CInt + +c_sendfile :: Fd -> Fd -> COff -> Ptr COff -> IO CInt +c_sendfile out_fd in_fd off pbytes = c_sendfile_darwin in_fd out_fd off pbytes nullPtr 0 diff --git a/src/System/SendFile/FreeBSD.hsc b/src/System/SendFile/FreeBSD.hsc new file mode 100644 --- /dev/null +++ b/src/System/SendFile/FreeBSD.hsc @@ -0,0 +1,38 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +-- | FreeBSD system-dependent code for 'sendfile'. +module System.SendFile.FreeBSD (sendFile) where + +import Data.Int +import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno) +import Foreign.C.Types (CInt, CSize) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (peek) +import System.Posix.Types (COff, Fd) + +sendFile :: Fd -> Fd -> Int64 -> Int64 -> IO Int64 +sendFile out_fd in_fd off count + | count == 0 = return 0 + | otherwise = alloca $ \pbytes -> do + sbytes <- sendfile out_fd in_fd (fromIntegral off) + (fromIntegral count) pbytes + return $ fromIntegral sbytes + +sendfile :: Fd -> Fd -> COff -> CSize -> Ptr COff -> IO COff +sendfile out_fd in_fd off count pbytes = + do threadWaitWrite out_fd + res <- c_sendfile_freebsd in_fd out_fd off count nullPtr pbytes 0 + nsent <- peek pbytes + if (res == 0) + then return nsent + else do errno <- getErrno + if (errno == eAGAIN) || (errno == eINTR) + then return nsent + else throwErrno "System.SendFile.FreeBSD.sendfile" + +-- max num of bytes in one send +maxBytes :: CSize +maxBytes = maxBound :: CSize + +foreign import ccall unsafe "sys/uio.h sendfile" c_sendfile_freebsd + :: Fd -> Fd -> COff -> CSize -> Ptr () -> Ptr COff -> CInt -> IO CInt diff --git a/src/System/SendFile/Linux.hsc b/src/System/SendFile/Linux.hsc new file mode 100644 --- /dev/null +++ b/src/System/SendFile/Linux.hsc @@ -0,0 +1,42 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +-- | Linux system-dependent code for 'sendfile'. +module System.SendFile.Linux (sendFile) where + +import Data.Int +import Foreign.C.Error (eAGAIN, getErrno, throwErrno) +import Foreign.C.Types (CSize) +import Foreign.Marshal (alloca) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (poke) +import System.Posix.Types (Fd, COff, CSsize) + +sendFile :: Fd -> Fd -> Int64 -> Int64 -> IO Int64 +sendFile out_fd in_fd off count + | count == 0 = return 0 + | off == 0 = do + sbytes <- sendfile out_fd in_fd nullPtr bytes + return $ fromIntegral sbytes + | otherwise = alloca $ \poff -> do + poke poff (fromIntegral off) + sbytes <- sendfile out_fd in_fd poff bytes + return $ fromIntegral sbytes + where + bytes = min (fromIntegral count) maxBytes + +sendfile :: Fd -> Fd -> Ptr COff -> CSize -> IO CSsize +sendfile out_fd in_fd poff bytes = do + nsent <- c_sendfile out_fd in_fd poff bytes + if nsent <= -1 + then do errno <- getErrno + if errno == eAGAIN + then sendfile out_fd in_fd poff bytes + else throwErrno "System.SendFile.Linux" + else return nsent + +-- max num of bytes in one send +maxBytes :: CSize +maxBytes = maxBound :: CSize + +-- sendfile64 gives LFS support +foreign import ccall unsafe "sys/sendfile.h sendfile64" c_sendfile + :: Fd -> Fd -> Ptr COff -> CSize -> IO CSsize diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal --- a/test/snap-server-testsuite.cabal +++ b/test/snap-server-testsuite.cabal @@ -34,12 +34,12 @@ HTTP >= 4000.0.9 && < 4001, HUnit >= 1.2 && < 2, monads-fd, - network == 2.2.1.*, + network == 2.2.1.7, network-bytestring >= 0.1.2 && < 0.2, old-locale, parallel > 2, iteratee >= 0.3.1 && < 0.4, - snap-core >= 0.2.1 && <0.3, + snap-core >= 0.2.7 && <0.3, test-framework >= 0.3.1 && <0.4, test-framework-hunit >= 0.2.5 && < 0.3, test-framework-quickcheck2 >= 0.2.6 && < 0.3, @@ -91,16 +91,17 @@ old-locale, parallel > 2, iteratee >= 0.3.1 && < 0.4, - network == 2.2.1.*, + network == 2.2.1.7, network-bytestring >= 0.1.2 && < 0.2, - sendfile >= 0.6.1 && < 0.7, - snap-core >= 0.2.1 && <0.3, + snap-core >= 0.2.7 && <0.3, time, transformers, unix-compat, vector >= 0.6.0.1 && < 0.7 - if !os(windows) + if flag(portable) || os(windows) + cpp-options: -DPORTABLE + else build-depends: unix if flag(libev) @@ -113,15 +114,37 @@ other-modules: Snap.Internal.Http.Server.SimpleBackend - if os(linux) - cpp-options: -DLINUX + if os(linux) && !flag(portable) + cpp-options: -DLINUX -DHAS_SENDFILE + other-modules: + System.SendFile, + System.SendFile.Linux - if os(darwin) - cpp-options: -DOSX + if os(darwin) && !flag(portable) + cpp-options: -DOSX -DHAS_SENDFILE + other-modules: + System.SendFile, + System.SendFile.Darwin + if os(freebsd) && !flag(portable) + cpp-options: -DFREEBSD -DHAS_SENDFILE + other-modules: + System.SendFile, + System.SendFile.FreeBSD + if flag(portable) || os(windows) cpp-options: -DPORTABLE ghc-options: -Wall -O2 -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind ghc-prof-options: -prof -auto-all + +Executable benchmark + hs-source-dirs: benchmark ../src + main-is: Benchmark.hs + build-depends: + base >= 4 && < 5, + network == 2.2.1.7, + HTTP >= 4000.0.9 && < 4001, + criterion == 0.5.0.0 + diff --git a/test/suite/Snap/Internal/Http/Parser/Tests.hs b/test/suite/Snap/Internal/Http/Parser/Tests.hs --- a/test/suite/Snap/Internal/Http/Parser/Tests.hs +++ b/test/suite/Snap/Internal/Http/Parser/Tests.hs @@ -15,6 +15,9 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.ByteString.Internal (c2w) +import Data.IORef +import Data.Iteratee.WrappedByteString +import Data.List import qualified Data.Map as Map import Data.Maybe (isNothing) import Test.Framework @@ -28,7 +31,7 @@ import Snap.Internal.Http.Parser import Snap.Internal.Http.Types hiding (Enumerator) -import Snap.Iteratee +import Snap.Iteratee hiding (foldl') import Snap.Test.Common() @@ -37,6 +40,10 @@ , testCookie , testChunked , testBothChunked + , testBothChunkedBuffered1 + , testBothChunkedBuffered2 + , testBothChunkedPipelined + , testBothChunkedEmpty , testP2I , testNull , testPartial @@ -147,18 +154,176 @@ prop s = do buf <- QC.run mkIterateeBuffer bs <- QC.run $ - writeChunkedTransferEncoding buf (enumLBS s) stream2stream - >>= run >>= return . fromWrap + writeChunkedTransferEncoding buf (enumBS s) stream2stream + >>= run >>= return . unWrap - let enum = enumLBS bs + let enum = enumBS bs iter <- do i <- (readChunkedTransferEncoding stream2stream) >>= enum - return $ liftM fromWrap i + return $ liftM unWrap i x <- run iter QC.assert $ s == x + +testBothChunkedBuffered1 :: Test +testBothChunkedBuffered1 = testProperty "testBothChunkedBuffered1" $ + monadicIO prop + where + prop = do + sz <- QC.pick (choose (1000,4000)) + s' <- QC.pick $ resize sz arbitrary + ntimes <- QC.pick (choose (4,7)) + + let e = enumLBS s' + + buf <- QC.run mkIterateeBuffer + + enums <- QC.run $ + replicateM ntimes + (mkIterateeBuffer >>= + return . flip writeChunkedTransferEncoding e) + + let mothra = foldl' (>.) (enumBS "") enums + + ---------------------------------------------------------------------- + -- first go, buffer, no cancellation + (inputIter1,_) <- QC.run $ bufferIteratee stream2stream + bs1 <- QC.run $ mothra inputIter1 + >>= run >>= return . unWrap + let e1 = enumBS bs1 + let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s + iters <- QC.run $ + replicateM ntimes $ + readChunkedTransferEncoding stream2stream + let godzilla = sequence $ map (>>= pcrlf) iters + outiter1 <- QC.run $ e1 godzilla + x1 <- QC.run $ liftM (map unWrap) $ run outiter1 + + QC.assert $ + (map (L.fromChunks . (:[])) x1) == (replicate ntimes s') + + + +testBothChunkedBuffered2 :: Test +testBothChunkedBuffered2 = testProperty "testBothChunkedBuffered2" $ + monadicIO prop + where + prop = do + sz <- QC.pick (choose (1000,4000)) + s' <- QC.pick $ resize sz arbitrary + ntimes <- QC.pick (choose (4,7)) + + let e = enumLBS s' + + buf <- QC.run mkIterateeBuffer + + enums <- QC.run $ + replicateM ntimes + (mkIterateeBuffer >>= + return . flip writeChunkedTransferEncoding e) + + let mothra = foldl' (>.) (enumBS "") enums + + ---------------------------------------------------------------------- + -- 2nd pass, cancellation + let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s + (inputIter2,esc) <- QC.run $ bufferIteratee stream2stream + QC.run $ writeIORef esc True + bs2 <- QC.run $ mothra inputIter2 + >>= run >>= return . unWrap + let e2 = enumBS bs2 + iters' <- QC.run $ + replicateM ntimes $ + readChunkedTransferEncoding stream2stream + let godzilla2 = sequence $ map (>>= pcrlf) iters' + outiter2 <- QC.run $ e2 godzilla2 + x2 <- QC.run $ liftM (map unWrap) $ run outiter2 + + QC.assert $ + (map (L.fromChunks . (:[])) x2) == (replicate ntimes s') + + + +testBothChunkedPipelined :: Test +testBothChunkedPipelined = testProperty "testBothChunkedPipelined" $ + monadicIO prop + where + prop = do + sz <- QC.pick (choose (1000,4000)) + s' <- QC.pick $ resize sz arbitrary + ntimes <- QC.pick (choose (4,7)) + --let s' = L.take 2000 $ L.fromChunks $ repeat s + + let e = enumLBS s' + + buf <- QC.run mkIterateeBuffer + + enums <- QC.run $ + replicateM ntimes + (mkIterateeBuffer >>= + return . flip writeChunkedTransferEncoding e) + + let mothra = foldl' (>.) (enumBS "") enums + + (bufi,_) <- QC.run $ bufferIteratee stream2stream + + bs <- QC.run $ mothra bufi + >>= run >>= return . unWrap + + let e2 = enumBS bs + + let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s + + iters <- QC.run $ + replicateM ntimes $ + readChunkedTransferEncoding stream2stream + let godzilla = sequence $ map (>>= pcrlf) iters + + iter <- QC.run $ e2 godzilla + + x <- QC.run $ liftM (map unWrap) $ run iter + + QC.assert $ + (map (L.fromChunks . (:[])) x) == (replicate ntimes s') + + + +testBothChunkedEmpty :: Test +testBothChunkedEmpty = testCase "testBothChunkedEmpty" prop + where + prop = do + let s' = "" + let e = enumLBS s' + + let ntimes = 5 + + buf <- mkIterateeBuffer + + enums <- replicateM ntimes + (mkIterateeBuffer >>= + return . flip writeChunkedTransferEncoding e) + + let mothra = foldl' (>.) (enumBS "") enums + + bs <- mothra stream2stream + >>= run >>= return . unWrap + + let e2 = enumBS bs + + let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s + + iters <- replicateM ntimes $ + readChunkedTransferEncoding stream2stream + let godzilla = sequence $ map (>>= pcrlf) iters + + iter <- e2 godzilla + + x <- liftM (map unWrap) $ run iter + + assertBool "empty chunked transfer" $ + (map (L.fromChunks . (:[])) x) == (replicate ntimes s') testCookie :: Test diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs b/test/suite/Snap/Internal/Http/Server/Tests.hs --- a/test/suite/Snap/Internal/Http/Server/Tests.hs +++ b/test/suite/Snap/Internal/Http/Server/Tests.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PackageImports #-} module Snap.Internal.Http.Server.Tests ( tests ) where @@ -7,13 +8,14 @@ import Control.Concurrent import Control.Exception (try, SomeException) import Control.Monad -import Control.Monad.Trans +import "monads-fd" Control.Monad.Trans import qualified Data.ByteString 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.Char +import Data.Int import Data.IORef import Data.Iteratee.WrappedByteString import qualified Data.Map as Map @@ -36,14 +38,14 @@ import Snap.Types -import System.IO - tests :: [Test] tests = [ testHttpRequest1 , testMultiRequest , testHttpRequest2 , testHttpRequest3 , testHttpResponse1 + , testHttpResponse2 + , testHttpResponse3 , testHttp1 , testHttp2 , testPartialParse @@ -289,7 +291,7 @@ testHttpResponse1 :: Test testHttpResponse1 = testCase "HttpResponse1" $ do - let onSendFile = \f -> enumFile f copyingStream2stream >>= run + let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run buf <- mkIterateeBuffer @@ -304,6 +306,21 @@ , "0123456789" ]) b + where + rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $ + setContentLength 10 $ + setResponseStatus 600 "Test" $ + modifyResponseBody (>. (enumBS "0123456789")) $ + setResponseBody return $ + emptyResponse { rspHttpVersion = (1,0) } + + +testHttpResponse2 :: Test +testHttpResponse2 = testCase "HttpResponse2" $ do + let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run + + buf <- mkIterateeBuffer + b2 <- run $ rsm $ sendResponse rsp2 copyingStream2stream buf (return ()) onSendFile >>= return . fromWrap . snd @@ -314,7 +331,22 @@ , "Foo: Bar\r\n\r\n" , "0123456789" ]) b2 + where + rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $ + setContentLength 10 $ + setResponseStatus 600 "Test" $ + modifyResponseBody (>. (enumBS "0123456789")) $ + setResponseBody return $ + emptyResponse { rspHttpVersion = (1,0) } + rsp2 = rsp1 { rspContentLength = Nothing } + +testHttpResponse3 :: Test +testHttpResponse3 = testCase "HttpResponse3" $ do + let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run + + buf <- mkIterateeBuffer + b3 <- run $ rsm $ sendResponse rsp3 copyingStream2stream buf (return ()) onSendFile >>= return . fromWrap . snd @@ -337,7 +369,6 @@ modifyResponseBody (>. (enumBS "0123456789")) $ setResponseBody return $ emptyResponse { rspHttpVersion = (1,0) } - rsp2 = rsp1 { rspContentLength = Nothing } rsp3 = setContentType "text/plain" $ (rsp2 { rspHttpVersion = (1,1) }) @@ -407,8 +438,8 @@ assertBool "pipelined responses" ok -mkIter :: IORef L.ByteString -> (Iteratee IO (), FilePath -> IO ()) -mkIter ref = (iter, \f -> onF f iter) +mkIter :: IORef L.ByteString -> (Iteratee IO (), FilePath -> Int64 -> IO ()) +mkIter ref = (iter, \f _ -> onF f iter) where iter = do x <- copyingStream2stream @@ -549,6 +580,6 @@ return () where - waitabit = threadDelay $ ((10::Int)^(6::Int)) + waitabit = threadDelay $ 2*((10::Int)^(6::Int)) port = 8145