diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -1,4 +1,6 @@ Doug Beardsley Gregory Collins Shu-yu Guo +Carl Howells James Sanders +Jacob Stanley diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -33,17 +33,6 @@ [libev](http://software.schmorp.de/pkg/libev.html) for high-speed, O(1) scalable socket event processing. -If you decide to use the libev backend, you will also need to download and -install the darcs head version of the -[hlibev](http://hackage.haskell.org/package/hlibev) library: - - $ darcs get --lazy http://code.haskell.org/hlibev/ - $ cd hlibev - $ cabal install -O2 (or "cabal install -O2 -p" for profiling support) - -It has some new patches that we rely upon. - - ## Building snap-server The snap-server library is built using [Cabal](http://www.haskell.org/cabal/) diff --git a/cbits/linger.c b/cbits/linger.c deleted file mode 100644 --- a/cbits/linger.c +++ /dev/null @@ -1,23 +0,0 @@ -#include -#include - - -void set_linger(int fd) { - struct linger linger; - - /* five seconds of linger */ - linger.l_onoff = 1; - linger.l_linger = 5; - - setsockopt(fd, SOL_SOCKET, SO_LINGER, &linger, sizeof(linger)); -} - - -void set_fd_timeout(int fd) { - struct timeval timeout; - timeout.tv_sec = 10; - timeout.tv_usec = 0; - - setsockopt(fd, SOL_SOCKET, SO_SNDTIMEO, &timeout, sizeof(timeout)); - setsockopt(fd, SOL_SOCKET, SO_RCVTIMEO, &timeout, sizeof(timeout)); -} 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.2 +version: 0.2.4 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 @@ -60,8 +60,10 @@ test/data/fileServe/foo.html, test/data/fileServe/foo.txt, test/pongserver/Main.hs, + test/pongserver/Paths_snap_server.hs, test/runTestsAndCoverage.sh, test/snap-server-testsuite.cabal, + test/suite/Paths_snap_server.hs, test/suite/Snap/Internal/Http/Parser/Tests.hs, test/suite/Snap/Internal/Http/Server/Tests.hs, test/suite/Snap/Test/Common.hs, @@ -72,27 +74,30 @@ Description: Use libev? Default: False +Flag portable + Description: Compile in cross-platform mode. No platform-specific code or + optimizations such as C routines will be used. + Default: False + Library hs-source-dirs: src - c-sources: cbits/linger.c - include-dirs: cbits - exposed-modules: Snap.Http.Server, Snap.Http.Server.Config, System.FastLogger other-modules: + Paths_snap_server, Snap.Internal.Http.Parser, - Snap.Internal.Http.Server, + Snap.Internal.Http.Server, Snap.Internal.Http.Server.Date build-depends: array >= 0.2 && <0.4, attoparsec >= 0.8.0.2 && < 0.9, - attoparsec-iteratee >= 0.1 && <0.2, + attoparsec-iteratee >= 0.1.1 && <0.2, base >= 4 && < 5, bytestring, bytestring-nums, @@ -110,15 +115,22 @@ snap-core >= 0.2.1 && <0.3, time, transformers, - unix, + unix-compat, vector >= 0.6 && <0.7 + if flag(portable) || os(windows) + cpp-options: -DPORTABLE + else + build-depends: unix + if flag(libev) - build-depends: hlibev >= 0.2.2 + build-depends: hlibev >= 0.2.3 other-modules: Snap.Internal.Http.Server.LibevBackend cpp-options: -DLIBEV else - build-depends: network-bytestring >= 0.1.2 && < 0.2 + build-depends: network-bytestring >= 0.1.2 && < 0.2, + PSQueue >= 1.1 && <1.2 + other-modules: Snap.Internal.Http.Server.SimpleBackend if os(linux) diff --git a/src/Snap/Http/Server.hs b/src/Snap/Http/Server.hs --- a/src/Snap/Http/Server.hs +++ b/src/Snap/Http/Server.hs @@ -5,6 +5,7 @@ module Snap.Http.Server ( httpServe +, snapServerVersion ) where import Data.ByteString (ByteString) @@ -12,6 +13,12 @@ import qualified Snap.Internal.Http.Server as Int +------------------------------------------------------------------------------ +snapServerVersion :: ByteString +snapServerVersion = Int.snapServerVersion + + +------------------------------------------------------------------------------ -- | Starts serving HTTP requests on the given port using the given handler. -- This function never returns; to shut down the HTTP server, kill the -- controlling thread. 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 @@ -37,6 +37,8 @@ import qualified Data.Vector.Unboxed as Vec import Data.Vector.Unboxed (Vector) import Data.Word (Word8, Word64) +import Foreign.C.Types +import Foreign.ForeignPtr import Prelude hiding (take, takeWhile) ------------------------------------------------------------------------------ import Snap.Internal.Http.Types hiding (Enumerator) @@ -108,10 +110,13 @@ -- > -- > Chunk "3\r\nfoo\r\n3\r\nbar\r\n4\r\nquux\r\n0\r\n\r\n" Empty -- -writeChunkedTransferEncoding :: (Monad m) => Enumerator m a -> Enumerator m a -writeChunkedTransferEncoding enum it = do - i' <- wrap it - i <- bufferIteratee i' +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 where @@ -122,8 +127,7 @@ i <- checkIfDone return v runIter i (EOF Nothing) (EOF e) -> return $ Cont undefined e - (Chunk x') -> do - let x = S.concat $ L.toChunks $ fromWrap x' + (Chunk (WrapBS x)) -> do let n = S.length x if n == 0 then do 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 @@ -14,6 +14,7 @@ import Data.CIByteString import Data.ByteString (ByteString) import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as SC import qualified Data.ByteString.Lazy as L import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Nums.Careless.Int as Cvt @@ -22,16 +23,21 @@ import qualified Data.Map as Map import Data.Maybe (fromJust, catMaybes, fromMaybe) import Data.Monoid +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 -import System.Posix.Files hiding (setFileSize) +import System.PosixCompat.Files hiding (setFileSize) +import System.Posix.Types (FileOffset) import Text.Show.ByteString hiding (runPut) ------------------------------------------------------------------------------ import System.FastLogger import Snap.Internal.Http.Types hiding (Enumerator) import Snap.Internal.Http.Parser -import Snap.Iteratee hiding (foldl', head, take) +import Snap.Iteratee hiding (foldl', head, take, FileOffset) import qualified Snap.Iteratee as I #ifdef LIBEV @@ -44,6 +50,8 @@ import Snap.Internal.Http.Server.Date +import qualified Paths_snap_server as V + ------------------------------------------------------------------------------ -- | The handler has to return the request object because we have to clear the -- HTTP request body before we send the response. If the handler consumes the @@ -104,6 +112,8 @@ where spawnAll alog elog = {-# SCC "httpServe/spawnAll" #-} do + logE elog $ S.concat [ "Server.httpServe: START (" + , Backend.name, ")"] let n = numCapabilities bracket (spawn n) (\xs -> do @@ -158,7 +168,7 @@ {-# SCC "httpServe/runOne" #-} do debug "Server.httpServe.runOne: entered" let readEnd = Backend.getReadEnd conn - writeEnd <- I.bufferIteratee $ Backend.getWriteEnd conn + let writeEnd = Backend.getWriteEnd conn let raddr = Backend.getRemoteAddr conn let rport = Backend.getRemotePort conn @@ -166,8 +176,9 @@ let lport = Backend.getLocalPort conn runHTTP localHostname laddr lport raddr rport - alog elog readEnd writeEnd (Backend.sendFile conn) - handler + alog elog readEnd writeEnd + (Backend.sendFile conn) + (Backend.tickleTimeout conn) handler debug "Server.httpServe.runHTTP: finished" @@ -243,29 +254,37 @@ -> Enumerator IO () -- ^ read end of socket -> Iteratee IO () -- ^ write end of socket -> (FilePath -> IO ()) -- ^ sendfile end + -> IO () -- ^ timeout tickler -> ServerHandler -- ^ handler procedure -> IO () -runHTTP lh lip lp rip rp alog elog readEnd writeEnd onSendFile handler = +runHTTP lh lip lp rip rp alog elog + readEnd writeEnd onSendFile tickle handler = go `catches` [ Handler $ \(e :: AsyncException) -> do throwIO e , Handler $ \(_ :: Backend.TimeoutException) -> return () , Handler $ \(e :: SomeException) -> - logE elog $ S.concat [ "Server.runHTTP.go: got someexception: " - , bshow e ] ] + logE elog $ S.concat [ logPrefix , bshow e ] ] where + logPrefix = S.concat [ "[", rip, "]: error: " ] + go = do + --buf <- mkIterateeBuffer + buf <- newForeignPtr_ nullPtr let iter = runServerMonad lh lip lp rip rp (logA alog) (logE elog) $ - httpSession writeEnd onSendFile handler + httpSession writeEnd buf onSendFile tickle + handler readEnd iter >>= run ------------------------------------------------------------------------------ sERVER_HEADER :: [ByteString] -sERVER_HEADER = ["Snap/0.pre-1"] +sERVER_HEADER = [S.concat ["Snap/", snapServerVersion]] +snapServerVersion :: ByteString +snapServerVersion = SC.pack $ showVersion $ V.version ------------------------------------------------------------------------------ logAccess :: Request -> Response -> ServerMonad () @@ -278,15 +297,31 @@ ------------------------------------------------------------------------------ -- | 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 -> ServerMonad () -httpSession writeEnd onSendFile handler = do +httpSession writeEnd' ibuf onSendFile tickle handler = do + + -- (writeEnd, cancelBuffering) <- + -- liftIO $ I.unsafeBufferIterateeWithBuffer ibuf writeEnd' + -- let killBuffer = writeIORef cancelBuffering True + + writeEnd <- liftIO $ I.bufferIteratee writeEnd' + let killBuffer = return () + liftIO $ debug "Server.httpSession: entered" - mreq <- receiveRequest + mreq <- receiveRequest + -- successfully got a request, so restart timer + liftIO tickle case mreq of (Just req) -> do + liftIO $ debug $ "got request: " ++ + Prelude.show (rqMethod req) ++ + " " ++ SC.unpack (rqURI req) ++ + " " ++ Prelude.show (rqVersion req) logerr <- gets _logError (req',rspOrig) <- lift $ handler logerr req let rspTmp = rspOrig { rspHttpVersion = rqVersion req } @@ -307,15 +342,18 @@ 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 rsp' writeEnd ibuf killBuffer onSendFile + liftIO . debug $ "Server.httpSession: sent " ++ + (Prelude.show bytesSent) ++ " bytes" + maybe (logAccess req rsp') (\_ -> logAccess req $ setContentLength bytesSent rsp') (rspContentLength rsp') if cc then return () - else httpSession writeEnd onSendFile handler + else httpSession writeEnd ibuf onSendFile tickle handler Nothing -> return () @@ -472,9 +510,11 @@ -- Response must be well-formed here sendResponse :: Response -> Iteratee IO a + -> ForeignPtr CChar + -> IO () -> (FilePath -> IO a) -> ServerMonad (Int,a) -sendResponse rsp' writeEnd onSendFile = do +sendResponse rsp' writeEnd ibuf killBuffering onSendFile = do rsp <- fixupResponse rsp' let !headerString = mkHeaderString rsp @@ -522,8 +562,10 @@ let sendChunked = (rspHttpVersion r) == (1,1) if sendChunked then do + liftIO $ killBuffering let r' = setHeader "Transfer-Encoding" "chunked" r - let e = writeChunkedTransferEncoding $ rspBodyToEnum $ rspBody r + let e = writeChunkedTransferEncoding ibuf $ + rspBodyToEnum $ rspBody r return $ r' { rspBody = Enum e } else do diff --git a/src/Snap/Internal/Http/Server/Date.hs b/src/Snap/Internal/Http/Server/Date.hs --- a/src/Snap/Internal/Http/Server/Date.hs +++ b/src/Snap/Internal/Http/Server/Date.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} module Snap.Internal.Http.Server.Date ( getDateString @@ -9,16 +10,18 @@ import Control.Exception import Control.Monad import Data.ByteString (ByteString) -import Data.ByteString.Internal (c2w) -import qualified Data.ByteString as B import Data.IORef -import Data.Time.Clock -import Data.Time.LocalTime -import Data.Time.Format +import Foreign.C.Types import System.IO.Unsafe -import System.Locale +#ifndef PORTABLE +import System.Posix.Time +#else +import Data.Time.Clock.POSIX +#endif +import Snap.Internal.Http.Types (formatHttpTime, formatLogTime) + -- Here comes a dirty hack. We don't want to be wasting context switches -- building date strings, so we're only going to compute one every two -- seconds. (Approximate timestamps to within a couple of seconds are OK here, @@ -31,7 +34,7 @@ data DateState = DateState { _cachedDateString :: !(IORef ByteString) , _cachedLogString :: !(IORef ByteString) - , _cachedDate :: !(IORef UTCTime) + , _cachedDate :: !(IORef CTime) , _valueIsOld :: !(IORef Bool) , _morePlease :: !(MVar ()) , _dataAvailable :: !(MVar ()) @@ -57,17 +60,22 @@ return d -fetchTime :: IO (ByteString,ByteString,UTCTime) +#ifdef PORTABLE +epochTime :: IO CTime +epochTime = do + t <- getPOSIXTime + return $ fromInteger $ truncate t +#endif + + +fetchTime :: IO (ByteString,ByteString,CTime) fetchTime = do - now <- getCurrentTime - zt <- liftM zonedTimeToLocalTime getZonedTime - return (t1 now, t2 zt, now) - where - t1 now = B.pack $ map c2w $ - formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" now - t2 now = B.pack $ map c2w $ - formatTime defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z" now + now <- epochTime + t1 <- formatHttpTime now + t2 <- formatLogTime now + return (t1, t2, now) + dateThread :: DateState -> IO () dateThread ds@(DateState dateString logString time valueIsOld morePlease dataAvailable _) = do @@ -108,7 +116,7 @@ readIORef $ _cachedLogString dateState -getCurrentDateTime :: IO UTCTime +getCurrentDateTime :: IO CTime getCurrentDateTime = block $ do ensureFreshDate readIORef $ _cachedDate dateState diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs b/src/Snap/Internal/Http/Server/LibevBackend.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Internal/Http/Server/LibevBackend.hs @@ -0,0 +1,740 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Snap.Internal.Http.Server.LibevBackend + ( Backend + , BackendTerminatedException + , Connection + , TimeoutException + , name + , debug + , bindIt + , new + , stop + , withConnection + , sendFile + , tickleTimeout + , getReadEnd + , getWriteEnd + , getRemoteAddr + , getRemotePort + , getLocalAddr + , getLocalPort + ) where + +--------------------------- +-- TODO: document module -- +--------------------------- + +------------------------------------------------------------------------------ +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 Snap.Iteratee +import Snap.Internal.Debug + + +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 + } + + +data Connection = Connection + { _backend :: !Backend + , _socket :: !Socket + , _socketFd :: !CInt + , _remoteAddr :: !ByteString + , _remotePort :: !Int + , _localAddr :: !ByteString + , _localPort :: !Int + , _readAvailable :: !(MVar ()) + , _writeAvailable :: !(MVar ()) + , _timerObj :: !EvTimerPtr + , _timerCallback :: !(FunPtr TimerCallback) + , _readActive :: !(IORef Bool) + , _writeActive :: !(IORef Bool) + , _connReadIOObj :: !EvIoPtr + , _connReadIOCallback :: !(FunPtr IoCallback) + , _connWriteIOObj :: !EvIoPtr + , _connWriteIOCallback :: !(FunPtr IoCallback) + , _connThread :: !(MVar ThreadId) + } + +{-# INLINE name #-} +name :: ByteString +name = "libev" + + +sendFile :: Connection -> FilePath -> IO () +sendFile c fp = do + withMVar lock $ \_ -> do + act <- readIORef $ _writeActive c + when act $ evIoStop loop io + writeIORef (_writeActive c) False + evAsyncSend loop asy + + SF.sendFile s fp + + withMVar lock $ \_ -> do + tryTakeMVar $ _readAvailable c + tryTakeMVar $ _writeAvailable c + evAsyncSend loop asy + + where + s = _socket c + io = _connWriteIOObj c + b = _backend c + loop = _evLoop b + lock = _loopLock b + asy = _asyncObj b + + +bindIt :: ByteString -- ^ bind address, or \"*\" for all + -> Int -- ^ port to bind to + -> IO (Socket,CInt) +bindIt bindAddress bindPort = do + sock <- socket AF_INET Stream 0 + addr <- getHostAddr bindPort bindAddress + setSocketOption sock ReuseAddr 1 + bindSocket sock addr + listen sock 150 + let sockFd = fdSocket sock + c_setnonblocking sockFd + return (sock, sockFd) + + +new :: (Socket,CInt) -- ^ value you got from bindIt + -> Int -- ^ cpu + -> IO Backend +new (sock,sockFd) cpu = do + connq <- newChan + + -- We'll try kqueue on OSX even though the libev docs complain that it's + -- "broken", in the hope that it works as expected for sockets + f <- evRecommendedBackends + lp <- evLoopNew $ toEnum . fromEnum $ f .|. evbackend_kqueue + + + -- we'll be working multithreaded so we need to set up locking for the C + -- event loop struct + (mc1,mc2,looplock) <- setupLockingForLoop lp + + -- setup async callbacks -- these allow us to wake up the main loop + -- (normally blocked in c-land) from other threads + asyncObj <- mkEvAsync + asyncCB <- mkAsyncCallback $ \_ _ _ -> do + debug "async wakeup" + return () + + killObj <- mkEvAsync + killCB <- mkAsyncCallback $ \_ _ _ -> do + debug "async kill wakeup" + evUnloop lp 2 + return () + + evAsyncInit asyncObj asyncCB + evAsyncStart lp asyncObj + evAsyncInit killObj killCB + evAsyncStart lp killObj + + -- setup the accept callback; this watches for read readiness on the listen + -- port + accCB <- mkIoCallback $ acceptCallback sockFd connq + accIO <- mkEvIo + 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 + + let b = Backend sock + sockFd + connq + lp + accCB + accIO + threadMVar + (mc1,mc2) + looplock + asyncCB + asyncObj + killCB + killObj + threadSetMVar + cpu + + tid <- forkOnIO cpu $ loopThread b + putMVar threadMVar tid + + debug $ "Backend.new: loop spawned" + return b + + +-- | Run evLoop in a thread +loopThread :: Backend -> IO () +loopThread backend = do + debug $ "starting loop" + (ignoreException go) `finally` cleanup + debug $ "loop finished" + where + cleanup = do + debug $ "loopThread: cleaning up" + ignoreException $ freeBackend backend + lock = _loopLock backend + loop = _evLoop backend + go = takeMVar lock >> block (evLoop loop 0) + + +acceptCallback :: CInt -> Chan CInt -> IoCallback +acceptCallback accFd chan _loopPtr _ioPtr _ = do + debug "inside acceptCallback" + r <- c_accept accFd + + case r of + -- this (EWOULDBLOCK) shouldn't happen (we just got told it was ready!), + -- if it does (maybe the request got picked up by another thread) we'll + -- just bail out + -2 -> return () + -1 -> debugErrno "Backend.acceptCallback:c_accept()" + fd -> do + debug $ "acceptCallback: accept()ed fd, writing to chan " ++ show fd + writeChan chan fd + + +ioReadCallback :: CInt -> IORef Bool -> MVar () -> IoCallback +ioReadCallback fd active ra _loopPtr _ioPtr _ = do + -- send notifications to the worker thread + debug $ "ioReadCallback: notification (" ++ show fd ++ ")" + tryPutMVar ra () + debug $ "stopping ioReadCallback (" ++ show fd ++ ")" + evIoStop _loopPtr _ioPtr + writeIORef active False + + +ioWriteCallback :: CInt -> IORef Bool -> MVar () -> IoCallback +ioWriteCallback fd active wa _loopPtr _ioPtr _ = do + -- send notifications to the worker thread + debug $ "ioWriteCallback: notification (" ++ show fd ++ ")" + tryPutMVar wa () + debug $ "stopping ioWriteCallback (" ++ show fd ++ ")" + evIoStop _loopPtr _ioPtr + writeIORef active False + + +seconds :: Int -> Int +seconds n = n * ((10::Int)^(6::Int)) + + +stop :: Backend -> IO () +stop b = ignoreException $ do + debug $ "Backend.stop" + + -- FIXME: what are we gonna do here? + -- + -- 1. take the loop lock + -- 2. shut down the accept() callback + -- 3. stuff a poison pill (a bunch of -1 values should do) down the + -- connection queue so that withConnection knows to throw an exception + -- back up to its caller + -- 4. release the loop lock + -- 5. wait until all of the threads have finished, or until 10 seconds have + -- elapsed, whichever comes first + -- 6. take the loop lock + -- 7. call evUnloop and wake up the loop using evAsyncSend + -- 8. release the loop lock, the main loop thread should then free/clean + -- everything up (threads, connections, io objects, callbacks, etc) + + withMVar lock $ \_ -> do + evIoStop loop acceptObj + replicateM_ 10 $ writeChan connQ (-1) + + debug $ "Backend.stop: waiting at most 10 seconds for connection threads to die" + waitForThreads b $ seconds 10 + debug $ "Backend.stop: all threads dead, unlooping" + + withMVar lock $ \_ -> do + -- FIXME: hlibev should export EVUNLOOP_ALL + evUnloop loop 2 + evAsyncSend loop killObj + + debug $ "unloop sent" + + + where + loop = _evLoop b + acceptObj = _acceptIOObj b + killObj = _killObj b + lock = _loopLock b + connQ = _connectionQueue b + + + +waitForThreads :: Backend -> Int -> IO () +waitForThreads backend t = timeout t wait >> return () + where + threadSet = _connectionThreads backend + wait = do + threads <- readMVar threadSet + if (Set.null threads) + then return () + else threadDelay (seconds 1) >> wait + + + +getAddr :: SockAddr -> IO (ByteString, Int) +getAddr addr = + case addr of + SockAddrInet p ha -> do + s <- liftM (B.pack . map c2w) (inet_ntoa ha) + return (s, fromIntegral p) + + a -> throwIO $ AddressNotSupportedException (show a) + + +-- | 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 + + +freeConnection :: Connection -> IO () +freeConnection conn = ignoreException $ do + withMVar loopLock $ \_ -> block $ do + debug $ "freeConnection (" ++ show fd ++ ")" + c_close fd + + -- stop and free timer object + evTimerStop loop timerObj + freeEvTimer timerObj + freeTimerCallback timerCb + + -- stop and free i/o objects + evIoStop loop ioWrObj + freeEvIo ioWrObj + freeIoCallback ioWrCb + + evIoStop loop ioRdObj + 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' + + -- 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 + ioRdCb = _connReadIOCallback conn + timerObj = _timerObj conn + timerCb = _timerCallback conn + + +ignoreException :: IO () -> IO () +ignoreException = handle (\(_::SomeException) -> return ()) + + +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 + + debug $ "Backend.freeBackend: wait at most 2 seconds for threads to die" + waitForThreads backend $ seconds 2 + + debug $ "Backend.freeBackend: all threads dead" + + debug $ "Backend.freeBackend: destroying resources" + freeEvIo acceptObj + freeIoCallback acceptCb + c_close fd + + evAsyncStop loop asyncObj + freeEvAsync asyncObj + freeAsyncCallback asyncCb + + evAsyncStop loop killObj + freeEvAsync killObj + freeAsyncCallback killCb + + freeMutexCallback mcb1 + freeMutexCallback mcb2 + + evLoopDestroy loop + debug $ "Backend.freeBackend: resources destroyed" + + where + fd = _acceptFd backend + acceptObj = _acceptIOObj backend + acceptCb = _acceptIOCallback backend + tsetMVar = _connectionThreads backend + asyncObj = _asyncObj backend + asyncCb = _asyncCb backend + killObj = _killObj backend + killCb = _killCb backend + (mcb1,mcb2) = _mutexCallbacks backend + loop = _evLoop backend + + +-- | Note: proc gets run in the background +withConnection :: Backend -> Int -> (Connection -> IO ()) -> IO () +withConnection backend cpu proc = go + where + threadProc conn = ignoreException (proc conn) `finally` freeConnection conn + + go = do + debug $ "withConnection: reading from chan" + fd <- readChan $ _connectionQueue backend + debug $ "withConnection: got fd " ++ show fd + + -- if fd < 0 throw an exception here (because this only happens if stop + -- is called) + when (fd < 0) $ throwIO BackendTerminatedException + + sock <- mkSocket fd AF_INET Stream 0 Connected + peerName <- getPeerName sock + sockName <- getSocketName sock + + -- set_linger fd + c_setnonblocking fd + + (remoteAddr, remotePort) <- getAddr peerName + (localAddr, localPort) <- getAddr sockName + + let lp = _evLoop backend + + -- makes sense to assume the socket is read/write available when + -- opened; worst-case is we get EWOULDBLOCK + ra <- newMVar () + wa <- newMVar () + + tmr <- mkEvTimer + thrmv <- newEmptyMVar + tcb <- mkTimerCallback $ timerCallback thrmv + evTimerInit tmr tcb 0 20.0 + + readActive <- newIORef True + writeActive <- newIORef True + + evioRead <- mkEvIo + ioReadCb <- mkIoCallback $ ioReadCallback fd readActive ra + + evioWrite <- mkEvIo + ioWriteCb <- mkIoCallback $ ioWriteCallback fd writeActive wa + + evIoInit evioRead ioReadCb fd ev_read + evIoInit evioWrite ioWriteCb fd ev_write + + -- take ev_loop lock, start timer and io watchers + withMVar (_loopLock backend) $ \_ -> do + evTimerAgain lp tmr + evIoStart lp evioRead + evIoStart lp evioWrite + + -- wakeup the loop thread so that these new watchers get + -- registered next time through the loop + evAsyncSend lp $ _asyncObj backend + + let conn = Connection backend + sock + fd + remoteAddr + remotePort + localAddr + localPort + ra + wa + tmr + tcb + readActive + writeActive + evioRead + ioReadCb + evioWrite + ioWriteCb + thrmv + + + tid <- forkOnIO cpu $ threadProc conn + + modifyMVar_ (_connectionThreads backend) $ ins tid + putMVar thrmv tid + + where + ins !thr !s = let !r = Set.insert thr s in return (r `seq` r) + + +data BackendTerminatedException = BackendTerminatedException + deriving (Typeable) + +instance Show BackendTerminatedException where + show BackendTerminatedException = "Backend terminated" + +instance Exception BackendTerminatedException + + + +data AddressNotSupportedException = AddressNotSupportedException String + deriving (Typeable) + +instance Show AddressNotSupportedException where + show (AddressNotSupportedException x) = "Address not supported: " ++ x + +instance Exception AddressNotSupportedException + + +getRemoteAddr :: Connection -> ByteString +getRemoteAddr = _remoteAddr + +getRemotePort :: Connection -> Int +getRemotePort = _remotePort + +getLocalAddr :: Connection -> ByteString +getLocalAddr = _localAddr + +getLocalPort :: Connection -> Int +getLocalPort = _localPort + +------------------------------------------------------------------------------ + +-- fixme: new function name +getHostAddr :: Int + -> ByteString + -> IO SockAddr +getHostAddr p s = do + h <- if s == "*" + then return iNADDR_ANY + else inet_addr (map w2c . B.unpack $ s) + + return $ SockAddrInet (fromIntegral p) h + + + +bLOCKSIZE :: Int +bLOCKSIZE = 8192 + +-- +-- About timeouts +-- +-- It's not good enough to restart the timer from io(Read|Write)Callback, +-- because those seem to be edge-triggered. I've definitely had where after +-- 20 seconds they still weren't being re-awakened. +-- + +data TimeoutException = TimeoutException + deriving (Typeable) + +instance Show TimeoutException where + show _ = "timeout" + +instance Exception TimeoutException + +tickleTimeout :: Connection -> IO () +tickleTimeout conn = do + debug "Backend.tickleTimeout" + withMVar (_loopLock bk) $ \_ -> evTimerAgain lp tmr + + where + bk = _backend conn + lp = _evLoop bk + tmr = _timerObj conn + +recvData :: Connection -> Int -> IO ByteString +recvData conn n = do + dbg "entered" + allocaBytes n $ \cstr -> do + sz <- throwErrnoIfMinus1RetryMayBlock + "recvData" + (c_read fd cstr (toEnum n)) + waitForLock + + -- we got activity, but don't do restart timer due to the + -- slowloris attack + + dbg $ "sz returned " ++ show sz + + if sz == 0 + then return "" + else B.packCStringLen ((castPtr cstr),(fromEnum sz)) + + where + io = _connReadIOObj conn + bk = _backend conn + active = _readActive conn + lp = _evLoop bk + looplock = _loopLock bk + async = _asyncObj bk + + dbg s = debug $ "Backend.recvData(" ++ show (_socketFd conn) ++ "): " ++ s + + fd = _socketFd conn + lock = _readAvailable conn + waitForLock = do + dbg "start waitForLock" + + withMVar looplock $ \_ -> do + act <- readIORef active + if act + then dbg "read watcher already active, skipping" + else do + dbg "starting watcher, sending async" + tryTakeMVar lock + evIoStart lp io + writeIORef active True + evAsyncSend lp async + + dbg "waitForLock: waiting for mvar" + takeMVar lock + dbg "waitForLock: took mvar" + + +sendData :: Connection -> ByteString -> IO () +sendData conn bs = do + let len = B.length bs + dbg $ "entered w/ " ++ show len ++ " bytes" + written <- B.unsafeUseAsCString bs $ \cstr -> + throwErrnoIfMinus1RetryMayBlock + "sendData" + (c_write fd cstr (toEnum len)) + waitForLock + + -- we got activity, so restart timer + tickleTimeout conn + + let n = fromEnum written + let last10 = B.drop (n-10) $ B.take n bs + + dbg $ "wrote " ++ show written ++ " bytes, last 10='" ++ show last10 ++ "'" + + if n < len + then do + dbg $ "short write, need to write " ++ show (len-n) ++ " more bytes" + sendData conn $ B.drop n bs + else return () + + where + io = _connWriteIOObj conn + bk = _backend conn + active = _writeActive conn + lp = _evLoop bk + looplock = _loopLock bk + async = _asyncObj bk + + dbg s = debug $ "Backend.sendData(" ++ show (_socketFd conn) ++ "): " ++ s + fd = _socketFd conn + lock = _writeAvailable conn + waitForLock = do + dbg "waitForLock: starting" + withMVar looplock $ \_ -> do + act <- readIORef active + if act + then dbg "write watcher already running, skipping" + else do + dbg "starting watcher, sending async event" + tryTakeMVar lock + evIoStart lp io + writeIORef active True + evAsyncSend lp async + + dbg "waitForLock: taking mvar" + takeMVar lock + dbg "waitForLock: took mvar" + + +getReadEnd :: Connection -> Enumerator IO a +getReadEnd = enumerate + + +getWriteEnd :: Connection -> Iteratee IO () +getWriteEnd = writeOut + + +enumerate :: (MonadIO m) => Connection -> Enumerator m a +enumerate = loop + where + loop conn f = do + s <- liftIO $ recvData conn bLOCKSIZE + sendOne conn f s + + sendOne conn f s = do + v <- runIter f (if B.null s + then EOF Nothing + else Chunk $ WrapBS s) + case v of + r@(Done _ _) -> return $ liftI r + (Cont k Nothing) -> loop conn k + (Cont _ (Just e)) -> return $ throwErr e + + +writeOut :: (MonadIO m) => Connection -> Iteratee m () +writeOut conn = IterateeG out + where + out c@(EOF _) = return $ Done () c + + out (Chunk s) = do + let x = unWrap s + + liftIO $ sendData conn x + + return $ Cont (writeOut conn) Nothing + diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hsc b/src/Snap/Internal/Http/Server/LibevBackend.hsc deleted file mode 100644 --- a/src/Snap/Internal/Http/Server/LibevBackend.hsc +++ /dev/null @@ -1,631 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Snap.Internal.Http.Server.LibevBackend -( Backend -, BackendTerminatedException -, Connection -, TimeoutException -, debug -, bindIt -, new -, stop -, withConnection -, sendFile -, getReadEnd -, getWriteEnd -, getRemoteAddr -, getRemotePort -, getLocalAddr -, getLocalPort -) where - ---------------------------- --- TODO: document module -- ---------------------------- - ------------------------------------------------------------------------------- -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 Snap.Iteratee -import Snap.Internal.Debug - - -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 - } - - -data Connection = Connection - { _backend :: Backend - , _socket :: Socket - , _socketFd :: CInt - , _remoteAddr :: ByteString - , _remotePort :: Int - , _localAddr :: ByteString - , _localPort :: Int - , _readAvailable :: MVar () - , _writeAvailable :: MVar () - , _timerObj :: EvTimerPtr - , _timerCallback :: FunPtr TimerCallback - , _openingTime :: CDouble - , _lastActivity :: IORef CDouble - , _connIOObj :: EvIoPtr - , _connIOCallback :: FunPtr IoCallback - , _connThread :: MVar ThreadId - } - - -sendFile :: Connection -> FilePath -> IO () -sendFile c fp = do - withMVar lock $ \_ -> evIoStop loop io - SF.sendFile s fp - withMVar lock $ \_ -> do - tryPutMVar (_readAvailable c) () - tryPutMVar (_writeAvailable c) () - evIoStart loop io - evAsyncSend loop asy - - where - s = _socket c - io = _connIOObj c - b = _backend c - loop = _evLoop b - lock = _loopLock b - asy = _asyncObj b - - -bindIt :: ByteString -- ^ bind address, or \"*\" for all - -> Int -- ^ port to bind to - -> IO (Socket,CInt) -bindIt bindAddress bindPort = do - sock <- socket AF_INET Stream 0 - addr <- getHostAddr bindPort bindAddress - setSocketOption sock ReuseAddr 1 - bindSocket sock addr - listen sock bindPort - let sockFd = fdSocket sock - c_setnonblocking sockFd - return (sock, sockFd) - - -new :: (Socket,CInt) -- ^ value you got from bindIt - -> Int -- ^ cpu - -> IO Backend -new (sock,sockFd) cpu = do - connq <- newChan - - -- We'll try kqueue on OSX even though the libev docs complain that it's - -- "broken", in the hope that it works as expected for sockets - f <- evRecommendedBackends - lp <- evLoopNew $ toEnum . fromEnum $ f .|. evbackend_kqueue - - - -- we'll be working multithreaded so we need to set up locking for the C - -- event loop struct - (mc1,mc2,looplock) <- setupLockingForLoop lp - - -- setup async callbacks -- these allow us to wake up the main loop - -- (normally blocked in c-land) from other threads - asyncObj <- mkEvAsync - asyncCB <- mkAsyncCallback $ \_ _ _ -> do - debug "async wakeup" - return () - - killObj <- mkEvAsync - killCB <- mkAsyncCallback $ \_ _ _ -> do - debug "async kill wakeup" - evUnloop lp 2 - return () - - evAsyncInit asyncObj asyncCB - evAsyncStart lp asyncObj - evAsyncInit killObj killCB - evAsyncStart lp killObj - - -- setup the accept callback; this watches for read readiness on the listen - -- port - accCB <- mkIoCallback $ acceptCallback sockFd connq - accIO <- mkEvIo - 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 - - let b = Backend sock - sockFd - connq - lp - accCB - accIO - threadMVar - (mc1,mc2) - looplock - asyncCB - asyncObj - killCB - killObj - threadSetMVar - cpu - - tid <- forkOnIO cpu $ loopThread b - putMVar threadMVar tid - - debug $ "Backend.new: loop spawned" - return b - - --- | Run evLoop in a thread -loopThread :: Backend -> IO () -loopThread backend = do - debug $ "starting loop" - (ignoreException go) `finally` cleanup - debug $ "loop finished" - where - cleanup = do - debug $ "loopThread: cleaning up" - ignoreException $ freeBackend backend - lock = _loopLock backend - loop = _evLoop backend - go = takeMVar lock >> block (evLoop loop 0) - - -acceptCallback :: CInt -> Chan CInt -> IoCallback -acceptCallback accFd chan _loopPtr _ioPtr _ = do - r <- c_accept accFd - - case r of - -- this (EWOULDBLOCK) shouldn't happen (we just got told it was ready!), - -- if it does (maybe the request got picked up by another thread) we'll - -- just bail out - -2 -> return () - -1 -> debugErrno "Backend.acceptCallback:c_accept()" - fd -> writeChan chan fd - - -ioCallback :: MVar () -> MVar () -> IoCallback -ioCallback ra wa _loopPtr _ioPtr event = do - -- send notifications to the worker thread - when isRead $ tryPutMVar ra () >> return () - when isWrite $ tryPutMVar wa () >> return () - - where - isRead = (event .&. ev_read) /= 0 - isWrite = (event .&. ev_write) /= 0 - - -seconds :: Int -> Int -seconds n = n * ((10::Int)^(6::Int)) - - -stop :: Backend -> IO () -stop b = ignoreException $ do - debug $ "Backend.stop" - - -- FIXME: what are we gonna do here? - -- - -- 1. take the loop lock - -- 2. shut down the accept() callback - -- 3. stuff a poison pill (a bunch of -1 values should do) down the - -- connection queue so that withConnection knows to throw an exception - -- back up to its caller - -- 4. release the loop lock - -- 5. wait until all of the threads have finished, or until 10 seconds have - -- elapsed, whichever comes first - -- 6. take the loop lock - -- 7. call evUnloop and wake up the loop using evAsyncSend - -- 8. release the loop lock, the main loop thread should then free/clean - -- everything up (threads, connections, io objects, callbacks, etc) - - withMVar lock $ \_ -> do - evIoStop loop acceptObj - replicateM_ 10 $ writeChan connQ (-1) - - debug $ "Backend.stop: waiting at most 10 seconds for connection threads to die" - waitForThreads b $ seconds 10 - debug $ "Backend.stop: all threads dead, unlooping" - - withMVar lock $ \_ -> do - -- FIXME: hlibev should export EVUNLOOP_ALL - evUnloop loop 2 - evAsyncSend loop killObj - - debug $ "unloop sent" - - - where - loop = _evLoop b - acceptObj = _acceptIOObj b - killObj = _killObj b - lock = _loopLock b - connQ = _connectionQueue b - - - -waitForThreads :: Backend -> Int -> IO () -waitForThreads backend t = timeout t wait >> return () - where - threadSet = _connectionThreads backend - wait = do - threads <- readMVar threadSet - if (Set.null threads) - then return () - else threadDelay (seconds 1) >> wait - - - -getAddr :: SockAddr -> IO (ByteString, Int) -getAddr addr = - case addr of - SockAddrInet p ha -> do - s <- liftM (B.pack . map c2w) (inet_ntoa ha) - return (s, fromIntegral p) - - a -> throwIO $ AddressNotSupportedException (show a) - - --- | throw a timeout exception to the handling thread -- it'll clean up --- everything -timerCallback :: MVar ThreadId -> TimerCallback -timerCallback tmv _ _ _ = do - tid <- readMVar tmv - throwTo tid TimeoutException - - -freeConnection :: Connection -> IO () -freeConnection conn = ignoreException $ do - withMVar loopLock $ \_ -> block $ do - -- close socket (twice to get proper linger behaviour) - c_close fd - c_close fd - - -- stop and free timer object - evTimerStop loop timerObj - freeEvTimer timerObj - freeTimerCallback timerCb - - -- stop and free i/o object - evIoStop loop ioObj - freeEvIo ioObj - freeIoCallback ioCb - - -- remove the thread id from the backend set - tid <- readMVar threadMVar - modifyMVar_ tsetMVar $ return . 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 - ioObj = _connIOObj conn - ioCb = _connIOCallback conn - timerObj = _timerObj conn - timerCb = _timerCallback conn - - -ignoreException :: IO () -> IO () -ignoreException = handle (\(_::SomeException) -> return ()) - - -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 - - debug $ "Backend.freeBackend: wait at most 2 seconds for threads to die" - waitForThreads backend $ seconds 2 - - debug $ "Backend.freeBackend: all threads dead" - - debug $ "Backend.freeBackend: destroying resources" - freeEvIo acceptObj - freeIoCallback acceptCb - c_close fd - - evAsyncStop loop asyncObj - freeEvAsync asyncObj - freeAsyncCallback asyncCb - - evAsyncStop loop killObj - freeEvAsync killObj - freeAsyncCallback killCb - - freeMutexCallback mcb1 - freeMutexCallback mcb2 - - evLoopDestroy loop - debug $ "Backend.freeBackend: resources destroyed" - - where - fd = _acceptFd backend - acceptObj = _acceptIOObj backend - acceptCb = _acceptIOCallback backend - tsetMVar = _connectionThreads backend - asyncObj = _asyncObj backend - asyncCb = _asyncCb backend - killObj = _killObj backend - killCb = _killCb backend - (mcb1,mcb2) = _mutexCallbacks backend - loop = _evLoop backend - - --- | Note: proc gets run in the background -withConnection :: Backend -> Int -> (Connection -> IO ()) -> IO () -withConnection backend cpu proc = go - where - threadProc conn = ignoreException (proc conn) `finally` freeConnection conn - - go = do - fd <- readChan $ _connectionQueue backend - - -- if fd < 0 throw an exception here (because this only happens if stop - -- is called) - when (fd < 0) $ throwIO BackendTerminatedException - - sock <- mkSocket fd AF_INET Stream 0 Connected - peerName <- getPeerName sock - sockName <- getSocketName sock - - -- set_linger fd - c_setnonblocking fd - - (remoteAddr, remotePort) <- getAddr peerName - (localAddr, localPort) <- getAddr sockName - - let lp = _evLoop backend - - now <- evNow lp - lastActRef <- newIORef now - - -- makes sense to assume the socket is read/write available when - -- opened; worst-case is we get EWOULDBLOCK - ra <- newMVar () - wa <- newMVar () - - tmr <- mkEvTimer - thrmv <- newEmptyMVar - tcb <- mkTimerCallback $ timerCallback thrmv - evTimerInit tmr tcb 20 0 - - evio <- mkEvIo - iocb <- mkIoCallback $ ioCallback ra wa - evIoInit evio iocb fd (ev_read .|. ev_write) - - -- take ev_loop lock, start timer and io watchers - withMVar (_loopLock backend) $ \_ -> do - evTimerStart lp tmr - evIoStart lp evio - - -- wakeup the loop thread so that these new watchers get - -- registered next time through the loop - evAsyncSend lp $ _asyncObj backend - - let conn = Connection backend - sock - fd - remoteAddr - remotePort - localAddr - localPort - ra - wa - tmr - tcb - now - lastActRef - evio - iocb - thrmv - - - tid <- forkOnIO cpu $ threadProc conn - - modifyMVar_ (_connectionThreads backend) $ ins tid - putMVar thrmv tid - - where - ins !thr !s = let !r = Set.insert thr s in return (r `seq` r) - - -data BackendTerminatedException = BackendTerminatedException - deriving (Typeable) - -instance Show BackendTerminatedException where - show BackendTerminatedException = "Backend terminated" - -instance Exception BackendTerminatedException - - - -data AddressNotSupportedException = AddressNotSupportedException String - deriving (Typeable) - -instance Show AddressNotSupportedException where - show (AddressNotSupportedException x) = "Address not supported: " ++ x - -instance Exception AddressNotSupportedException - - -getRemoteAddr :: Connection -> ByteString -getRemoteAddr = _remoteAddr - -getRemotePort :: Connection -> Int -getRemotePort = _remotePort - -getLocalAddr :: Connection -> ByteString -getLocalAddr = _localAddr - -getLocalPort :: Connection -> Int -getLocalPort = _localPort - ------------------------------------------------------------------------------- - --- fixme: new function name -getHostAddr :: Int - -> ByteString - -> IO SockAddr -getHostAddr p s = do - h <- if s == "*" - then return iNADDR_ANY - else inet_addr (map w2c . B.unpack $ s) - - return $ SockAddrInet (fromIntegral p) h - - - -bLOCKSIZE :: Int -bLOCKSIZE = 8192 - - -data TimeoutException = TimeoutException - deriving (Typeable) - -instance Show TimeoutException where - show _ = "timeout" - -instance Exception TimeoutException - - -recvData :: Connection -> Int -> IO ByteString -recvData conn n = do - dbg "entered" - allocaBytes n $ \cstr -> do - sz <- throwErrnoIfMinus1RetryMayBlock - "recvData" - (c_read fd cstr (toEnum n)) - waitForLock - - dbg $ "sz returned " ++ show sz - - if sz == 0 - then return "" - else B.packCStringLen ((castPtr cstr),(fromEnum sz)) - - where - dbg s = debug $ "Backend.recvData(" ++ show (_socketFd conn) ++ "): " ++ s - - fd = _socketFd conn - lock = _readAvailable conn - waitForLock = do - dbg "waitForLock" - takeMVar lock - - -sendData :: Connection -> ByteString -> IO () -sendData conn bs = do - let len = B.length bs - dbg $ "entered w/ " ++ show len ++ " bytes" - written <- B.unsafeUseAsCString bs $ \cstr -> - throwErrnoIfMinus1RetryMayBlock - "sendData" - (c_write fd cstr (toEnum len)) - waitForLock - - dbg $ "wrote " ++ show written ++ " bytes" - - let n = fromEnum written - if n < len - then sendData conn $ B.drop n bs - else return () - - where - dbg s = debug $ "Backend.sendData(" ++ show (_socketFd conn) ++ "): " ++ s - fd = _socketFd conn - lock = _writeAvailable conn - waitForLock = takeMVar lock - - -getReadEnd :: Connection -> Enumerator IO a -getReadEnd = enumerate - - -getWriteEnd :: Connection -> Iteratee IO () -getWriteEnd = writeOut - - -enumerate :: (MonadIO m) => Connection -> Enumerator m a -enumerate = loop - where - loop conn f = do - s <- liftIO $ recvData conn bLOCKSIZE - sendOne conn f s - - sendOne conn f s = do - v <- runIter f (if B.null s - then EOF Nothing - else Chunk $ WrapBS s) - case v of - r@(Done _ _) -> return $ liftI r - (Cont k Nothing) -> loop conn k - (Cont _ (Just e)) -> return $ throwErr e - - -writeOut :: (MonadIO m) => Connection -> Iteratee m () -writeOut conn = IterateeG out - where - out c@(EOF _) = return $ Done () c - - out (Chunk s) = do - let x = unWrap s - - ee <- liftIO $ ((try $ sendData conn x) - :: IO (Either SomeException ())) - - case ee of - (Left e) -> return $ Done () (EOF $ Just $ Err $ show e) - (Right _) -> return $ Cont (writeOut conn) Nothing - diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hs b/src/Snap/Internal/Http/Server/SimpleBackend.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Snap.Internal.Http.Server.SimpleBackend + ( Backend + , BackendTerminatedException + , Connection + , TimeoutException + , name + , debug + , bindIt + , new + , stop + , withConnection + , sendFile + , tickleTimeout + , getReadEnd + , getWriteEnd + , getRemoteAddr + , getRemotePort + , getLocalAddr + , getLocalPort + ) where + +------------------------------------------------------------------------------ +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.Iteratee.WrappedByteString +import qualified Data.PSQueue as PSQ +import Data.PSQueue (PSQ) +import Data.Typeable +import Foreign hiding (new) +import Foreign.C.Types (CTime) +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 + + +data BackendTerminatedException = BackendTerminatedException + deriving (Typeable) + +instance Show BackendTerminatedException where + show (BackendTerminatedException) = "Backend terminated" + +instance Exception BackendTerminatedException + +data Backend = Backend + { _acceptSocket :: Socket + , _timeoutTable :: MVar (PSQ ThreadId CTime) + , _timeoutThread :: MVar ThreadId } + +data Connection = Connection + { _backend :: Backend + , _socket :: Socket + , _remoteAddr :: ByteString + , _remotePort :: Int + , _localAddr :: ByteString + , _localPort :: Int + , _connTid :: MVar ThreadId } + +{-# INLINE name #-} +name :: ByteString +name = "simple" + + +sendFile :: Connection -> FilePath -> IO () +sendFile c fp = do + let s = _socket c + SF.sendFile s fp + + +bindIt :: ByteString -- ^ bind address, or \"*\" for all + -> Int -- ^ port to bind to + -> IO Socket +bindIt bindAddress bindPort = do + sock <- socket AF_INET Stream 0 + addr <- getHostAddr bindPort bindAddress + setSocketOption sock ReuseAddr 1 + bindSocket sock addr + listen sock 150 + return sock + + +new :: Socket -- ^ value you got from bindIt + -> Int + -> IO Backend +new sock _ = do + debug $ "Backend.new: listening" + + mv <- newMVar PSQ.empty + t <- newEmptyMVar + + let b = Backend sock mv t + + tid <- forkIO $ timeoutThread b + putMVar t tid + + return b + + +timeoutThread :: Backend -> IO () +timeoutThread backend = loop + where + loop = do + killTooOld + threadDelay (5000000) + loop + + + killTooOld = modifyMVar_ tmvar $ \table -> do + now <- getCurrentDateTime + !t' <- killOlderThan now table + return t' + + + -- timeout = 60 seconds + tIMEOUT = 60 + + killOlderThan now !table = do + let mmin = PSQ.findMin table + maybe (return table) + (\m -> if now - PSQ.prio m > tIMEOUT + then do + killThread $ PSQ.key m + killOlderThan now $ PSQ.deleteMin table + else return table) + mmin + + tmvar = _timeoutTable backend + + +stop :: Backend -> IO () +stop (Backend s _ t) = do + debug $ "Backend.stop" + sClose s + + -- kill timeout thread and current thread + readMVar t >>= killThread + myThreadId >>= killThread + + +data AddressNotSupportedException = AddressNotSupportedException String + deriving (Typeable) + +instance Show AddressNotSupportedException where + show (AddressNotSupportedException x) = "Address not supported: " ++ x + +instance Exception AddressNotSupportedException + + +withConnection :: Backend -> Int -> (Connection -> IO ()) -> IO () +withConnection backend cpu proc = do + debug $ "Backend.withConnection: calling accept()" + let asock = _acceptSocket backend + (sock,addr) <- accept asock + + let fd = fdSocket sock + + debug $ "Backend.withConnection: accepted connection" + debug $ "Backend.withConnection: remote: " ++ show addr + + (port,host) <- + case addr of + SockAddrInet p h -> do + h' <- inet_ntoa h + return (fromIntegral p, B.pack $ map c2w h') + x -> throwIO $ AddressNotSupportedException $ show x + + laddr <- getSocketName sock + + (lport,lhost) <- + case laddr of + SockAddrInet p h -> do + h' <- inet_ntoa h + return (fromIntegral p, B.pack $ map c2w h') + x -> throwIO $ AddressNotSupportedException $ show x + + tmvar <- newEmptyMVar + + let c = Connection backend sock host port lhost lport tmvar + + tid <- forkOnIO cpu $ do + labelMe $ "connHndl " ++ show fd + bracket (return c) + (\_ -> block $ do + debug "sClose sock" + thr <- readMVar tmvar + + -- remove thread from timeout table + modifyMVar_ (_timeoutTable backend) $ + return . PSQ.delete thr + eatException $ shutdown sock ShutdownBoth + eatException $ sClose sock + ) + proc + + putMVar tmvar tid + tickleTimeout c + return () + + +labelMe :: String -> IO () +labelMe s = do + tid <- myThreadId + labelThread tid s + + +eatException :: IO a -> IO () +eatException act = (act >> return ()) `catch` \(_::SomeException) -> return () + +getReadEnd :: Connection -> Enumerator IO a +getReadEnd = enumerate + + +getWriteEnd :: Connection -> Iteratee IO () +getWriteEnd = writeOut + + +getRemoteAddr :: Connection -> ByteString +getRemoteAddr = _remoteAddr + +getRemotePort :: Connection -> Int +getRemotePort = _remotePort + +getLocalAddr :: Connection -> ByteString +getLocalAddr = _localAddr + +getLocalPort :: Connection -> Int +getLocalPort = _localPort + +------------------------------------------------------------------------------ +getHostAddr :: Int + -> ByteString + -> IO SockAddr +getHostAddr p s = do + h <- if s == "*" + then return iNADDR_ANY + else inet_addr (map w2c . B.unpack $ s) + + return $ SockAddrInet (fromIntegral p) h + + + +data TimeoutException = TimeoutException + deriving (Typeable) + +instance Show TimeoutException where + show TimeoutException = "timeout" + +instance Exception TimeoutException + + +tickleTimeout :: Connection -> IO () +tickleTimeout conn = modifyMVar_ ttmvar $ \t -> do + now <- getCurrentDateTime + tid <- readMVar $ _connTid conn + let !t' = PSQ.insert tid now t + return t' + + where + ttmvar = _timeoutTable $ _backend conn + + +timeoutRecv :: Connection -> Int -> IO ByteString +timeoutRecv conn n = do + let sock = _socket conn + SB.recv sock n + + +timeoutSend :: Connection -> ByteString -> IO () +timeoutSend conn s = do + let sock = _socket conn + SB.sendAll sock s + tickleTimeout conn + + +bLOCKSIZE :: Int +bLOCKSIZE = 8192 + + +enumerate :: (MonadIO m) => Connection -> Enumerator m a +enumerate = loop + where + loop conn f = do + s <- liftIO $ timeoutRecv conn bLOCKSIZE + sendOne conn f s + + sendOne conn f s = do + v <- runIter f (if B.null s + then EOF Nothing + else Chunk $ WrapBS s) + case v of + r@(Done _ _) -> return $ liftI r + (Cont k Nothing) -> loop conn k + (Cont _ (Just e)) -> return $ throwErr e + + +writeOut :: (MonadIO m) => Connection -> Iteratee m () +writeOut conn = IterateeG out + where + out c@(EOF _) = return $ Done () c + + out (Chunk s) = do + let x = unWrap s + + ee <- liftIO $ ((try $ timeoutSend conn x) + :: IO (Either SomeException ())) + + case ee of + (Left e) -> return $ Done () (EOF $ Just $ Err $ show e) + (Right _) -> return $ Cont (writeOut conn) Nothing + diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hsc b/src/Snap/Internal/Http/Server/SimpleBackend.hsc deleted file mode 100644 --- a/src/Snap/Internal/Http/Server/SimpleBackend.hsc +++ /dev/null @@ -1,259 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Snap.Internal.Http.Server.SimpleBackend -( Backend -, BackendTerminatedException -, Connection -, TimeoutException -, debug -, bindIt -, new -, stop -, withConnection -, sendFile -, getReadEnd -, getWriteEnd -, getRemoteAddr -, getRemotePort -, getLocalAddr -, getLocalPort -) where - ------------------------------------------------------------------------------- -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.Iteratee.WrappedByteString -import Data.Typeable -#ifdef LINUX -import Foreign hiding (new) -#endif -import Foreign.C.Types -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.Iteratee - - -data BackendTerminatedException = BackendTerminatedException - deriving (Typeable) - -instance Show BackendTerminatedException where - show (BackendTerminatedException) = "Backend terminated" - -instance Exception BackendTerminatedException - - --- foreign import ccall unsafe "set_linger" --- set_linger :: CInt -> IO () - -foreign import ccall unsafe "set_fd_timeout" - set_fd_timeout :: CInt -> IO () - - -data Backend = Backend - { _acceptSocket :: Socket } - -data Connection = Connection - { _socket :: Socket - , _remoteAddr :: ByteString - , _remotePort :: Int - , _localAddr :: ByteString - , _localPort :: Int } - - -sendFile :: Connection -> FilePath -> IO () -sendFile c fp = do - let s = _socket c - SF.sendFile s fp - - -bindIt :: ByteString -- ^ bind address, or \"*\" for all - -> Int -- ^ port to bind to - -> IO Socket -bindIt bindAddress bindPort = do - sock <- socket AF_INET Stream 0 - addr <- getHostAddr bindPort bindAddress - setSocketOption sock ReuseAddr 1 - bindSocket sock addr - listen sock bindPort - return sock - - -new :: Socket -- ^ value you got from bindIt - -> Int - -> IO Backend -new sock _ = do - debug $ "Backend.new: listening" - return $ Backend sock - - -stop :: Backend -> IO () -stop (Backend s) = do - debug $ "Backend.stop" - sClose s - - -data AddressNotSupportedException = AddressNotSupportedException String - deriving (Typeable) - -instance Show AddressNotSupportedException where - show (AddressNotSupportedException x) = "Address not supported: " ++ x - -instance Exception AddressNotSupportedException - - -withConnection :: Backend -> Int -> (Connection -> IO ()) -> IO () -withConnection (Backend asock) cpu proc = do - debug $ "Backend.withConnection: calling accept()" - (sock,addr) <- accept asock - - let fd = fdSocket sock - -- set linger - --set_linger fd - set_fd_timeout fd - - debug $ "Backend.withConnection: accepted connection" - debug $ "Backend.withConnection: remote: " ++ show addr - - (port,host) <- - case addr of - SockAddrInet p h -> do - h' <- inet_ntoa h - return (fromIntegral p, B.pack $ map c2w h') - x -> throwIO $ AddressNotSupportedException $ show x - - laddr <- getSocketName sock - - (lport,lhost) <- - case laddr of - SockAddrInet p h -> do - h' <- inet_ntoa h - return (fromIntegral p, B.pack $ map c2w h') - x -> throwIO $ AddressNotSupportedException $ show x - - let c = Connection sock host port lhost lport - - forkOnIO cpu $ do - labelMe $ "connHndl " ++ show fd - bracket (return c) - (\_ -> do - debug "sClose sock" - eatException $ shutdown sock ShutdownBoth - eatException $ sClose sock - eatException $ sClose sock - ) - proc - - return () - - -labelMe :: String -> IO () -labelMe s = do - tid <- myThreadId - labelThread tid s - - -eatException :: IO a -> IO () -eatException act = (act >> return ()) `catch` \(_::SomeException) -> return () - -getReadEnd :: Connection -> Enumerator IO a -getReadEnd = enumerate - - -getWriteEnd :: Connection -> Iteratee IO () -getWriteEnd = writeOut - - -getRemoteAddr :: Connection -> ByteString -getRemoteAddr = _remoteAddr - -getRemotePort :: Connection -> Int -getRemotePort = _remotePort - -getLocalAddr :: Connection -> ByteString -getLocalAddr = _localAddr - -getLocalPort :: Connection -> Int -getLocalPort = _localPort - ------------------------------------------------------------------------------- -getHostAddr :: Int - -> ByteString - -> IO SockAddr -getHostAddr p s = do - h <- if s == "*" - then return iNADDR_ANY - else inet_addr (map w2c . B.unpack $ s) - - return $ SockAddrInet (fromIntegral p) h - - - -data TimeoutException = TimeoutException - deriving (Typeable) - -instance Show TimeoutException where - show TimeoutException = "timeout" - -instance Exception TimeoutException - - -timeoutRecv :: Connection -> Int -> IO ByteString -timeoutRecv conn n = do - let sock = _socket conn - SB.recv sock n - -timeoutSend :: Connection -> ByteString -> IO () -timeoutSend conn s = do - let sock = _socket conn - SB.sendAll sock s - - -bLOCKSIZE :: Int -bLOCKSIZE = 8192 - - -enumerate :: (MonadIO m) => Connection -> Enumerator m a -enumerate = loop - where - loop conn f = do - s <- liftIO $ timeoutRecv conn bLOCKSIZE - sendOne conn f s - - sendOne conn f s = do - v <- runIter f (if B.null s - then EOF Nothing - else Chunk $ WrapBS s) - case v of - r@(Done _ _) -> return $ liftI r - (Cont k Nothing) -> loop conn k - (Cont _ (Just e)) -> return $ throwErr e - - -writeOut :: (MonadIO m) => Connection -> Iteratee m () -writeOut conn = IterateeG out - where - out c@(EOF _) = return $ Done () c - - out (Chunk s) = do - let x = unWrap s - - ee <- liftIO $ ((try $ timeoutSend conn x) - :: IO (Either SomeException ())) - - case ee of - (Left e) -> return $ Done () (EOF $ Just $ Err $ show e) - (Right _) -> return $ Cont (writeOut conn) Nothing - diff --git a/src/System/FastLogger.hs b/src/System/FastLogger.hs --- a/src/System/FastLogger.hs +++ b/src/System/FastLogger.hs @@ -23,7 +23,6 @@ import Data.IORef import Data.Maybe import Data.Serialize.Put -import Data.Time.Clock import Prelude hiding (catch, show) import qualified Prelude import System.IO @@ -176,7 +175,7 @@ t <- getCurrentDateTime old <- readIORef lastOpened - if diffUTCTime t old > 900 + if t-old > 900 then do closeIt h openIt >>= writeIORef href diff --git a/test/pongserver/Paths_snap_server.hs b/test/pongserver/Paths_snap_server.hs new file mode 100644 --- /dev/null +++ b/test/pongserver/Paths_snap_server.hs @@ -0,0 +1,9 @@ +module Paths_snap_server ( + version + ) where + +import Data.Version (Version(..)) + +version :: Version +version = Version {versionBranch = [0,0,0], versionTags = ["unknown"]} + 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 @@ -7,18 +7,20 @@ Description: Use libev? Default: False +Flag portable + Description: Compile in cross-platform mode. No platform-specific code or + optimizations such as C routines will be used. + Default: False + Executable testsuite - hs-source-dirs: ../src suite + hs-source-dirs: suite ../src main-is: TestSuite.hs - c-sources: ../cbits/linger.c - include-dirs: ../cbits - build-depends: QuickCheck >= 2, array >= 0.3 && <0.4, attoparsec >= 0.8.0.2 && < 0.9, - attoparsec-iteratee >= 0.1 && <0.2, + attoparsec-iteratee >= 0.1.1 && <0.2, base >= 4 && < 5, binary >= 0.5 && < 0.6, bytestring, @@ -44,31 +46,36 @@ time, transformers, vector >= 0.6.0.1 && < 0.7 - + + if !os(windows) + build-depends: unix + if flag(libev) build-depends: hlibev >= 0.2.1 other-modules: Snap.Internal.Http.Server.LibevBackend cpp-options: -DLIBEV else - build-depends: network-bytestring >= 0.1.2 && < 0.2 + build-depends: network-bytestring >= 0.1.2 && < 0.2, + PSQueue >= 1.1 && <1.2 + other-modules: Snap.Internal.Http.Server.SimpleBackend + if flag(portable) || os(windows) + cpp-options: -DPORTABLE + ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind Executable pongserver - hs-source-dirs: ../src pongserver + hs-source-dirs: pongserver ../src main-is: Main.hs - c-sources: ../cbits/linger.c - include-dirs: ../cbits - build-depends: QuickCheck >= 2, array >= 0.3 && <0.4, attoparsec >= 0.8.0.2 && < 0.9, - attoparsec-iteratee >= 0.1 && <0.2, + attoparsec-iteratee >= 0.1.1 && <0.2, base >= 4 && < 5, bytestring, bytestring-nums >= 0.3.1 && < 0.4, @@ -90,15 +97,20 @@ snap-core >= 0.2.1 && <0.3, time, transformers, - unix, + unix-compat, vector >= 0.6.0.1 && < 0.7 + if !os(windows) + build-depends: unix + if flag(libev) build-depends: hlibev >= 0.2.1 other-modules: Snap.Internal.Http.Server.LibevBackend cpp-options: -DLIBEV else - build-depends: network-bytestring >= 0.1.2 && < 0.2 + build-depends: network-bytestring >= 0.1.2 && < 0.2, + PSQueue >= 1.1 && <1.2 + other-modules: Snap.Internal.Http.Server.SimpleBackend if os(linux) @@ -106,6 +118,9 @@ if os(darwin) cpp-options: -DOSX + + if flag(portable) || os(windows) + cpp-options: -DPORTABLE ghc-options: -Wall -O2 -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind diff --git a/test/suite/Paths_snap_server.hs b/test/suite/Paths_snap_server.hs new file mode 100644 --- /dev/null +++ b/test/suite/Paths_snap_server.hs @@ -0,0 +1,9 @@ +module Paths_snap_server ( + version + ) where + +import Data.Version (Version(..)) + +version :: Version +version = Version {versionBranch = [0,0,0], versionTags = ["unknown"]} + 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 @@ -6,7 +6,7 @@ ( tests ) where import qualified Control.Exception as E -import Control.Exception hiding (try) +import Control.Exception hiding (try, assert) import Control.Monad import Control.Monad.Identity import Control.Parallel.Strategies @@ -16,9 +16,13 @@ import qualified Data.ByteString.Lazy as L import Data.ByteString.Internal (c2w) import qualified Data.Map as Map +import Data.Maybe (isNothing) import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck +import qualified Test.QuickCheck.Monadic as QC +import Test.QuickCheck.Monadic hiding (run, assert) import Test.HUnit hiding (Test, path) import Text.Printf @@ -59,17 +63,18 @@ assertEqual "should be foo" "foo" l + forceErr :: SomeException -> IO () forceErr e = f `seq` (return ()) where !f = show e + testNull :: Test testNull = testCase "short parse" $ do - f <- E.try $ run (parseRequest) + f <- run (parseRequest) + assertBool "should be Nothing" $ isNothing f - case f of (Left e) -> forceErr e - (Right x) -> assertFailure $ "expected exception, got " ++ show x testPartial :: Test testPartial = testCase "partial parse" $ do @@ -136,22 +141,23 @@ return $ liftM fromWrap i testBothChunked :: Test -testBothChunked = testProperty "chunk . unchunk == id" prop +testBothChunked = testProperty "chunk . unchunk == id" $ + monadicIO $ forAllM arbitrary prop where - prop :: L.ByteString -> Bool - prop s = runIdentity (run iter) == s - where - bs = runIdentity $ - (writeChunkedTransferEncoding - (enumLBS s) stream2stream) >>= - run >>= - return . fromWrap + prop s = do + buf <- QC.run mkIterateeBuffer + bs <- QC.run $ + writeChunkedTransferEncoding buf (enumLBS s) stream2stream + >>= run >>= return . fromWrap - enum = enumLBS bs + let enum = enumLBS bs - iter = runIdentity $ do - i <- (readChunkedTransferEncoding stream2stream) >>= enum - return $ liftM fromWrap i + iter <- do + i <- (readChunkedTransferEncoding stream2stream) >>= enum + return $ liftM fromWrap i + + x <- run iter + QC.assert $ s == x 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 @@ -15,10 +15,13 @@ import Data.ByteString.Internal (c2w, w2c) import Data.Char import Data.IORef +import Data.Iteratee.WrappedByteString import qualified Data.Map as Map import Data.Maybe (fromJust) +import Data.Monoid import Data.Time.Calendar import Data.Time.Clock +import Data.Word import qualified Network.HTTP as HTTP import Prelude hiding (take) import qualified Prelude @@ -81,6 +84,21 @@ where ms = [ GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT ] + +copyingStream2stream :: Iteratee IO (WrappedByteString Word8) +copyingStream2stream = IterateeG (step mempty) + where + step acc (Chunk (WrapBS ls)) + | S.null ls = return $ Cont (IterateeG (step acc)) Nothing + | otherwise = do + let !ls' = S.copy ls + let !bs' = WrapBS $! ls' + return $ Cont (IterateeG (step (acc `mappend` bs'))) + Nothing + + step acc str = return $ Done acc str + + testHttpRequest1 :: Test testHttpRequest1 = testCase "HttpRequest1" $ do @@ -89,7 +107,7 @@ r <- liftM fromJust $ rsm receiveRequest se <- liftIO $ readIORef (rqBody r) let (SomeEnumerator e) = se - b <- liftM fromWrap $ joinIM $ e stream2stream + b <- liftM fromWrap $ joinIM $ e copyingStream2stream return (r,b) (req,body) <- run iter @@ -132,11 +150,11 @@ r1 <- liftM fromJust $ rsm receiveRequest se1 <- liftIO $ readIORef (rqBody r1) let (SomeEnumerator e1) = se1 - b1 <- liftM fromWrap $ joinIM $ e1 stream2stream + b1 <- liftM fromWrap $ joinIM $ e1 copyingStream2stream r2 <- liftM fromJust $ rsm receiveRequest se2 <- liftIO $ readIORef (rqBody r2) let (SomeEnumerator e2) = se2 - b2 <- liftM fromWrap $ joinIM $ e2 stream2stream + b2 <- liftM fromWrap $ joinIM $ e2 copyingStream2stream return (r1,b1,r2,b2) (req1,body1,req2,body2) <- run iter @@ -209,7 +227,7 @@ r <- liftM fromJust $ rsm receiveRequest se <- liftIO $ readIORef (rqBody r) let (SomeEnumerator e) = se - b <- liftM fromWrap $ joinIM $ e stream2stream + b <- liftM fromWrap $ joinIM $ e copyingStream2stream return (r,b) (_,body) <- run iter @@ -225,7 +243,7 @@ r <- liftM fromJust $ rsm receiveRequest se <- liftIO $ readIORef (rqBody r) let (SomeEnumerator e) = se - b <- liftM fromWrap $ joinIM $ e stream2stream + b <- liftM fromWrap $ joinIM $ e copyingStream2stream return (r,b) (req,body) <- run iter @@ -271,10 +289,13 @@ testHttpResponse1 :: Test testHttpResponse1 = testCase "HttpResponse1" $ do - let onSendFile = \f -> enumFile f stream2stream >>= run + let onSendFile = \f -> enumFile f copyingStream2stream >>= run + buf <- mkIterateeBuffer + b <- run $ rsm $ - sendResponse rsp1 stream2stream onSendFile >>= return . fromWrap . snd + sendResponse rsp1 copyingStream2stream buf (return ()) onSendFile >>= + return . fromWrap . snd assertEqual "http response" (L.concat [ "HTTP/1.0 600 Test\r\n" @@ -284,7 +305,8 @@ ]) b b2 <- run $ rsm $ - sendResponse rsp2 stream2stream onSendFile >>= return . fromWrap . snd + sendResponse rsp2 copyingStream2stream buf (return ()) onSendFile >>= + return . fromWrap . snd assertEqual "http response" (L.concat [ "HTTP/1.0 600 Test\r\n" @@ -294,7 +316,8 @@ ]) b2 b3 <- run $ rsm $ - sendResponse rsp3 stream2stream onSendFile >>= return . fromWrap . snd + sendResponse rsp3 copyingStream2stream buf (return ()) onSendFile >>= + return . fromWrap . snd assertEqual "http response" b3 $ L.concat [ "HTTP/1.1 600 Test\r\n" @@ -329,7 +352,7 @@ echoServer _ req = do se <- liftIO $ readIORef (rqBody req) let (SomeEnumerator enum) = se - let i = joinIM $ enum stream2stream + let i = joinIM $ enum copyingStream2stream b <- liftM fromWrap i let cl = L.length b liftIO $ writeIORef (rqBody req) (SomeEnumerator $ return . joinI . take 0) @@ -357,7 +380,7 @@ let (iter,onSendFile) = mkIter ref runHTTP "localhost" "127.0.0.1" 80 "127.0.0.1" 58384 - Nothing Nothing enumBody iter onSendFile echoServer + Nothing Nothing enumBody iter onSendFile (return ()) echoServer s <- readIORef ref @@ -388,7 +411,7 @@ mkIter ref = (iter, \f -> onF f iter) where iter = do - x <- stream2stream + x <- copyingStream2stream liftIO $ modifyIORef ref $ \s -> L.append s (fromWrap x) onF f i = enumFile f i >>= run @@ -402,7 +425,7 @@ let (iter,onSendFile) = mkIter ref runHTTP "localhost" "127.0.0.1" 80 "127.0.0.1" 58384 - Nothing Nothing enumBody iter onSendFile f + Nothing Nothing enumBody iter onSendFile (return ()) f -- this is a pretty lame way of checking whether the output was chunked, -- but "whatever" @@ -451,6 +474,7 @@ enumBody iter onSendFile + (return ()) echoServer2 s <- readIORef ref