From 0b8a0f7cc834e5f5bc03388f7fc5cd9e1bde2921 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Thu, 16 Sep 2021 21:43:07 +0200
Subject: [PATCH] Add ClientDisplay and ClientRegistry types, wrapping protocol
 internals

---
 quasar-wayland.cabal                   |  3 ++
 src/Quasar/Wayland/Client.hs           | 18 +++++++----
 src/Quasar/Wayland/Connection.hs       | 15 ++++-----
 src/Quasar/Wayland/Display.hs          | 30 +++++++++++++++++
 src/Quasar/Wayland/Protocol.hs         | 32 ------------------
 src/Quasar/Wayland/Protocol/Display.hs | 26 +++++++++++++++
 src/Quasar/Wayland/Registry.hs         | 45 ++++++++++++++++++++++++++
 7 files changed, 123 insertions(+), 46 deletions(-)
 create mode 100644 src/Quasar/Wayland/Display.hs
 create mode 100644 src/Quasar/Wayland/Protocol/Display.hs
 create mode 100644 src/Quasar/Wayland/Registry.hs

diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal
index 4a053b4..555283e 100644
--- a/quasar-wayland.cabal
+++ b/quasar-wayland.cabal
@@ -85,10 +85,13 @@ library
   exposed-modules:
     Quasar.Wayland.Client
     Quasar.Wayland.Connection
+    Quasar.Wayland.Display
     Quasar.Wayland.Protocol
     Quasar.Wayland.Protocol.Core
+    Quasar.Wayland.Protocol.Display
     Quasar.Wayland.Protocol.Generated
     Quasar.Wayland.Protocol.TH
+    Quasar.Wayland.Registry
   build-depends:
     base >=4.7 && <5,
     binary,
