Add connection to generalize client/server, update for new types

quasar-wayland.cabal

@@ -84,6 +84,7 @@ library
   import: shared-properties
   exposed-modules:
     Quasar.Wayland.Client
+    Quasar.Wayland.Connection
     Quasar.Wayland.Core
     Quasar.Wayland.Protocol
     Quasar.Wayland.TH

src/Quasar/Wayland/Client.hs

@@ -5,12 +5,16 @@ module Quasar.Wayland.Client (
 
 import Control.Concurrent.STM
 import Control.Monad.Catch
+import Control.Monad.State (StateT, lift, runStateT, execStateT)
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as BSL
 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.Connection
 import Quasar.Wayland.Core
 import Quasar.Wayland.Protocol
 import System.Environment (getEnv, lookupEnv)
@@ -18,67 +22,21 @@ import System.FilePath ((</>), isRelative)
 import Text.Read (readEither)
 
 
-data WaylandClient = WaylandClient {
-  protocolStateVar :: TVar ClientProtocolState,
-  socket :: Socket,
-  resourceManager :: ResourceManager
-}
+data WaylandClient = WaylandClient (WaylandConnection 'Client)
 
 instance IsResourceManager WaylandClient where
-  toResourceManager client = client.resourceManager
+  toResourceManager (WaylandClient connection) = toResourceManager connection
 
 instance IsDisposable WaylandClient where
-  toDisposable client = toDisposable client.resourceManager
+  toDisposable (WaylandClient connection) = toDisposable connection
 
 newWaylandClient :: MonadResourceManager m => Socket -> m WaylandClient
-newWaylandClient socket = do
-  protocolStateVar <- liftIO $ newTVarIO initialClientProtocolState
-  resourceManager <- newResourceManager
-
-  onResourceManager resourceManager do
-    let client = WaylandClient {
-      protocolStateVar,
-      socket,
-      resourceManager
-    }
-
-    registerDisposeAction $ closeWaylandClient client
-
-    runUnlimitedAsync do
-      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
-  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"
-  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
-
-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 ()
+newWaylandClient socket = WaylandClient <$> newWaylandConnection wlDisplayCallback socket
 
+wlDisplayCallback :: ClientCallback STM I_wl_display
+wlDisplayCallback = Callback {
+  messageCallback = \_ _ -> lift $ traceM "Callback called"
+}
 
 connectWaylandClient :: MonadResourceManager m => m WaylandClient
 connectWaylandClient = mask_ do

src/Quasar/Wayland/Connection.hs

+module Quasar.Wayland.Connection (
+  WaylandConnection,
+  newWaylandConnection,
+) where
+
+import Control.Concurrent.STM
+import Control.Monad.Catch
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as BSL
+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.Core
+import Quasar.Wayland.Protocol
+
+
+data WaylandConnection s = WaylandConnection {
+  protocolStateVar :: TVar (ProtocolState s STM),
+  outboxVar :: TMVar BSL.ByteString,
+  socket :: Socket,
+  resourceManager :: ResourceManager
+}
+
+instance IsResourceManager (WaylandConnection s) where
+  toResourceManager connection = connection.resourceManager
+
+instance IsDisposable (WaylandConnection s) where
+  toDisposable connection = toDisposable connection.resourceManager
+
+newWaylandConnection :: forall s m. MonadResourceManager m => Callback s STM I_wl_display -> Socket -> m (WaylandConnection s)
+newWaylandConnection wlDisplayCallback socket = do
+  protocolStateVar <- liftIO $ newTVarIO $ initialProtocolState wlDisplayCallback
+  outboxVar <- liftIO newEmptyTMVarIO
+
+  resourceManager <- newResourceManager
+
+  onResourceManager resourceManager do
+    let connection = WaylandConnection {
+      protocolStateVar,
+      outboxVar,
+      socket,
+      resourceManager
+    }
+
+    registerDisposeAction $ closeConnection connection
+
+    runUnlimitedAsync do
+      async $ liftIO $ waylandConnectionSendThread connection `catchAll` \ex -> traceIO (displayException ex) >> void (dispose resourceManager)
+      async $ liftIO $ waylandConnectionReceiveThread connection `catchAll` \ex -> traceIO (displayException ex) >> void (dispose resourceManager)
+
+    -- HACK to send first message (queued internally)
+    stepProtocol connection $ feedInput ""
+
+    pure connection
+
+stepProtocol :: forall s m a. MonadIO m => WaylandConnection s -> ProtocolStep s STM a -> m a
+stepProtocol connection step = liftIO do
+  result <- atomically do
+    oldState <- readTVar connection.protocolStateVar
+    (result, outBytes, newState) <- step oldState
+    writeTVar connection.protocolStateVar newState
+    mapM_ (putTMVar connection.outboxVar) outBytes
+    pure result
+  case result of
+    Left ex -> throwM (ex :: SomeException)
+    Right result -> pure result
+
+
+waylandConnectionSendThread :: WaylandConnection s -> IO ()
+waylandConnectionSendThread connection = forever do
+  bytes <- atomically $ takeTMVar connection.outboxVar
+
+  traceIO $ "Sending data: " <> show (BSL.length bytes) <> " bytes"
+  SocketL.sendAll connection.socket bytes
+
+
+waylandConnectionReceiveThread :: WaylandConnection s -> IO ()
+waylandConnectionReceiveThread connection = forever do
+  bytes <- Socket.recv connection.socket 4096
+
+  when (BS.length bytes == 0) do
+    fail "Socket is closed"
+
+  traceIO $ "Received " <> show (BS.length bytes) <> " bytes"
+
+  stepProtocol connection $ feedInput bytes
+
+closeConnection :: WaylandConnection s -> IO (Awaitable ())
+closeConnection connection = do
+  -- gracefulClose may fail but guarantees that the socket is deallocated
+  Socket.close connection.socket `catch` \(_ :: SomeException) -> pure ()
+  pure $ pure ()