Parse received messages

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

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

src/Quasar/Wayland/Protocol.hs

 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})

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