当前位置: 动力学知识库 > 问答 > 编程问答 >

haskell - TimeoutManager uses tryPutMVar to put nothing

问题描述:

In Snap source Snap.Internal.Http.Server.TimeoutManager

------------------------------------------------------------------------------

-- | Register a new connection with the TimeoutManager.

register :: IO () -- ^ action to run when the timeout deadline is

-- exceeded.

-> TimeoutManager -- ^ manager to register with.

-> IO TimeoutHandle

register killAction tm = do

now <- getTime

let !state = Deadline $ now + toEnum defaultTimeout

stateRef <- newIORef state

let !h = TimeoutHandle killAction stateRef getTime

atomicModifyIORef connections $ \x -> (h:x, ())

inact <- readIORef inactivity

when inact $ do

-- wake up manager thread

writeIORef inactivity False

_ <- tryPutMVar morePlease ()

return ()

return h

where

getTime = _getTime tm

inactivity = _inactivity tm

morePlease = _morePlease tm

connections = _connections tm

defaultTimeout = _defaultTimeout tm

Why there is _morePlease field?

What does _ <- tryPutMVar morePlease () do?

网友答案:
managerThread :: TimeoutManager -> IO ()
managerThread tm = loop `finally` (readIORef connections >>= destroyAll)
  where
    --------------------------------------------------------------------------
    connections = _connections tm
    getTime     = _getTime tm
    inactivity  = _inactivity tm
    morePlease  = _morePlease tm
    waitABit    = threadDelay 5000000

    --------------------------------------------------------------------------
    loop = do
        waitABit
        handles <- atomicModifyIORef connections (\x -> ([],x))

        if null handles
          then do
            -- we're inactive, go to sleep until we get new threads
            writeIORef inactivity True
            takeMVar morePlease
          else do
            now   <- getTime
            dlist <- processHandles now handles id
            atomicModifyIORef connections (\x -> (dlist x, ()))

        loop

    --------------------------------------------------------------------------
    processHandles !now handles initDlist = go handles initDlist
      where
        go [] !dlist = return dlist

        go (x:xs) !dlist = do
            state   <- readIORef $ _state x
            !dlist' <- case state of
                         Canceled   -> return dlist
                         Deadline t -> if t <= now
                                         then do
                                           _killAction x
                                           return dlist
                                         else return (dlist . (x:))
            go xs dlist'

    --------------------------------------------------------------------------
    destroyAll = mapM_ diediedie

    --------------------------------------------------------------------------
    diediedie x = do
        state <- readIORef $ _state x
        case state of
          Canceled -> return ()
          _        -> _killAction x

If there is no handles to be processed, managerThread will be blocked by takeMVar morePlease. _ <- tryPutMVar morePlease () wakes him up.

分享给朋友:
您可能感兴趣的文章:
随机阅读: