From 0e1add6fae63eb51c5f73caf4dd42838ec955a86 Mon Sep 17 00:00:00 2001 From: Hannes Schulze Date: Sun, 4 Aug 2024 17:31:56 +0200 Subject: implement signal handling --- wayland/Wayland/Server.hs | 91 ++++++++++++++++++++++++++++++--------- wayland/Wayland/Server/System.hsc | 30 +++++++------ 2 files changed, 88 insertions(+), 33 deletions(-) (limited to 'wayland/Wayland') diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs index 0b0b6ea..76b9ff4 100644 --- a/wayland/Wayland/Server.hs +++ b/wayland/Wayland/Server.hs @@ -11,6 +11,7 @@ module Wayland.Server , Global , DisplayM(..) , ResourceClass(..) + , RequestClass , InterfaceDesc(..) , MessageDesc(..) , ArgumentDesc(..) @@ -24,19 +25,31 @@ module Wayland.Server , destroyResource , registerGlobal , unregisterGlobal + , registerSignalEvent + , requestTermination ) where import Data.Typeable (Typeable, Proxy, cast) import Data.Kind (Type) -import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..), runStateT, gets) +import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..), runStateT) import Lens.Micro.Mtl.Internal (Zoom(..), Zoomed) import Wayland.Server.System import Control.Monad.Trans (MonadTrans(..)) import Foreign.C (peekCString) +import Foreign.C.Types (CInt) +import Foreign (nullPtr) +import Data.IORef (IORef, newIORef, writeIORef, readIORef) +import Control.Monad.Reader (ReaderT, MonadReader (..), runReaderT) +import Control.Exception (bracket) +import Data.Functor (($>)) -data DisplayState - = DisplayState { display :: WLDisplay - } +type RequestHandler s = Request -> DisplayM s () +type EventLoopHandler = Request -> IO () + +data Display + = Display { display :: !WLDisplay + , activeEventLoop :: !(IORef (Maybe EventLoopHandler)) + } data Global = Global @@ -79,37 +92,55 @@ class ResourceClass r where objectID :: r -> ObjectID interface :: Proxy r -> InterfaceDesc -data Request = forall a. Typeable a => Request a +class (Typeable r, Show r) => RequestClass r where + +data Request = forall a. RequestClass a => Request a + +instance Show Request where + show (Request r) = show r -newtype DisplayM s a = DisplayM { runDisplayM :: StateT s (StateT DisplayState IO) a } +newtype DisplayM s a = DisplayM { runDisplayM :: StateT s (ReaderT Display IO) a } deriving (Functor, Applicative, Monad, MonadIO, MonadState s) -type instance Zoomed (DisplayM s) = Zoomed (StateT s (StateT DisplayState IO)) +type instance Zoomed (DisplayM s) = Zoomed (StateT s (ReaderT Display IO)) instance Zoom (DisplayM s) (DisplayM t) s t where zoom l (DisplayM m) = DisplayM (zoom l m) +getDisplay :: DisplayM s Display +getDisplay = DisplayM $ lift ask + fromRequest :: Typeable a => Request -> Maybe a fromRequest (Request x) = cast x withDisplay :: s -> DisplayM s a -> IO (a, s) -withDisplay initialState f = do - disp <- wlDisplayCreate - let dispState = DisplayState { display = disp } - (res, _) <-runStateT (runStateT (runDisplayM f) initialState) dispState - wlDisplayDestroy disp - return res +withDisplay initialState f = bracket wlDisplayCreate wlDisplayDestroy $ \sysDisp -> do + eventLoop <- newIORef Nothing + let disp = Display { display = sysDisp + , activeEventLoop = eventLoop } + runReaderT (runStateT (runDisplayM f) initialState) disp bindSocket :: DisplayM s String bindSocket = do - disp <- DisplayM $ lift $ gets display - name <- liftIO $ wlDisplayAddSocketAuto disp + disp <- getDisplay + name <- liftIO $ wlDisplayAddSocketAuto (display disp) liftIO $ peekCString name -processRequests :: (Request -> DisplayM s ()) -> DisplayM s () -processRequests _ = do - disp <- DisplayM $ lift $ gets display - liftIO $ wlDisplayRun disp +processRequests :: RequestHandler s -> DisplayM s () +processRequests h = do + disp <- getDisplay + stateBefore <- get + stateRef <- liftIO $ newIORef stateBefore + let handler :: Request -> IO () + handler r = do + s <- readIORef stateRef + (_, s') <- runReaderT (runStateT (runDisplayM (h r)) s) disp + writeIORef stateRef s' + pure () + liftIO $ writeIORef (activeEventLoop disp) (Just handler) + liftIO $ wlDisplayRun (display disp) + stateAfter <- liftIO $ readIORef stateRef + put stateAfter sendEvent :: ResourceClass r => r -> ResourceEvent r -> DisplayM s () sendEvent _ _ = undefined @@ -120,8 +151,28 @@ flushEvents = undefined destroyResource :: ResourceClass r => r -> DisplayM s () destroyResource _ = undefined -registerGlobal :: ResourceClass r => Typeable req => (r -> req) -> DisplayM s Global +registerGlobal :: ResourceClass r => RequestClass req => (r -> req) -> DisplayM s Global registerGlobal _ = pure Global unregisterGlobal :: Global -> DisplayM s () unregisterGlobal _ = pure () + +runRequest :: Display -> Request -> IO () +runRequest disp r = do + loop <- readIORef (activeEventLoop disp) + case loop of + Just handler -> handler r + Nothing -> putStrLn $ "Lost request because no event loop is active: " ++ show r + +registerSignalEvent :: RequestClass req => req -> CInt -> DisplayM s () +registerSignalEvent r sig = do + disp <- getDisplay + loop <- liftIO $ wlDisplayGetEventLoop (display disp) + func <- liftIO $ wrapWLEventLoopSignalFunc $ \_ _ -> runRequest disp (Request r) $> 0 + _ <- liftIO $ wlEventLoopAddSignal loop sig func nullPtr + pure () + +requestTermination :: DisplayM s () +requestTermination = do + disp <- getDisplay + liftIO $ wlDisplayTerminate (display disp) diff --git a/wayland/Wayland/Server/System.hsc b/wayland/Wayland/Server/System.hsc index d86f59a..60940ce 100644 --- a/wayland/Wayland/Server/System.hsc +++ b/wayland/Wayland/Server/System.hsc @@ -1,20 +1,11 @@ {-# LANGUAGE ForeignFunctionInterface #-} -module Wayland.Server.System - ( WLMessage(..) - , WLInterface(..) - , WLDisplay(WLDisplay) - , wlDisplayCreate - , wlDisplayDestroy - , wlDisplayAddSocketAuto - , wlDisplayRun - , wlDisplayTerminate - ) where +module Wayland.Server.System where #include -import Foreign (Ptr, Storable(..)) -import Foreign.C (CString, CInt) +import Foreign (FunPtr, Ptr, Storable(..)) +import Foreign.C (CString, CInt(..)) data WLMessage = WLMessage { msgName :: CString @@ -31,7 +22,14 @@ data WLInterface , ifEvents :: Ptr WLMessage } -newtype WLDisplay = WLDisplay (Ptr WLDisplay) +newtype WLDisplay = WLDisplay (Ptr WLDisplay) +newtype WLEventLoop = WLEventLoop (Ptr WLEventLoop) +newtype WLEventSource = WLEventSource (Ptr WLEventSource) + +type WLEventLoopSignalFunc = CInt -> Ptr () -> IO CInt + +foreign import ccall "wrapper" + wrapWLEventLoopSignalFunc :: WLEventLoopSignalFunc -> IO (FunPtr WLEventLoopSignalFunc) foreign import ccall "wl_display_create" wlDisplayCreate :: IO WLDisplay @@ -48,6 +46,12 @@ foreign import ccall "wl_display_run" foreign import ccall "wl_display_terminate" wlDisplayTerminate :: WLDisplay -> IO () +foreign import ccall "wl_display_get_event_loop" + wlDisplayGetEventLoop :: WLDisplay -> IO WLEventLoop + +foreign import ccall "wl_event_loop_add_signal" + wlEventLoopAddSignal :: WLEventLoop -> CInt -> FunPtr WLEventLoopSignalFunc -> Ptr () -> IO WLEventSource + instance Storable WLMessage where sizeOf _ = #{size struct wl_message} alignment _ = #{alignment struct wl_message} -- cgit v1.3.1