diff options
Diffstat (limited to 'wayland/Wayland')
| -rw-r--r-- | wayland/Wayland/Server.hs | 1 | ||||
| -rw-r--r-- | wayland/Wayland/Server/Display.hs | 16 | ||||
| -rw-r--r-- | wayland/Wayland/Server/Object.hs | 161 |
3 files changed, 118 insertions, 60 deletions
diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs index 07fc3d7..0e18048 100644 --- a/wayland/Wayland/Server.hs +++ b/wayland/Wayland/Server.hs @@ -54,6 +54,7 @@ module Wayland.Server , EventClass , ArgumentMarshaller(..) , ArgumentDemarshaller(..) + , Marshallable(..) ) where import Wayland.Server.Interface diff --git a/wayland/Wayland/Server/Display.hs b/wayland/Wayland/Server/Display.hs index 527d9da..2594330 100644 --- a/wayland/Wayland/Server/Display.hs +++ b/wayland/Wayland/Server/Display.hs @@ -338,7 +338,8 @@ flushClientEvents c = liftIO (unwrapClient c >>= wlClientFlush) -- 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 + :: 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. @@ -394,7 +395,7 @@ createObject o destroyHook = do -- This will invoke the object's "destroy" hook. destroyObject :: Object o => o -> DisplayM s () destroyObject o = liftIO $ do - ptr <- unwrapResource o + ptr <- unwrapResource (toAny o) wlResourceDestroy ptr -- | Send an event for an object to the client it is associated with. @@ -510,11 +511,12 @@ unregisterFileSource file = liftIO $ do 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 +fromFileEventMask events = 0 + .|. conditionalMask wlEventReadable (fileEventReadable events) + .|. conditionalMask wlEventWritable (fileEventWritable events) + .|. conditionalMask wlEventHangup (fileEventHangup events) + .|. conditionalMask wlEventError (fileEventError events) + where conditionalMask mask enabled = if enabled then mask else 0 toFileEventMask :: Word32 -> FileEventMask toFileEventMask bits = FileEventMask { fileEventReadable = testMask wlEventReadable diff --git a/wayland/Wayland/Server/Object.hs b/wayland/Wayland/Server/Object.hs index b13e36f..1fec556 100644 --- a/wayland/Wayland/Server/Object.hs +++ b/wayland/Wayland/Server/Object.hs @@ -4,6 +4,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} -- | -- Module : Wayland.Server.Object @@ -23,6 +24,7 @@ module Wayland.Server.Object , EventClass , ArgumentMarshaller(..) , ArgumentDemarshaller(..) + , Marshallable(..) , -- * State ObjectCache , ObjectCacheState @@ -50,6 +52,7 @@ import Control.Monad.State.Strict (StateT(..), MonadState(..)) import Control.Monad.Cont (ContT(..)) import Control.Monad.Trans (MonadIO(..), MonadTrans(..)) import Control.Monad.Reader (ReaderT (..), MonadReader(..)) +import Control.Monad.Except (MonadError (..), ExceptT, runExceptT) import Wayland.Server.System import Wayland.Server.Interface (MessageDesc(..), InterfaceDesc(..), InterfaceCache, newInterfaceCache, destroyInterfaceCache, resolveInterface) import Wayland.Server.Client (Client, unwrapClient, wrapClient) @@ -114,32 +117,33 @@ class MessageClass e => EventClass e where -- For libwayland, the arguments are stored into wl_arguments. It is considered a programmer error to write more -- arguments than expected by an event or different argument types than the ones specified. class Monad m => ArgumentMarshaller m where - marshalInt :: Int -> m () - marshalUInt :: Word -> m () - marshalFixed :: Float -> m () - marshalString :: String -> m () - marshalMaybeString :: Maybe String -> m () - marshalObject :: Object o => o -> m () - marshalMaybeObject :: Object o => Maybe o -> m () - marshalNewID :: Object o => NewObject o -> m () - marshalArray :: ByteString -> m () - marshalFD :: Fd -> m () + marshalInt :: Int32 -> m () + marshalUInt :: Word32 -> m () + marshalFixed :: Float -> m () + marshalString :: Maybe String -> m () + marshalObject :: Maybe AnyObject -> m () + marshalNewID :: Object o => NewObject o -> m () + marshalArray :: ByteString -> m () + marshalFD :: Fd -> m () -- | A monad providing an environment for reading a fixed number of arguments of various types. -- -- For libwayland, the arguments are read from wl_arguments. It is considered a programmer error to read more arguments -- than expected by a request or different argument types than the ones specified. -class Monad m => ArgumentDemarshaller m where - demarshalInt :: m Int - demarshalUInt :: m Word - demarshalFixed :: m Float - demarshalString :: m String - demarshalMaybeString :: m (Maybe String) - demarshalObject :: Object o => m o - demarshalMaybeObject :: Object o => m (Maybe o) - demarshalNewID :: Object o => m (NewObject o) - demarshalArray :: m ByteString - demarshalFD :: m Fd +class MonadError String m => ArgumentDemarshaller m where + demarshalInt :: m Int32 + demarshalUInt :: m Word32 + demarshalFixed :: m Float + demarshalString :: m (Maybe String) + demarshalObject :: m (Maybe AnyObject) + demarshalNewID :: Object o => m (NewObject o) + demarshalArray :: m ByteString + demarshalFD :: m Fd + +-- | A type that can be marshalled or demarshalled in the corresponding monad. +class Marshallable t where + marshal :: ArgumentMarshaller m => t -> m () + demarshal :: ArgumentDemarshaller m => m t -- | An opaque handle to a Wayland object. -- @@ -187,8 +191,8 @@ newtype ArgumentWriter r a = ArgumentWriter { runArgumentWriter :: StateT Argume deriving (Functor, Applicative, Monad, MonadState ArgumentIterator, MonadIO) -- | 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) +newtype ArgumentReader a = ArgumentReader { runArgumentReader :: ExceptT String (StateT ArgumentIterator (ReaderT Client IO)) a } + deriving (Functor, Applicative, Monad, MonadState ArgumentIterator, MonadIO, MonadError String, MonadReader Client) makeLenses ''ObjectCache @@ -210,6 +214,52 @@ instance Show (NewObject o) where instance Eq (NewObject o) where a == b = newObject a == newObject b +instance Marshallable Int32 where + marshal = marshalInt + demarshal = demarshalInt + +instance Marshallable Word32 where + marshal = marshalUInt + demarshal = demarshalUInt + +instance Marshallable Float where + marshal = marshalFixed + demarshal = demarshalFixed + +instance Marshallable String where + marshal = marshalString . Just + demarshal = do str <- demarshalString + case str of + Just s -> pure s + Nothing -> throwError "Expected string, got <null>" + +instance Marshallable (Maybe String) where + marshal = marshalString + demarshal = demarshalString + +instance Marshallable AnyObject where + marshal = marshalObject . Just + demarshal = do obj <- demarshalObject + case obj of + Just o -> pure o + Nothing -> throwError "Expected object, got <null>" + +instance Marshallable (Maybe AnyObject) where + marshal = marshalObject + demarshal = demarshalObject + +instance Object o => Marshallable (NewObject o) where + marshal = marshalNewID + demarshal = demarshalNewID + +instance Marshallable ByteString where + marshal = marshalArray + demarshal = demarshalArray + +instance Marshallable Fd where + marshal = marshalFD + demarshal = demarshalFD + -- | Create a handle to an object that has yet to be created. createNewObject :: Client -> Word32 -> IO (NewObject o) createNewObject client objID = do @@ -241,13 +291,13 @@ destroyObjectCache c = do -- | Get the underlying Wayland resource wrapped by a typed object. -- -- This function may raise an error if the underlying resource is no longer alive. -unwrapResource :: Object o => o -> IO WLResource -unwrapResource o = resolveHandle (objHandle (toAny o)) +unwrapResource :: AnyObject -> IO WLResource +unwrapResource o = resolveHandle (objHandle o) -- | Get the typed object wrapping a Wayland resource. -- -- The object wrapper is stored as a StablePtr in the resource's userdata. -wrapResource :: Object o => WLResource -> IO o +wrapResource :: WLResource -> IO AnyObject wrapResource o = do objPtr <- castPtrToStablePtr <$> wlResourceGetUserData o deRefStablePtr objPtr @@ -267,7 +317,8 @@ destroyResource res = do -- -- This not only creates the object but also attaches a dispatch function to it and updates the destroy callback. createResource - :: forall o destroyMsg. Object o + :: 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 @@ -284,13 +335,13 @@ createResource handler newObj destroyHook = do 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 - } + let obj = 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 + writeIORef (newObject newObj) (Just (fromAny obj)) + pure (fromAny obj) -- | Send an event for a typed object. -- @@ -298,7 +349,7 @@ createResource handler newObj destroyHook = do sendResourceEvent :: forall o. Object o => o -> ObjectEvent o -> IO () sendResourceEvent o e = do let paramCount = length $ msgArguments (eventSignature (Proxy :: Proxy o) e) - res <- unwrapResource o + res <- unwrapResource (toAny o) allocaArray0 paramCount $ \buffer -> runContT (runStateT (runArgumentWriter (marshalEvent (Proxy :: Proxy o) e)) (ArgumentIterator buffer)) $ \(opcode, _) -> wlResourcePostEventArray res (fromIntegral opcode) buffer @@ -306,12 +357,24 @@ sendResourceEvent o e = do -- | Request handler for a typed object. -- -- This provides a WLDispatcherFunc for an object type. -dispatchResourceRequest :: forall o. Object o => Proxy o -> (Message -> IO ()) -> Ptr () -> WLResource -> Word32 -> Ptr WLMessage -> Ptr WLArgument -> IO CInt +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 + obj :: o <- fromAny <$> wrapResource res client <- wlResourceGetClient res >>= wrapClient - (req, _) <- runReaderT (runStateT (runArgumentReader (demarshalRequest obj (fromIntegral opcode))) (ArgumentIterator args)) client - handler $ Message req + (req, _) <- runReaderT (runStateT (runExceptT (runArgumentReader (demarshalRequest obj (fromIntegral opcode)))) (ArgumentIterator args)) client + case req of + Left err -> putStrLn $ "Received invalid request: " ++ err + Right r -> handler $ Message r pure 0 -- | Resolve a type information for an object type. @@ -360,30 +423,28 @@ liftCont = ArgumentWriter . lift . ContT instance ArgumentMarshaller (ArgumentWriter r) where marshalInt v = do arg <- advanceIterator - liftIO $ wlArgumentPokeInt arg (fromIntegral v) + liftIO $ wlArgumentPokeInt arg v marshalUInt v = do arg <- advanceIterator - liftIO $ wlArgumentPokeUInt arg (fromIntegral v) + liftIO $ wlArgumentPokeUInt arg v marshalFixed v = do arg <- advanceIterator liftIO $ wlArgumentPokeFixed arg (WLFixed (round (v * 256))) marshalFD (Fd v) = do arg <- advanceIterator liftIO $ wlArgumentPokeFD arg (fromIntegral v) - marshalString v = do + marshalString (Just v) = do arg <- advanceIterator str <- liftCont $ withCString v liftIO $ wlArgumentPokeString arg str - marshalMaybeString (Just v) = marshalString v - marshalMaybeString Nothing = do + marshalString Nothing = do arg <- advanceIterator liftIO $ wlArgumentPokeString arg nullPtr - marshalObject v = do + marshalObject (Just v) = do arg <- advanceIterator obj <- liftIO $ unwrapResource v liftIO $ wlArgumentPokeObject arg obj - marshalMaybeObject (Just v) = marshalObject v - marshalMaybeObject Nothing = do + marshalObject Nothing = do arg <- advanceIterator liftIO $ wlArgumentPokeObject arg (WLResource nullPtr) marshalNewID v = do @@ -399,20 +460,14 @@ instance ArgumentMarshaller (ArgumentWriter r) where liftIO $ wlArgumentPokeArray arg arr instance ArgumentDemarshaller ArgumentReader where - demarshalInt = fromIntegral <$> (advanceIterator >>= liftIO . wlArgumentPeekInt) - demarshalUInt = fromIntegral <$> (advanceIterator >>= liftIO . wlArgumentPeekUInt) + demarshalInt = advanceIterator >>= liftIO . wlArgumentPeekInt + demarshalUInt = advanceIterator >>= liftIO . wlArgumentPeekUInt demarshalFixed = wlFixedToFloat <$> (advanceIterator >>= liftIO . wlArgumentPeekFixed) demarshalString = do ptr <- advanceIterator >>= liftIO . wlArgumentPeekString - liftIO $ peekCString ptr - demarshalMaybeString = do - ptr <- advanceIterator >>= liftIO . wlArgumentPeekString if ptr == nullPtr then pure Nothing else Just <$> liftIO (peekCString ptr) demarshalObject = do ptr <- advanceIterator >>= liftIO . wlArgumentPeekObject - liftIO $ wrapResource ptr - demarshalMaybeObject = do - ptr <- advanceIterator >>= liftIO . wlArgumentPeekObject if ptr == WLResource nullPtr then pure Nothing else Just <$> liftIO (wrapResource ptr) demarshalNewID = do objID <- advanceIterator >>= liftIO . wlArgumentPeekNewID |