Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge branch 'fix-timeouts' into 0.8

  • Loading branch information...
commit a5e07560d356e62764441bee24a98809dcf41a74 2 parents 282645c + 13bb78e
@gregorycollins gregorycollins authored
View
8 src/Snap/Internal/Http/Server.hs
@@ -78,7 +78,7 @@ 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 ())
- -> (Int -> IO ())
+ -> ((Int -> Int) -> IO ())
-> Request
-> Iteratee ByteString IO (Request,Response)
@@ -264,7 +264,7 @@ runHTTP :: Int -- ^ default timeout
-> Iteratee ByteString IO () -- ^ write end of socket
-> (FilePath -> Int64 -> Int64 -> IO ())
-- ^ sendfile end
- -> (Int -> IO ()) -- ^ timeout tickler
+ -> ((Int -> Int) -> IO ()) -- ^ timeout tickler
-> IO ()
runHTTP defaultTimeout alog elog handler lh sinfo readEnd writeEnd onSendFile
tickle =
@@ -348,7 +348,7 @@ httpSession :: Int
-> Buffer -- ^ builder buffer
-> (FilePath -> Int64 -> Int64 -> IO ())
-- ^ sendfile continuation
- -> (Int -> IO ()) -- ^ timeout tickler
+ -> ((Int -> Int) -> IO ()) -- ^ timeout modifier
-> ServerHandler -- ^ handler procedure
-> ServerMonad ()
httpSession defaultTimeout writeEnd' buffer onSendFile tickle handler = do
@@ -360,7 +360,7 @@ httpSession defaultTimeout writeEnd' buffer onSendFile tickle handler = do
debug "Server.httpSession: receiveRequest finished"
-- successfully got a request, so restart timer
- liftIO $ tickle defaultTimeout
+ liftIO $ tickle (max defaultTimeout)
case mreq of
(Just req) -> do
View
2  src/Snap/Internal/Http/Server/Backend.hs
@@ -42,7 +42,7 @@ type SessionHandler =
-> Enumerator ByteString IO () -- ^ read end of socket
-> Iteratee ByteString IO () -- ^ write end of socket
-> (FilePath -> Int64 -> Int64 -> IO ()) -- ^ sendfile end
- -> (Int -> IO ()) -- ^ timeout tickler
+ -> ((Int -> Int) -> IO ()) -- ^ timeout tickler
-> IO ()
View
45 src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -570,46 +570,47 @@ instance Exception TimeoutException
------------------------------------------------------------------------------
-tickleTimeout :: Connection -> Int -> IO ()
-tickleTimeout conn tm = do
- debug $ "Libev.tickleTimeout: " ++ show tm
- now <- getCurrentDateTime
- prev <- readIORef ref
- let !n = max (now + toEnum tm) prev
- writeIORef ref n
-
- where
- ref = _timerTimeoutTime conn
+modifyTimeout :: Connection -> (Int -> Int) -> IO ()
+modifyTimeout conn f = do
+ debug "Libev.modifyTimeout"
+ !prev <- readIORef tt
+ !now <- getCurrentDateTime
+ let !remaining = fromEnum $ max 0 (prev - now)
+ let !newRemaining = f remaining
+ let !newTimeout = now + toEnum newRemaining
-------------------------------------------------------------------------------
-setTimeout :: Connection -> Int -> IO ()
-setTimeout conn tm = do
- debug $ "Libev.setTimeout: " ++ show tm
- old <- readIORef tt
- now <- getCurrentDateTime
-
- let newTimeout = now + toEnum tm
- writeIORef tt newTimeout
+ writeIORef tt $! now + toEnum newRemaining
-- Here the question is: do we reset the ev timer? If we're extending the
-- timeout, the ev manual suggests it's more efficient to let the timer
-- lapse and re-arm. If we're shortening the timeout, we need to update the
-- timer so it fires when it's supposed to.
- when (newTimeout < old) $ withMVar loopLock $ \_ -> do
- evTimerSetRepeat tmr $ fromRational $ toRational $ tm
+ when (newTimeout < prev) $ withMVar loopLock $ \_ -> do
+ evTimerSetRepeat tmr $! toEnum newRemaining
evTimerAgain loop tmr
-- wake up the event loop so it can be apprised of the changes
evAsyncSend loop asyncObj
where
+ tt = _timerTimeoutTime conn
backend = _backend conn
asyncObj = _asyncObj backend
loopLock = _loopLock backend
- tt = _timerTimeoutTime conn
loop = _evLoop backend
tmr = _timerObj conn
+
+------------------------------------------------------------------------------
+tickleTimeout :: Connection -> Int -> IO ()
+tickleTimeout conn = modifyTimeout conn . max
+
+
+------------------------------------------------------------------------------
+setTimeout :: Connection -> Int -> IO ()
+setTimeout conn = modifyTimeout conn . const
+
+
------------------------------------------------------------------------------
waitForLock :: Bool -- ^ True = wait for read, False = wait for write
-> Connection
View
5 src/Snap/Internal/Http/Server/SimpleBackend.hs
@@ -161,7 +161,8 @@ runSession defaultTimeout handler tmgr lsock sock addr = do
let sinfo = SessionInfo lhost lport rhost rport $ Listen.isSecure lsock
timeoutHandle <- TM.register (killThread curId) tmgr
- let tickleTimeout = TM.tickle timeoutHandle
+ let modifyTimeout = TM.modify timeoutHandle
+ let tickleTimeout = modifyTimeout . max
bracket (Listen.createSession lsock 8192 fd
(threadWaitRead $ fromIntegral fd))
@@ -182,7 +183,7 @@ runSession defaultTimeout handler tmgr lsock sock addr = do
writeEnd
(sendFile lsock (tickleTimeout defaultTimeout)
fd writeEnd)
- tickleTimeout
+ modifyTimeout
)
View
85 src/Snap/Internal/Http/Server/TimeoutManager.hs
@@ -8,6 +8,7 @@ module Snap.Internal.Http.Server.TimeoutManager
, register
, tickle
, set
+ , modify
, cancel
) where
@@ -23,6 +24,8 @@ data State = Deadline !CTime
| Canceled
deriving (Eq)
+
+------------------------------------------------------------------------------
instance Ord State where
compare Canceled Canceled = EQ
compare Canceled _ = LT
@@ -31,6 +34,43 @@ instance Ord State where
------------------------------------------------------------------------------
+-- Probably breaks Num laws, but I can live with it
+--
+instance Num State where
+ --------------------------------------------------------------------------
+ Canceled + Canceled = Canceled
+ Canceled + x = x
+ x + Canceled = x
+ (Deadline a) + (Deadline b) = Deadline $! a + b
+
+ --------------------------------------------------------------------------
+ Canceled - Canceled = Canceled
+ Canceled - x = negate x
+ x - Canceled = x
+ (Deadline a) - (Deadline b) = Deadline $! a - b
+
+ --------------------------------------------------------------------------
+ Canceled * _ = Canceled
+ _ * Canceled = Canceled
+ (Deadline a) * (Deadline b) = Deadline $! a * b
+
+ --------------------------------------------------------------------------
+ negate Canceled = Canceled
+ negate (Deadline d) = Deadline (negate d)
+
+ --------------------------------------------------------------------------
+ abs Canceled = Canceled
+ abs (Deadline d) = Deadline (abs d)
+
+ --------------------------------------------------------------------------
+ signum Canceled = Canceled
+ signum (Deadline d) = Deadline (signum d)
+
+ --------------------------------------------------------------------------
+ fromInteger = Deadline . fromInteger
+
+
+------------------------------------------------------------------------------
data TimeoutHandle = TimeoutHandle {
_killAction :: !(IO ())
, _state :: !(IORef State)
@@ -39,6 +79,20 @@ data TimeoutHandle = TimeoutHandle {
------------------------------------------------------------------------------
+-- | Given a 'State' value and the current time, apply the given modification
+-- function to the amount of time remaining.
+--
+smap :: CTime -> (Int -> Int) -> State -> State
+smap _ _ Canceled = Canceled
+
+smap now f (Deadline t) = Deadline t'
+ where
+ !remaining = fromEnum $ max 0 (t - now)
+ !newremaining = f remaining
+ !t' = now + toEnum newremaining
+
+
+------------------------------------------------------------------------------
data TimeoutManager = TimeoutManager {
_defaultTimeout :: !Int
, _getTime :: !(IO CTime)
@@ -108,38 +162,37 @@ register killAction tm = do
-- 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
+tickle th = modify th . max
+{-# INLINE tickle #-}
------------------------------------------------------------------------------
-- | Set the timeout on a connection to be N seconds into the future.
set :: TimeoutHandle -> Int -> IO ()
-set th n = do
- now <- getTime
+set th = modify th . const
+{-# INLINE set #-}
- let state = Deadline $ now + toEnum n
- writeIORef stateRef state
+
+------------------------------------------------------------------------------
+-- | Modify the timeout with the given function.
+modify :: TimeoutHandle -> (Int -> Int) -> IO ()
+modify th f = do
+ now <- getTime
+ state <- readIORef stateRef
+ let !state' = smap now f state
+ writeIORef stateRef state'
where
getTime = _hGetTime th
stateRef = _state th
+{-# INLINE modify #-}
------------------------------------------------------------------------------
-- | Cancel a timeout.
cancel :: TimeoutHandle -> IO ()
cancel h = writeIORef (_state h) Canceled
+{-# INLINE cancel #-}
------------------------------------------------------------------------------
View
31 test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -195,8 +195,8 @@ testHttpRequest1 =
assertEqual "parse body" "0123456789" body
- assertEqual "cookie"
- [Cookie "foo" "bar\"" Nothing Nothing Nothing False False]
+ assertEqual "cookie"
+ [Cookie "foo" "bar\"" Nothing Nothing Nothing False False]
(rqCookies req)
assertEqual "continued headers" (Just ["foo bar"]) $
@@ -387,14 +387,21 @@ testHttpResponse1 = testCase "server/HttpResponse1" $ do
sendResponse req rsp1 buf copyingStream2Stream testOnSendFile >>=
return . snd
- assertEqual "http response" (L.concat [
- "HTTP/1.0 600 Test\r\n"
- , "Content-Length: 10\r\n"
- , "Foo: Bar\r\n\r\n"
- , "0123456789"
- ]) b
+ assertBool "http response" (b == text1 || b == text2)
where
+ text1 = L.concat [ "HTTP/1.0 600 Test\r\n"
+ , "Content-Length: 10\r\n"
+ , "Foo: Bar\r\n\r\n"
+ , "0123456789"
+ ]
+
+ text2 = L.concat [ "HTTP/1.0 600 Test\r\n"
+ , "Foo: Bar\r\n"
+ , "Content-Length: 10\r\n\r\n"
+ , "0123456789"
+ ]
+
rsp1 = updateHeaders (H.insert "Foo" "Bar") $
setContentLength 10 $
setResponseStatus 600 "Test" $
@@ -547,16 +554,16 @@ testHttpResponseCookies = testCase "server/HttpResponseCookies" $ do
ch Nothing = False
ch (Just l) =
- sort l == [
+ sort l == [
"ck1=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com; Secure\r"
, "ck2=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com; HttpOnly\r"
, "ck3=bar\r"
]
-
+
rsp1 = setResponseStatus 304 "Test" $ emptyResponse { rspHttpVersion = (1,0) }
- rsp2 = addResponseCookie cook3 . addResponseCookie cook2
+ rsp2 = addResponseCookie cook3 . addResponseCookie cook2
. addResponseCookie cook $ rsp1
utc = UTCTime (ModifiedJulianDay 55226) 0
@@ -567,7 +574,7 @@ testHttpResponseCookies = testCase "server/HttpResponseCookies" $ do
echoServer :: (ByteString -> IO ())
- -> (Int -> IO ())
+ -> ((Int -> Int) -> IO ())
-> Request
-> Iteratee ByteString IO (Request,Response)
echoServer _ _ req = do
Please sign in to comment.
Something went wrong with that request. Please try again.