1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
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
|
