This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-server".
The branch, master has been updated
via 05d2cb488d0d931a7e18def96caef4c8096734a8 (commit)
from cd3dc3ebe53f10a6c5f1a9321e5af489e6bff0f0 (commit)
Summary of changes:
src/Snap/Http/Server.hs | 4 +-
src/Snap/Http/Server/Config.hs | 90 +++++++++++++++--------
src/Snap/Internal/Http/Server.hs | 43 +++++++-----
src/Snap/Internal/Http/Server/Backend.hs | 13 ++--
src/Snap/Internal/Http/Server/Date.hs | 2 +-
src/Snap/Internal/Http/Server/LibevBackend.hs | 60 ++++++++++------
src/Snap/Internal/Http/Server/SimpleBackend.hs | 53 ++++++++------
src/Snap/Internal/Http/Server/TimeoutTable.hs | 4 +-
test/suite/Snap/Internal/Http/Server/Tests.hs | 42 +++++++-----
test/suite/Test/Blackbox.hs | 1 +
10 files changed, 188 insertions(+), 124 deletions(-)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 05d2cb488d0d931a7e18def96caef4c8096734a8
Author: Gregory Collins <[email protected]>
Date: Thu Jan 27 21:46:36 2011 +0100
Expose timeout support to the user.
diff --git a/src/Snap/Http/Server.hs b/src/Snap/Http/Server.hs
index 8250161..b16af51 100644
--- a/src/Snap/Http/Server.hs
+++ b/src/Snap/Http/Server.hs
@@ -50,13 +50,15 @@ snapServerVersion = Int.snapServerVersion
simpleHttpServe :: MonadSnap m => Config m a -> Snap () -> IO ()
simpleHttpServe config handler = do
setUnicodeLocale $ fromJust $ getLocale conf
- Int.httpServe (map listenToInt $ getListen conf)
+ Int.httpServe tout
+ (map listenToInt $ getListen conf)
(fmap backendToInt $ getBackend conf)
(fromJust $ getHostname conf)
(fromJust $ getAccessLog conf)
(fromJust $ getErrorLog conf)
(runSnap handler)
where
+ tout = fromMaybe 60 $ getDefaultTimeout config
conf = completeConfig config
listenToInt (ListenHttp b p) = Int.HttpPort b p
listenToInt (ListenHttps b p c k) = Int.HttpsPort b p c k
diff --git a/src/Snap/Http/Server/Config.hs b/src/Snap/Http/Server/Config.hs
index 99ab5f1..144ae43 100644
--- a/src/Snap/Http/Server/Config.hs
+++ b/src/Snap/Http/Server/Config.hs
@@ -26,6 +26,7 @@ module Snap.Http.Server.Config
, getCompression
, getVerbose
, getErrorHandler
+ , getDefaultTimeout
, getOther
, setHostname
@@ -37,6 +38,7 @@ module Snap.Http.Server.Config
, setCompression
, setVerbose
, setErrorHandler
+ , setDefaultTimeout
, setOther
) where
@@ -94,25 +96,26 @@ data ConfigBackend = ConfigSimpleBackend
-- Any fields which are unspecified in the 'Config' passed to 'httpServe' (and
-- this is the norm) are filled in with default values from 'defaultConfig'.
data MonadSnap m => Config m a = Config
- { hostname :: Maybe ByteString
+ { hostname :: Maybe ByteString
-- ^ The name of the server
- , listen :: [ConfigListen]
+ , listen :: [ConfigListen]
-- ^ The local interfaces to listen on
- , accessLog :: Maybe (Maybe FilePath)
+ , accessLog :: Maybe (Maybe FilePath)
-- ^ The path to the access log
- , errorLog :: Maybe (Maybe FilePath)
+ , errorLog :: Maybe (Maybe FilePath)
-- ^ The path to the error log
- , locale :: Maybe String
+ , locale :: Maybe String
-- ^ The locale to use
- , backend :: Maybe ConfigBackend
+ , backend :: Maybe ConfigBackend
-- ^ The backend to use
- , compression :: Maybe Bool
+ , compression :: Maybe Bool
-- ^ Whether to use compression
- , verbose :: Maybe Bool
+ , verbose :: Maybe Bool
-- ^ Whether to write server status updates to stderr
- , errorHandler :: Maybe (SomeException -> m ())
+ , errorHandler :: Maybe (SomeException -> m ())
-- ^ A MonadSnap action to handle 500 errors
- , other :: Maybe a
+ , defaultTimeout :: Maybe Int
+ , other :: Maybe a
-- ^ This is for any other state needed to initialize a custom server
}
@@ -129,6 +132,7 @@ instance MonadSnap m => Show (Config m a) where
, showM "compression" . compression
, showM "verbose" . verbose
, showM "errorHandler" . fmap (const ()) . errorHandler
+ , showM "defaultTimeout" . fmap (const ()) . defaultTimeout
]) ++ "}"
where
showM s = maybe "" ((++) (s ++ " = ") . show)
@@ -145,29 +149,31 @@ emptyConfig = mempty
------------------------------------------------------------------------------
instance MonadSnap m => Monoid (Config m a) where
mempty = Config
- { hostname = Nothing
- , listen = []
- , accessLog = Nothing
- , errorLog = Nothing
- , locale = Nothing
- , backend = Nothing
- , compression = Nothing
- , verbose = Nothing
- , errorHandler = Nothing
- , other = Nothing
+ { hostname = Nothing
+ , listen = []
+ , accessLog = Nothing
+ , errorLog = Nothing
+ , locale = Nothing
+ , backend = Nothing
+ , compression = Nothing
+ , verbose = Nothing
+ , errorHandler = Nothing
+ , defaultTimeout = Nothing
+ , other = Nothing
}
a `mappend` b = Config
- { hostname = (hostname b) `mplus` (hostname a)
- , listen = (listen b) ++ (listen a)
- , accessLog = (accessLog b) `mplus` (accessLog a)
- , errorLog = (errorLog b) `mplus` (errorLog a)
- , locale = (locale b) `mplus` (locale a)
- , backend = (backend b) `mplus` (backend a)
- , compression = (compression b) `mplus` (compression a)
- , verbose = (verbose b) `mplus` (verbose a)
- , errorHandler = (errorHandler b) `mplus` (errorHandler a)
- , other = (other b) `mplus` (other a)
+ { hostname = (hostname b) `mplus` (hostname a)
+ , listen = (listen b) ++ (listen a)
+ , accessLog = (accessLog b) `mplus` (accessLog a)
+ , errorLog = (errorLog b) `mplus` (errorLog a)
+ , locale = (locale b) `mplus` (locale a)
+ , backend = (backend b) `mplus` (backend a)
+ , compression = (compression b) `mplus` (compression a)
+ , verbose = (verbose b) `mplus` (verbose a)
+ , errorHandler = (errorHandler b) `mplus` (errorHandler a)
+ , defaultTimeout = (defaultTimeout b) `mplus` (defaultTimeout a)
+ , other = (other b) `mplus` (other a)
}
@@ -202,6 +208,7 @@ defaultConfig = Config
. setResponseStatus 500 "Internal Server Error"
. modifyResponseBody (>==> enumBuilder (fromByteString msg))
$ emptyResponse
+ , defaultTimeout = Just 60
, other = Nothing
}
@@ -231,6 +238,7 @@ data MonadSnap m => OptionData m a = OptionData
, sslport :: Maybe Int
, sslcert :: Maybe FilePath
, sslkey :: Maybe FilePath
+ , tout :: Maybe Int
}
@@ -244,6 +252,7 @@ instance MonadSnap m => Monoid (OptionData m a) where
, sslport = Nothing
, sslcert = Nothing
, sslkey = Nothing
+ , tout = Nothing
}
a `mappend` b = OptionData
@@ -254,6 +263,7 @@ instance MonadSnap m => Monoid (OptionData m a) where
, sslport = (sslport b) `mplus` (sslport a)
, sslcert = (sslcert b) `mplus` (sslcert a)
, sslkey = (sslkey b) `mplus` (sslkey a)
+ , tout = (tout b) `mplus` (tout a)
}
@@ -268,13 +278,14 @@ defaultOptions = OptionData
, sslport = Nothing
, sslcert = Just "cert.pem"
, sslkey = Just "key.pem"
+ , tout = Just 60
}
------------------------------------------------------------------------------
-- | Convert options to config
optionsToConfig :: MonadSnap m => OptionData m a -> Config m a
-optionsToConfig o = mconcat $ [config o] ++ http ++ https
+optionsToConfig o = mconcat $ [config o] ++ http ++ https ++ [tmOut]
where lhttp = maybe2 [] ListenHttp (bind o) (port o)
lhttps = maybe4 [] ListenHttps (sslbind o)
(sslport o)
@@ -288,6 +299,9 @@ optionsToConfig o = mconcat $ [config o] ++ http ++ https
maybe4 _ f (Just a) (Just b) (Just c) (Just d) = [f a b c d]
maybe4 d _ _ _ _ _ = d
+ tmOut = maybe mempty
+ (\t -> mempty { defaultTimeout = Just t })
+ (tout o)
------------------------------------------------------------------------------
-- | Convert config to options
@@ -300,6 +314,7 @@ configToOptions c = OptionData
, sslport = Nothing
, sslcert = Nothing
, sslkey = Nothing
+ , tout = (defaultTimeout c)
}
@@ -359,6 +374,9 @@ options defaults =
, Option ['c'] ["compression"]
(NoArg $ Just $ setConfig setCompression True)
$ "use gzip compression on responses"
+ , Option ['t'] ["timeout"]
+ (ReqArg (\t -> Just $ mempty { tout = Just $ read t}) "SECS")
+ $ "set default timeout in seconds"
, Option [] ["no-compression"]
(NoArg $ Just $ setConfig setCompression False)
$ "serve responses uncompressed"
@@ -469,6 +487,11 @@ getOther = other
------------------------------------------------------------------------------
+getDefaultTimeout :: MonadSnap m => Config m a -> Maybe Int
+getDefaultTimeout = defaultTimeout
+
+
+------------------------------------------------------------------------------
setHostname :: MonadSnap m => ByteString -> Config m a -> Config m a
setHostname a m = m {hostname = Just a}
@@ -517,3 +540,8 @@ setErrorHandler a m = m {errorHandler = Just a}
------------------------------------------------------------------------------
setOther :: MonadSnap m => a -> Config m a -> Config m a
setOther a m = m {other = Just a}
+
+
+------------------------------------------------------------------------------
+setDefaultTimeout :: MonadSnap m => Int -> Config m a -> Config m a
+setDefaultTimeout t m = m {defaultTimeout = Just t}
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index 086733f..d67714d 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -64,8 +64,9 @@ import qualified Paths_snap_server as V
-- Note that we won't be bothering end users with this -- the details will be
-- hidden inside the Snap monad
type ServerHandler = (ByteString -> IO ())
- -> Request
- -> Iteratee ByteString IO (Request,Response)
+ -> (Int -> IO ())
+ -> Request
+ -> Iteratee ByteString IO (Request,Response)
------------------------------------------------------------------------------
@@ -122,7 +123,8 @@ runServerMonad lh s la le m = evalStateT m st
------------------------------------------------------------------------------
-httpServe :: [ListenPort] -- ^ ports to listen on
+httpServe :: Int -- ^ default timeout
+ -> [ListenPort] -- ^ ports to listen on
-> Maybe EventLoopType -- ^ Specify a given event loop,
-- otherwise a default is picked
-> ByteString -- ^ local hostname (server name)
@@ -130,7 +132,8 @@ httpServe :: [ListenPort] -- ^ ports to listen on
-> Maybe FilePath -- ^ path to the error log
-> ServerHandler -- ^ handler procedure
-> IO ()
-httpServe ports mevType localHostname alogPath elogPath handler =
+httpServe defaultTimeout ports mevType localHostname alogPath elogPath
+ handler =
withLoggers alogPath elogPath
(\(alog, elog) -> spawnAll alog elog)
@@ -152,9 +155,9 @@ httpServe ports mevType localHostname alogPath elogPath
handler =
nports <- mapM bindPort ports
- (runEventLoop evType nports numCapabilities (logE elog) $
- runHTTP alog elog handler localHostname) `finally` do
-
+ (runEventLoop evType defaultTimeout nports numCapabilities (logE elog)
+ $ runHTTP defaultTimeout alog elog handler localHostname)
+ `finally` do
logE elog "Server.httpServe: SHUTDOWN"
if initHttps
@@ -233,7 +236,8 @@ logA' logger req rsp = do
------------------------------------------------------------------------------
-runHTTP :: Maybe Logger -- ^ access logger
+runHTTP :: Int -- ^ default timeout
+ -> Maybe Logger -- ^ access logger
-> Maybe Logger -- ^ error logger
-> ServerHandler -- ^ handler procedure
-> ByteString -- ^ local host name
@@ -242,9 +246,10 @@ runHTTP :: Maybe Logger -- ^ access logger
-> Iteratee ByteString IO () -- ^ write end of socket
-> (FilePath -> Int64 -> Int64 -> IO ())
-- ^ sendfile end
- -> IO () -- ^ timeout tickler
+ -> (Int -> IO ()) -- ^ timeout tickler
-> IO ()
-runHTTP alog elog handler lh sinfo readEnd writeEnd onSendFile tickle =
+runHTTP defaultTimeout alog elog handler lh sinfo readEnd writeEnd onSendFile
+ tickle =
go `catches` [ Handler $ \(e :: AsyncException) -> do
throwIO e
@@ -257,8 +262,8 @@ runHTTP alog elog handler lh sinfo readEnd writeEnd
onSendFile tickle =
go = do
buf <- allocBuffer 16384
let iter1 = runServerMonad lh sinfo (logA alog) (logE elog) $
- httpSession writeEnd buf onSendFile tickle
- handler
+ httpSession defaultTimeout writeEnd buf
+ onSendFile tickle handler
let iter = iterateeDebugWrapper "httpSession iteratee" iter1
debug "runHTTP/go: prepping iteratee for start"
@@ -292,14 +297,15 @@ logError s = gets _logError >>= (\l -> liftIO $ l s)
------------------------------------------------------------------------------
-- | Runs an HTTP session.
-httpSession :: Iteratee ByteString IO () -- ^ write end of socket
+httpSession :: Int
+ -> Iteratee ByteString IO () -- ^ write end of socket
-> Buffer -- ^ builder buffer
-> (FilePath -> Int64 -> Int64 -> IO ())
-- ^ sendfile continuation
- -> IO () -- ^ timeout tickler
+ -> (Int -> IO ()) -- ^ timeout tickler
-> ServerHandler -- ^ handler procedure
-> ServerMonad ()
-httpSession writeEnd' buffer onSendFile tickle handler = do
+httpSession defaultTimeout writeEnd' buffer onSendFile tickle handler = do
let writeEnd = iterateeDebugWrapper "writeEnd" writeEnd'
@@ -308,7 +314,7 @@ httpSession writeEnd' buffer onSendFile tickle handler = do
liftIO $ debug "Server.httpSession: receiveRequest finished"
-- successfully got a request, so restart timer
- liftIO tickle
+ liftIO $ tickle defaultTimeout
case mreq of
(Just req) -> do
@@ -322,7 +328,7 @@ httpSession writeEnd' buffer onSendFile tickle handler = do
logerr <- gets _logError
- (req',rspOrig) <- lift $ handler logerr req
+ (req',rspOrig) <- lift $ handler logerr tickle req
liftIO $ debug $ "Server.httpSession: finished running user handler"
@@ -368,7 +374,8 @@ httpSession writeEnd' buffer onSendFile tickle handler = do
then do
debug $ "httpSession: Connection: Close, harikari"
liftIO $ myThreadId >>= killThread
- else httpSession writeEnd' buffer onSendFile tickle handler
+ else httpSession defaultTimeout writeEnd' buffer onSendFile tickle
+ handler
Nothing -> do
liftIO $ debug $ "Server.httpSession: parser did not produce a " ++
diff --git a/src/Snap/Internal/Http/Server/Backend.hs
b/src/Snap/Internal/Http/Server/Backend.hs
index 3791724..1364eb3 100644
--- a/src/Snap/Internal/Http/Server/Backend.hs
+++ b/src/Snap/Internal/Http/Server/Backend.hs
@@ -36,16 +36,17 @@ type SessionHandler =
-> Enumerator ByteString IO () -- ^ read end of socket
-> Iteratee ByteString IO () -- ^ write end of socket
-> (FilePath -> Int64 -> Int64 -> IO ()) -- ^ sendfile end
- -> IO () -- ^ timeout tickler
+ -> (Int -> IO ()) -- ^ timeout tickler
-> IO ()
------------------------------------------------------------------------------
-type EventLoop = [ListenSocket] -- ^ list of ports
- -> Int -- ^ number of capabilities
- -> (ByteString -> IO ()) -- ^ error log
- -> SessionHandler -- ^ session handler
- -> IO ()
+type EventLoop = Int -- ^ default timeout
+ -> [ListenSocket] -- ^ list of ports
+ -> Int -- ^ number of capabilities
+ -> (ByteString -> IO ()) -- ^ error log
+ -> SessionHandler -- ^ session handler
+ -> IO ()
{- For performance reasons, we do not implement this as a class
diff --git a/src/Snap/Internal/Http/Server/Date.hs
b/src/Snap/Internal/Http/Server/Date.hs
index 3d68f1b..0e0b09a 100644
--- a/src/Snap/Internal/Http/Server/Date.hs
+++ b/src/Snap/Internal/Http/Server/Date.hs
@@ -102,7 +102,7 @@ dateThread ds@(DateState _ _ _ valueIsOld morePlease _) =
loop
ensureFreshDate :: IO ()
ensureFreshDate = block $ do
old <- readIORef $ _valueIsOld dateState
- tryPutMVar (_morePlease dateState) ()
+ _ <- tryPutMVar (_morePlease dateState) ()
-- if the value is not fresh we will tickle the date thread but also fetch
-- the new value immediately; we used to block but we'll do a little extra
diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs
b/src/Snap/Internal/Http/Server/LibevBackend.hs
index 803038e..c2d463b 100644
--- a/src/Snap/Internal/Http/Server/LibevBackend.hs
+++ b/src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -22,7 +22,7 @@ data LibevException = LibevException String
instance Exception LibevException
libEvEventLoop :: EventLoop
-libEvEventLoop _ _ _ _ = throwIO $
+libEvEventLoop _ _ _ _ _ = throwIO $
LibevException "libev event loop is not supported"
#else
@@ -107,8 +107,9 @@ data Connection = Connection
------------------------------------------------------------------------------
libEvEventLoop :: EventLoop
-libEvEventLoop sockets cap elog handler = do
- backends <- Prelude.mapM (newLoop sockets handler elog) [0..(cap-1)]
+libEvEventLoop defaultTimeout sockets cap elog handler = do
+ backends <- Prelude.mapM (newLoop defaultTimeout sockets handler elog)
+ [0..(cap-1)]
debug "libevEventLoop: waiting for loop exit"
Prelude.mapM_ (takeMVar . _loopExit) backends `finally` do
@@ -118,12 +119,13 @@ libEvEventLoop sockets cap elog handler = do
------------------------------------------------------------------------------
-newLoop :: [ListenSocket] -- ^ value you got from bindIt
+newLoop :: Int -- ^ default timeout
+ -> [ListenSocket] -- ^ value you got from bindIt
-> SessionHandler -- ^ handler
-> (ByteString -> IO ()) -- ^ error logger
-> Int -- ^ cpu
-> IO Backend
-newLoop sockets handler elog cpu = do
+newLoop defaultTimeout sockets handler elog cpu = do
-- 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
@@ -179,7 +181,8 @@ newLoop sockets handler elog cpu = do
-- setup the accept callback; this watches for read readiness on the
-- listen port
forM_ (zip3 sockets accIOs accMVars) $ \(sock, accIO, x) -> do
- accCB <- mkIoCallback $ acceptCallback b handler elog cpu sock
+ accCB <- mkIoCallback $ acceptCallback defaultTimeout b handler elog
+ cpu sock
evIoInit accIO accCB (fdSocket $ Listen.listenSocket sock) ev_read
evIoStart lp accIO
putMVar x accCB
@@ -209,13 +212,14 @@ loopThread backend = do
------------------------------------------------------------------------------
-acceptCallback :: Backend
+acceptCallback :: Int
+ -> Backend
-> SessionHandler
-> (ByteString -> IO ())
-> Int
-> ListenSocket
-> IoCallback
-acceptCallback back handler elog cpu sock _loopPtr _ioPtr _ = do
+acceptCallback defaultTimeout back handler elog cpu sock _loopPtr _ioPtr _ = do
debug "inside acceptCallback"
r <- c_accept $ fdSocket $ Listen.listenSocket sock
@@ -230,7 +234,7 @@ acceptCallback back handler elog cpu sock _loopPtr _ioPtr _
= do
forkOnIO cpu $ (go r `catches` cleanup)
return ()
where
- go = runSession back handler sock
+ go = runSession defaultTimeout back handler sock
cleanup = [ Handler $ \(_ :: TimeoutException) -> return ()
, Handler $ \(e :: SomeException) ->
elog $ S.concat [ "libev.acceptCallback: "
@@ -436,12 +440,13 @@ freeBackend backend = ignoreException $ block $ do
------------------------------------------------------------------------------
-- | Note: proc gets run in the background
-runSession :: Backend
+runSession :: Int
+ -> Backend
-> SessionHandler
-> ListenSocket
-> CInt
-> IO ()
-runSession backend handler lsock fd = do
+runSession defaultTimeout backend handler lsock fd = do
sock <- mkSocket fd AF_INET Stream 0 Connected
peerName <- getPeerName sock
sockName <- getSocketName sock
@@ -527,8 +532,8 @@ runSession backend handler lsock fd = do
(\session -> do H.update tid conn (_connectionThreads backend)
handler sinfo
(enumerate conn session)
- (writeOut conn session)
- (sendFile conn session)
+ (writeOut defaultTimeout conn session)
+ (sendFile defaultTimeout conn session)
(tickleTimeout conn)
)
@@ -573,11 +578,11 @@ instance Exception TimeoutException
------------------------------------------------------------------------------
-tickleTimeout :: Connection -> IO ()
-tickleTimeout conn = do
+tickleTimeout :: Connection -> Int -> IO ()
+tickleTimeout conn tm = do
debug "Libev.tickleTimeout"
now <- getCurrentDateTime
- writeIORef (_timerTimeoutTime conn) (now + 30)
+ writeIORef (_timerTimeoutTime conn) (now + toEnum tm)
------------------------------------------------------------------------------
@@ -621,9 +626,14 @@ waitForLock readLock conn = do
------------------------------------------------------------------------------
-sendFile :: Connection -> NetworkSession -> FilePath -> Int64 -> Int64
+sendFile :: Int
+ -> Connection
+ -> NetworkSession
+ -> FilePath
+ -> Int64
+ -> Int64
-> IO ()
-sendFile c s fp start sz = do
+sendFile defaultTimeout c s fp start sz = do
withMVar lock $ \_ -> do
act <- readIORef $ _writeActive c
when act $ evIoStop loop io
@@ -636,10 +646,10 @@ sendFile c s fp start sz = do
(closeFd)
(go start sz)
_ -> do
- step <- runIteratee $ writeOut c s
+ step <- runIteratee $ writeOut defaultTimeout c s
run_ $ enumFilePartial fp (start,start+sz) step
#else
- step <- runIteratee $ writeOut c s
+ step <- runIteratee $ writeOut defaultTimeout c s
run_ $ enumFilePartial fp (start,start+sz) step
return ()
@@ -657,7 +667,8 @@ sendFile c s fp start sz = do
| otherwise = do
sent <- SF.sendFile sfd fd off bytes
if sent < bytes
- then tickleTimeout c >> go (off+sent) (bytes-sent) fd
+ then tickleTimeout c defaultTimeout >>
+ go (off+sent) (bytes-sent) fd
else return ()
sfd = Fd $ _rawSocket c
@@ -707,10 +718,11 @@ enumerate conn session = loop
------------------------------------------------------------------------------
writeOut :: (MonadIO m)
- => Connection
+ => Int
+ -> Connection
-> NetworkSession
-> Iteratee ByteString m ()
-writeOut conn session = loop
+writeOut defaultTimeout conn session = loop
where
loop = continue k
@@ -720,7 +732,7 @@ writeOut conn session = loop
loop
sendData = Listen.send (_listenSocket conn)
- (tickleTimeout conn)
+ (tickleTimeout conn defaultTimeout)
(waitForLock False conn)
session
diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hs
b/src/Snap/Internal/Http/Server/SimpleBackend.hs
index 32b1269..ea2b84a 100644
--- a/src/Snap/Internal/Http/Server/SimpleBackend.hs
+++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs
@@ -63,29 +63,31 @@ data EventLoopCpu = EventLoopCpu
------------------------------------------------------------------------------
simpleEventLoop :: EventLoop
-simpleEventLoop sockets cap elog handler = do
- loops <- Prelude.mapM (newLoop sockets handler elog) [0..(cap-1)]
+simpleEventLoop defaultTimeout sockets cap elog handler = do
+ loops <- Prelude.mapM (newLoop defaultTimeout sockets handler elog)
+ [0..(cap-1)]
debug "simpleEventLoop: waiting for mvars"
--wait for all threads to exit
Prelude.mapM_ (takeMVar . _exitMVar) loops `finally` do
debug "simpleEventLoop: killing all threads"
- mapM stopLoop loops
- mapM Listen.closeSocket sockets
+ _ <- mapM_ stopLoop loops
+ mapM_ Listen.closeSocket sockets
------------------------------------------------------------------------------
-newLoop :: [ListenSocket]
+newLoop :: Int
+ -> [ListenSocket]
-> SessionHandler
-> (S.ByteString -> IO ())
-> Int
-> IO EventLoopCpu
-newLoop sockets handler elog cpu = do
+newLoop defaultTimeout sockets handler elog cpu = do
tt <- TT.new
exit <- newEmptyMVar
accThreads <- forM sockets $ \p -> forkOnIO cpu $
- acceptThread handler tt elog cpu p
+ acceptThread defaultTimeout handler tt elog cpu p
tid <- forkOnIO cpu $ timeoutThread tt exit
return $ EventLoopCpu cpu accThreads tt tid exit
@@ -99,22 +101,23 @@ stopLoop loop = block $ do
------------------------------------------------------------------------------
-acceptThread :: SessionHandler
+acceptThread :: Int
+ -> SessionHandler
-> TimeoutTable
-> (S.ByteString -> IO ())
-> Int
-> ListenSocket
-> IO ()
-acceptThread handler tt elog cpu sock = loop
+acceptThread defaultTimeout handler tt elog cpu sock = loop
where
loop = 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)
+ _ <- forkOnIO cpu (go s addr `catches` cleanup)
loop
- go = runSession handler tt sock
+ go = runSession defaultTimeout handler tt sock
cleanup =
[
@@ -141,10 +144,7 @@ timeoutThread table exitMVar = do
killTooOld = do
now <- getCurrentDateTime
- TT.killOlderThan (now - tIMEOUT) table
-
- -- timeout = 30 seconds
- tIMEOUT = 30
+ TT.killOlderThan now table
killAll = do
debug "Backend.timeoutThread: shutdown, killing all connections"
@@ -162,9 +162,13 @@ instance Exception AddressNotSupportedException
------------------------------------------------------------------------------
-runSession :: SessionHandler -> TimeoutTable -> ListenSocket -> Socket
+runSession :: Int
+ -> SessionHandler
+ -> TimeoutTable
+ -> ListenSocket
+ -> Socket
-> SockAddr -> IO ()
-runSession handler tt lsock sock addr = do
+runSession defaultTimeout handler tt lsock sock addr = do
let fd = fdSocket sock
curId <- myThreadId
@@ -191,7 +195,7 @@ runSession handler tt lsock sock addr = do
let curHash = hashString $ show curId
let timeout = tickleTimeout tt curId curHash
- timeout
+ timeout defaultTimeout
bracket (Listen.createSession lsock 8192 fd
(threadWaitRead $ fromIntegral fd))
@@ -205,11 +209,12 @@ runSession handler tt lsock sock addr = do
eatException $ shutdown sock ShutdownBoth
eatException $ sClose sock
)
- (\s -> let writeEnd = writeOut lsock s sock timeout
+ (\s -> let writeEnd = writeOut lsock s sock (timeout
defaultTimeout)
in handler sinfo
(enumerate lsock s sock)
writeEnd
- (sendFile lsock timeout fd writeEnd)
+ (sendFile lsock (timeout defaultTimeout) fd
+ writeEnd)
timeout
)
@@ -257,11 +262,11 @@ sendFile _ _ _ writeEnd fp start sz = do
------------------------------------------------------------------------------
-tickleTimeout :: TimeoutTable -> ThreadId -> Word -> IO ()
-tickleTimeout table tid thash = do
+tickleTimeout :: TimeoutTable -> ThreadId -> Word -> Int -> IO ()
+tickleTimeout table tid thash tm = do
debug "Backend.tickleTimeout"
now <- getCurrentDateTime
- TT.insert thash tid now table
+ TT.insert thash tid (now + toEnum tm) table
------------------------------------------------------------------------------
@@ -321,7 +326,7 @@ writeOut :: (MonadIO m)
=> ListenSocket
-> NetworkSession
-> Socket
- -> IO ()
+ -> (IO ())
-> Iteratee ByteString m ()
writeOut port session sock tickle = loop
where
diff --git a/src/Snap/Internal/Http/Server/TimeoutTable.hs
b/src/Snap/Internal/Http/Server/TimeoutTable.hs
index b46ddc0..699fefd 100644
--- a/src/Snap/Internal/Http/Server/TimeoutTable.hs
+++ b/src/Snap/Internal/Http/Server/TimeoutTable.hs
@@ -73,7 +73,7 @@ insert thash tid time (TimeoutTable maps act) = do
let !psq' = PSQ.insert tid time psq
return $! psq'
- tryPutMVar act ()
+ _ <- tryPutMVar act ()
return ()
where
@@ -88,7 +88,7 @@ delete thash tid (TimeoutTable maps act) = do
let !psq' = PSQ.delete tid psq
return $! psq'
- tryPutMVar act ()
+ _ <- tryPutMVar act ()
return ()
where
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs
b/test/suite/Snap/Internal/Http/Server/Tests.hs
index 1d50557..a855b5a 100644
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -514,9 +514,10 @@ testHttpResponseCookies = testCase
"server/HttpResponseCookies" $ do
echoServer :: (ByteString -> IO ())
+ -> (Int -> IO ())
-> Request
-> Iteratee ByteString IO (Request,Response)
-echoServer _ req = do
+echoServer _ _ req = do
se <- liftIO $ readIORef (rqBody req)
let (SomeEnumerator enum) = se
i <- liftM enum $ lift $ runIteratee copyingStream2Stream
@@ -531,8 +532,8 @@ echoServer _ req = do
echoServer2 :: ServerHandler
-echoServer2 _ req = do
- (rq,rsp) <- echoServer (const $ return ()) req
+echoServer2 _ _ req = do
+ (rq,rsp) <- echoServer (const $ return ()) (const $ return ()) req
return (rq, addResponseCookie cook rsp)
where
cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/")
@@ -547,8 +548,9 @@ testHttp1 = testCase "server/httpSession" $ do
let (iter,onSendFile) = mkIter ref
- runHTTP Nothing Nothing echoServer "localhost" (SessionInfo "127.0.0.1" 80
"127.0.0.1" 58384 False)
- enumBody iter onSendFile (return ())
+ runHTTP 60 Nothing Nothing echoServer "localhost"
+ (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False)
+ enumBody iter onSendFile (const $ return ())
s <- readIORef ref
@@ -601,8 +603,9 @@ testChunkOn1_0 = testCase "server/transfer-encoding
chunked" $ do
let (iter,onSendFile) = mkIter ref
done <- newEmptyMVar
- forkIO (runHTTP Nothing Nothing f "localhost" (SessionInfo "127.0.0.1" 80
"127.0.0.1" 58384 False)
- enumBody iter onSendFile (return ())
+ forkIO (runHTTP 60 Nothing Nothing f "localhost"
+ (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False)
+ enumBody iter onSendFile (const $ return ())
`finally` putMVar done ())
takeMVar done
@@ -618,7 +621,7 @@ testChunkOn1_0 = testCase "server/transfer-encoding
chunked" $ do
lower = S.map toLower . S.concat . L.toChunks
f :: ServerHandler
- f _ req = do
+ f _ _ req = do
let s = L.fromChunks $ Prelude.take 500 $ repeat "fldkjlfksdjlfd"
let out = enumBuilder $ fromLazyByteString s
return (req, emptyResponse { rspBody = Enum out })
@@ -646,7 +649,8 @@ testHttp2 = testCase "server/connection: close" $ do
done <- newEmptyMVar
- forkIO (runHTTP Nothing
+ forkIO (runHTTP 60
+ Nothing
Nothing
echoServer2
"localhost"
@@ -654,7 +658,7 @@ testHttp2 = testCase "server/connection: close" $ do
enumBody
iter
onSendFile
- (return ()) `finally` putMVar done ())
+ (const $ return ()) `finally` putMVar done ())
takeMVar done
@@ -687,7 +691,8 @@ testHttp100 = testCase "server/expect100" $ do
let (iter,onSendFile) = mkIter ref
- runHTTP Nothing
+ runHTTP 60
+ Nothing
Nothing
echoServer2
"localhost"
@@ -695,7 +700,7 @@ testHttp100 = testCase "server/expect100" $ do
enumBody
iter
onSendFile
- (return ())
+ (const $ return ())
s <- readIORef ref
@@ -730,7 +735,8 @@ testExpectGarbage = testCase "server/Expect: garbage" $ do
let (iter,onSendFile) = mkIter ref
- runHTTP Nothing
+ runHTTP 60
+ Nothing
Nothing
echoServer2
"localhost"
@@ -738,7 +744,7 @@ testExpectGarbage = testCase "server/Expect: garbage" $ do
enumBody
iter
onSendFile
- (return ())
+ (const $ return ())
s <- readIORef ref
@@ -783,7 +789,7 @@ testSendFile = testCase "server/sendFile" $ do
m)
where
- serve = (httpServe [HttpPort "*" port] Nothing "localhost"
+ serve = (httpServe 60 [HttpPort "*" port] Nothing "localhost"
Nothing Nothing
$ runSnap sendFileFoo)
`catch` \(_::SomeException) -> return ()
@@ -807,7 +813,8 @@ testSendFile = testCase "server/sendFile" $ do
testServerStartupShutdown :: Test
testServerStartupShutdown = testCase "server/startup/shutdown" $ do
bracket (forkIO $
- httpServe [HttpPort "*" port]
+ httpServe 20
+ [HttpPort "*" port]
Nothing
"localhost"
(Just "test-access.log")
@@ -845,7 +852,8 @@ testServerStartupShutdown = testCase
"server/startup/shutdown" $ do
testServerShutdownWithOpenConns :: Test
testServerShutdownWithOpenConns = testCase "server/shutdown-open-conns" $ do
tid <- forkIO $
- httpServe [HttpPort "127.0.0.1" port]
+ httpServe 20
+ [HttpPort "127.0.0.1" port]
Nothing
"localhost"
Nothing
diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs
index 8a58a1f..746050a 100644
--- a/test/suite/Test/Blackbox.hs
+++ b/test/suite/Test/Blackbox.hs
@@ -67,6 +67,7 @@ startTestServer port sslport backend = do
setErrorLog (Just $ "ts-error." ++ show backend ++ ".log") .
addListen (ListenHttp "*" port) .
setBackend backend .
+ setDefaultTimeout 10 .
setVerbose False $
defaultConfig
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
