From 539930f228d9dda1fe3462e5a6d913061dc6a652 Mon Sep 17 00:00:00 2001 From: Hannes Schulze Date: Thu, 8 Aug 2024 18:47:02 +0200 Subject: finish implementing wayland server api --- wayland/Wayland/Server/Object.hs | 201 ++++++++++++++++++--------------------- 1 file changed, 94 insertions(+), 107 deletions(-) (limited to 'wayland/Wayland/Server/Object.hs') diff --git a/wayland/Wayland/Server/Object.hs b/wayland/Wayland/Server/Object.hs index 1437cc9..b56bbaf 100644 --- a/wayland/Wayland/Server/Object.hs +++ b/wayland/Wayland/Server/Object.hs @@ -21,8 +21,6 @@ module Wayland.Server.Object , createNewObject , RequestClass , EventClass - , Request(..) - , fromRequest , ArgumentMarshaller(..) , ArgumentDemarshaller(..) , -- * State @@ -38,23 +36,24 @@ module Wayland.Server.Object , sendResourceEvent ) where -import System.Mem.StableName (makeStableName, StableName) +import System.Posix.Types (Fd(..)) import Data.Kind (Type) import Data.Hashable (Hashable(..)) -import Data.IORef (readIORef, newIORef, writeIORef, IORef) -import Data.Typeable (Proxy(..), TypeRep, typeRep, Typeable, cast) +import Data.IORef (readIORef, newIORef, IORef, writeIORef) +import Data.Typeable (Proxy(..), TypeRep, typeRep, Typeable) import Foreign import Foreign.C (withCString, peekCString, CInt) -import Lens.Micro.Mtl ((<<%=), use, (%=), zoom) +import Lens.Micro.Mtl (use, (%=), zoom) import Lens.Micro.TH (makeLenses) -import Control.Monad.State.Strict (StateT(..), MonadState) +import Control.Monad.State.Strict (StateT(..), MonadState(..)) import Control.Monad.Cont (ContT(..)) import Control.Monad.Trans (MonadIO(..), MonadTrans(..)) -import Control.Monad (when) +import Control.Monad.Reader (ReaderT (..), MonadReader(..)) import Wayland.Server.System -import Wayland.Server.Interface (MessageDesc(..), InterfaceDesc, InterfaceCache, newInterfaceCache, destroyInterfaceCache, resolveInterface) +import Wayland.Server.Interface (MessageDesc(..), InterfaceDesc(..), InterfaceCache, newInterfaceCache, destroyInterfaceCache, resolveInterface) +import Wayland.Server.Client (Client, unwrapClient, wrapClient) +import Wayland.Server.Types (Handle, invalidateHandle, resolveHandle, createHandle, MessageClass, Message(..)) import qualified Data.Map as M -import Wayland.Server.Client (Client, unwrapClient) -- | The primary data type for typed object handles. -- @@ -100,18 +99,14 @@ class (Typeable o, RequestClass (ObjectRequest o), EventClass (ObjectEvent o)) = -- | A request for an object sent by a client. -- --- The request usually includes the object it is referring to, as well as arguments provided by the client. --- --- The request's type is erased and it is then processed by the display's event loop. -class (Typeable r, Show r) => RequestClass r where +-- The request usually includes the object it is referring to, as well as arguments provided by the client. It is +-- processed as part of the server's message loop. +class MessageClass r => RequestClass r where -- | An event that can be emitted on an object by the server. -- -- The event stores the arguments passed to the client. -class (Typeable e, Show e) => EventClass e where - --- | A type-erased request. -data Request = forall r. RequestClass r => Request r +class MessageClass e => EventClass e where -- | A monad providing an environment for marshalling a fixed number of arguments of various types. -- @@ -125,7 +120,7 @@ class Monad m => ArgumentMarshaller m where marshalObject :: Object o => o -> m () marshalNewID :: Object o => NewObject o -> m () marshalArray :: Storable a => [a] -> m () - marshalFD :: Int32 -> m () + marshalFD :: Fd -> m () -- | A monad providing an environment for reading a fixed number of arguments of various types. -- @@ -139,28 +134,25 @@ class Monad m => ArgumentDemarshaller m where demarshalObject :: Object o => m o demarshalNewID :: Object o => m (NewObject o) demarshalArray :: Storable a => m [a] - demarshalFD :: m Int32 + demarshalFD :: m Fd -- | An opaque handle to a Wayland object. -- -- The handle remains valid and can be used for equality checks even after the underlying libwayland resource was --- destroyed. This is realized using an IORef which is set to nullPtr once the resource is destroyed. The IORef itself --- is used for equality checks. +-- destroyed. However, actions using the object (like sending events to it) will fail. -- -- In addition, a custom type-erased cleanup action is stored which is invoked once the resource is destroyed. data AnyObject - = AnyObject { objName :: StableName (IORef WLResource) -- ^ Name used for hashing and ordering. - , objResource :: IORef WLResource -- ^ Reference to the underlying resource. - , objDestroyHook :: AnyObject -> IO () -- ^ Function executed after the object was destroyed. + = AnyObject { objHandle :: Handle WLResource -- ^ The underlying resource. + , objDestroyHook :: AnyObject -> IO () -- ^ Function executed after the object was destroyed. } -- | Handle to an object which has not yet been created but has an ID assigned by the client. -- --- This handle can be used to create an object. +-- This handle can be used to create an object. It is a programmer error to use it more than once. data NewObject o = NewObject { newClient :: !Client -- ^ The client this object is associated with. , newID :: !Word32 -- ^ Object ID of the new object. - , newVersion :: !CInt -- ^ Protocol version to use for the newly created object. , newObject :: !(IORef (Maybe o)) -- ^ Reference to the object, assigned when it is created. } @@ -180,51 +172,42 @@ data ObjectCache -- | A state monad providing an instance of 'ObjectCache'. type ObjectCacheState = StateT ObjectCache IO --- | State used when iterating over a fixed number of wl_arguments. -data ArgumentIterator - = ArgumentIterator { _argNext :: !(Ptr WLArgument) -- ^ Pointer to the next argument to be processed. - , _argRemaining :: !Int -- ^ Number of remaining arguments in the list. - } +-- | State used when iterating over a buffer of wl_arguments. +newtype ArgumentIterator = ArgumentIterator (Ptr WLArgument) --- | A state monad providing an instance of 'ArgumentIterator'. +-- | Monad used for writing arguments into a wl_argument buffer. -- -- The monad wraps a ContT monad to allow using alloca when wrapping arguments. -newtype ArgumentIteratorState r a - = ArgumentIteratorState { runArgumentIteratorState :: StateT ArgumentIterator (ContT r IO) a } +newtype ArgumentWriter r a = ArgumentWriter { runArgumentWriter :: StateT ArgumentIterator (ContT r IO) a } deriving (Functor, Applicative, Monad, MonadState ArgumentIterator, MonadIO) -makeLenses ''ObjectCache -makeLenses ''ArgumentIterator +-- | Monad used for reading arguments from a wl_argument buffer. +newtype ArgumentReader a = ArgumentReader { runArgumentReader :: StateT ArgumentIterator (ReaderT Client IO) a } + deriving (Functor, Applicative, Monad, MonadState ArgumentIterator, MonadIO, MonadReader Client) -instance Show Request where - show (Request r) = show r - --- | Try to cast a type-erased request into a concrete 'RequestClass'. -fromRequest :: RequestClass a => Request -> Maybe a -fromRequest (Request x) = cast x +makeLenses ''ObjectCache instance Eq AnyObject where - a == b = objResource a == objResource b + a == b = objHandle a == objHandle b instance Ord AnyObject where - a <= b = hash (objName a) <= hash (objName b) + a <= b = objHandle a <= objHandle b instance Hashable AnyObject where - hashWithSalt s o = hashWithSalt s (objName o) + hashWithSalt s o = hashWithSalt s (objHandle o) instance Show AnyObject where - show o = "AnyObject " ++ show (hash (objName o)) + show o = show (objHandle o) instance Show (NewObject o) where show o = "NewObject " ++ show (newClient o) ++ " " ++ show (newID o) -- | Create a handle to an object that has yet to be created. -createNewObject :: Client -> Word32 -> CInt -> IO (NewObject o) -createNewObject client objID version = do +createNewObject :: Client -> Word32 -> IO (NewObject o) +createNewObject client objID = do obj <- newIORef Nothing pure $ NewObject { newClient = client , newID = objID - , newVersion = version , newObject = obj } @@ -251,10 +234,7 @@ destroyObjectCache c = do -- -- This function may raise an error if the underlying resource is no longer alive. unwrapResource :: Object o => o -> IO WLResource -unwrapResource o = fetch (toAny o) - where fetch obj = readIORef (objResource obj) >>= check - check res@(WLResource ptr) | ptr == nullPtr = error "Invalid object handle." - | otherwise = pure res +unwrapResource o = resolveHandle (objHandle (toAny o)) -- | Get the typed object wrapping a Wayland resource. -- @@ -271,39 +251,38 @@ destroyResource :: WLResource -> IO () destroyResource res = do objPtr <- castPtrToStablePtr <$> wlResourceGetUserData res obj <- deRefStablePtr objPtr - writeIORef (objResource obj) (WLResource nullPtr) + invalidateHandle (objHandle obj) freeStablePtr objPtr - -- TODO: Prevent destroy hook from being invoked while in the request handler. objDestroyHook obj obj -- | Create a new Wayland resource and associate it with a typed object wrapper. -- -- This not only creates the object but also attaches a dispatch function to it and updates the destroy callback. createResource - :: forall o destroyReq. Object o - => RequestClass destroyReq - => (Request -> IO ()) -- ^ Request handler used for dispatching object requests and the destroy hook. + :: forall o destroyMsg. Object o + => MessageClass destroyMsg + => (Message -> IO ()) -- ^ Message handler used for dispatching object requests and the destroy hook. -> 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. -> ObjectCacheState o -- ^ State monad returning the newly created object. -createResource handle newObj destroyHook = do +createResource handler newObj destroyHook = do existing <- liftIO $ readIORef (newObject newObj) case existing of - Just obj -> pure obj - Nothing -> do typeInfo <- resolveTypeInfo (Proxy :: Proxy o) - destroyFunc <- use cacheDestroyFunc - liftIO $ do - client <- unwrapClient (newClient newObj) - res <- wlResourceCreate client (typeInterface typeInfo) (newVersion newObj) (newID newObj) - resRef <- newIORef res - name <- makeStableName resRef - let obj = fromAny $ AnyObject { objName = name - , objResource = resRef - , objDestroyHook = handle . Request . destroyHook . fromAny - } - objPtr <- newStablePtr obj - wlResourceSetDispatcher res (typeDispatchFunc typeInfo) nullPtr (castStablePtrToPtr objPtr) destroyFunc - pure obj + Just _ -> error "The NewObject instance was already used to create an object." + Nothing -> do typeInfo <- resolveTypeInfo (Proxy :: Proxy o) handler + destroyFunc <- use cacheDestroyFunc + liftIO $ do + let version = Wayland.Server.Interface.ifVersion (describeInterface (Proxy :: Proxy o)) + client <- unwrapClient (newClient newObj) + res <- wlResourceCreate client (typeInterface typeInfo) (fromIntegral version) (newID newObj) + handle <- createHandle res + let obj = fromAny $ AnyObject { objHandle = handle + , objDestroyHook = handler . Message . destroyHook . fromAny + } + objPtr <- newStablePtr obj + wlResourceSetDispatcher res (typeDispatchFunc typeInfo) nullPtr (castStablePtrToPtr objPtr) destroyFunc + writeIORef (newObject newObj) (Just obj) + pure obj -- | Send an event for a typed object. -- @@ -313,32 +292,36 @@ sendResourceEvent o e = do let paramCount = length $ msgArguments (eventSignature (Proxy :: Proxy o) e) res <- unwrapResource o allocaArray0 paramCount $ \buffer -> - let s = ArgumentIterator { _argNext = buffer - , _argRemaining = paramCount - } - handler (opcode, _) = wlResourcePostEventArray res (fromIntegral opcode) buffer - in runContT (runStateT (runArgumentIteratorState (marshalEvent (Proxy :: Proxy o) e)) s) handler + runContT (runStateT (runArgumentWriter (marshalEvent (Proxy :: Proxy o) e)) (ArgumentIterator buffer)) $ \(opcode, _) -> + wlResourcePostEventArray res (fromIntegral opcode) buffer -- | Request handler for a typed object. -- -- This provides a WLDispatcherFunc for an object type. -dispatchResourceRequest :: forall o. Object o => Proxy o -> Ptr () -> WLResource -> Word32 -> Ptr WLMessage -> Ptr WLArgument -> IO CInt -dispatchResourceRequest _ _ res _ _ _ = do - _ :: o <- wrapResource res - -- TODO: Handle request +dispatchResourceRequest :: forall o. Object o => Proxy o -> (Message -> IO ()) -> Ptr () -> WLResource -> Word32 -> Ptr WLMessage -> Ptr WLArgument -> IO CInt +dispatchResourceRequest _ handler _ res opcode _ args = do + obj :: o <- wrapResource res + client <- wlResourceGetClient res >>= wrapClient + (req, _) <- runReaderT (runStateT (runArgumentReader (demarshalRequest obj (fromIntegral opcode))) (ArgumentIterator args)) client + handler $ Message req pure 0 -- | Resolve a type information for an object type. -- -- This will first attempt to use an existing instance from the 'ObjectCache'. If there is none, it will create a new -- structure storing the wl_interface pointer and allocating a function pointer to the typed dispatcher function. -resolveTypeInfo :: Object o => Proxy o -> ObjectCacheState TypeInfo -resolveTypeInfo proxy = do +resolveTypeInfo + :: Object o + => Proxy o -- ^ Proxy for the object type to resolve. + -> (Message -> IO ()) -- ^ Message handler used to dispatch requests in the type's dispatch func. + -> ObjectCacheState TypeInfo -- ^ State monad wrapping the type information. +resolveTypeInfo proxy handler = do existing <- use cacheTypeInfo case M.lookup (typeRep proxy) existing of Just info -> pure info - Nothing -> do interface <- zoom cacheInterfaces $ resolveInterface (describeInterface proxy) - dispatchFunc <- liftIO $ wrapWLDispatcherFunc (dispatchResourceRequest proxy) + Nothing -> do let desc = describeInterface proxy + interface <- zoom cacheInterfaces $ resolveInterface desc + dispatchFunc <- liftIO $ wrapWLDispatcherFunc (dispatchResourceRequest proxy handler) let info = TypeInfo { typeInterface = interface , typeDispatchFunc = dispatchFunc } @@ -346,24 +329,27 @@ resolveTypeInfo proxy = do pure info -- | Resolve the native interface for an object type. -resolveTypeInterface :: Object o => Proxy o -> ObjectCacheState (Ptr WLInterface) -resolveTypeInterface proxy = typeInterface <$> resolveTypeInfo proxy +resolveTypeInterface + :: Object o + => Proxy o -- ^ Proxy for the object type to resolve. + -> (Message -> IO ()) -- ^ Message handler used to dispatch requests in the type's dispatch func. + -> ObjectCacheState (Ptr WLInterface) -- ^ State monad wrapping the native interface. +resolveTypeInterface proxy handler = typeInterface <$> resolveTypeInfo proxy handler -- | Get the next argument in an argument iterator. -- -- This function may raise an error if there is no more argument remaining. -advanceIterator :: ArgumentIteratorState r (Ptr WLArgument) +advanceIterator :: MonadState ArgumentIterator m => m (Ptr WLArgument) advanceIterator = do - next <- argNext <<%= \p -> plusPtr p (sizeOf (undefined :: WLArgument)) - remaining <- argRemaining <<%= (+(-1)) - when (remaining == 0) (error "Out of range for argument") - pure next + ArgumentIterator arg <- get + put $ ArgumentIterator $ plusPtr arg (sizeOf (undefined :: WLArgument)) + pure arg --- | Create an 'ArgumentIteratorState' wrapping a continuation (like alloca). -liftCont :: ((a -> IO r) -> IO r) -> ArgumentIteratorState r a -liftCont = ArgumentIteratorState . lift . ContT +-- | Create an 'ArgumentWriter' wrapping a continuation (like alloca). +liftCont :: ((a -> IO r) -> IO r) -> ArgumentWriter r a +liftCont = ArgumentWriter . lift . ContT -instance ArgumentMarshaller (ArgumentIteratorState r) where +instance ArgumentMarshaller (ArgumentWriter r) where marshalInt v = do arg <- advanceIterator liftIO $ wlArgumentPokeInt arg (fromIntegral v) @@ -373,7 +359,7 @@ instance ArgumentMarshaller (ArgumentIteratorState r) where marshalFixed v = do arg <- advanceIterator liftIO $ wlArgumentPokeFixed arg (WLFixed (round (v * 256))) - marshalFD v = do + marshalFD (Fd v) = do arg <- advanceIterator liftIO $ wlArgumentPokeFD arg (fromIntegral v) marshalString v = do @@ -385,8 +371,8 @@ instance ArgumentMarshaller (ArgumentIteratorState r) where obj <- liftIO $ unwrapResource v liftIO $ wlArgumentPokeObject arg obj marshalNewID v = do - -- TODO - undefined + arg <- advanceIterator + liftIO $ wlArgumentPokeNewID arg (newID v) marshalArray v = do arg <- advanceIterator let len = fromIntegral $ length v * sizeOf (head v) @@ -397,7 +383,7 @@ instance ArgumentMarshaller (ArgumentIteratorState r) where } liftIO $ wlArgumentPokeArray arg arr -instance ArgumentDemarshaller (ArgumentIteratorState r) where +instance ArgumentDemarshaller ArgumentReader where demarshalInt = fromIntegral <$> (advanceIterator >>= liftIO . wlArgumentPeekInt) demarshalUInt = fromIntegral <$> (advanceIterator >>= liftIO . wlArgumentPeekUInt) demarshalFixed = wlFixedToFloat <$> (advanceIterator >>= liftIO . wlArgumentPeekFixed) @@ -408,10 +394,11 @@ instance ArgumentDemarshaller (ArgumentIteratorState r) where ptr <- advanceIterator >>= liftIO . wlArgumentPeekObject liftIO $ wrapResource ptr demarshalNewID = do - -- TODO - undefined + objID <- advanceIterator >>= liftIO . wlArgumentPeekNewID + client <- ask + liftIO $ createNewObject client objID demarshalArray = do ptr <- advanceIterator >>= liftIO . wlArgumentPeekArray arr <- liftIO $ peek ptr liftIO $ peekArray (fromIntegral (arrSize arr)) (castPtr (arrData arr)) - demarshalFD = advanceIterator >>= liftIO . wlArgumentPeekFD + demarshalFD = Fd . fromIntegral <$> (advanceIterator >>= liftIO . wlArgumentPeekFD) -- cgit v1.3.1