diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs index cb1a2ada777a5dc19f8bc15ec4dd452e819d5660..b6bb0a0a6cc91e156cdce6054e43d97a101d14af 100644 --- a/src/Quasar/Wayland/Protocol/Core.hs +++ b/src/Quasar/Wayland/Protocol/Core.hs @@ -37,6 +37,8 @@ module Quasar.Wayland.Protocol.Core ( enterObject, -- * Low-level protocol interaction + objectWireArgument, + checkObject, sendMessage, newObject, newObjectFromId, @@ -605,15 +607,33 @@ handleWlDisplayError _protocol oId code message = throwM $ ServerError code (toS handleWlDisplayDeleteId :: ProtocolHandle 'Client -> Word32 -> STM () handleWlDisplayDeleteId protocol oId = runProtocolM protocol do modifyProtocolVar (.objectsVar) $ HM.delete (GenericObjectId oId) - traceM $ mconcat ["Deleted object id ", show oId] --- | Sends a message without checking any ids or creating proxy objects objects. (TODO) +checkObject :: IsInterface i => Object s i -> ProtocolM s (Either String ()) +checkObject object = do + -- TODO check if object belongs to current connection + isActiveObject <- HM.member (genericObjectId object) <$> readProtocolVar (.objectsVar) + pure + if isActiveObject + then pure () + else Left $ mconcat ["Object ", show object, " has been deleted"] + + +-- | Verify that an object can be used as an argument (throws otherwise) and return its id. +objectWireArgument :: IsInterface i => Object s i -> ProtocolM s (ObjectId (InterfaceName i)) +objectWireArgument object = do + checkObject object >>= \case + Left msg -> throwM $ ProtocolUsageError $ "Tried to send a reference to an invalid object: " <> msg + Right () -> pure object.objectId + + +-- | Sends a message, for use in generated code. sendMessage :: forall s i. IsInterfaceSide s i => Object s i -> WireUp s i -> ProtocolM s () sendMessage object message = do - isActiveObject <- HM.member oId <$> readProtocolVar (.objectsVar) - unless isActiveObject $ throwM $ ProtocolUsageError $ "Tried to send message on an invalid object: " <> show object + checkObject object >>= \case + Left msg -> throwM $ ProtocolUsageError $ "Tried to send message to an invalid object: " <> msg + Right () -> pure () (opcode, pairs) <- putWireUp object message let (putBodyParts, partLengths) = unzip pairs diff --git a/src/Quasar/Wayland/Protocol/TH.hs b/src/Quasar/Wayland/Protocol/TH.hs index c3743bc55e3bceabcf2c6ea3350067281e498aec..822e0ffd46ec59938eb1c4edaab98a51d8682cbe 100644 --- a/src/Quasar/Wayland/Protocol/TH.hs +++ b/src/Quasar/Wayland/Protocol/TH.hs @@ -277,8 +277,7 @@ messageProxyInstanceDecs side messageContexts = mapM messageProxyInstanceD messa wireArgE arg = toWireArgument arg.argType (msgArgE msg arg) toWireArgument :: ArgumentType -> Q Exp -> Q Exp - -- TODO verify object validity - toWireArgument (ObjectArgument _) objectE = [|pure $objectE.objectId|] + toWireArgument (ObjectArgument _) objectE = [|objectWireArgument $objectE|] toWireArgument (NewIdArgument _) _ = unreachableCodePath -- The specification parser has a check to prevent this toWireArgument _ x = [|pure $x|]