snap-server 0.2.2 → 0.2.4
raw patch · 18 files changed
+1297/−1018 lines, 18 filesdep +PSQueuedep +unix-compatdep ~attoparsec-iterateedep ~hlibev
Dependencies added: PSQueue, unix-compat
Dependency ranges changed: attoparsec-iteratee, hlibev
Files
- CONTRIBUTORS +2/−0
- README.md +0/−11
- cbits/linger.c +0/−23
- snap-server.cabal +21/−9
- src/Snap/Http/Server.hs +7/−0
- src/Snap/Internal/Http/Parser.hs +10/−6
- src/Snap/Internal/Http/Server.hs +58/−16
- src/Snap/Internal/Http/Server/Date.hs +25/−17
- src/Snap/Internal/Http/Server/LibevBackend.hs +740/−0
- src/Snap/Internal/Http/Server/LibevBackend.hsc +0/−631
- src/Snap/Internal/Http/Server/SimpleBackend.hs +326/−0
- src/Snap/Internal/Http/Server/SimpleBackend.hsc +0/−259
- src/System/FastLogger.hs +1/−2
- test/pongserver/Paths_snap_server.hs +9/−0
- test/snap-server-testsuite.cabal +29/−14
- test/suite/Paths_snap_server.hs +9/−0
- test/suite/Snap/Internal/Http/Parser/Tests.hs +23/−17
- test/suite/Snap/Internal/Http/Server/Tests.hs +37/−13
CONTRIBUTORS view
@@ -1,4 +1,6 @@ Doug Beardsley <mightybyte@gmail.com> Gregory Collins <greg@gregorycollins.net> Shu-yu Guo <shu@rfrn.org>+Carl Howells James Sanders <jimmyjazz14@gmail.com>+Jacob Stanley <jystic@jystic.com>
README.md view
@@ -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/)
− cbits/linger.c
@@ -1,23 +0,0 @@-#include <sys/socket.h>-#include <sys/time.h>---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));-}
snap-server.cabal view
@@ -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)
src/Snap/Http/Server.hs view
@@ -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.
src/Snap/Internal/Http/Parser.hs view
@@ -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
src/Snap/Internal/Http/Server.hs view
@@ -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
src/Snap/Internal/Http/Server/Date.hs view
@@ -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
+ src/Snap/Internal/Http/Server/LibevBackend.hs view
@@ -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+
− src/Snap/Internal/Http/Server/LibevBackend.hsc
@@ -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-
+ src/Snap/Internal/Http/Server/SimpleBackend.hs view
@@ -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+
− src/Snap/Internal/Http/Server/SimpleBackend.hsc
@@ -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-
src/System/FastLogger.hs view
@@ -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
+ test/pongserver/Paths_snap_server.hs view
@@ -0,0 +1,9 @@+module Paths_snap_server (+ version+ ) where++import Data.Version (Version(..))++version :: Version+version = Version {versionBranch = [0,0,0], versionTags = ["unknown"]}+
test/snap-server-testsuite.cabal view
@@ -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
+ test/suite/Paths_snap_server.hs view
@@ -0,0 +1,9 @@+module Paths_snap_server (+ version+ ) where++import Data.Version (Version(..))++version :: Version+version = Version {versionBranch = [0,0,0], versionTags = ["unknown"]}+
test/suite/Snap/Internal/Http/Parser/Tests.hs view
@@ -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
test/suite/Snap/Internal/Http/Server/Tests.hs view
@@ -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