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.6.0.1 +version: 0.7 synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework description: Snap is a simple and fast web development framework and server written in @@ -27,7 +27,7 @@ build-type: Simple cabal-version: >= 1.6 homepage: http://snapframework.com/ -category: Web +category: Web, Snap extra-source-files: CONTRIBUTORS, @@ -100,28 +100,28 @@ build-depends: array >= 0.2 && <0.4, - attoparsec >= 0.8.1 && < 0.10, - attoparsec-enumerator >= 0.2.0.1 && < 0.3, + attoparsec >= 0.10 && < 0.11, + attoparsec-enumerator >= 0.3 && < 0.4, base >= 4 && < 5, binary >= 0.5 && < 0.6, blaze-builder >= 0.2.1.4 && < 0.4, blaze-builder-enumerator >= 0.2.0 && < 0.3, - bytestring >= 0.9.1 && < 0.10, + bytestring >= 0.9.1 && < 0.10, bytestring-nums, - case-insensitive >= 0.3 && < 0.4, - containers >= 0.3 && < 0.5, - directory-tree >= 0.10 && < 0.11, + case-insensitive >= 0.3 && < 0.5, + containers >= 0.3 && < 0.5, + directory-tree >= 0.10 && < 0.11, enumerator >= 0.4.13.1 && < 0.5, - filepath >= 1.1 && < 1.3, + filepath >= 1.1 && < 1.3, MonadCatchIO-transformers >= 0.2.1 && < 0.3, mtl >= 2 && < 3, murmur-hash >= 0.1 && < 0.2, network >= 2.3 && < 2.4, old-locale, - snap-core >= 0.6 && < 0.7, + snap-core >= 0.7 && < 0.8, template-haskell >= 2.2 && < 2.7, text >= 0.11 && < 0.12, - time >= 1.0 && < 1.4, + time >= 1.0 && < 1.5, transformers >= 0.2 && < 0.3, unix-compat >= 0.2 && < 0.4, vector >= 0.7 && < 0.10, 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 @@ -21,7 +21,7 @@ import Control.Exception import Control.Monad (liftM) import Control.Monad.Trans -import Data.Attoparsec hiding (many, Result(..)) +import Data.Attoparsec import Data.Attoparsec.Enumerator import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs --- a/src/Snap/Internal/Http/Server.hs +++ b/src/Snap/Internal/Http/Server.hs @@ -18,6 +18,7 @@ , finally , Handler ) +import qualified Control.Monad.CatchIO as CatchIO import Control.Monad.State.Strict import Control.Exception hiding (catch, throw) import Data.Char @@ -45,6 +46,7 @@ import System.Locale ------------------------------------------------------------------------------ import System.FastLogger (timestampedLogEntry, combinedLogEntry) +import Snap.Core (EscapeHttpException (..)) import Snap.Internal.Http.Types import Snap.Internal.Debug import Snap.Internal.Http.Parser @@ -371,8 +373,11 @@ logerr <- gets _logError - (req',rspOrig) <- (lift $ handler logerr tickle req) `catch` - errCatch "user hander" req + (req',rspOrig) <- (lift $ handler logerr tickle req) + `CatchIO.catches` + [ CatchIO.Handler $ escapeHttpCatch + , CatchIO.Handler $ errCatch "user handler" req + ] debug $ "Server.httpSession: finished running user handler" @@ -430,6 +435,12 @@ return () where + escapeHttpCatch :: EscapeHttpException -> ServerMonad a + escapeHttpCatch (EscapeHttpException escapeIter) = do + lift $ escapeIter tickle writeEnd' + throw ExceptionAlreadyCaught + + errCatch :: ByteString -> Request -> SomeException -> ServerMonad a errCatch phase req e = do logError $ toByteString $ mconcat [ fromByteString "httpSession caught an exception during " diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hs b/src/Snap/Internal/Http/Server/SimpleBackend.hs --- a/src/Snap/Internal/Http/Server/SimpleBackend.hs +++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs @@ -107,14 +107,29 @@ acceptThread defaultTimeout handler tmgr elog cpu sock exitMVar = loop `finally` (tryPutMVar exitMVar () >> return ()) where - loop = do + acceptAndFork = do debug $ "acceptThread: calling accept() on socket " ++ show sock (s,addr) <- accept $ Listen.listenSocket sock debug $ "acceptThread: accepted connection from remote: " ++ show addr _ <- forkOnIO cpu (go s addr `catches` cleanup) + return () + + loop = do + acceptAndFork `catches` acceptHandler loop go = runSession defaultTimeout handler tmgr sock + + acceptHandler = + [ Handler $ \(e :: AsyncException) -> throwIO e + , Handler $ \(e :: SomeException) -> do + elog $ S.concat [ "SimpleBackend.acceptThread: accept threw: " + , S.pack . map c2w $ show e ] + -- we're out of file descriptors, and it isn't likely to get + -- better immediately; sleep for 10ms to avoid spamming the error + -- log. + threadDelay $ 10000 + ] cleanup = [ diff --git a/src/System/SendFile/Darwin.hsc b/src/System/SendFile/Darwin.hsc --- a/src/System/SendFile/Darwin.hsc +++ b/src/System/SendFile/Darwin.hsc @@ -1,14 +1,22 @@ -{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE CPP, ForeignFunctionInterface #-} -- | Darwin system-dependent code for 'sendfile'. module System.SendFile.Darwin (sendFile) where import Data.Int import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno) +#if __GLASGOW_HASKELL__ >= 703 +import Foreign.C.Types (CInt(CInt)) +#else import Foreign.C.Types (CInt) +#endif import Foreign.Marshal (alloca) import Foreign.Ptr (Ptr, nullPtr) import Foreign.Storable (peek, poke) +#if __GLASGOW_HASKELL__ >= 703 +import System.Posix.Types (Fd(Fd), COff(COff)) +#else import System.Posix.Types (Fd, COff) +#endif sendFile :: IO () -> Fd -> Fd -> Int64 -> Int64 -> IO Int64 sendFile onBlock out_fd in_fd off count 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 @@ -23,8 +23,8 @@ build-depends: QuickCheck >= 2, array >= 0.3 && <0.4, - attoparsec >= 0.8.1 && < 0.10, - attoparsec-enumerator >= 0.2.0.1 && < 0.3, + attoparsec >= 0.10 && < 0.11, + attoparsec-enumerator >= 0.3 && < 0.4, base >= 4 && < 5, base16-bytestring == 0.1.*, binary >= 0.5 && < 0.6, @@ -37,7 +37,7 @@ directory-tree, enumerator >= 0.4.13.1 && <0.5, filepath, - http-enumerator >= 0.7 && <0.8, + http-enumerator >= 0.7.1.6 && <0.8, HUnit >= 1.2 && < 2, mtl >= 2 && <3, murmur-hash >= 0.1 && < 0.2, @@ -45,14 +45,14 @@ old-locale, parallel > 2, process, - snap-core >= 0.6 && < 0.7, + snap-core >= 0.7 && < 0.8, template-haskell, test-framework >= 0.4 && < 0.5, test-framework-hunit >= 0.2.5 && < 0.3, test-framework-quickcheck2 >= 0.2.6 && < 0.3, text >= 0.11 && <0.12, time, - tls >= 0.7.1 && <0.9, + tls >= 0.8.2 && <0.9, transformers, vector >= 0.7 && <0.10, vector-algorithms >= 0.4 && <0.6, @@ -99,8 +99,8 @@ build-depends: QuickCheck >= 2, array >= 0.3 && <0.4, - attoparsec >= 0.8.1 && < 0.10, - attoparsec-enumerator >= 0.2.0.1 && < 0.3, + attoparsec >= 0.10 && < 0.11, + attoparsec-enumerator >= 0.3 && < 0.4, base >= 4 && < 5, base16-bytestring == 0.1.*, blaze-builder >= 0.2.1.4 && <0.4, @@ -119,7 +119,7 @@ parallel > 2, MonadCatchIO-transformers >= 0.2.1 && < 0.3, network == 2.3.*, - snap-core >= 0.6 && < 0.7, + snap-core >= 0.7 && < 0.8, template-haskell, time, transformers, @@ -175,15 +175,15 @@ build-depends: QuickCheck >= 2, array >= 0.3 && <0.4, - attoparsec >= 0.8.1 && < 0.10, - attoparsec-enumerator >= 0.2.0.1 && < 0.3, + attoparsec >= 0.10 && < 0.11, + attoparsec-enumerator >= 0.3 && < 0.4, base >= 4 && < 5, binary >= 0.5 && < 0.6, blaze-builder >= 0.2.1.4 && <0.4, blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring, bytestring-nums >= 0.3.1 && < 0.4, - case-insensitive >= 0.3 && < 0.4, + case-insensitive >= 0.3 && < 0.5, containers, directory-tree, enumerator >= 0.4.7 && <0.5, @@ -195,7 +195,7 @@ network == 2.3.*, old-locale, parallel > 2, - snap-core >= 0.6 && < 0.7, + snap-core >= 0.7 && < 0.8, template-haskell, test-framework >= 0.4 && < 0.5, test-framework-hunit >= 0.2.5 && < 0.3, @@ -239,6 +239,6 @@ build-depends: base >= 4 && < 5, network == 2.3.*, - http-enumerator >= 0.7 && <0.8, - tls >= 0.7.1 && <0.9, + http-enumerator >= 0.7.1.6 && <0.8, + tls >= 0.8.2 && <0.9, criterion >= 0.5 && <0.6 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 @@ -27,6 +27,8 @@ import Data.ByteString.Internal (c2w) import qualified Data.CaseInsensitive as CI import Data.Char +import qualified Data.Enumerator as E +import qualified Data.Enumerator.List as EL import Data.Int import Data.IORef import Data.List (foldl', sort) @@ -75,6 +77,7 @@ , testHttp2 , testHttp100 , test411 + , testEscapeHttp , testExpectGarbage , testPartialParse , testMethodParsing @@ -846,6 +849,31 @@ assertBool "411 Length Required" ok + +testEscapeHttp :: Test +testEscapeHttp = testCase "server/escapeHttp" $ do + ref <- newIORef "" + let (iter,onSendFile) = mkIter ref + + runHTTP 60 + Nothing + Nothing + escapeServer + "localhost" + (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) + (enumBS sampleRequest) + iter + onSendFile + (const $ return ()) + + s <- readIORef ref + + assertEqual "escapeHttp" "0123456789" s + where + -- Escape HTTP traffic. Read one ByteString and send it back. + escapeServer = runSnap $ escapeHttp $ \_ sendIter -> do + Just bs <- EL.head + liftIO $ E.run_ $ E.enumList 1 [bs] $$ sendIter testExpectGarbage :: Test