diff --git a/src/Quasar/Wayland/Client.hs b/src/Quasar/Wayland/Client.hs
index 7e8bccb..8ecd959 100644
--- a/src/Quasar/Wayland/Client.hs
+++ b/src/Quasar/Wayland/Client.hs
@@ -1,4 +1,5 @@
 module Quasar.Wayland.Client (
+  WaylandClient(display),
   connectWaylandClient,
   newWaylandClient,
   connectWaylandSocket,
@@ -11,6 +12,8 @@ import Network.Socket qualified as Socket
 import Quasar
 import Quasar.Prelude
 import Quasar.Wayland.Connection
+import Quasar.Wayland.Display
+import Quasar.Wayland.Protocol
 import Quasar.Wayland.Protocol.Core
 import Quasar.Wayland.Protocol.Generated
 import System.Environment (getEnv, lookupEnv)
@@ -18,7 +21,10 @@ import System.FilePath ((</>), isRelative)
 import Text.Read (readEither)
 
 
-data WaylandClient = WaylandClient (WaylandConnection 'Client) (Object 'Client I_wl_display)
+data WaylandClient = WaylandClient {
+  connection :: WaylandConnection 'Client,
+  display :: ClientDisplay
+}
 
 instance IsResourceManager WaylandClient where
   toResourceManager (WaylandClient connection _) = toResourceManager connection
@@ -28,11 +34,11 @@ instance IsDisposable WaylandClient where
 
 newWaylandClient :: MonadResourceManager m => Socket -> m WaylandClient
 newWaylandClient socket = do
-  (connection, wlDisplay) <- newWaylandConnection @I_wl_display (traceCallback ignoreMessage) socket
-
-  (_wlRegistry, newId) <- runProtocolM connection.protocolHandle $ newObject @'Client @I_wl_registry (traceCallback ignoreMessage)
-  runProtocolM connection.protocolHandle $ sendMessage wlDisplay $ R_wl_display_get_registry newId
-  pure $ WaylandClient connection wlDisplay
+  (display, connection) <- newWaylandConnection newClientDisplay socket
+  pure WaylandClient {
+    connection,
+    display
+  }
 
 connectWaylandClient :: MonadResourceManager m => m WaylandClient
 connectWaylandClient = mask_ do
diff --git a/src/Quasar/Wayland/Connection.hs b/src/Quasar/Wayland/Connection.hs
index 6013a7a..5246d68 100644
--- a/src/Quasar/Wayland/Connection.hs
+++ b/src/Quasar/Wayland/Connection.hs
@@ -1,5 +1,5 @@
 module Quasar.Wayland.Connection (
-  WaylandConnection(protocolHandle),
+  WaylandConnection,
   newWaylandConnection,
 ) where
 
@@ -14,7 +14,6 @@ import Network.Socket.ByteString.Lazy qualified as SocketL
 import Quasar
 import Quasar.Prelude
 import Quasar.Wayland.Protocol.Core
-import Quasar.Wayland.Protocol.Generated
 
 
 data WaylandConnection s = WaylandConnection {
@@ -34,12 +33,12 @@ data SocketClosed = SocketClosed
   deriving anyclass Exception
 
 newWaylandConnection
-  :: forall wl_display s m. (IsInterfaceSide s wl_display, MonadResourceManager m)
-  => Callback s wl_display
+  :: forall s m a. (IsSide s, MonadResourceManager m)
+  => STM (a, ProtocolHandle s)
   -> Socket
-  -> m (WaylandConnection s, Object s wl_display)
-newWaylandConnection wlDisplayCallback socket = do
-  (wlDisplay, protocolHandle) <- liftIO $ atomically $ initializeProtocol wlDisplayCallback pure
+  -> m (a, WaylandConnection s)
+newWaylandConnection initializeProtocolAction socket = do
+  (result, protocolHandle) <- liftIO $ atomically $ initializeProtocolAction
 
   resourceManager <- newResourceManager
 
@@ -56,7 +55,7 @@ newWaylandConnection wlDisplayCallback socket = do
       connectionThread connection $ sendThread connection
       connectionThread connection $ receiveThread connection
 
-    pure (connection, wlDisplay)
+    pure (result, connection)
 
 connectionThread :: MonadAsync m => WaylandConnection s -> IO () -> m ()
 connectionThread connection work = async_ $ liftIO $ work `catches` [ignoreCancelTask, handleAll]
diff --git a/src/Quasar/Wayland/Display.hs b/src/Quasar/Wayland/Display.hs
new file mode 100644
index 0000000..5c2fbb5
--- /dev/null
+++ b/src/Quasar/Wayland/Display.hs
@@ -0,0 +1,30 @@
+module Quasar.Wayland.Display (
+  ClientDisplay,
+  newClientDisplay,
+) where
+
+import Control.Concurrent.STM
+import Control.Monad.Catch
+import Data.ByteString.UTF8 qualified as BS
+import Data.HashMap.Strict qualified as HM
+import Quasar.Prelude
+import Quasar.Wayland.Protocol.Core
+import Quasar.Wayland.Protocol.Display
+import Quasar.Wayland.Protocol.Generated
+import Quasar.Wayland.Registry
+
+data ClientDisplay = ClientDisplay {
+  wlDisplay :: Object 'Client I_wl_display,
+  registry :: ClientRegistry
+}
+
+newClientDisplay
+  :: (IsInterfaceSide 'Client I_wl_display)
+  => STM (ClientDisplay, ProtocolHandle 'Client)
+newClientDisplay =
+  initializeProtocol clientWlDisplayCallback \wlDisplay -> do
+    registry <- createClientRegistry wlDisplay
+    pure ClientDisplay {
+      wlDisplay,
+      registry
+    }
diff --git a/src/Quasar/Wayland/Protocol.hs b/src/Quasar/Wayland/Protocol.hs
index e770a3d..e0b431c 100644
--- a/src/Quasar/Wayland/Protocol.hs
+++ b/src/Quasar/Wayland/Protocol.hs
@@ -1,34 +1,2 @@
 module Quasar.Wayland.Protocol (
-  -- * A pure implementation of the Wayland wire protocol
-  createClientStateWithRegistry
 ) where
-
-import Control.Concurrent.STM
-import Control.Monad.Catch
-import Control.Monad.State (StateT, runStateT)
-import Data.ByteString.UTF8 (toString)
-import Quasar.Prelude
-import Quasar.Wayland.Protocol.Core
-import Quasar.Wayland.Protocol.Generated
-
-
-createClientStateWithRegistry :: STM (ProtocolHandle 'Client)
-createClientStateWithRegistry = do
-  (wlRegistry, protocolHandle) <- initializeProtocol wlDisplayCallback createRegistry
-  pure protocolHandle
-  where
-    createRegistry :: Object 'Client I_wl_display -> ProtocolM 'Client (Object 'Client I_wl_registry)
-    createRegistry wlDisplay = do
-      (wlRegistry, newId) <- newObject @'Client @I_wl_registry (traceCallback ignoreMessage)
-      sendMessage wlDisplay $ R_wl_display_get_registry newId
-
-      pure wlRegistry
-
-    wlDisplayCallback :: IsInterfaceSide 'Client I_wl_display => Callback 'Client I_wl_display
-    wlDisplayCallback = internalFnCallback handler
-      where
-        -- | wl_display is specified to never change, so manually specifying the callback is safe
-        handler :: Object 'Client I_wl_display -> E_wl_display -> ProtocolM 'Client ()
-        -- TODO parse oId
-        handler _ (E_wl_display_error oId code message) = throwM $ ServerError code (toString message)
-        handler _ (E_wl_display_delete_id deletedId) = pure () -- TODO confirm delete
diff --git a/src/Quasar/Wayland/Protocol/Display.hs b/src/Quasar/Wayland/Protocol/Display.hs
new file mode 100644
index 0000000..0a0bf17
--- /dev/null
+++ b/src/Quasar/Wayland/Protocol/Display.hs
@@ -0,0 +1,26 @@
+module Quasar.Wayland.Protocol.Display (
+  clientWlDisplayCallback,
+) where
+
+import Control.Concurrent.STM
+import Control.Monad.Catch
+import Data.ByteString.UTF8 qualified as BS
+import Data.HashMap.Strict qualified as HM
+import Quasar.Prelude
+import Quasar.Wayland.Protocol.Core
+import Quasar.Wayland.Protocol.Generated
+import Quasar.Wayland.Registry
+
+
+-- | Default implementation for @wl_display@ that handles errors and confirms deleted object ids.
+--
+-- This is only required when manually managing the @wl_display@ interface (usually it's applied by
+-- 'Quasar.Wayland.Display.newClientDisplay').
+clientWlDisplayCallback :: IsInterfaceSide 'Client I_wl_display => Callback 'Client I_wl_display
+clientWlDisplayCallback = internalFnCallback handler
+  where
+    -- | wl_display is specified to never change, so manually specifying the callback is safe
+    handler :: Object 'Client I_wl_display -> E_wl_display -> ProtocolM 'Client ()
+    -- TODO parse oId
+    handler _ (E_wl_display_error oId code message) = throwM $ ServerError code (BS.toString message)
+    handler _ (E_wl_display_delete_id deletedId) = pure () -- TODO confirm delete
diff --git a/src/Quasar/Wayland/Registry.hs b/src/Quasar/Wayland/Registry.hs
new file mode 100644
index 0000000..0e47877
--- /dev/null
+++ b/src/Quasar/Wayland/Registry.hs
@@ -0,0 +1,45 @@
+module Quasar.Wayland.Registry (
+  ClientRegistry,
+  createClientRegistry,
+) where
+
+import Control.Concurrent.STM
+import Control.Monad.Fix (mfix)
+import Control.Monad.Reader (lift)
+import Data.ByteString qualified as BS
+import Data.ByteString.UTF8 qualified as BS
+import Data.HashMap.Strict qualified as HM
+import Data.Tuple (swap)
+import Quasar.Prelude
+import Quasar.Wayland.Protocol.Core
+import Quasar.Wayland.Protocol.Generated
+
+data ClientRegistry = ClientRegistry {
+  wlRegistry :: Object 'Client I_wl_registry,
+  globalsVar :: TVar (HM.HashMap Word32 (BS.ByteString, Word32))
+}
+
+createClientRegistry :: Object 'Client I_wl_display -> ProtocolM 'Client ClientRegistry
+createClientRegistry wlDisplay = mfix \clientRegistry -> do
+  globalsVar <- lift $ newTVar HM.empty
+
+  (wlRegistry, newId) <- newObject @'Client @I_wl_registry (traceCallback (callback clientRegistry))
+  sendMessage wlDisplay $ R_wl_display_get_registry newId
+
+  pure ClientRegistry {
+    wlRegistry,
+    globalsVar
+  }
+  where
+    callback :: ClientRegistry -> IsInterfaceSide 'Client I_wl_registry => Callback 'Client I_wl_registry
+    callback clientRegistry = internalFnCallback handler
+      where
+        -- | wl_registry is specified to never change, so manually specifying the callback is safe
+        handler :: Object 'Client I_wl_registry -> E_wl_registry -> ProtocolM 'Client ()
+        handler _ (E_wl_registry_global name interface version) = do
+          lift $ modifyTVar clientRegistry.globalsVar (HM.insert name (interface, version))
+        handler _ (E_wl_registry_global_remove name) = do
+          result <- lift $ stateTVar clientRegistry.globalsVar (swap . lookupDelete name)
+          case result of
+            Nothing -> traceM $ "Invalid global removed by server: " <> show name
+            Just (interface, version) -> pure ()
-- 
GitLab