Merge branch 'fix-timeouts' into 0.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

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 ()
 
 

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

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
             )
 
 

src/Snap/Internal/Http/Server/TimeoutManager.hs

@@ -8,6 +8,7 @@ module Snap.Internal.Http.Server.TimeoutManager
   , register
   , tickle
   , set
+  , modify
   , cancel
   ) where
 
@@ -23,13 +24,52 @@ 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
 
 
+------------------------------------------------------------------------------
+-- 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 ())
@@ -38,6 +78,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
@@ -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 #-}
 
 
 ------------------------------------------------------------------------------

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