diff --git a/src/Quasar/Wayland/Client.hs b/src/Quasar/Wayland/Client.hs index d082d5f313c49c854f3a74fdd243abd5f56329d5..65e9d5fd4e0fe3b76943868be6d857333f881c42 100644 --- a/src/Quasar/Wayland/Client.hs +++ b/src/Quasar/Wayland/Client.hs @@ -36,6 +36,8 @@ newWaylandClient socket = WaylandClient <$> @I_wl_display @I_wl_registry (traceCallback ignoreMessage) + -- HACK to send get_registry + (Just (R_wl_display_get_registry (NewId 2))) (traceCallback ignoreMessage) socket diff --git a/src/Quasar/Wayland/Connection.hs b/src/Quasar/Wayland/Connection.hs index fb6a66a4edfdb07c818ecefb737e334860f3df98..8efeed6710a339378f34a3669172833ce52aad41 100644 --- a/src/Quasar/Wayland/Connection.hs +++ b/src/Quasar/Wayland/Connection.hs @@ -37,11 +37,12 @@ data SocketClosed = SocketClosed newWaylandConnection :: forall wl_display wl_registry s m. (IsInterfaceSide s wl_display, IsInterfaceSide s wl_registry, MonadResourceManager m) => Callback s STM wl_display + -> Maybe (Up s wl_display) -> Callback s STM wl_registry -> Socket -> m (WaylandConnection s) -newWaylandConnection wlDisplayCallback wlRegistryCallback socket = do - protocolStateVar <- liftIO $ newTVarIO $ initialProtocolState wlDisplayCallback wlRegistryCallback +newWaylandConnection wlDisplayCallback initializationMessage wlRegistryCallback socket = do + protocolStateVar <- liftIO $ newTVarIO protocolState outboxVar <- liftIO newEmptyTMVarIO resourceManager <- newResourceManager @@ -60,10 +61,16 @@ newWaylandConnection wlDisplayCallback wlRegistryCallback socket = do connectionThread connection $ sendThread connection connectionThread connection $ receiveThread connection - -- HACK to send first message (queued internally) - stepProtocol connection $ feedInput "" + -- Create registry, if requested + forM_ initializationMessage \msg -> + sendProtocolMessage connection wlDisplay msg pure connection + where + (protocolState, wlDisplay) = initialProtocolState wlDisplayCallback wlRegistryCallback + +sendProtocolMessage :: (IsInterfaceSide s i, MonadIO m) => WaylandConnection s -> Object s STM i -> Up s i -> m () +sendProtocolMessage connection object message = stepProtocol connection $ sendMessage object message stepProtocol :: forall s m a. MonadIO m => WaylandConnection s -> ProtocolStep s STM a -> m a stepProtocol connection step = liftIO do diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs index fa16a38e68fcf58c594362670d71ce839ba1ff72..78a37fd972f3033ac54f56a4c50c5359b42c2120 100644 --- a/src/Quasar/Wayland/Protocol/Core.hs +++ b/src/Quasar/Wayland/Protocol/Core.hs @@ -2,21 +2,19 @@ module Quasar.Wayland.Protocol.Core ( ObjectId, + NewId(..), Opcode, ArgumentType(..), Fixed, - IsSide, + IsSide(..), Side(..), IsInterface(..), - IsInterfaceSide(..), + IsInterfaceSide, IsInterfaceHandler(..), Object, - IsObject(..), IsObject, IsMessage(..), ProtocolState, - ClientProtocolState, - ServerProtocolState, Callback(..), internalFnCallback, traceCallback, @@ -272,39 +270,10 @@ showObjectMessage object message = objectInterfaceName object <> "@" <> show (objectId object) <> "." <> show message --- TODO remove -data DynamicArgument - = DynamicIntArgument Int32 - | DynamicUIntArgument Word32 - -- TODO - | DynamicFixedArgument Void - | DynamicStringArgument String - | DynamicObjectArgument ObjectId - | DynamicNewIdArgument ObjectId - | DynamicFdArgument () - -dynamicArgumentSize :: DynamicArgument -> Word16 -dynamicArgumentSize (DynamicIntArgument _) = 4 -dynamicArgumentSize (DynamicUIntArgument _) = 4 -dynamicArgumentSize (DynamicObjectArgument _) = 4 -dynamicArgumentSize (DynamicNewIdArgument _) = 4 -dynamicArgumentSize _ = undefined - -putDynamicArgument :: DynamicArgument -> Put -putDynamicArgument (DynamicIntArgument x) = putInt32host x -putDynamicArgument (DynamicUIntArgument x) = putWord32host x -putDynamicArgument (DynamicObjectArgument x) = putWord32host x -putDynamicArgument (DynamicNewIdArgument x) = putWord32host x -putDynamicArgument _ = undefined - - -type ClientProtocolState m = ProtocolState 'Client m -type ServerProtocolState m = ProtocolState 'Server m - data ProtocolState (s :: Side) m = ProtocolState { protocolException :: Maybe SomeException, - bytesReceived :: !Word64, - bytesSent :: !Word64, + bytesReceived :: !Int64, + bytesSent :: !Int64, inboxDecoder :: Decoder RawMessage, outbox :: Maybe Put, objects :: HashMap ObjectId (SomeObject s m) @@ -384,8 +353,8 @@ initialProtocolState :: forall wl_display wl_registry s m. (IsInterfaceSide s wl_display, IsInterfaceSide s wl_registry) => Callback s m wl_display -> Callback s m wl_registry - -> ProtocolState s m -initialProtocolState wlDisplayCallback wlRegistryCallback = sendInitialMessage initialState + -> (ProtocolState s m, Object s m wl_display) +initialProtocolState wlDisplayCallback wlRegistryCallback = (initialState, wlDisplay) where wlDisplay :: Object s m wl_display wlDisplay = Object 1 wlDisplayCallback @@ -412,10 +381,25 @@ feedInput bytes = protocolStep do inboxDecoder = pushChunk st.inboxDecoder bytes } - undefined message - runCallbacks +-- | Sends a message without checking any ids or creating proxy objects objects. sendMessage :: forall s m i. (IsInterfaceSide s i, MonadCatch m) => Object s m i -> Up s i -> ProtocolStep s m () sendMessage object message = protocolStep do + traceM $ "-> " <> showObjectMessage object message + sendRawMessage messageWithHeader + where + body :: BSL.ByteString + opcode :: Opcode + (opcode, body) = runPutM $ putUp object message + messageWithHeader :: Put + messageWithHeader = do + putWord32host $ objectId object + putWord32host $ (fromIntegral msgSize `shiftL` 16) .|. fromIntegral opcode + putLazyByteString body + msgSize :: Word16 + msgSize = if msgSizeInteger <= fromIntegral (maxBound :: Word16) then fromIntegral msgSizeInteger else error "Message too large" + -- TODO: body length should be returned from `putMessage`, instead of realizing it to a ByteString here + msgSizeInteger :: Integer + msgSizeInteger = 8 + fromIntegral (BSL.length body) setException :: (MonadCatch m, Exception e) => e -> ProtocolStep s m () setException ex = protocolStep do @@ -425,14 +409,12 @@ setException ex = protocolStep do -- | Take data that has to be sent (if available) takeOutbox :: MonadCatch m => ProtocolState s m -> (Maybe BSL.ByteString, ProtocolState s m) -takeOutbox st = (maybeOutboxBytes, st{outbox = Nothing}) +takeOutbox st = (maybeOutboxData, st{outbox = Nothing, bytesSent = st.bytesSent + outboxNumBytes}) where - maybeOutboxBytes = if isJust st.protocolException then Nothing else outboxBytes - outboxBytes = runPut <$> st.outbox - + maybeOutboxData = if isJust st.protocolException then Nothing else outboxData + outboxData = runPut <$> st.outbox + outboxNumBytes = maybe 0 BSL.length maybeOutboxData -sendInitialMessage :: ProtocolState s m -> ProtocolState s m -sendInitialMessage = sendMessageInternal 1 1 [DynamicNewIdArgument 2] receiveMessages :: (IsSide s, MonadCatch m) => StateT (ProtocolState s m) m () receiveMessages = receiveRawMessage >>= \case @@ -520,19 +502,7 @@ skipPadding = do skip $ fromIntegral ((4 - (bytes `mod` 4)) `mod` 4) -sendMessageInternal :: ObjectId -> Opcode -> [DynamicArgument] -> ProtocolState s m -> ProtocolState s m -sendMessageInternal oId opcode args = sendRaw do - putWord32host oId - putWord32host $ (fromIntegral msgSize `shiftL` 16) .|. fromIntegral opcode - mapM_ putDynamicArgument args - -- TODO padding - where - msgSize :: Word16 - msgSize = if msgSizeInteger <= fromIntegral (maxBound :: Word16) then fromIntegral msgSizeInteger else undefined - msgSizeInteger :: Integer - msgSizeInteger = foldr ((+) . (fromIntegral . dynamicArgumentSize)) 8 args :: Integer - -sendRaw :: Put -> ProtocolState s m -> ProtocolState s m -sendRaw x oldState = oldState { - outbox = Just (maybe x (<> x) oldState.outbox) +sendRawMessage :: MonadCatch m => Put -> ProtocolAction s m () +sendRawMessage x = State.modify \st -> st { + outbox = Just (maybe x (<> x) st.outbox) }