diff options
Diffstat (limited to 'wayland/Wayland/Server/Display.hs')
| -rw-r--r-- | wayland/Wayland/Server/Display.hs | 493 |
1 files changed, 378 insertions, 115 deletions
diff --git a/wayland/Wayland/Server/Display.hs b/wayland/Wayland/Server/Display.hs index 2a30323..527d9da 100644 --- a/wayland/Wayland/Server/Display.hs +++ b/wayland/Wayland/Server/Display.hs @@ -8,91 +8,147 @@ -- | -- Module : Wayland.Server.Display --- Description: Entrypoint for the server, managing the request loop and server state. +-- Description: Entrypoint for the server, managing the message loop and server state. -- --- A wayland server provides a "display" that can be controlled using a UNIX socket. The server runs an event loop --- handling requests. These requests may be events, requests to create objects, or requests for a particular object --- instance. +-- A wayland server provides a "display" that can be controlled using a UNIX socket. The server runs a message loop +-- handling messages. These messages may be timers, UNIX signals, requests to create objects, or requests for a +-- particular object instance. module Wayland.Server.Display ( -- * The Display Monad DisplayM , withDisplay , bindSocket - , -- * Processing Requests - RequestHandler - , processRequests + , -- * Processing Messages + MessageHandler + , processMessages , requestTermination + , -- * Managing Clients + destroyClient + , flushClientEvents , -- * Managing Objects Global , registerGlobal + , hideGlobal , unregisterGlobal , createObject , destroyObject , sendEvent , flushEvents - , -- * Event Sources - EventSource - , registerSignalEvent + , -- * Message Sources + SignalSource + , TimerSource + , FileSource + , FileEventMask(..) + , registerSignalSource + , unregisterSignalSource + , registerTimerSource + , setTimerSource + , unregisterTimerSource + , registerFileSource + , updateFileSourceMask + , unregisterFileSource ) where import Data.Maybe (isJust) import Data.Functor (($>)) import Data.Typeable (Proxy(..)) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Foreign (Ptr, FunPtr, Word32, nullPtr) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) +import Data.Hashable (Hashable(..)) +import Data.Time.Clock (DiffTime, diffTimeToPicoseconds) +import Data.Bits ((.&.), (.|.)) +import Foreign (Ptr, FunPtr, Word32, nullPtr, freeHaskellFunPtr, free, new, castPtr) import Foreign.C (peekCString, CInt) import Lens.Micro.TH (makeLenses) import Lens.Micro.Mtl.Internal (Zoom(..), Zoomed) import Control.Monad.State.Strict (StateT(..), MonadState(..)) import Control.Monad.Reader (ReaderT(..), ask, asks) import Control.Monad.Trans (MonadIO(..), MonadTrans(..)) -import Control.Exception (bracket) -import Control.Monad (when) +import Control.Exception (bracket, bracket_) +import Control.Monad (when, void) import Wayland.Server.System -import Wayland.Server.Object (ObjectCache, Request(..), newObjectCache, destroyObjectCache, createResource, RequestClass, Object(..), unwrapResource, resolveTypeInterface, sendResourceEvent, NewObject, createNewObject) -import Wayland.Server.Client (wrapClient) +import Wayland.Server.Object +import Wayland.Server.Client (wrapClient, ClientData, newClientData, destroyClientData, ClientMessage(..), createClient, Client, unwrapClient) +import Wayland.Server.Types (Message(..), MessageClass, Handle, createHandle, resolveHandle, invalidateHandle) +import Wayland.Server.Interface (InterfaceDesc(..)) +import System.Posix.Types (Fd (..)) -- | The display monad. -- --- All server-related logic runs in this monad, including the initial set-up and all request handlers. The monad +-- All server-related logic runs in this monad, including the initial set-up and all message handlers. The monad -- provides custom state and support for IO operations. newtype DisplayM s a = DisplayM { runDisplayM :: StateT s (ReaderT Display (StateT DisplayState IO)) a } deriving (Functor, Applicative, Monad, MonadIO, MonadState s) --- | A function handling a type-erased request. +-- | A function handling a type-erased message. -- --- This handler is executed as part of the event loop. -type RequestHandler s = Request -> DisplayM s () +-- This handler is executed as part of the message loop. +type MessageHandler s = Message -> DisplayM s () -- | Read-only data related to the display. data Display - = Display { display :: !WLDisplay -- ^ The underlying wl_display instance. - , activeEventLoop :: !(IORef (Maybe EventLoop)) -- ^ Mutable reference to the active request handler. + = Display { dispDisplay :: !WLDisplay -- ^ The underlying wl_display instance. + , dispActiveMessageLoop :: !(IORef (Maybe MessageLoop)) -- ^ Mutable reference to the active message handler. + , dispClientData :: !ClientData } -- | Mutable state for the display. newtype DisplayState = DisplayState { _stateObjectCache :: ObjectCache } --- | A function handling a request in the IO monad. +-- | A function handling a message in the IO monad. -- --- The event loop callback needs to retrieve the current state, run the request handler in a Display monad, and update +-- The message loop callback needs to retrieve the current state, run the message handler in a Display monad, and update -- the state. -newtype EventLoop = EventLoop { handleEvent :: Request -> IO () } +newtype MessageLoop = MessageLoop (Message -> IO ()) --- | Handle to an event source that dispatches requests to the event loop. +-- | Handle to a message source that dispatches messages when a UNIX signal was raised. -- --- This may be a signal event source, timer event source, etc. The event source handle remains valid even after it has --- expired or after it was unregistered. -data EventSource = EventSource (FunPtr WLEventLoopSignalFunc) (IORef WLEventSource) - deriving (Eq) +-- The message source handle remains valid even after it is unregistered. However, actions using the source (like +-- unregistering it) will fail. +data SignalSource + = SignalSource { signalHandle :: !(Handle WLEventSource) + , signalFunc :: !(FunPtr WLEventLoopSignalFunc) + } + +-- | Handle to a message source that dispatches messages after a timeout has passed. +-- +-- The timer can be reused and/or reset multiple times before it is unregistered. +-- +-- The message source handle remains valid even after it is unregistered. However, actions using the source (like +-- unregistering it) will fail. +data TimerSource + = TimerSource { timerHandle :: !(Handle WLEventSource) + , timerFunc :: !(FunPtr WLEventLoopTimerFunc) + } + +-- | Handle to a message source that dispatches messages for file descriptor events. +-- +-- The message source handle remains valid even after it is unregistered. However, actions using the source (like +-- unregistering it) will fail. +data FileSource + = FileSource { fileHandle :: !(Handle WLEventSource) + , fileFunc :: !(FunPtr WLEventLoopFdFunc) + } + +-- | The file events listened for by a 'FileSource' on a UNIX file descriptor. +data FileEventMask + = FileEventMask { fileEventReadable :: Bool + , fileEventWritable :: Bool + , fileEventHangup :: Bool + , fileEventError :: Bool + } + deriving (Show, Eq, Ord) -- | Handle to a global object shared between all clients. -- --- For each client, the global can be "bound" to a specific object. The global handle remains valid even after it was --- unregistered. -data Global = Global (FunPtr WLGlobalBindFunc) (IORef WLGlobal) - deriving (Eq) +-- For each client, the global can be "bound" to a specific object. +-- +-- The global handle remains valid even after it is destroyed. However, actions using the global (like unregistering it) +-- will fail. +data Global + = Global { glbHandle :: Handle WLGlobal + , glbBindFunc :: FunPtr WLGlobalBindFunc + } makeLenses ''DisplayState @@ -101,6 +157,54 @@ type instance Zoomed (DisplayM s) = Zoomed (StateT s (ReaderT Display (StateT Di instance Zoom (DisplayM s) (DisplayM t) s t where zoom l (DisplayM m) = DisplayM (zoom l m) +instance Eq SignalSource where + a == b = signalHandle a == signalHandle b + +instance Ord SignalSource where + a <= b = signalHandle a <= signalHandle b + +instance Hashable SignalSource where + hashWithSalt s o = hashWithSalt s (signalHandle o) + +instance Show SignalSource where + show o = "SignalSource " ++ show (signalHandle o) + +instance Eq TimerSource where + a == b = timerHandle a == timerHandle b + +instance Ord TimerSource where + a <= b = timerHandle a <= timerHandle b + +instance Hashable TimerSource where + hashWithSalt s o = hashWithSalt s (timerHandle o) + +instance Show TimerSource where + show o = "TimerSource " ++ show (timerHandle o) + +instance Eq FileSource where + a == b = fileHandle a == fileHandle b + +instance Ord FileSource where + a <= b = fileHandle a <= fileHandle b + +instance Hashable FileSource where + hashWithSalt s o = hashWithSalt s (fileHandle o) + +instance Show FileSource where + show o = "FileSource " ++ show (fileHandle o) + +instance Eq Global where + a == b = glbHandle a == glbHandle b + +instance Ord Global where + a <= b = glbHandle a <= glbHandle b + +instance Hashable Global where + hashWithSalt s o = hashWithSalt s (glbHandle o) + +instance Show Global where + show o = "Global " ++ show (glbHandle o) + -- | Lift a 'Display' reader operation into the display monad. liftDisplay :: ReaderT Display (StateT DisplayState IO) a -> DisplayM s a liftDisplay = DisplayM . lift @@ -111,20 +215,25 @@ liftDisplayState = DisplayM . lift . lift -- | Get a reference to the underlying wl_display instance. getDisplay :: DisplayM s WLDisplay -getDisplay = liftDisplay $ asks display +getDisplay = liftDisplay $ asks dispDisplay --- | Get a function which can be used to handle a request. +-- | Get a function which can be used to handle a message. -- --- This function can be used even before the event loop is started as it will use the mutable "activeEventLoop" --- reference which gets updated when the event loop is started. -getRequestHandler :: DisplayM s (Request -> IO ()) -getRequestHandler = do - loopRef <- liftDisplay $ asks activeEventLoop - pure $ \req -> do - loop <- readIORef loopRef - case loop of - Just handler -> handleEvent handler req - Nothing -> putStrLn $ "Lost request because no event loop is active: " ++ show req +-- This function can be used even before the message loop is started as it will use the mutable "activeMessageLoop" +-- reference which gets updated when the message loop is started. +getMessageHandler :: DisplayM s (Message -> IO ()) +getMessageHandler = liftDisplay $ asks (handleMessage . dispActiveMessageLoop) + +-- | Handle a message within a display's message loop. +-- +-- The message loop supports reentrant calls. In this case, dispatching the message is delayed until after the current +-- message has been processed. +handleMessage :: IORef (Maybe MessageLoop) -> Message -> IO () +handleMessage loopRef msg = do + loop <- readIORef loopRef + case loop of + Just (MessageLoop handler) -> handler msg + Nothing -> putStrLn $ "Lost message because no message loop is active: " ++ show msg -- | Create a new display and execute the given action on it. -- @@ -134,16 +243,31 @@ withDisplay -> DisplayM s a -- ^ The display action to execute. -> IO (a, s) -- ^ IO monad returning the result and the resulting state. withDisplay initialState f = bracket wlDisplayCreate wlDisplayDestroy $ \sysDisp -> do - eventLoop <- newIORef Nothing - let disp = Display { display = sysDisp - , activeEventLoop = eventLoop - } + messageLoop <- newIORef Nothing + clientData <- newClientData (handleMessage messageLoop) objectCache <- newObjectCache + let disp = Display { dispDisplay = sysDisp + , dispActiveMessageLoop = messageLoop + , dispClientData = clientData + } let dispState = DisplayState { _stateObjectCache = objectCache } - (res, dispState') <- runStateT (runReaderT (runStateT (runDisplayM f) initialState) disp) dispState + (res, dispState') <- handleClientCreated disp $ + runStateT (runReaderT (runStateT (runDisplayM f) initialState) disp) dispState destroyObjectCache (_stateObjectCache dispState') + destroyClientData clientData pure res +-- | Handle the "client created" event, creating a wrapper and dispatching a message. +handleClientCreated :: Display -> IO a -> IO a +handleClientCreated disp action = + let clientCreated :: Ptr WLListener -> Ptr () -> IO () + clientCreated _ c = do + client <- runReaderT (createClient (WLClient (castPtr c))) (dispClientData disp) + handleMessage (dispActiveMessageLoop disp) $ Message $ ClientCreated client + in bracket (wrapWLNotifyFunc clientCreated) freeHaskellFunPtr $ \clientCreatedFunc -> + bracket (new $ WLListener clientCreatedFunc) free $ \clientListener -> + bracket_ (wlDisplayAddClientCreatedListener (dispDisplay disp) clientListener) (wlListenerRemove clientListener) action + -- | Bind the display to a UNIX socket so it is reachable from clients. -- -- This will return the name of the Wayland display. @@ -153,49 +277,117 @@ bindSocket = do name <- liftIO $ wlDisplayAddSocketAuto disp liftIO $ peekCString name --- | Start the event loop for the display. +-- | Start the message loop for the display. -- --- The display will then handle all requests using the provided handler until 'requestTermination' is called. The state --- may be modified by the request handler. -processRequests :: RequestHandler s -> DisplayM s () -processRequests h = do +-- The display will then handle all messages using the provided handler until 'requestTermination' is called. The state +-- may be modified by the message handler. +processMessages :: MessageHandler s -> DisplayM s () +processMessages h = do disp <- liftDisplay ask stateBefore <- get displayStateBefore <- liftDisplayState get - stateRef <- liftIO $ newIORef (stateBefore, displayStateBefore) - let handler :: Request -> IO () + stateRef <- liftIO $ newIORef $ Just (stateBefore, displayStateBefore) + queued <- liftIO $ newIORef [] + let snoc r (x:xs) = x : snoc r xs + snoc r [] = [r] + let runQueued :: MessageHandler s -> DisplayM s () + runQueued h' = do + x <- liftIO $ readIORef queued + case x of + (r:rs) -> do liftIO $ writeIORef queued rs + h' r + runQueued h' + [] -> pure () + let handler :: Message -> IO () handler r = do - (s, ds) <- readIORef stateRef - ((_, s'), ds') <- runStateT (runReaderT (runStateT (runDisplayM (h r)) s) disp) ds - writeIORef stateRef (s', ds') - loop <- liftIO $ readIORef (activeEventLoop disp) - when (isJust loop) (error "Cannot start an event loop from within an event handler.") - liftIO $ writeIORef (activeEventLoop disp) (Just (EventLoop handler)) - liftIO $ wlDisplayRun (display disp) - (stateAfter, displayStateAfter) <- liftIO $ readIORef stateRef - put stateAfter - liftDisplayState $ put displayStateAfter + stateVal <- readIORef stateRef + modifyIORef queued (snoc r) -- In most cases, queued is empty, so we don't really care about snoc's runtime. + case stateVal of + Just (s, ds) -> do writeIORef stateRef Nothing + ((_, s'), ds') <- runStateT (runReaderT (runStateT (runDisplayM (runQueued h)) s) disp) ds + writeIORef stateRef $ Just (s', ds') + Nothing -> pure () -- Reentrant call, dispatch after completing the current message. + loop <- liftIO $ readIORef (dispActiveMessageLoop disp) + when (isJust loop) (error "Cannot start a message loop from within a message handler.") + liftIO $ writeIORef (dispActiveMessageLoop disp) (Just (MessageLoop handler)) + liftIO $ wlDisplayRun (dispDisplay disp) + stateVal <- liftIO $ readIORef stateRef + case stateVal of + Just (stateAfter, displayStateAfter) -> do put stateAfter + liftDisplayState $ put displayStateAfter + Nothing -> pure () --- | Request the event loop to stop. +-- | Request the message loop to stop. -- --- The 'processRequests' will return following this action. +-- The 'processMessages' will return following this action. requestTermination :: DisplayM s () requestTermination = do disp <- getDisplay liftIO $ wlDisplayTerminate disp +-- | Destroy a client instance. +destroyClient :: Client -> DisplayM s () +destroyClient c = liftIO (unwrapClient c >>= wlClientDestroy) + +-- | Ensure that all queued events are sent to a particular client. +flushClientEvents :: Client -> DisplayM s () +flushClientEvents c = liftIO (unwrapClient c >>= wlClientFlush) + +-- | Register a global object which can be bound by clients. +-- +-- The object is published through the global wl_registry instance. When a client wants to instantiate the global +-- object, the given "bind" message will be dispatched in the message loop. +registerGlobal + :: forall o bindMsg s. Object o + => MessageClass bindMsg + => (Global -> NewObject o -> bindMsg) -- ^ Function used to create a message to bind the global object for a client. + -> DisplayM s Global -- ^ Display monad wrapping a handle to the global which can be used to unregister it. +registerGlobal mkBindMsg = do + disp <- getDisplay + handler <- getMessageHandler + iface <- liftDisplayState $ zoom stateObjectCache $ resolveTypeInterface (Proxy :: Proxy o) handler + liftIO $ do + ref <- newIORef Nothing + let version = Wayland.Server.Interface.ifVersion (describeInterface (Proxy :: Proxy o)) + let bind :: WLClient -> Ptr () -> Word32 -> Word32 -> IO () + bind client _ _ objID = do wrappedClient <- wrapClient client + Just global <- readIORef ref + obj <- createNewObject wrappedClient objID + handler $ Message (mkBindMsg global obj) + bindFunc <- wrapWLGlobalBindFunc bind + handle <- wlGlobalCreate disp iface (fromIntegral version) nullPtr bindFunc >>= createHandle + let res = Global handle bindFunc + writeIORef ref (Just res) + pure res + +-- | Stop advertizing a global object to client. +-- +-- The global will continue to exist until it is destroyed using 'destroyGlobal'. This is useful for waiting for a +-- timeout to elapse before actually destroying the global. +hideGlobal :: Global -> DisplayM s () +hideGlobal global = liftIO (resolveHandle (glbHandle global) >>= wlGlobalRemove) + +-- | Unregister a global once it is no longer available. +-- +-- The global and all resources associated with it will be destroyed. +unregisterGlobal :: Global -> DisplayM s () +unregisterGlobal global = liftIO $ do + resolveHandle (glbHandle global) >>= wlGlobalDestroy + invalidateHandle (glbHandle global) + freeHaskellFunPtr (glbBindFunc global) + -- | Create a new object instance. -- --- If the NewObject instance has already been used to create an instance, the same instance is returned again. +-- It is a programmer error to use a NewObject instance more than once. createObject :: Object o - => RequestClass destroyReq + => MessageClass destroyMsg => NewObject o -- ^ Handle describing the object to be created - -> (o -> destroyReq) -- ^ Function creating a request dispatched after the object was destroyed. + -> (o -> destroyMsg) -- ^ Function creating a message dispatched after the object was destroyed. -> DisplayM s o -- ^ Display monad wrapping the newly created object. createObject o destroyHook = do - handle <- getRequestHandler - liftDisplayState $ zoom stateObjectCache $ createResource handle o destroyHook + handler <- getMessageHandler + liftDisplayState $ zoom stateObjectCache $ createResource handler o destroyHook -- | Destroy an object instance. -- @@ -215,48 +407,119 @@ flushEvents = do disp <- getDisplay liftIO $ wlDisplayFlushClients disp --- | Register a global object which can be bound by clients. +-- | Register a message to be dispatched in the message loop when a UNIX signal is sent to the server process. +registerSignalSource + :: MessageClass msg + => (SignalSource -> msg) -- ^ Function used to create the message when the signal is received. + -> CInt -- ^ The code of the UNIX signal to listen for. + -> DisplayM s SignalSource -- ^ Display monad wrapping a handle to the newly registered message source. +registerSignalSource mkMsg sig = do + disp <- getDisplay + handler <- getMessageHandler + liftIO $ do + ref <- newIORef Nothing + loop <- wlDisplayGetEventLoop disp + func <- wrapWLEventLoopSignalFunc $ \_ _ -> do + Just src <- readIORef ref + handler (Message (mkMsg src)) $> 0 + handle <- wlEventLoopAddSignal loop sig func nullPtr >>= createHandle + let res = SignalSource handle func + writeIORef ref (Just res) + pure res + +-- | Unregister a signal message source and stop it from dispatching any more messages. +unregisterSignalSource :: SignalSource -> DisplayM s () +unregisterSignalSource signal = liftIO $ do + _ <- resolveHandle (signalHandle signal) >>= wlEventSourceRemove + invalidateHandle (signalHandle signal) + freeHaskellFunPtr (signalFunc signal) + +-- | Register a message to be dispatched using a timer. -- --- The object is published through the global wl_registry instance. When a client wants to instantiate the global --- object, the given "bind" request will be dispatched in the request loop. -registerGlobal - :: forall o req s. Object o - => RequestClass req - => (NewObject o -> req) -- ^ Function used to create a request to bind the global object for a client. - -> Int -- ^ Version of the global published. - -> DisplayM s Global -- ^ Display monad wrapping a handle to the global which can be used to unregister it. -registerGlobal mkReq version = do - disp <- getDisplay - handle <- getRequestHandler - iface <- liftDisplayState $ zoom stateObjectCache $ resolveTypeInterface (Proxy :: Proxy o) - let bind :: WLClient -> Ptr () -> Word32 -> Word32 -> IO () - bind client _ ver objID = do wrappedClient <- wrapClient client - obj <- createNewObject wrappedClient objID (fromIntegral ver) - handle $ Request (mkReq obj) +-- Initially, the timer is not set. Use 'setTimerSource' to arm/disarm the timer later. +registerTimerSource + :: MessageClass msg + => (TimerSource -> msg) -- ^ Function used to create a message on timeout. + -> DisplayM s TimerSource -- ^ Display monad wrapping a handle to the newly registered message source. +registerTimerSource mkMsg = do + disp <- getDisplay + handler <- getMessageHandler liftIO $ do - bindFunc <- wrapWLGlobalBindFunc bind - global <- wlGlobalCreate disp iface (fromIntegral version) nullPtr bindFunc - globalRef <- newIORef global - -- TODO: Free func - pure $ Global bindFunc globalRef + ref <- newIORef Nothing + loop <- wlDisplayGetEventLoop disp + func <- wrapWLEventLoopTimerFunc $ \_ -> do + Just src <- readIORef ref + handler (Message (mkMsg src)) $> 0 + handle <- wlEventLoopAddTimer loop func nullPtr >>= createHandle + let res = TimerSource handle func + writeIORef ref (Just res) + pure res --- | Unregister a global after it is no longer available. -unregisterGlobal :: Global -> DisplayM s () -unregisterGlobal _ = pure () +-- | Arm/disarm a timer message source. +-- +-- Any active timeout is stopped. If the specified timeout is not Nothing, a new timeout is started. +setTimerSource :: TimerSource -> Maybe DiffTime -> DisplayM s () +setTimerSource timer timeout = liftIO $ do + src <- resolveHandle (timerHandle timer) + let msDelay = case timeout of + Just diff -> fromIntegral $ max 1 (diffTimeToPicoseconds diff `div` 1000000000) + Nothing -> 0 + void $ wlEventSourceTimerUpdate src msDelay --- | Register an event to be dispatched in the request loop when a UNIX signal is sent to the server process. -registerSignalEvent - :: RequestClass req - => req -- ^ The request dispatched when the signal is received. - -> CInt -- ^ The code of the UNIX signal to listen for. - -> DisplayM s EventSource -- ^ Display monad wrapping a handle to the event source which can be used to unregister it. -registerSignalEvent r sig = do - disp <- getDisplay - handle <- getRequestHandler +-- | Unregister a timer message source and stop it from dispatching any more messages. +unregisterTimerSource :: TimerSource -> DisplayM s () +unregisterTimerSource timer = liftIO $ do + _ <- resolveHandle (timerHandle timer) >>= wlEventSourceRemove + invalidateHandle (timerHandle timer) + freeHaskellFunPtr (timerFunc timer) + +-- | Register a message to be dispatched for file events on a UNIX file descriptor. +-- +-- Initially, file descriptors are usually writable so the event should only be listened for after a write fails. +registerFileSource + :: MessageClass msg + => (FileSource -> FileEventMask -> msg) -- ^ Function used to create a message following one or more file events (as specified). + -> Fd -- ^ The UNIX file descriptor to watch. + -> FileEventMask -- ^ Events to watch for. + -> DisplayM s FileSource -- ^ Display monad wrapping a handle to the newly registered message source. +registerFileSource mkMsg (Fd fd) events = do + disp <- getDisplay + handler <- getMessageHandler liftIO $ do - loop <- wlDisplayGetEventLoop disp - func <- wrapWLEventLoopSignalFunc $ \_ _ -> handle (Request r) $> 0 - src <- wlEventLoopAddSignal loop sig func nullPtr - srcRef <- newIORef src - -- TODO: Free func - pure $ EventSource func srcRef + ref <- newIORef Nothing + loop <- wlDisplayGetEventLoop disp + func <- wrapWLEventLoopFdFunc $ \_ e _ -> do + Just src <- readIORef ref + handler (Message (mkMsg src (toFileEventMask e))) $> 0 + handle <- wlEventLoopAddFd loop fd (fromFileEventMask events) func nullPtr >>= createHandle + let res = FileSource handle func + writeIORef ref (Just res) + pure res + +-- | Update the file events to watch for using an existing file message source. +updateFileSourceMask :: FileSource -> FileEventMask -> DisplayM s () +updateFileSourceMask file events = liftIO $ do + src <- resolveHandle (fileHandle file) + void $ wlEventSourceFdUpdate src (fromFileEventMask events) + +-- | Unregister a file message source and stop it from dispatching any more messages. +unregisterFileSource :: FileSource -> DisplayM s () +unregisterFileSource file = liftIO $ do + _ <- resolveHandle (fileHandle file) >>= wlEventSourceRemove + invalidateHandle (fileHandle file) + freeHaskellFunPtr (fileFunc file) + +fromFileEventMask :: FileEventMask -> Word32 +fromFileEventMask events = conditionalMask wlEventReadable (fileEventReadable events) + $ conditionalMask wlEventWritable (fileEventWritable events) + $ conditionalMask wlEventHangup (fileEventHangup events) + $ conditionalMask wlEventError (fileEventError events) 0 + where conditionalMask mask enabled x = if enabled then x .|. mask else x + +toFileEventMask :: Word32 -> FileEventMask +toFileEventMask bits = FileEventMask { fileEventReadable = testMask wlEventReadable + , fileEventWritable = testMask wlEventWritable + , fileEventHangup = testMask wlEventHangup + , fileEventError = testMask wlEventError + } + where testMask mask = (bits .&. mask) /= 0 |