From f2f5def1d782d8409c8d35b3a13d0f978a25a995 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Sun, 5 Sep 2021 22:51:41 +0200
Subject: [PATCH] Add send- and receive thread
---
quasar-wayland.cabal | 2 +-
src/Quasar/Wayland/Client.hs | 39 +++++++++++++++++++++++++++++++++---
2 files changed, 37 insertions(+), 4 deletions(-)
diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal
index 77ff807..63d666c 100644
--- a/quasar-wayland.cabal
+++ b/quasar-wayland.cabal
@@ -98,7 +98,7 @@ library
template-haskell,
--unix,
--unordered-containers,
- --stm,
+ stm,
xml,
-- required for record-dot-preprocessor
record-dot-preprocessor,
diff --git a/src/Quasar/Wayland/Client.hs b/src/Quasar/Wayland/Client.hs
index 3d055a8..0a3d3c3 100644
--- a/src/Quasar/Wayland/Client.hs
+++ b/src/Quasar/Wayland/Client.hs
@@ -3,17 +3,21 @@ module Quasar.Wayland.Client (
newWaylandClient,
) where
+import Control.Concurrent.STM
import Control.Monad.Catch
-import Network.Socket qualified as Socket
import Network.Socket (Socket)
+import Network.Socket qualified as Socket
+import Network.Socket.ByteString qualified as Socket
import Quasar
import Quasar.Prelude
+import Quasar.Wayland.Protocol
import System.Environment (getEnv, lookupEnv)
import System.FilePath ((</>), isRelative)
import Text.Read (readEither)
data WaylandClient = WaylandClient {
+ protocolStateVar :: TVar ProtocolState,
socket :: Socket,
resourceManager :: ResourceManager
}
@@ -26,14 +30,43 @@ instance IsDisposable WaylandClient where
newWaylandClient :: MonadResourceManager m => Socket -> m WaylandClient
newWaylandClient socket = do
+ protocolStateVar <- liftIO $ newTVarIO initialProtocolState
resourceManager <- newResourceManager
+
onResourceManager resourceManager do
- registerDisposeAction (pure () <$ Socket.close socket)
- pure WaylandClient {
+ let client = WaylandClient {
+ protocolStateVar,
socket,
resourceManager
}
+ registerDisposeAction $ closeWaylandClient client
+
+ runUnlimitedAsync do
+ async $ liftIO $ waylandClientSendThread client
+ async $ liftIO $ waylandClientReceiveThread client
+
+ pure client
+
+waylandClientSendThread :: WaylandClient -> IO ()
+waylandClientSendThread client = forever do
+ undefined
+
+waylandClientReceiveThread :: WaylandClient -> IO ()
+waylandClientReceiveThread client = forever do
+ bytes <- Socket.recv client.socket 4096
+ traceIO $ "Received data"
+ atomically $ modifyTVar client.protocolStateVar $ feedInput bytes
+
+ state <- atomically $ readTVar client.protocolStateVar
+ traceIO $ show state.bytesReceived
+
+closeWaylandClient :: WaylandClient -> IO (Awaitable ())
+closeWaylandClient client = isDisposed <$> forkTask do
+ -- gracefulClose may fail but guarantees that the socket is deallocated
+ Socket.gracefulClose client.socket 2000 `catch` \(_ :: SomeException) -> pure ()
+
+
connectWaylandClient :: MonadResourceManager m => m WaylandClient
connectWaylandClient = mask_ do
socket <- liftIO connectWaylandSocket
--
GitLab