snap-server 0.2.6 → 0.2.7
raw patch · 14 files changed
+770/−212 lines, 14 filesdep −sendfiledep ~snap-core
Dependencies removed: sendfile
Dependency ranges changed: snap-core
Files
- CONTRIBUTORS +1/−1
- snap-server.cabal +18/−7
- src/Snap/Internal/Http/Parser.hs +51/−31
- src/Snap/Internal/Http/Server.hs +49/−37
- src/Snap/Internal/Http/Server/LibevBackend.hs +186/−85
- src/Snap/Internal/Http/Server/SimpleBackend.hs +74/−27
- src/System/FastLogger.hs +2/−1
- src/System/SendFile.hs +26/−0
- src/System/SendFile/Darwin.hsc +41/−0
- src/System/SendFile/FreeBSD.hsc +38/−0
- src/System/SendFile/Linux.hsc +42/−0
- test/snap-server-testsuite.cabal +33/−10
- test/suite/Snap/Internal/Http/Parser/Tests.hs +170/−5
- test/suite/Snap/Internal/Http/Server/Tests.hs +39/−8
CONTRIBUTORS view
@@ -1,6 +1,6 @@ Doug Beardsley <mightybyte@gmail.com> Gregory Collins <greg@gregorycollins.net> Shu-yu Guo <shu@rfrn.org>-Carl Howells+Carl Howells <chowells79@gmail.com> James Sanders <jimmyjazz14@gmail.com> Jacob Stanley <jystic@jystic.com>
snap-server.cabal view
@@ -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
src/Snap/Internal/Http/Parser.hs view
@@ -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) =>
src/Snap/Internal/Http/Server.hs view
@@ -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
src/Snap/Internal/Http/Server/LibevBackend.hs view
@@ -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
src/Snap/Internal/Http/Server/SimpleBackend.hs view
@@ -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
src/System/FastLogger.hs view
@@ -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
+ src/System/SendFile.hs view
@@ -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
+ src/System/SendFile/Darwin.hsc view
@@ -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
+ src/System/SendFile/FreeBSD.hsc view
@@ -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
+ src/System/SendFile/Linux.hsc view
@@ -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
test/snap-server-testsuite.cabal view
@@ -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+
test/suite/Snap/Internal/Http/Parser/Tests.hs view
@@ -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
test/suite/Snap/Internal/Http/Server/Tests.hs view
@@ -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