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.5.4 +version: 0.5.5 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 @@ -102,7 +102,7 @@ array >= 0.2 && <0.4, attoparsec >= 0.8.1 && < 0.10, attoparsec-enumerator >= 0.2.0.1 && < 0.3, - base >= 4.3 && < 5, + base >= 4 && < 5, binary >= 0.5 && <0.6, blaze-builder >= 0.2.1.4 && <0.4, blaze-builder-enumerator >= 0.2.0 && <0.3, 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 @@ -13,6 +13,7 @@ import Blaze.ByteString.Builder.Enumerator import Blaze.ByteString.Builder.HTTP import Control.Arrow (first, second) +import Control.Concurrent (newMVar) import Control.Monad.CatchIO hiding ( bracket , catches , finally @@ -40,7 +41,9 @@ import Data.Typeable import Data.Version import GHC.Conc +import Network.Socket (withSocketsDo) import Prelude hiding (catch) +import System.IO import System.PosixCompat.Files hiding (setFileSize) import System.Posix.Types (FileOffset) import System.Locale @@ -164,8 +167,7 @@ -> IO () httpServe defaultTimeout ports mevType localHostname alogPath elogPath handler = - withLoggers alogPath elogPath - (\(alog, elog) -> spawnAll alog elog) + withSocketsDo $ withLoggers alogPath elogPath $ uncurry spawnAll where -------------------------------------------------------------------------- @@ -208,13 +210,18 @@ -------------------------------------------------------------------------- - maybeSpawnLogger = maybe (return Nothing) $ (liftM Just) . newLogger + maybeSpawnLogger f = + maybe (return Nothing) + ((liftM Just) . newLoggerWithCustomErrorFunction f) -------------------------------------------------------------------------- withLoggers afp efp = - bracket (do alog <- maybeSpawnLogger afp - elog <- maybeSpawnLogger efp + bracket (do mvar <- newMVar () + let f s = withMVar mvar + (const $ S.hPutStr stderr s >> hFlush stderr) + alog <- maybeSpawnLogger f afp + elog <- maybeSpawnLogger f efp return (alog, elog)) (\(alog, elog) -> do maybe (return ()) stopLogger alog 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 @@ -62,7 +62,7 @@ ------------------------------------------------------------------------------ ensureFreshDate :: IO () -ensureFreshDate = mask_ $ do +ensureFreshDate = block $ do now <- epochTime old <- readIORef $ _lastFetchTime dateState when (now > old) $ updateState dateState @@ -70,14 +70,14 @@ ------------------------------------------------------------------------------ getDateString :: IO ByteString -getDateString = mask_ $ do +getDateString = block $ do ensureFreshDate readIORef $ _cachedDateString dateState ------------------------------------------------------------------------------ getLogDateString :: IO ByteString -getLogDateString = mask_ $ do +getLogDateString = block $ do ensureFreshDate readIORef $ _cachedLogString dateState diff --git a/src/Snap/Internal/Http/Server/HttpPort.hs b/src/Snap/Internal/Http/Server/HttpPort.hs --- a/src/Snap/Internal/Http/Server/HttpPort.hs +++ b/src/Snap/Internal/Http/Server/HttpPort.hs @@ -99,7 +99,7 @@ let sent' = fromIntegral sent if sent' < len then tickleTimeout >> loop (plusPtr ptr sent') (len - sent') - else return () + else tickleTimeout ------------------------------------------------------------------------------ diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs b/src/Snap/Internal/Http/Server/LibevBackend.hs --- a/src/Snap/Internal/Http/Server/LibevBackend.hs +++ b/src/Snap/Internal/Http/Server/LibevBackend.hs @@ -456,13 +456,12 @@ ----------------- tmr <- mkEvTimer now <- getCurrentDateTime - timeoutTime <- newIORef $ now + 20 + timeoutTime <- newIORef $ now + (fromIntegral defaultTimeout) tcb <- mkTimerCallback $ timerCallback lp tmr timeoutTime tid - -- 20 second timeout - evTimerInit tmr tcb 0 20.0 + evTimerInit tmr tcb 0 (fromIntegral defaultTimeout) readActive <- newIORef True @@ -525,7 +524,7 @@ (enumerate conn session) (writeOut defaultTimeout conn session) (sendFile defaultTimeout conn session) - (tickleTimeout conn) + (setTimeout conn) ) @@ -572,6 +571,19 @@ ------------------------------------------------------------------------------ tickleTimeout :: Connection -> Int -> IO () tickleTimeout conn tm = do + debug "Libev.tickleTimeout" + now <- getCurrentDateTime + prev <- readIORef ref + let !n = max (now + toEnum tm) prev + writeIORef ref n + + where + ref = _timerTimeoutTime conn + + +------------------------------------------------------------------------------ +setTimeout :: Connection -> Int -> IO () +setTimeout conn tm = do debug "Libev.tickleTimeout" now <- getCurrentDateTime writeIORef (_timerTimeoutTime conn) (now + toEnum tm) 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 @@ -145,7 +145,8 @@ let sinfo = SessionInfo lhost lport rhost rport $ Listen.isSecure lsock timeoutHandle <- TM.register (killThread curId) tmgr - let timeout = TM.tickle timeoutHandle + let setTimeout = TM.set timeoutHandle + let tickleTimeout = TM.tickle timeoutHandle bracket (Listen.createSession lsock 8192 fd (threadWaitRead $ fromIntegral fd)) @@ -160,13 +161,13 @@ eatException $ sClose sock ) (\s -> let writeEnd = writeOut lsock s sock - (timeout defaultTimeout) + (tickleTimeout defaultTimeout) in handler sinfo (enumerate lsock s sock) writeEnd - (sendFile lsock (timeout defaultTimeout) fd + (sendFile lsock (tickleTimeout defaultTimeout) fd writeEnd) - timeout + setTimeout ) diff --git a/src/Snap/Internal/Http/Server/TimeoutManager.hs b/src/Snap/Internal/Http/Server/TimeoutManager.hs --- a/src/Snap/Internal/Http/Server/TimeoutManager.hs +++ b/src/Snap/Internal/Http/Server/TimeoutManager.hs @@ -7,6 +7,7 @@ , stop , register , tickle + , set , cancel ) where @@ -20,8 +21,15 @@ ------------------------------------------------------------------------------ data State = Deadline !CTime | Canceled + deriving (Eq) +instance Ord State where + compare Canceled Canceled = EQ + compare Canceled _ = LT + compare _ Canceled = GT + compare (Deadline a) (Deadline b) = compare a b + ------------------------------------------------------------------------------ data TimeoutHandle = TimeoutHandle { _killAction :: !(IO ()) @@ -96,9 +104,28 @@ ------------------------------------------------------------------------------ --- | Tickle the timeout on a connection to be N seconds into the future. +-- | Tickle the timeout on a connection to be at least N seconds into the +-- future. If the existing timeout is set for M seconds from now, where M > N, +-- then the timeout is unaffected. tickle :: TimeoutHandle -> Int -> IO () tickle th n = do + now <- getTime + + -- don't need atomicity here -- kill the space leak. + orig <- readIORef stateRef + let state = Deadline $ now + toEnum n + let !newState = max orig state + writeIORef stateRef newState + + where + getTime = _hGetTime th + stateRef = _state th + + +------------------------------------------------------------------------------ +-- | Set the timeout on a connection to be N seconds into the future. +set :: TimeoutHandle -> Int -> IO () +set th n = do now <- getTime let state = Deadline $ now + toEnum n diff --git a/src/System/FastLogger.hs b/src/System/FastLogger.hs --- a/src/System/FastLogger.hs +++ b/src/System/FastLogger.hs @@ -7,6 +7,7 @@ , timestampedLogEntry , combinedLogEntry , newLogger +, newLoggerWithCustomErrorFunction , logMsg , stopLogger ) where @@ -18,11 +19,14 @@ import Control.Concurrent import Control.Exception import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.ByteString.Internal (c2w) import Data.Int import Data.IORef import Data.Monoid +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Prelude hiding (catch) import System.IO @@ -35,7 +39,9 @@ { _queuedMessages :: !(IORef Builder) , _dataWaiting :: !(MVar ()) , _loggerPath :: !(FilePath) - , _loggingThread :: !(MVar ThreadId) } + , _loggingThread :: !(MVar ThreadId) + , _errAction :: ByteString -> IO () + } ------------------------------------------------------------------------------ @@ -43,13 +49,27 @@ -- \"-\", then log to stdout; if it's \"stderr\" then we log to stderr, -- otherwise we log to a regular file in append mode. The file is closed and -- re-opened every 15 minutes to facilitate external log rotation. -newLogger :: FilePath -> IO Logger -newLogger fp = do +newLogger :: FilePath -- ^ log file to use + -> IO Logger +newLogger = newLoggerWithCustomErrorFunction + (\s -> S.hPutStr stderr s >> hFlush stderr) + + +------------------------------------------------------------------------------ +-- | Like 'newLogger', but uses a custom error action if the logger needs to +-- print an error message of its own (for instance, if it can't open the output +-- file.) +newLoggerWithCustomErrorFunction :: (ByteString -> IO ()) + -- ^ logger uses this action to log any + -- error messages of its own + -> FilePath -- ^ log file to use + -> IO Logger +newLoggerWithCustomErrorFunction errAction fp = do q <- newIORef mempty dw <- newEmptyMVar th <- newEmptyMVar - let lg = Logger q dw fp th + let lg = Logger q dw fp th errAction tid <- forkIO $ loggingThread lg putMVar th tid @@ -133,32 +153,39 @@ ------------------------------------------------------------------------------ loggingThread :: Logger -> IO () -loggingThread (Logger queue notifier filePath _) = do +loggingThread (Logger queue notifier filePath _ errAct) = do initialize >>= go where openIt = if filePath == "-" then return stdout - else if filePath == "stderr" - then return stderr - else openFile filePath AppendMode `catch` - \(e::SomeException) -> do - hPutStrLn stderr $ "can't open log file " ++ filePath - hPutStrLn stderr $ "exception: " ++ show e - hPutStrLn stderr $ "logging to stderr instead." - return stderr + else + if filePath == "stderr" + then return stderr + else openFile filePath AppendMode `catch` + \(e::SomeException) -> do + logInternalError $ "Can't open log file \"" ++ + filePath ++ "\".\n" + logInternalError $ "Exception: " ++ show e ++ "\n" + logInternalError $ "Logging to stderr instead. " ++ + "**THIS IS BAD, YOU OUGHT TO " ++ + "FIX THIS**\n\n" + return stderr closeIt h = if h == stdout || h == stderr then return () else hClose h + logInternalError = errAct . T.encodeUtf8 . T.pack + go (href, lastOpened) = (loop (href, lastOpened)) `catches` [ Handler $ \(_::AsyncException) -> killit (href, lastOpened) , Handler $ \(e::SomeException) -> do - hPutStrLn stderr $ "logger got exception: " ++ Prelude.show e + logInternalError $ "logger got exception: " + ++ Prelude.show e ++ "\n" threadDelay 20000000 go (href, lastOpened) ] @@ -184,11 +211,10 @@ h <- readIORef href (do L.hPut h msgs hFlush h) `catch` \(e::SomeException) -> do - hPutStrLn stderr $ "got exception writing to log " ++ - filePath ++ ": " ++ show e - hPutStrLn stderr $ "writing log entries to stderr." - L.hPut stderr msgs - hFlush stderr + logInternalError $ "got exception writing to log " ++ + filePath ++ ": " ++ show e ++ "\n" + logInternalError $ "writing log entries to stderr.\n" + mapM_ errAct $ L.toChunks msgs -- close the file every 15 minutes (for log rotation) t <- getCurrentDateTime diff --git a/test/common/Test/Common/TestHandler.hs b/test/common/Test/Common/TestHandler.hs --- a/test/common/Test/Common/TestHandler.hs +++ b/test/common/Test/Common/TestHandler.hs @@ -4,6 +4,7 @@ module Test.Common.TestHandler (testHandler) where import Blaze.ByteString.Builder +import Control.Concurrent (threadDelay) import Control.Monad import Control.Monad.Trans import qualified Data.ByteString.Char8 as S @@ -22,6 +23,38 @@ import Test.Common.Rot13 (rot13) + +------------------------------------------------------------------------------ +-- timeout handling +------------------------------------------------------------------------------ +timeoutTickleHandler :: Snap () +timeoutTickleHandler = do + noCompression -- FIXME: remove this when zlib-bindings and + -- zlib-enumerator support gzip stream flushing + modifyResponse $ setResponseBody (trickleOutput 6) + . setContentType "text/plain" + setTimeout 2 + + where + trickleOutput :: Int -> Enumerator Builder IO a + trickleOutput n = concatEnums $ dots `interleave` delays + where + enumOne = enumList 1 [fromByteString ".\n", flush] + delay st = do + liftIO $ threadDelay 1000000 + returnI st + + interleave x0 y0 = (go id x0 y0) [] + where + go !dl [] ys = dl . (++ys) + go !dl xs [] = dl . (++xs) + go !dl (x:xs) (y:ys) = go (dl . (x:) . (y:)) xs ys + + dots = replicate n enumOne + delays = replicate n delay + + +------------------------------------------------------------------------------ pongHandler :: Snap () pongHandler = modifyResponse $ setResponseBody (enumBuilder $ fromByteString "PONG") . @@ -148,4 +181,5 @@ , ("respcode/:code" , responseHandler ) , ("upload/form" , uploadForm ) , ("upload/handle" , uploadHandler ) + , ("timeout/tickle" , timeoutTickleHandler ) ] 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 @@ -87,7 +87,7 @@ array >= 0.3 && <0.4, attoparsec >= 0.8.1 && < 0.10, attoparsec-enumerator >= 0.2.0.1 && < 0.3, - base >= 4.3 && < 5, + base >= 4 && < 5, base16-bytestring == 0.1.*, blaze-builder >= 0.2.1.4 && <0.4, blaze-builder-enumerator >= 0.2.0 && <0.3, @@ -163,7 +163,7 @@ array >= 0.3 && <0.4, attoparsec >= 0.8.1 && < 0.10, attoparsec-enumerator >= 0.2.0.1 && < 0.3, - base >= 4.3 && < 5, + base >= 4 && < 5, binary >= 0.5 && < 0.6, blaze-builder >= 0.2.1.4 && <0.4, blaze-builder-enumerator >= 0.2.0 && <0.3, @@ -223,7 +223,7 @@ ghc-prof-options: -prof -auto-all build-depends: - base >= 4.3 && < 5, + base >= 4 && < 5, network == 2.3.*, http-enumerator >= 0.7 && <0.8, tls >= 0.7.1 && <0.8, diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs --- a/test/suite/Test/Blackbox.hs +++ b/test/suite/Test/Blackbox.hs @@ -9,9 +9,11 @@ , startTestServer ) where -------------------------------------------------------------------------------- +import Blaze.ByteString.Builder import Control.Concurrent import Control.Exception (SomeException, catch, throwIO) import Control.Monad +import Control.Monad.Trans import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as S import Data.ByteString.Char8 (ByteString) @@ -36,6 +38,8 @@ import Test.QuickCheck.Monadic hiding (run, assert) ------------------------------------------------------------------------------ import Snap.Internal.Debug +import Snap.Iteratee hiding (map, head) +import qualified Snap.Iteratee as I import Snap.Http.Server import Snap.Test.Common import Test.Common.Rot13 @@ -53,6 +57,7 @@ , testBigResponse , testPartial , testFileUpload + , testTimeoutTickle ] @@ -412,3 +417,16 @@ , HTTP.requestHeaders = hdrs } +------------------------------------------------------------------------------ +-- This test checks two things: +-- +-- 1. that the timeout tickling logic works +-- 2. that "flush" is passed along through a gzip operation. +testTimeoutTickle :: Bool -> Int -> String -> Test +testTimeoutTickle ssl port name = + testCase (name ++ "/blackbox/timeout/tickle") $ do + let uri = (if ssl then "https" else "http") + ++ "://127.0.0.1:" ++ show port ++ "/timeout/tickle" + doc <- liftM (S.concat . L.toChunks) $ fetch uri + let expected = S.concat $ replicate 6 ".\n" + assertEqual "response equal" expected doc