diff --git a/src/Quasar/Wayland/Client.hs b/src/Quasar/Wayland/Client.hs
index ce645517768d06690e2bacf95cbea27268d6e662..3c4aa1b42d869064d7ab2414ecb74761f00fe1d1 100644
--- a/src/Quasar/Wayland/Client.hs
+++ b/src/Quasar/Wayland/Client.hs
@@ -48,7 +48,7 @@ newWaylandClient socket = do
}
where
newClientDisplay :: STM ((Object 'Client Interface_wl_display, Registry), ProtocolHandle 'Client)
- newClientDisplay = initializeProtocol wlDisplayEventHandler initalize
+ newClientDisplay = initializeProtocol wlDisplayEventHandler (\_ _ -> unreachableCodePathM) initalize
initalize :: Object 'Client Interface_wl_display -> STM (Object 'Client Interface_wl_display, Registry)
initalize wlDisplay = do
diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs
index bc56fa3332c85799b5bc8c8aad081e9938b9e0a4..c4644a11d44726667c0aebcbc574c0346c2112b0 100644
--- a/src/Quasar/Wayland/Protocol/Core.hs
+++ b/src/Quasar/Wayland/Protocol/Core.hs
@@ -42,7 +42,6 @@ module Quasar.Wayland.Protocol.Core (
-- * Low-level protocol interaction
objectWireArgument,
nullableObjectWireArgument,
- handleDestructor,
checkObject,
sendMessage,
newObject,
@@ -71,7 +70,7 @@ module Quasar.Wayland.Protocol.Core (
) where
import Control.Monad.Catch
-import Control.Monad.Reader (ReaderT, runReaderT, ask, lift)
+import Control.Monad.Reader (ReaderT, runReaderT, ask, asks, lift)
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
@@ -104,6 +103,9 @@ newtype GenericObjectId = GenericObjectId Word32
toGenericObjectId :: ObjectId j -> GenericObjectId
toGenericObjectId (ObjectId oId) = GenericObjectId oId
+objectIdValue :: ObjectId j -> Word32
+objectIdValue (ObjectId value) = value
+
type Opcode = Word16
type Version = Word32
@@ -243,6 +245,8 @@ class Typeable s => IsSide (s :: Side) where
type WireDown s i
initialId :: Word32
maximumId :: Word32
+ -- | Should be called by generated code _after_ calling a destructor.
+ handleDestructor :: IsInterfaceSide s i => Object s i -> ProtocolM s () -> ProtocolM s ()
instance IsSide 'Client where
type MessageHandler 'Client i = EventHandler i
@@ -251,6 +255,7 @@ instance IsSide 'Client where
-- Id #1 is reserved for wl_display
initialId = 2
maximumId = 0xfeffffff
+ handleDestructor object msgFn = handleDestructorPre object >> msgFn
instance IsSide 'Server where
type MessageHandler 'Server i = RequestHandler i
@@ -258,6 +263,21 @@ instance IsSide 'Server where
type WireDown 'Server i = WireRequest i
initialId = 0xff000000
maximumId = 0xffffffff
+ handleDestructor object msgFn = do
+ handleDestructorPre object
+ msgFn
+ when (oid <= maximumId @'Client) do
+ sendWlDisplayDeleteId :: Word32 -> STM () <- asks (.sendWlDisplayDeleteId)
+ liftSTM $ sendWlDisplayDeleteId oid
+ where
+ oid :: Word32
+ oid = objectIdValue object.objectId
+
+-- Shared destructor code for client and server
+handleDestructorPre :: IsInterfaceSide s i => Object s i -> ProtocolM s ()
+handleDestructorPre object = do
+ traceM $ "Destroying " <> showObject object
+ lift $ writeTVar object.destroyed True
class (
@@ -416,13 +436,14 @@ data ProtocolState (s :: Side) = ProtocolState {
outboxVar :: TVar (Maybe Put),
outboxFdsVar :: TVar (Seq Fd),
objectsVar :: TVar (HashMap GenericObjectId (SomeObject s)),
- nextIdVar :: TVar Word32
+ nextIdVar :: TVar Word32,
+ sendWlDisplayDeleteId :: Word32 -> STM ()
}
type ProtocolM s a = ReaderT (ProtocolState s) STM a
askProtocol :: ProtocolM s (ProtocolHandle s)
-askProtocol = (.protocolHandle) <$> ask
+askProtocol = asks (.protocolHandle)
readProtocolVar :: (ProtocolState s -> TVar a) -> ProtocolM s a
readProtocolVar fn = do
@@ -457,9 +478,13 @@ swapProtocolVar fn x = do
initializeProtocol
:: forall s wl_display a. (IsInterfaceSide s wl_display)
=> (ProtocolHandle s -> MessageHandler s wl_display)
+ -- FIXME only required for server code
+ -> (Object s wl_display -> Word32 -> STM ())
+ -- ^ Send a wl_display.delete_id message. Because this is part of the core protocol but generated from the xml it has
+ -- to be provided by the main server module.
-> (Object s wl_display -> STM a)
-> STM (a, ProtocolHandle s)
-initializeProtocol wlDisplayMessageHandler initializationAction = do
+initializeProtocol wlDisplayMessageHandler sendWlDisplayDeleteId initializationAction = do
bytesReceivedVar <- newTVar 0
bytesSentVar <- newTVar 0
inboxDecoderVar <- newTVar $ runGetIncremental getRawMessage
@@ -477,6 +502,10 @@ initializeProtocol wlDisplayMessageHandler initializationAction = do
stateVar
}
+ messageHandlerVar <- newTVar (Just (wlDisplayMessageHandler protocol))
+ destroyed <- newTVar False
+ let wlDisplay = Object protocol wlDisplayId messageHandlerVar destroyed
+
let state = ProtocolState {
protocolHandle = protocol,
protocolKey,
@@ -487,13 +516,11 @@ initializeProtocol wlDisplayMessageHandler initializationAction = do
outboxVar,
outboxFdsVar,
objectsVar,
- nextIdVar
+ nextIdVar,
+ sendWlDisplayDeleteId = (sendWlDisplayDeleteId wlDisplay)
}
writeTVar stateVar (Right state)
- messageHandlerVar <- newTVar (Just (wlDisplayMessageHandler protocol))
- destroyed <- newTVar False
- let wlDisplay = Object protocol wlDisplayId messageHandlerVar destroyed
modifyTVar' objectsVar (HM.insert (toGenericObjectId wlDisplayId) (SomeObject wlDisplay))
result <- initializationAction wlDisplay
@@ -675,12 +702,6 @@ handleWlDisplayDeleteId protocol oId = runProtocolM protocol do
modifyProtocolVar (.objectsVar) $ HM.delete (GenericObjectId oId)
-handleDestructor :: IsInterfaceSide s i => Object s i -> ProtocolM s ()
-handleDestructor object = do
- traceM $ "Handling destructor for " <> showObject object
- lift $ writeTVar object.destroyed True
-
-
checkObject :: IsInterface i => Object s i -> ProtocolM s (Either String ())
checkObject object = do
-- TODO check if object belongs to current connection
diff --git a/src/Quasar/Wayland/Protocol/TH.hs b/src/Quasar/Wayland/Protocol/TH.hs
index 10f6410dbecf0d56b500503700cb137b609ff1c9..1fbb56f20acd0935b67952a4d92a0a634a48f8b0 100644
--- a/src/Quasar/Wayland/Protocol/TH.hs
+++ b/src/Quasar/Wayland/Protocol/TH.hs
@@ -258,7 +258,7 @@ interfaceDecs interface = do
msgHandlerE = [|$(appTypeE [|getField|] fieldNameLitT) $handlerE|]
bodyE :: Q Exp
bodyE
- | msg.msgSpec.isDestructor = [|handleDestructor $objectE >> $msgE|]
+ | msg.msgSpec.isDestructor = [|handleDestructor $objectE $msgE|]
| otherwise = msgE
msgE :: Q Exp
msgE = [|$(applyMsgArgs msgHandlerE) >>= lift|]
@@ -312,7 +312,7 @@ messageProxyInstanceDecs side messageContexts = mapM messageProxyInstanceD messa
msgE idArgE = mkWireMsgE (idArgE : (wireArgE <$> args))
dtorE :: Q Exp
- dtorE = [|handleDestructor object >> $normalE|]
+ dtorE = [|handleDestructor object $normalE|]
-- Body for a normal (i.e. non-constructor) proxy
normalE :: Q Exp
diff --git a/src/Quasar/Wayland/Server.hs b/src/Quasar/Wayland/Server.hs
index a3f1c4c4a770b31277d17b0a93ec2d4d4d95af15..1d8ba7681f25aeac8ee1478781b3be197ad09837 100644
--- a/src/Quasar/Wayland/Server.hs
+++ b/src/Quasar/Wayland/Server.hs
@@ -41,7 +41,7 @@ newWaylandServerConnection server socket = do
}
where
newServerDisplay :: STM (Object 'Server Interface_wl_display, ProtocolHandle 'Server)
- newServerDisplay = initializeProtocol wlDisplayRequestHandler pure
+ newServerDisplay = initializeProtocol wlDisplayRequestHandler (.delete_id) pure
wlDisplayRequestHandler :: ProtocolHandle 'Server -> RequestHandler_wl_display
wlDisplayRequestHandler _protocol =