From 5b086e236ab3903a717dfac115bebc6e5d006c07 Mon Sep 17 00:00:00 2001 From: Hannes Schulze Date: Tue, 6 Aug 2024 16:32:17 +0200 Subject: refactor Wayland.Server.System --- wayland/Wayland/Server.hs | 60 ++++---- wayland/Wayland/Server/System.hsc | 297 +++++++++++++++++++++----------------- 2 files changed, 202 insertions(+), 155 deletions(-) (limited to 'wayland/Wayland') diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs index 89a9780..30300de 100644 --- a/wayland/Wayland/Server.hs +++ b/wayland/Wayland/Server.hs @@ -45,7 +45,7 @@ import qualified Wayland.Server.System as Sys import Control.Monad.Trans (MonadTrans(..)) import Foreign.C (peekCString, newCString, withCString) import Foreign.C.Types (CInt) -import Foreign (Ptr, nullPtr, new, newStablePtr, castStablePtrToPtr, castPtrToStablePtr, deRefStablePtr, freeStablePtr, Storable(..), Int32, castPtr, withArray, with, allocaArray0) +import Foreign (Ptr, nullPtr, new, newStablePtr, castStablePtrToPtr, castPtrToStablePtr, deRefStablePtr, freeStablePtr, Storable(..), Int32, castPtr, withArray, with, allocaArray0, FunPtr, plusPtr) import Data.IORef (IORef, newIORef, writeIORef, readIORef) import Control.Monad.Reader (ReaderT, MonadReader(..), runReaderT) import Control.Exception (bracket) @@ -57,10 +57,13 @@ import Foreign.Marshal (newArray) import Data.Word (Word32) import System.Mem.StableName (StableName, makeStableName) import Data.Hashable (Hashable(..)) -import Foreign.Ptr (plusPtr) import Control.Monad.Cont (ContT(..)) -data Global = Global +data EventSource = EventSource (FunPtr Sys.WLEventLoopSignalFunc) (IORef Sys.WLEventSource) + deriving (Eq) + +data Global = Global (FunPtr Sys.WLGlobalBindFunc) (IORef Sys.WLGlobal) + deriving (Eq) -- IORef set to nullPtr once destroyed. data ObjectID = ObjectID (StableName (IORef Sys.WLResource)) (IORef Sys.WLResource) @@ -246,18 +249,17 @@ registerGlobal mkBindReq mkUnbindReq version = do handlePtr <- newStablePtr objID dis <- Sys.wrapWLDispatcherFunc dispatcher des <- Sys.wrapWLResourceDestroyFunc destroy - -- TODO: Free functions + -- TODO: Free dis and des Sys.wlResourceSetDispatcher res dis nullPtr (castStablePtrToPtr handlePtr) des let req = mkBindReq (fromID objID) runRequest disp (Request req) pure () liftIO $ do func <- Sys.wrapWLGlobalBindFunc createObject - _ <- Sys.wlGlobalCreate (display disp) iface (fromIntegral version) nullPtr func + global <- Sys.wlGlobalCreate (display disp) iface (fromIntegral version) nullPtr func + globalRef <- newIORef global -- TODO: Free func - -- TODO: Return proper Global - pure () - pure Global + pure $ Global func globalRef unregisterGlobal :: Global -> DisplayM s () unregisterGlobal _ = pure () @@ -269,16 +271,16 @@ runRequest disp r = do Just handler -> handleEvent handler r Nothing -> putStrLn $ "Lost request because no event loop is active: " ++ show r -registerSignalEvent :: RequestClass req => req -> CInt -> DisplayM s () +registerSignalEvent :: RequestClass req => req -> CInt -> DisplayM s EventSource registerSignalEvent r sig = do disp <- getDisplay liftIO $ do loop <- Sys.wlDisplayGetEventLoop (display disp) func <- Sys.wrapWLEventLoopSignalFunc $ \_ _ -> runRequest disp (Request r) $> 0 - _ <- Sys.wlEventLoopAddSignal loop sig func nullPtr + src <- Sys.wlEventLoopAddSignal loop sig func nullPtr + srcRef <- newIORef src -- TODO: Free func - -- TODO: Return event source handle - pure () + pure $ EventSource func srcRef requestTermination :: DisplayM s () requestTermination = do @@ -358,32 +360,40 @@ advanceIterator = do when (remaining == 0) (fail "Out of range for argument") pure next -getObjectForHandle :: ResourceClass r => r -> IO (Ptr a) +getObjectForHandle :: ResourceClass r => r -> IO Sys.WLResource getObjectForHandle r = fetch (objectID r) where fetch (ObjectID _ handle) = readIORef handle >>= check - check (Sys.WLResource ptr) | ptr == nullPtr = fail "Invalid object handle." - | otherwise = pure (castPtr ptr) + check res@(Sys.WLResource ptr) | ptr == nullPtr = fail "Invalid object handle." + | otherwise = pure res liftCont :: ((a -> IO r) -> IO r) -> ArgumentIterator r a liftCont = ArgumentIterator . lift . ContT instance ArgumentMarshaller (ArgumentIterator r) where - marshalInt v = advanceIterator >>= (liftIO . Sys.wlArgumentSetInt (fromIntegral v)) - marshalUInt v = advanceIterator >>= (liftIO . Sys.wlArgumentSetUInt (fromIntegral v)) - marshalFixed v = advanceIterator >>= (liftIO . Sys.wlArgumentSetFixed (Sys.WLFixed (round (v * 256)))) - marshalFD v = advanceIterator >>= (liftIO . Sys.wlArgumentSetFD (fromIntegral v)) + marshalInt v = do + arg <- advanceIterator + liftIO $ Sys.wlArgumentPokeInt arg (fromIntegral v) + marshalUInt v = do + arg <- advanceIterator + liftIO $ Sys.wlArgumentPokeUInt arg (fromIntegral v) + marshalFixed v = do + arg <- advanceIterator + liftIO $ Sys.wlArgumentPokeFixed arg (Sys.WLFixed (round (v * 256))) + marshalFD v = do + arg <- advanceIterator + liftIO $ Sys.wlArgumentPokeFD arg (fromIntegral v) marshalString v = do arg <- advanceIterator str <- liftCont $ withCString v - liftIO $ Sys.wlArgumentSetString str arg + liftIO $ Sys.wlArgumentPokeString arg str marshalObject v = do arg <- advanceIterator obj <- liftIO $ getObjectForHandle v - liftIO $ Sys.wlArgumentSetObject obj arg + liftIO $ Sys.wlArgumentPokeObject arg obj marshalNewID v = do arg <- advanceIterator obj <- liftIO $ getObjectForHandle v - liftIO $ Sys.wlArgumentSetObject obj arg + liftIO $ Sys.wlArgumentPokeObject arg obj marshalArray v = do arg <- advanceIterator let len = fromIntegral $ length v * sizeOf (head v) @@ -392,7 +402,7 @@ instance ArgumentMarshaller (ArgumentIterator r) where , Sys.arrAlloc = len , Sys.arrData = castPtr buf } - liftIO $ Sys.wlArgumentSetArray arr arg + liftIO $ Sys.wlArgumentPokeArray arg arr sendEvent :: forall r s. ResourceClass r => r -> ResourceEvent r -> DisplayM s () sendEvent res e = liftIO $ do @@ -402,7 +412,7 @@ sendEvent res e = liftIO $ do let s = ArgumentIteratorState { _argNext = buffer , _argRemaining = length params } - handler (opcode, _) = Sys.wlResourcePostEventArray (Sys.WLResource ptr) (fromIntegral opcode) buffer + handler (opcode, _) = Sys.wlResourcePostEventArray ptr (fromIntegral opcode) buffer in runContT (runStateT (runArgumentIterator (marshalEvent (Proxy :: Proxy r) e)) s) handler flushEvents :: DisplayM s () @@ -413,4 +423,4 @@ flushEvents = do destroyResource :: ResourceClass r => r -> DisplayM s () destroyResource r = liftIO $ do ptr <- getObjectForHandle r - Sys.wlResourceDestroy (Sys.WLResource ptr) + Sys.wlResourceDestroy ptr diff --git a/wayland/Wayland/Server/System.hsc b/wayland/Wayland/Server/System.hsc index 0f68578..b01611e 100644 --- a/wayland/Wayland/Server/System.hsc +++ b/wayland/Wayland/Server/System.hsc @@ -1,49 +1,24 @@ {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : Wayland.Server.System +-- Description: Bindings for the system-provided libwayland library. +-- +-- libwayland is used to handle socket creation, implementing the protocol, and the event loop. We do not use the +-- interfaces or bindings provided by it but only its primitives like wl_resource in combination with our own code +-- generator which generates the interfaces and (de-)marshals all arguments and opcodes. This is done to keep the amount +-- of C interop small. module Wayland.Server.System where #include -import Foreign (FunPtr, Ptr, Storable(..), Int32, castPtr) -import Foreign.C (CString, CInt(..), CSize) +import Foreign (FunPtr, Ptr, Int32, Storable(..), castPtr) +import Foreign.C (CString, CSize, CInt(..)) import Data.Word (Word32) -data WLMessage - = WLMessage { msgName :: CString - , msgSignature :: CString - , msgTypes :: Ptr (Ptr WLInterface) - } - deriving (Show) - -data WLInterface - = WLInterface { ifName :: CString - , ifVersion :: CInt - , ifMethodCount :: CInt - , ifMethods :: Ptr WLMessage - , ifEventCount :: CInt - , ifEvents :: Ptr WLMessage - } - deriving (Show) - -newtype WLFixed = WLFixed #{type wl_fixed_t} - deriving (Show) - -data WLArray - = WLArray { arrSize :: CSize - , arrAlloc :: CSize - , arrData :: Ptr () - } - deriving (Show) - -data WLArgument = WLArgument - deriving (Show) - -newtype WLDisplay = WLDisplay (Ptr WLDisplay) deriving (Show) -newtype WLEventLoop = WLEventLoop (Ptr WLEventLoop) deriving (Show) -newtype WLEventSource = WLEventSource (Ptr WLEventSource) deriving (Show) -newtype WLGlobal = WLGlobal (Ptr WLGlobal) deriving (Show) -newtype WLClient = WLClient (Ptr WLClient) deriving (Show) -newtype WLResource = WLResource (Ptr WLResource) deriving (Show) +-- * Callback Types type WLEventLoopSignalFunc = CInt -> Ptr () -> IO CInt type WLGlobalBindFunc = WLClient -> Ptr () -> Word32 -> Word32 -> IO () @@ -62,95 +37,16 @@ foreign import ccall "wrapper" foreign import ccall "wrapper" wrapWLResourceDestroyFunc :: WLResourceDestroyFunc -> IO (FunPtr WLResourceDestroyFunc) -foreign import ccall "wl_display_create" - wlDisplayCreate :: IO WLDisplay +-- * Primitive Types -foreign import ccall "wl_display_destroy" - wlDisplayDestroy :: WLDisplay -> IO () +-- ** wl_message -foreign import ccall "wl_display_flush_clients" - wlDisplayFlushClients :: WLDisplay -> IO () - -foreign import ccall "wl_display_add_socket_auto" - wlDisplayAddSocketAuto :: WLDisplay -> IO CString - -foreign import ccall "wl_display_run" - wlDisplayRun :: WLDisplay -> IO () - -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 - -foreign import ccall "wl_global_create" - wlGlobalCreate :: WLDisplay -> Ptr WLInterface -> CInt -> Ptr () -> FunPtr WLGlobalBindFunc -> IO WLGlobal - -foreign import ccall "wl_resource_create" - wlResourceCreate :: WLClient -> Ptr WLInterface -> CInt -> Word32 -> IO WLResource - -foreign import ccall "wl_resource_set_dispatcher" - wlResourceSetDispatcher :: WLResource -> FunPtr WLDispatcherFunc -> Ptr () -> Ptr () -> FunPtr WLResourceDestroyFunc -> IO () - -foreign import ccall "wl_resource_get_user_data" - wlResourceGetUserData :: WLResource -> IO (Ptr ()) - -foreign import ccall "wl_resource_post_event_array" - wlResourcePostEventArray :: WLResource -> Word32 -> Ptr WLArgument -> IO () - -foreign import ccall "wl_resource_destroy" - wlResourceDestroy :: WLResource -> IO () - -wlArgumentGetInt :: Ptr WLArgument -> IO Int32 -wlArgumentGetInt = #{peek union wl_argument, i} - -wlArgumentGetUInt :: Ptr WLArgument -> IO Word32 -wlArgumentGetUInt = #{peek union wl_argument, u} - -wlArgumentGetFixed :: Ptr WLArgument -> IO WLFixed -wlArgumentGetFixed = #{peek union wl_argument, f} - -wlArgumentGetString :: Ptr WLArgument -> IO CString -wlArgumentGetString = #{peek union wl_argument, s} - -wlArgumentGetObject :: Ptr WLArgument -> IO (Ptr ()) -wlArgumentGetObject = #{peek union wl_argument, o} - -wlArgumentGetNewID :: Ptr WLArgument -> IO Word32 -wlArgumentGetNewID = #{peek union wl_argument, n} - -wlArgumentGetArray :: Ptr WLArgument -> IO (Ptr WLArray) -wlArgumentGetArray = #{peek union wl_argument, a} - -wlArgumentGetFD :: Ptr WLArgument -> IO Int32 -wlArgumentGetFD = #{peek union wl_argument, h} - -wlArgumentSetInt :: Int32 -> Ptr WLArgument -> IO () -wlArgumentSetInt v p = #{poke union wl_argument, i} p v - -wlArgumentSetUInt :: Word32 -> Ptr WLArgument -> IO () -wlArgumentSetUInt v p = #{poke union wl_argument, u} p v - -wlArgumentSetFixed :: WLFixed -> Ptr WLArgument -> IO () -wlArgumentSetFixed v p = #{poke union wl_argument, f} p v - -wlArgumentSetString :: CString -> Ptr WLArgument -> IO () -wlArgumentSetString v p = #{poke union wl_argument, s} p v - -wlArgumentSetObject :: Ptr () -> Ptr WLArgument -> IO () -wlArgumentSetObject v p = #{poke union wl_argument, o} p v - -wlArgumentSetNewID :: Word32 -> Ptr WLArgument -> IO () -wlArgumentSetNewID v p = #{poke union wl_argument, n} p v - -wlArgumentSetArray :: Ptr WLArray -> Ptr WLArgument -> IO () -wlArgumentSetArray v p = #{poke union wl_argument, a} p v - -wlArgumentSetFD :: Int32 -> Ptr WLArgument -> IO () -wlArgumentSetFD v p = #{poke union wl_argument, h} p v +data WLMessage + = WLMessage { msgName :: CString + , msgSignature :: CString + , msgTypes :: Ptr (Ptr WLInterface) + } + deriving (Show) instance Storable WLMessage where sizeOf _ = #{size struct wl_message} @@ -169,6 +65,18 @@ instance Storable WLMessage where #{poke struct wl_message, types} p $ msgTypes m return () +-- ** wl_interface + +data WLInterface + = WLInterface { ifName :: CString + , ifVersion :: CInt + , ifMethodCount :: CInt + , ifMethods :: Ptr WLMessage + , ifEventCount :: CInt + , ifEvents :: Ptr WLMessage + } + deriving (Show) + instance Storable WLInterface where sizeOf _ = #{size struct wl_interface} alignment _ = #{alignment struct wl_interface} @@ -195,6 +103,26 @@ instance Storable WLInterface where #{poke struct wl_interface, events} p $ ifEvents m return () +-- ** wl_fixed + +newtype WLFixed = WLFixed #{type wl_fixed_t} + deriving (Show) + +instance Storable WLFixed where + sizeOf _ = sizeOf (undefined :: #{type wl_fixed_t}) + alignment _ = alignment (undefined :: #{type wl_fixed_t}) + peek p = WLFixed <$> peek (castPtr p) + poke p (WLFixed v) = poke (castPtr p) v + +-- ** wl_array + +data WLArray + = WLArray { arrSize :: CSize + , arrAlloc :: CSize + , arrData :: Ptr () + } + deriving (Show) + instance Storable WLArray where sizeOf _ = #{size struct wl_array} alignment _ = #{alignment struct wl_array} @@ -212,14 +140,123 @@ instance Storable WLArray where #{poke struct wl_array, data} p $ arrData m return () -instance Storable WLFixed where - sizeOf _ = sizeOf (undefined :: #{type wl_fixed_t}) - alignment _ = alignment (undefined :: #{type wl_fixed_t}) - peek p = WLFixed <$> peek (castPtr p) - poke p (WLFixed v) = poke (castPtr p) v +-- ** wl_argument + +-- Accessed through the wlArgumentPeek* and wlArgumentPoke* methods as the actual data type is unknown just from looking +-- at the union. +data WLArgument = WLArgument + deriving (Show) instance Storable WLArgument where sizeOf _ = #{size union wl_argument} alignment _ = #{alignment union wl_argument} peek _ = pure WLArgument poke _ _ = pure () + +wlArgumentPeekInt :: Ptr WLArgument -> IO Int32 +wlArgumentPeekInt = #{peek union wl_argument, i} +wlArgumentPeekUInt :: Ptr WLArgument -> IO Word32 +wlArgumentPeekUInt = #{peek union wl_argument, u} +wlArgumentPeekFixed :: Ptr WLArgument -> IO WLFixed +wlArgumentPeekFixed = #{peek union wl_argument, f} +wlArgumentPeekString :: Ptr WLArgument -> IO CString +wlArgumentPeekString = #{peek union wl_argument, s} +wlArgumentPeekObject :: Ptr WLArgument -> IO WLResource +wlArgumentPeekObject = #{peek union wl_argument, o} +wlArgumentPeekNewID :: Ptr WLArgument -> IO Word32 +wlArgumentPeekNewID = #{peek union wl_argument, n} +wlArgumentPeekArray :: Ptr WLArgument -> IO (Ptr WLArray) +wlArgumentPeekArray = #{peek union wl_argument, a} +wlArgumentPeekFD :: Ptr WLArgument -> IO Int32 +wlArgumentPeekFD = #{peek union wl_argument, h} + +wlArgumentPokeInt :: Ptr WLArgument -> Int32 -> IO () +wlArgumentPokeInt = #{poke union wl_argument, i} +wlArgumentPokeUInt :: Ptr WLArgument -> Word32 -> IO () +wlArgumentPokeUInt = #{poke union wl_argument, u} +wlArgumentPokeFixed :: Ptr WLArgument -> WLFixed -> IO () +wlArgumentPokeFixed = #{poke union wl_argument, f} +wlArgumentPokeString :: Ptr WLArgument -> CString -> IO () +wlArgumentPokeString = #{poke union wl_argument, s} +wlArgumentPokeObject :: Ptr WLArgument -> WLResource -> IO () +wlArgumentPokeObject = #{poke union wl_argument, o} +wlArgumentPokeNewID :: Ptr WLArgument -> Word32 -> IO () +wlArgumentPokeNewID = #{poke union wl_argument, n} +wlArgumentPokeArray :: Ptr WLArgument -> Ptr WLArray -> IO () +wlArgumentPokeArray = #{poke union wl_argument, a} +wlArgumentPokeFD :: Ptr WLArgument -> Int32 -> IO () +wlArgumentPokeFD = #{poke union wl_argument, h} + +-- * Opaque Types + +-- ** wl_display + +newtype WLDisplay = WLDisplay (Ptr WLDisplay) + deriving (Show, Eq, Storable) + +foreign import ccall "wl_display_create" + wlDisplayCreate :: IO WLDisplay + +foreign import ccall "wl_display_destroy" + wlDisplayDestroy :: WLDisplay -> IO () + +foreign import ccall "wl_display_flush_clients" + wlDisplayFlushClients :: WLDisplay -> IO () + +foreign import ccall "wl_display_add_socket_auto" + wlDisplayAddSocketAuto :: WLDisplay -> IO CString + +foreign import ccall "wl_display_run" + wlDisplayRun :: WLDisplay -> IO () + +foreign import ccall "wl_display_terminate" + wlDisplayTerminate :: WLDisplay -> IO () + +foreign import ccall "wl_display_get_event_loop" + wlDisplayGetEventLoop :: WLDisplay -> IO WLEventLoop + +-- ** wl_event_loop + +newtype WLEventLoop = WLEventLoop (Ptr WLEventLoop) + deriving (Show, Eq, Storable) + +foreign import ccall "wl_event_loop_add_signal" + wlEventLoopAddSignal :: WLEventLoop -> CInt -> FunPtr WLEventLoopSignalFunc -> Ptr () -> IO WLEventSource + +-- ** wl_event_source + +newtype WLEventSource = WLEventSource (Ptr WLEventSource) + deriving (Show, Eq, Storable) + +-- ** wl_global + +newtype WLGlobal = WLGlobal (Ptr WLGlobal) + deriving (Show, Eq, Storable) + +foreign import ccall "wl_global_create" + wlGlobalCreate :: WLDisplay -> Ptr WLInterface -> CInt -> Ptr () -> FunPtr WLGlobalBindFunc -> IO WLGlobal + +-- ** wl_client + +newtype WLClient = WLClient (Ptr WLClient) + deriving (Show, Eq, Storable) + +-- ** wl_resource + +newtype WLResource = WLResource (Ptr WLResource) + deriving (Show, Eq, Storable) + +foreign import ccall "wl_resource_create" + wlResourceCreate :: WLClient -> Ptr WLInterface -> CInt -> Word32 -> IO WLResource + +foreign import ccall "wl_resource_set_dispatcher" + wlResourceSetDispatcher :: WLResource -> FunPtr WLDispatcherFunc -> Ptr () -> Ptr () -> FunPtr WLResourceDestroyFunc -> IO () + +foreign import ccall "wl_resource_get_user_data" + wlResourceGetUserData :: WLResource -> IO (Ptr ()) + +foreign import ccall "wl_resource_post_event_array" + wlResourcePostEventArray :: WLResource -> Word32 -> Ptr WLArgument -> IO () + +foreign import ccall "wl_resource_destroy" + wlResourceDestroy :: WLResource -> IO () -- cgit v1.3.1