module System.Event.Manager
(
EventManager
, new
, newWith
, newDefaultBackend
, finished
, loop
, step
, shutdown
, cleanup
, wakeManager
, Event
, evtRead
, evtWrite
, IOCallback
, FdKey(keyFd)
, registerFd_
, registerFd
, unregisterFd_
, unregisterFd
, closeFd
, TimeoutCallback
, TimeoutKey
, registerTimeout
, updateTimeout
, unregisterTimeout
) where
#include "EventConfig.h"
import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, readMVar)
import Control.Exception (finally)
import Control.Monad ((=<<), forM_, liftM, sequence_, when)
import Data.IORef (IORef, atomicModifyIORef, mkWeakIORef, newIORef, readIORef,
writeIORef)
import Data.Maybe (Maybe(..))
import Data.Monoid (mappend, mconcat, mempty)
import GHC.Base
import GHC.Conc.Signal (runHandlers)
import GHC.List (filter)
import GHC.Num (Num(..))
import GHC.Real ((/), fromIntegral )
import GHC.Show (Show(..))
import System.Event.Clock (getCurrentTime)
import System.Event.Control
import System.Event.Internal (Backend, Event, evtClose, evtRead, evtWrite,
Timeout(..))
import System.Event.Unique (Unique, UniqueSource, newSource, newUnique)
import System.Posix.Types (Fd)
import qualified System.Event.IntMap as IM
import qualified System.Event.Internal as I
import qualified System.Event.PSQ as Q
#if defined(HAVE_KQUEUE)
import qualified System.Event.KQueue as KQueue
#elif defined(HAVE_EPOLL)
import qualified System.Event.EPoll as EPoll
#elif defined(HAVE_POLL)
import qualified System.Event.Poll as Poll
#else
# error not implemented for this operating system
#endif
data FdData = FdData {
fdKey :: !FdKey
, fdEvents :: !Event
, _fdCallback :: !IOCallback
} deriving (Show)
data FdKey = FdKey {
keyFd :: !Fd
, keyUnique :: !Unique
} deriving (Eq, Show)
type IOCallback = FdKey -> Event -> IO ()
instance Show IOCallback where
show _ = "IOCallback"
newtype TimeoutKey = TK Unique
deriving (Eq)
type TimeoutCallback = IO ()
data State = Created
| Running
| Dying
| Finished
deriving (Eq, Show)
type TimeoutQueue = Q.PSQ TimeoutCallback
type TimeoutEdit = TimeoutQueue -> TimeoutQueue
data EventManager = EventManager
{ emBackend :: !Backend
, emFds :: !(MVar (IM.IntMap [FdData]))
, emTimeouts :: !(IORef TimeoutEdit)
, emState :: !(IORef State)
, emUniqueSource :: !UniqueSource
, emControl :: !Control
}
handleControlEvent :: EventManager -> FdKey -> Event -> IO ()
handleControlEvent mgr reg _evt = do
msg <- readControlMessage (emControl mgr) (keyFd reg)
case msg of
CMsgWakeup -> return ()
CMsgDie -> writeIORef (emState mgr) Finished
CMsgSignal fp s -> runHandlers fp s
newDefaultBackend :: IO Backend
#if defined(HAVE_KQUEUE)
newDefaultBackend = KQueue.new
#elif defined(HAVE_EPOLL)
newDefaultBackend = EPoll.new
#elif defined(HAVE_POLL)
newDefaultBackend = Poll.new
#else
newDefaultBackend = error "no back end for this platform"
#endif
new :: IO EventManager
new = newWith =<< newDefaultBackend
newWith :: Backend -> IO EventManager
newWith be = do
iofds <- newMVar IM.empty
timeouts <- newIORef id
ctrl <- newControl
state <- newIORef Created
us <- newSource
_ <- mkWeakIORef state $ do
st <- atomicModifyIORef state $ \s -> (Finished, s)
when (st /= Finished) $ do
I.delete be
closeControl ctrl
let mgr = EventManager { emBackend = be
, emFds = iofds
, emTimeouts = timeouts
, emState = state
, emUniqueSource = us
, emControl = ctrl
}
_ <- registerFd_ mgr (handleControlEvent mgr) (controlReadFd ctrl) evtRead
_ <- registerFd_ mgr (handleControlEvent mgr) (wakeupReadFd ctrl) evtRead
return mgr
shutdown :: EventManager -> IO ()
shutdown mgr = do
state <- atomicModifyIORef (emState mgr) $ \s -> (Dying, s)
when (state == Running) $ sendDie (emControl mgr)
finished :: EventManager -> IO Bool
finished mgr = (== Finished) `liftM` readIORef (emState mgr)
cleanup :: EventManager -> IO ()
cleanup EventManager{..} = do
writeIORef emState Finished
I.delete emBackend
closeControl emControl
loop :: EventManager -> IO ()
loop mgr@EventManager{..} = do
state <- atomicModifyIORef emState $ \s -> case s of
Created -> (Running, s)
_ -> (s, s)
case state of
Created -> go Q.empty `finally` cleanup mgr
Dying -> cleanup mgr
_ -> do cleanup mgr
error $ "System.Event.Manager.loop: state is already " ++
show state
where
go q = do (running, q') <- step mgr q
when running $ go q'
step :: EventManager -> TimeoutQueue -> IO (Bool, TimeoutQueue)
step mgr@EventManager{..} tq = do
(timeout, q') <- mkTimeout tq
I.poll emBackend timeout (onFdEvent mgr)
state <- readIORef emState
state `seq` return (state == Running, q')
where
mkTimeout :: TimeoutQueue -> IO (Timeout, TimeoutQueue)
mkTimeout q = do
now <- getCurrentTime
applyEdits <- atomicModifyIORef emTimeouts $ \f -> (id, f)
let (expired, q'') = let q' = applyEdits q in q' `seq` Q.atMost now q'
sequence_ $ map Q.value expired
let timeout = case Q.minView q'' of
Nothing -> Forever
Just (Q.E _ t _, _) ->
let t' = t now in t' `seq` Timeout t'
return (timeout, q'')
registerFd_ :: EventManager -> IOCallback -> Fd -> Event
-> IO (FdKey, Bool)
registerFd_ EventManager{..} cb fd evs = do
u <- newUnique emUniqueSource
modifyMVar emFds $ \oldMap -> do
let fd' = fromIntegral fd
reg = FdKey fd u
!fdd = FdData reg evs cb
(!newMap, (oldEvs, newEvs)) =
case IM.insertWith (++) fd' [fdd] oldMap of
(Nothing, n) -> (n, (mempty, evs))
(Just prev, n) -> (n, pairEvents prev newMap fd')
modify = oldEvs /= newEvs
when modify $ I.modifyFd emBackend fd oldEvs newEvs
return (newMap, (reg, modify))
registerFd :: EventManager -> IOCallback -> Fd -> Event -> IO FdKey
registerFd mgr cb fd evs = do
(r, wake) <- registerFd_ mgr cb fd evs
when wake $ wakeManager mgr
return r
wakeManager :: EventManager -> IO ()
wakeManager mgr = sendWakeup (emControl mgr)
eventsOf :: [FdData] -> Event
eventsOf = mconcat . map fdEvents
pairEvents :: [FdData] -> IM.IntMap [FdData] -> Int -> (Event, Event)
pairEvents prev m fd = let l = eventsOf prev
r = case IM.lookup fd m of
Nothing -> mempty
Just fds -> eventsOf fds
in (l, r)
unregisterFd_ :: EventManager -> FdKey -> IO Bool
unregisterFd_ EventManager{..} (FdKey fd u) =
modifyMVar emFds $ \oldMap -> do
let dropReg cbs = case filter ((/= u) . keyUnique . fdKey) cbs of
[] -> Nothing
cbs' -> Just cbs'
fd' = fromIntegral fd
(!newMap, (oldEvs, newEvs)) =
case IM.updateWith dropReg fd' oldMap of
(Nothing, _) -> (oldMap, (mempty, mempty))
(Just prev, newm) -> (newm, pairEvents prev newm fd')
modify = oldEvs /= newEvs
when modify $ I.modifyFd emBackend fd oldEvs newEvs
return (newMap, modify)
unregisterFd :: EventManager -> FdKey -> IO ()
unregisterFd mgr reg = do
wake <- unregisterFd_ mgr reg
when wake $ wakeManager mgr
closeFd :: EventManager -> (Fd -> IO ()) -> Fd -> IO ()
closeFd mgr close fd = do
fds <- modifyMVar (emFds mgr) $ \oldMap -> do
close fd
case IM.delete (fromIntegral fd) oldMap of
(Nothing, _) -> return (oldMap, [])
(Just fds, !newMap) -> do
when (eventsOf fds /= mempty) $ wakeManager mgr
return (newMap, fds)
forM_ fds $ \(FdData reg ev cb) -> cb reg (ev `mappend` evtClose)
registerTimeout :: EventManager -> Int -> TimeoutCallback -> IO TimeoutKey
registerTimeout mgr us cb = do
!key <- newUnique (emUniqueSource mgr)
if us <= 0 then cb
else do
now <- getCurrentTime
let expTime = fromIntegral us / 1000000.0 + now
atomicModifyIORef (emTimeouts mgr) $ \f ->
let f' = (Q.insert key expTime cb) . f in (f', ())
wakeManager mgr
return $ TK key
unregisterTimeout :: EventManager -> TimeoutKey -> IO ()
unregisterTimeout mgr (TK key) = do
atomicModifyIORef (emTimeouts mgr) $ \f ->
let f' = (Q.delete key) . f in (f', ())
wakeManager mgr
updateTimeout :: EventManager -> TimeoutKey -> Int -> IO ()
updateTimeout mgr (TK key) us = do
now <- getCurrentTime
let expTime = fromIntegral us / 1000000.0 + now
atomicModifyIORef (emTimeouts mgr) $ \f ->
let f' = (Q.adjust (const expTime) key) . f in (f', ())
wakeManager mgr
onFdEvent :: EventManager -> Fd -> Event -> IO ()
onFdEvent mgr fd evs = do
fds <- readMVar (emFds mgr)
case IM.lookup (fromIntegral fd) fds of
Just cbs -> forM_ cbs $ \(FdData reg ev cb) ->
when (evs `I.eventIs` ev) $ cb reg evs
Nothing -> return ()