diff options
Diffstat (limited to 'wayland/Wayland/Server/Interface.hs')
| -rw-r--r-- | wayland/Wayland/Server/Interface.hs | 159 |
1 files changed, 159 insertions, 0 deletions
diff --git a/wayland/Wayland/Server/Interface.hs b/wayland/Wayland/Server/Interface.hs new file mode 100644 index 0000000..07cc34e --- /dev/null +++ b/wayland/Wayland/Server/Interface.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Wayland.Server.Interface +-- Description: Description of the API for an object. +-- +-- This module provides data types for describing the requests and events supported by a Wayland object. This is used +-- for marshalling/demarshalling the message using the binary wire protocol. +-- +-- In addition, this module provides support for converting interface descriptions into their C equivalents and caching +-- the results (ensuring pointer equality for the same interface). + +module Wayland.Server.Interface + ( -- * Interface Descriptions + InterfaceDesc(..) + , MessageDesc(..) + , ArgumentDesc(..) + , Nullability(..) + , -- * Native Interfaces + InterfaceCache + , InterfaceCacheState + , newInterfaceCache + , destroyInterfaceCache + , resolveInterface + ) where + +import Control.Monad.State.Strict (MonadState(..), StateT) +import Control.Monad.Trans (MonadIO(..)) +import Foreign (Ptr, nullPtr, newArray, new, free, peekArray, Storable(..)) +import Foreign.C (newCString) +import qualified Wayland.Server.System as Sys +import qualified Data.Map as M + +-- | Description of a Wayland interface and the functionality it provides. +-- +-- This is analogous to the wl_interface structure in libwayland and is converted into it as needed. +-- +-- An interface can be implemented by an object which is associated with a client. +data InterfaceDesc + = InterfaceDesc { ifName :: !String -- ^ Name of the interface (for example, "wl_output"). + , ifVersion :: !Int -- ^ Version of the interface described in this data structure. + , ifRequests :: ![MessageDesc] -- ^ The requests a server should handle to implement the interface. + , ifEvents :: ![MessageDesc] -- ^ The events sent out by a server for instances of the interface. + } + deriving (Show, Eq, Ord) + +-- | Description of a message sent between the server and a client (either a request or an event). +-- +-- A message operates on an object implementing an interface. +data MessageDesc + = MessageDesc { msgName :: !String -- ^ Name of the protocol message. + , msgArguments :: ![ArgumentDesc] -- ^ The argument types passed to the message. + , msgSince :: !Int -- ^ Protocol version where the message was introduced. + , msgIsDestructor :: !Bool -- ^ Indicates whether this is a request to destroy an object. + } + deriving (Show, Eq, Ord) + +-- | Description of an argument in the signature of a message. +data ArgumentDesc + = ArgumentInt + | ArgumentUInt + | ArgumentFixed + | ArgumentString !Nullability + | ArgumentObject !Nullability !InterfaceDesc + | ArgumentNewID !InterfaceDesc + | ArgumentArray + | ArgumentFD + deriving (Show, Eq, Ord) + +-- | Describes whether a string/object argument in a message is optional. +data Nullability + = Nullable + | NotNull + deriving (Show, Eq, Ord) + +-- | State used to cache C interfaces. +-- +-- The wl_interface instances are cached so the same interface description always yields the same wl_interface pointer. +newtype InterfaceCache = InterfaceCache (M.Map InterfaceDesc (Ptr Sys.WLInterface)) + +-- | A state monad providing an instance of 'InterfaceCache'. +type InterfaceCacheState = StateT InterfaceCache IO + +-- | Initialize an interface cache. +newInterfaceCache :: IO InterfaceCache +newInterfaceCache = pure $ InterfaceCache M.empty + +-- | Destroy an interface cache, freeing all acquired resources. +-- +-- This should only be done after no wl_interface instances are referenced as it will free their underlying memory. +destroyInterfaceCache :: InterfaceCache -> IO () +destroyInterfaceCache (InterfaceCache m) = + let freeMessage :: Sys.WLMessage -> IO () + freeMessage msg = do + free (Sys.msgName msg) + free (Sys.msgSignature msg) + free (Sys.msgTypes msg) + freeInterface :: Ptr Sys.WLInterface -> IO () + freeInterface iface = do + iface' <- peek iface + peekArray (fromIntegral (Sys.ifMethodCount iface')) (Sys.ifMethods iface') >>= mapM_ freeMessage + peekArray (fromIntegral (Sys.ifEventCount iface')) (Sys.ifEvents iface') >>= mapM_ freeMessage + free (Sys.ifName iface') + free (Sys.ifMethods iface') + free (Sys.ifEvents iface') + free iface + in mapM_ freeInterface m + +-- | Resolve a native wl_interface pointer for an interface description. +-- +-- This will first attempt to use an existing instance from the 'InterfaceCache'. If there is none, it will create a new +-- native interface and put it in the cache. Resources are freed using 'destroyInterfaceCache'. +-- +-- Resolving an interface may also require resolving other interfaces used as arguments, thus this function is +-- implemented recursively. +resolveInterface :: InterfaceDesc -> InterfaceCacheState (Ptr Sys.WLInterface) +resolveInterface i = do + let mkArgumentType :: ArgumentDesc -> InterfaceCacheState (Ptr Sys.WLInterface) + mkArgumentType (ArgumentObject _ a) = resolveInterface a + mkArgumentType (ArgumentNewID a) = resolveInterface a + mkArgumentType _ = pure nullPtr + let mkArgument :: ArgumentDesc -> String + mkArgument ArgumentInt = "i" + mkArgument ArgumentUInt = "u" + mkArgument ArgumentFixed = "f" + mkArgument (ArgumentString NotNull) = "s" + mkArgument (ArgumentString Nullable) = "?s" + mkArgument (ArgumentObject NotNull _) = "o" + mkArgument (ArgumentObject Nullable _) = "?o" + mkArgument (ArgumentNewID _) = "n" + mkArgument ArgumentArray = "a" + mkArgument ArgumentFD = "h" + let mkMessage :: MessageDesc -> InterfaceCacheState Sys.WLMessage + mkMessage m = do + name <- liftIO $ newCString (msgName m) + signature <- liftIO $ newCString (show (msgSince m) ++ (msgArguments m >>= mkArgument)) + types <- mapM mkArgumentType (msgArguments m) >>= liftIO . newArray + pure $ Sys.WLMessage { Sys.msgName = name + , Sys.msgSignature = signature + , Sys.msgTypes = types + } + let mkInterface :: InterfaceCacheState (Ptr Sys.WLInterface) + mkInterface = do + name <- liftIO $ newCString (ifName i) + methods <- mapM mkMessage (ifRequests i) >>= liftIO . newArray + events <- mapM mkMessage (ifEvents i) >>= liftIO . newArray + liftIO $ new $ Sys.WLInterface { Sys.ifName = name + , Sys.ifVersion = fromIntegral (ifVersion i) + , Sys.ifMethodCount = fromIntegral (length (ifRequests i)) + , Sys.ifMethods = methods + , Sys.ifEventCount = fromIntegral (length (ifEvents i)) + , Sys.ifEvents = events + } + InterfaceCache existing <- get + case M.lookup i existing of + Just ptr -> pure ptr + Nothing -> do ptr <- mkInterface + put $ InterfaceCache $ M.insert i ptr existing + pure ptr |