From 842d60b134c0fd60f734adf68829a24e22c9cb3f Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Tue, 14 Dec 2021 18:04:57 +0100
Subject: [PATCH] Move wl_display and wl_registry implementation to client
module
This simplifies cyclic dependencies for now (the registry needs to call
wl_display.sync).
---
quasar-wayland.cabal | 3 +-
src/Quasar/Wayland/Client.hs | 107 +++++++++++++++++++---------
src/Quasar/Wayland/Client/Socket.hs | 43 +++++++++++
src/Quasar/Wayland/Display.hs | 36 ----------
src/Quasar/Wayland/Registry.hs | 45 ------------
5 files changed, 118 insertions(+), 116 deletions(-)
create mode 100644 src/Quasar/Wayland/Client/Socket.hs
delete mode 100644 src/Quasar/Wayland/Display.hs
delete mode 100644 src/Quasar/Wayland/Registry.hs
diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal
index 1c5bdc3..ebb8ae0 100644
--- a/quasar-wayland.cabal
+++ b/quasar-wayland.cabal
@@ -75,13 +75,12 @@ library
import: shared-properties
exposed-modules:
Quasar.Wayland.Client
+ Quasar.Wayland.Client.Socket
Quasar.Wayland.Connection
- Quasar.Wayland.Display
Quasar.Wayland.Protocol
Quasar.Wayland.Protocol.Display
Quasar.Wayland.Protocol.Generated
Quasar.Wayland.Protocol.TH
- Quasar.Wayland.Registry
other-modules:
Quasar.Wayland.Protocol.Core
build-depends:
diff --git a/src/Quasar/Wayland/Client.hs b/src/Quasar/Wayland/Client.hs
index 9544447..c9bcf13 100644
--- a/src/Quasar/Wayland/Client.hs
+++ b/src/Quasar/Wayland/Client.hs
@@ -3,19 +3,29 @@ module Quasar.Wayland.Client (
connectWaylandClient,
newWaylandClient,
connectWaylandSocket,
+
+ -- * wl_display
+ ClientDisplay,
+ newClientDisplay,
+
+ -- * wl_registry
+ ClientRegistry,
+ createClientRegistry,
) where
+import Control.Concurrent.STM
import Control.Monad.Catch
+import Data.HashMap.Strict qualified as HM
+import Data.Tuple (swap)
+import GHC.Records
import Network.Socket (Socket)
-import Network.Socket qualified as Socket
import Quasar
import Quasar.Prelude
+import Quasar.Wayland.Client.Socket
import Quasar.Wayland.Connection
-import Quasar.Wayland.Display
import Quasar.Wayland.Protocol
-import System.Environment (getEnv, lookupEnv)
-import System.FilePath ((</>), isRelative)
-import Text.Read (readEither)
+import Quasar.Wayland.Protocol.Display
+import Quasar.Wayland.Protocol.Generated
data WaylandClient = WaylandClient {
@@ -42,33 +52,64 @@ connectWaylandClient = mask_ do
socket <- liftIO connectWaylandSocket
newWaylandClient socket
-connectWaylandSocket :: IO Socket
-connectWaylandSocket = do
- lookupEnv "WAYLAND_SOCKET" >>= \case
- -- Parent process already established connection
- Just waylandSocketEnv -> do
- case readEither waylandSocketEnv of
- Left err -> fail $ "Failed to parse WAYLAND_SOCKET: " <> err
- Right fd -> Socket.mkSocket fd
- Nothing -> do
- path <- getWaylandSocketPath
- newUnixSocket path
+
+-- * wl_display
+
+data ClientDisplay = ClientDisplay {
+ wlDisplay :: Object 'Client Interface_wl_display,
+ registry :: ClientRegistry
+}
+
+newClientDisplay :: STM (ClientDisplay, ProtocolHandle 'Client)
+newClientDisplay =
+ initializeProtocol wlDisplayEventHandler \wlDisplay -> do
+ registry <- createClientRegistry wlDisplay
+ pure ClientDisplay {
+ wlDisplay,
+ registry
+ }
+
+instance HasField "sync" ClientDisplay (STM (Awaitable ())) where
+ getField display = do
+ var <- newAsyncVarSTM
+ wlCallback <- display.wlDisplay.sync
+ setEventHandler wlCallback EventHandler_wl_callback {
+ done = const $ putAsyncVarSTM_ var ()
+ }
+ pure $ toAwaitable var
+
+
+
+-- * wl_registry
+
+data ClientRegistry = ClientRegistry {
+ wlRegistry :: Object 'Client Interface_wl_registry,
+ globalsVar :: TVar (HM.HashMap Word32 (WlString, Word32))
+}
+
+createClientRegistry :: Object 'Client Interface_wl_display -> STM ClientRegistry
+createClientRegistry wlDisplay = mfix \clientRegistry -> do
+ globalsVar <- newTVar HM.empty
+
+ wlRegistry <- wlDisplay.get_registry
+ setMessageHandler wlRegistry (messageHandler clientRegistry)
+
+ pure ClientRegistry {
+ wlRegistry,
+ globalsVar
+ }
where
- getWaylandSocketPath :: IO FilePath
- getWaylandSocketPath = do
- waylandDisplayEnv <- lookupEnv "WAYLAND_DISPLAY"
- let waylandDisplay = fromMaybe "wayland-0" waylandDisplayEnv
- if isRelative waylandDisplay
- then do
- xdgRuntimeDir <- getEnv "XDG_RUNTIME_DIR"
- pure (xdgRuntimeDir </> waylandDisplay)
- else
- pure waylandDisplay
-
- newUnixSocket :: FilePath -> IO Socket
- newUnixSocket socketPath =
- bracketOnError (Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol) Socket.close $ \sock -> do
- Socket.withFdSocket sock Socket.setCloseOnExecIfNeeded
- Socket.connect sock $ Socket.SockAddrUnix socketPath
- pure sock
+ messageHandler :: ClientRegistry -> EventHandler_wl_registry
+ messageHandler clientRegistry = EventHandler_wl_registry { global, global_remove }
+ where
+ global :: Word32 -> WlString -> Word32 -> STM ()
+ global name interface version = do
+ modifyTVar clientRegistry.globalsVar (HM.insert name (interface, version))
+
+ global_remove :: Word32 -> STM ()
+ global_remove name = do
+ result <- stateTVar clientRegistry.globalsVar (swap . lookupDelete name)
+ case result of
+ Nothing -> traceM $ "Invalid global removed by server: " <> show name
+ Just (interface, version) -> pure ()
diff --git a/src/Quasar/Wayland/Client/Socket.hs b/src/Quasar/Wayland/Client/Socket.hs
new file mode 100644
index 0000000..106ce3f
--- /dev/null
+++ b/src/Quasar/Wayland/Client/Socket.hs
@@ -0,0 +1,43 @@
+module Quasar.Wayland.Client.Socket (
+ connectWaylandSocket
+) where
+
+import Control.Monad.Catch
+import Network.Socket (Socket)
+import Network.Socket qualified as Socket
+import Quasar.Prelude
+import System.Environment (getEnv, lookupEnv)
+import System.FilePath ((</>), isRelative)
+import Text.Read (readEither)
+
+
+connectWaylandSocket :: IO Socket
+connectWaylandSocket = do
+ lookupEnv "WAYLAND_SOCKET" >>= \case
+ -- Parent process already established connection
+ Just waylandSocketEnv -> do
+ case readEither waylandSocketEnv of
+ Left err -> fail $ "Failed to parse WAYLAND_SOCKET: " <> err
+ Right fd -> Socket.mkSocket fd
+ Nothing -> do
+ path <- getWaylandSocketPath
+ newUnixSocket path
+
+ where
+ getWaylandSocketPath :: IO FilePath
+ getWaylandSocketPath = do
+ waylandDisplayEnv <- lookupEnv "WAYLAND_DISPLAY"
+ let waylandDisplay = fromMaybe "wayland-0" waylandDisplayEnv
+ if isRelative waylandDisplay
+ then do
+ xdgRuntimeDir <- getEnv "XDG_RUNTIME_DIR"
+ pure (xdgRuntimeDir </> waylandDisplay)
+ else
+ pure waylandDisplay
+
+ newUnixSocket :: FilePath -> IO Socket
+ newUnixSocket socketPath =
+ bracketOnError (Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol) Socket.close $ \sock -> do
+ Socket.withFdSocket sock Socket.setCloseOnExecIfNeeded
+ Socket.connect sock $ Socket.SockAddrUnix socketPath
+ pure sock
diff --git a/src/Quasar/Wayland/Display.hs b/src/Quasar/Wayland/Display.hs
deleted file mode 100644
index 8350525..0000000
--- a/src/Quasar/Wayland/Display.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-module Quasar.Wayland.Display (
- ClientDisplay,
- newClientDisplay,
-) where
-
-import Control.Concurrent.STM
-import GHC.Records
-import Quasar.Awaitable
-import Quasar.Prelude
-import Quasar.Wayland.Protocol
-import Quasar.Wayland.Protocol.Display
-import Quasar.Wayland.Protocol.Generated
-import Quasar.Wayland.Registry
-
-data ClientDisplay = ClientDisplay {
- wlDisplay :: Object 'Client Interface_wl_display,
- registry :: ClientRegistry
-}
-
-newClientDisplay :: STM (ClientDisplay, ProtocolHandle 'Client)
-newClientDisplay =
- initializeProtocol wlDisplayEventHandler \wlDisplay -> do
- registry <- createClientRegistry wlDisplay
- pure ClientDisplay {
- wlDisplay,
- registry
- }
-
-instance HasField "sync" ClientDisplay (STM (Awaitable ())) where
- getField display = do
- var <- newAsyncVarSTM
- wlCallback <- display.wlDisplay.sync
- setEventHandler wlCallback EventHandler_wl_callback {
- done = const $ putAsyncVarSTM_ var ()
- }
- pure $ toAwaitable var
diff --git a/src/Quasar/Wayland/Registry.hs b/src/Quasar/Wayland/Registry.hs
deleted file mode 100644
index 9b8b798..0000000
--- a/src/Quasar/Wayland/Registry.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-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.HashMap.Strict qualified as HM
-import Data.Tuple (swap)
-import Quasar.Prelude
-import Quasar.Wayland.Protocol
-import Quasar.Wayland.Protocol.Generated
-
-data ClientRegistry = ClientRegistry {
- wlRegistry :: Object 'Client Interface_wl_registry,
- globalsVar :: TVar (HM.HashMap Word32 (WlString, Word32))
-}
-
-createClientRegistry :: Object 'Client Interface_wl_display -> STM ClientRegistry
-createClientRegistry wlDisplay = mfix \clientRegistry -> do
- globalsVar <- newTVar HM.empty
-
- wlRegistry <- wlDisplay.get_registry
- setMessageHandler wlRegistry (messageHandler clientRegistry)
-
- pure ClientRegistry {
- wlRegistry,
- globalsVar
- }
- where
- messageHandler :: ClientRegistry -> EventHandler_wl_registry
- messageHandler clientRegistry = EventHandler_wl_registry { global, global_remove }
- where
- global :: Word32 -> WlString -> Word32 -> STM ()
- global name interface version = do
- modifyTVar clientRegistry.globalsVar (HM.insert name (interface, version))
-
- global_remove :: Word32 -> STM ()
- global_remove name = do
- result <- stateTVar clientRegistry.globalsVar (swap . lookupDelete name)
- case result of
- Nothing -> traceM $ "Invalid global removed by server: " <> show name
- Just (interface, version) -> pure ()
--
GitLab