snap-server 0.5.4 → 0.5.5
raw patch · 11 files changed
+167/−42 lines, 11 filesdep ~base
Dependency ranges changed: base
Files
- snap-server.cabal +2/−2
- src/Snap/Internal/Http/Server.hs +12/−5
- src/Snap/Internal/Http/Server/Date.hs +3/−3
- src/Snap/Internal/Http/Server/HttpPort.hs +1/−1
- src/Snap/Internal/Http/Server/LibevBackend.hs +16/−4
- src/Snap/Internal/Http/Server/SimpleBackend.hs +5/−4
- src/Snap/Internal/Http/Server/TimeoutManager.hs +28/−1
- src/System/FastLogger.hs +45/−19
- test/common/Test/Common/TestHandler.hs +34/−0
- test/snap-server-testsuite.cabal +3/−3
- test/suite/Test/Blackbox.hs +18/−0
snap-server.cabal view
@@ -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,
src/Snap/Internal/Http/Server.hs view
@@ -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
src/Snap/Internal/Http/Server/Date.hs view
@@ -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
src/Snap/Internal/Http/Server/HttpPort.hs view
@@ -99,7 +99,7 @@ let sent' = fromIntegral sent if sent' < len then tickleTimeout >> loop (plusPtr ptr sent') (len - sent')- else return ()+ else tickleTimeout ------------------------------------------------------------------------------
src/Snap/Internal/Http/Server/LibevBackend.hs view
@@ -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)
src/Snap/Internal/Http/Server/SimpleBackend.hs view
@@ -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 )
src/Snap/Internal/Http/Server/TimeoutManager.hs view
@@ -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
src/System/FastLogger.hs view
@@ -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
test/common/Test/Common/TestHandler.hs view
@@ -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 ) ]
test/snap-server-testsuite.cabal view
@@ -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,
test/suite/Test/Blackbox.hs view
@@ -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