From a9be7bf5cc1c934c5de63830498e76a8aabe4ace Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Mon, 6 Sep 2021 04:01:05 +0200
Subject: [PATCH] Parse received messages
---
quasar-wayland.cabal | 6 +-
src/Quasar/Wayland/Client.hs | 24 +++--
src/Quasar/Wayland/Protocol.hs | 159 +++++++++++++++++++++++++++++++--
src/Quasar/Wayland/TH.hs | 88 +++++++++++++-----
4 files changed, 239 insertions(+), 38 deletions(-)
diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal
index 63d666c..ded8592 100644
--- a/quasar-wayland.cabal
+++ b/quasar-wayland.cabal
@@ -88,16 +88,16 @@ library
Quasar.Wayland.TH
build-depends:
base >=4.7 && <5,
- --binary,
+ binary,
bytestring,
exceptions,
filepath,
- --mtl,
+ mtl,
network,
quasar,
template-haskell,
--unix,
- --unordered-containers,
+ unordered-containers,
stm,
xml,
-- required for record-dot-preprocessor
diff --git a/src/Quasar/Wayland/Client.hs b/src/Quasar/Wayland/Client.hs
index 0a3d3c3..ddb9841 100644
--- a/src/Quasar/Wayland/Client.hs
+++ b/src/Quasar/Wayland/Client.hs
@@ -8,6 +8,7 @@ import Control.Monad.Catch
import Network.Socket (Socket)
import Network.Socket qualified as Socket
import Network.Socket.ByteString qualified as Socket
+import Network.Socket.ByteString.Lazy qualified as SocketL
import Quasar
import Quasar.Prelude
import Quasar.Wayland.Protocol
@@ -17,7 +18,7 @@ import Text.Read (readEither)
data WaylandClient = WaylandClient {
- protocolStateVar :: TVar ProtocolState,
+ protocolStateVar :: TVar ClientProtocolState,
socket :: Socket,
resourceManager :: ResourceManager
}
@@ -30,7 +31,7 @@ instance IsDisposable WaylandClient where
newWaylandClient :: MonadResourceManager m => Socket -> m WaylandClient
newWaylandClient socket = do
- protocolStateVar <- liftIO $ newTVarIO initialProtocolState
+ protocolStateVar <- liftIO $ newTVarIO initialClientProtocolState
resourceManager <- newResourceManager
onResourceManager resourceManager do
@@ -43,20 +44,31 @@ newWaylandClient socket = do
registerDisposeAction $ closeWaylandClient client
runUnlimitedAsync do
- async $ liftIO $ waylandClientSendThread client
- async $ liftIO $ waylandClientReceiveThread client
+ async $ liftIO $ waylandClientSendThread client `catchAll` \ex -> traceIO (displayException ex) >> void (dispose resourceManager)
+ async $ liftIO $ waylandClientReceiveThread client `catchAll` \ex -> traceIO (displayException ex) >> void (dispose resourceManager)
pure client
waylandClientSendThread :: WaylandClient -> IO ()
waylandClientSendThread client = forever do
- undefined
+ bytes <- atomically do
+ outbox <- stateTVar client.protocolStateVar takeOutbox
+ case outbox of
+ Just bytes -> pure bytes
+ Nothing -> retry
+
+ traceIO $ "Sending data"
+ SocketL.sendAll client.socket bytes
+
waylandClientReceiveThread :: WaylandClient -> IO ()
waylandClientReceiveThread client = forever do
bytes <- Socket.recv client.socket 4096
traceIO $ "Received data"
- atomically $ modifyTVar client.protocolStateVar $ feedInput bytes
+ events <- atomically $ stateTVar client.protocolStateVar $ feedInput bytes
+
+ traceIO $ "Received " <> show (length events) <> " events"
+ mapM_ (traceIO . show) events
state <- atomically $ readTVar client.protocolStateVar
traceIO $ show state.bytesReceived
diff --git a/src/Quasar/Wayland/Protocol.hs b/src/Quasar/Wayland/Protocol.hs
index 24dea57..aeb1398 100644
--- a/src/Quasar/Wayland/Protocol.hs
+++ b/src/Quasar/Wayland/Protocol.hs
@@ -1,29 +1,172 @@
module Quasar.Wayland.Protocol (
ProtocolState,
+ ClientProtocolState,
+ initialClientProtocolState,
+ --ServerProtocolState,
+ --initialServerProtocolState,
+ Request,
+ Event,
initialProtocolState,
feedInput,
+ takeOutbox,
) where
+import Control.Monad.State (State)
+import Control.Monad.State qualified as State
+import Data.Binary.Get
+import Data.Binary.Put
+import Data.Bits ((.&.), (.|.), shiftL, shiftR)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as BSL
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
import Quasar.Prelude
import Quasar.Wayland.TH
$(generateWaylandProcol "protocols/wayland.xml")
-data ProtocolState = ProtocolState {
+type ObjectId = Word32
+type ObjectType = String
+type Opcode = Word16
+
+data Object = Object {
+ objectId :: ObjectId,
+ objectType :: ObjectType
+}
+
+
+data Argument
+ = IntArgument Int32
+ | UIntArgument Word32
+ -- TODO
+ | FixedArgument Void
+ | StringArgument String
+ | ObjectArgument ObjectId
+ | NewIdArgument ObjectId
+ | FdArgument ()
+
+argumentSize :: Argument -> Word16
+argumentSize (IntArgument _) = 4
+argumentSize (UIntArgument _) = 4
+argumentSize (ObjectArgument _) = 4
+argumentSize (NewIdArgument _) = 4
+argumentSize _ = undefined
+
+putArgument :: Argument -> Put
+putArgument (IntArgument x) = putInt32host x
+putArgument (UIntArgument x) = putWord32host x
+putArgument (ObjectArgument x) = putWord32host x
+putArgument (NewIdArgument x) = putWord32host x
+putArgument _ = undefined
+
+
+type ClientProtocolState = ProtocolState Request Event
+type ServerProtocolState = ProtocolState Event Request
+
+data ProtocolState up down = ProtocolState {
bytesReceived :: Word64,
- bytesSent :: Word64
+ bytesSent :: Word64,
+ parser :: Decoder down,
+ inboxDecoder :: Decoder down,
+ outbox :: Maybe Put,
+ objects :: HashMap ObjectId Object
}
-initialProtocolState :: ProtocolState
-initialProtocolState = ProtocolState {
+data Request = Request ObjectId Opcode BSL.ByteString
+ deriving stock Show
+data Event = Event ObjectId Opcode (Either BSL.ByteString (Word32, BSL.ByteString, Word32))
+ deriving stock Show
+
+initialClientProtocolState :: ClientProtocolState
+initialClientProtocolState = initialProtocolState decodeEvent
+
+initialProtocolState :: Get down -> ProtocolState up down
+initialProtocolState downGet = sendInitialMessage ProtocolState {
bytesReceived = 0,
- bytesSent = 0
+ bytesSent = 0,
+ parser = runGetIncremental downGet,
+ inboxDecoder = runGetIncremental downGet,
+ outbox = Nothing,
+ objects = HM.singleton 1 (Object 1 "wl_display")
}
-feedInput :: ByteString -> ProtocolState -> (ProtocolState)
-feedInput bytes oldState = oldState {
- bytesReceived = oldState.bytesReceived + fromIntegral (BS.length bytes)
+sendInitialMessage :: ProtocolState up down -> ProtocolState up down
+sendInitialMessage = sendMessage 1 1 [NewIdArgument 2]
+
+feedInput :: forall up down. ByteString -> ProtocolState up down -> ([down], ProtocolState up down)
+feedInput bytes = State.runState do
+ State.modify (receive bytes)
+ go
+ where
+ go :: State (ProtocolState up down) [down]
+ go = State.state takeDownMsg >>= \case
+ Nothing -> pure []
+ Just msg -> (msg :) <$> go
+
+
+receive :: forall up down. ByteString -> ProtocolState up down -> ProtocolState up down
+receive bytes state = state {
+ bytesReceived = state.bytesReceived + fromIntegral (BS.length bytes),
+ inboxDecoder = pushChunk state.inboxDecoder bytes
}
+
+takeDownMsg :: forall up down. ProtocolState up down -> (Maybe down, ProtocolState up down)
+takeDownMsg state = (result, state{inboxDecoder = newDecoder})
+ where
+ result :: Maybe down
+ newDecoder :: Decoder down
+ (result, newDecoder) = checkDecoder state.inboxDecoder
+ checkDecoder :: Decoder down -> (Maybe down, Decoder down)
+ checkDecoder (Fail _ _ _) = undefined
+ checkDecoder x@(Partial _) = (Nothing, x)
+ checkDecoder (Done leftovers _ result) = (Just result, pushChunk state.parser leftovers)
+
+
+decodeEvent :: Get Event
+decodeEvent = do
+ objectId <- getWord32host
+ sizeAndOpcode <- getWord32host
+ let
+ size = fromIntegral (sizeAndOpcode `shiftR` 16) - 8
+ opcode = fromIntegral (sizeAndOpcode .&. 0xFFFF)
+ body <- if (objectId == 2 && opcode == 0)
+ then Right <$> parseGlobal
+ else Left <$> getLazyByteString size <* skipPadding
+ pure $ Event objectId opcode body
+ where
+ parseGlobal :: Get (Word32, BSL.ByteString, Word32)
+ parseGlobal = (,,) <$> getWord32host <*> getWaylandString <*> getWord32host
+ getWaylandString :: Get BSL.ByteString
+ getWaylandString = do
+ size <- getWord32host
+ Just (string, 0) <- BSL.unsnoc <$> getLazyByteString (fromIntegral size)
+ skipPadding
+ pure string
+
+skipPadding :: Get ()
+skipPadding = do
+ bytes <- bytesRead
+ skip $ fromIntegral ((4 - (bytes `mod` 4)) `mod` 4)
+
+
+sendMessage :: ObjectId -> Opcode -> [Argument] -> ProtocolState up down -> ProtocolState up down
+sendMessage objectId opcode args = sendRaw do
+ putWord32host objectId
+ putWord32host $ (fromIntegral msgSize `shiftL` 16) .|. fromIntegral opcode
+ mapM_ putArgument args
+ -- TODO padding
+ where
+ msgSize :: Word16
+ msgSize = if msgSizeInteger <= fromIntegral (maxBound :: Word16) then fromIntegral msgSizeInteger else undefined
+ msgSizeInteger :: Integer
+ msgSizeInteger = foldr ((+) . (fromIntegral . argumentSize)) 8 args :: Integer
+
+sendRaw :: Put -> ProtocolState up down -> ProtocolState up down
+sendRaw put oldState = oldState {
+ outbox = Just (maybe put (<> put) oldState.outbox)
+}
+
+takeOutbox :: ProtocolState up down -> (Maybe BSL.ByteString, ProtocolState up down)
+takeOutbox state = (runPut <$> state.outbox, state{outbox = Nothing})
diff --git a/src/Quasar/Wayland/TH.hs b/src/Quasar/Wayland/TH.hs
index 9d8943b..c76b8d6 100644
--- a/src/Quasar/Wayland/TH.hs
+++ b/src/Quasar/Wayland/TH.hs
@@ -11,35 +11,81 @@ import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax (addDependentFile)
+
generateWaylandProcol :: FilePath -> Q [Dec]
generateWaylandProcol protocolFile = do
addDependentFile protocolFile
xml <- liftIO (BS.readFile protocolFile)
- protocol <- loadProtocol xml
+ protocol <- parseProtocol xml
- traceIO $ show $ (.name) <$> (interfaces protocol)
+ traceIO $ show $ interfaces protocol
pure []
+type Opcode = Word16
+
data Protocol = Protocol {interfaces :: [Interface]}
- deriving (Show)
-data Interface = Interface { name :: String }
- deriving (Show)
-
-loadProtocol :: MonadFail m => BS.ByteString -> m Protocol
-loadProtocol xml = do
- (Just protocolEl) <- pure $ parseXMLDoc xml
- interfaces <- mapM loadInterface $ findChildren (blank_name { qName = "interface" }) protocolEl
- pure $ Protocol interfaces
-
-loadInterface :: MonadFail m => Element -> m Interface
-loadInterface interfaceEl = do
- name <- interfaceName
- pure $ Interface name
- where
- interfaceName :: MonadFail m => m String
- interfaceName = do
- (Just name) <- pure $ findAttr (blank_name { qName = "name" }) interfaceEl
- pure name
+ deriving stock (Show)
+
+data Interface = Interface {
+ name :: String,
+ requests :: [Request],
+ events :: [Event]
+}
+ deriving stock (Show)
+
+data Request = Request {
+ name :: String,
+ opcode :: Opcode
+}
+ deriving stock (Show)
+
+data Event = Event {
+ name :: String,
+ opcode :: Opcode
+}
+ deriving stock (Show)
+
+parseProtocol :: MonadFail m => BS.ByteString -> m Protocol
+parseProtocol xml = do
+ (Just element) <- pure $ parseXMLDoc xml
+ interfaces <- mapM parseInterface $ findChildren (blank_name { qName = "interface" }) element
+ pure Protocol {
+ interfaces
+ }
+
+parseInterface :: MonadFail m => Element -> m Interface
+parseInterface element = do
+ name <- getAttr "name" element
+ requests <- mapM parseRequest $ zip [0..] $ findChildren (qname "request") element
+ events <- mapM parseEvent $ zip [0..] $ findChildren (qname "events") element
+ pure Interface {
+ name,
+ requests,
+ events
+ }
+
+parseRequest :: MonadFail m => (Opcode, Element) -> m Request
+parseRequest (opcode, element) = do
+ name <- getAttr "name" element
+ pure Request {
+ name,
+ opcode
+ }
+
+parseEvent :: MonadFail m => (Opcode, Element) -> m Event
+parseEvent (opcode, element) = do
+ name <- getAttr "name" element
+ pure Event {
+ name,
+ opcode
+ }
+
+qname :: String -> QName
+qname name = blank_name { qName = name }
+getAttr :: MonadFail m => String -> Element -> m String
+getAttr name element = do
+ (Just value) <- pure $ findAttr (qname name) element
+ pure value
--
GitLab