From 6a60ce384b49bb8900b32f533300ad0a08a0fc01 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Sun, 5 Sep 2021 21:40:09 +0200
Subject: [PATCH] Connect to wayland socket
---
quasar-wayland.cabal | 4 ++-
src/Quasar/Wayland/Client.hs | 70 ++++++++++++++++++++++++++++++++++++
2 files changed, 73 insertions(+), 1 deletion(-)
create mode 100644 src/Quasar/Wayland/Client.hs
diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal
index 59a9904..61b0156 100644
--- a/quasar-wayland.cabal
+++ b/quasar-wayland.cabal
@@ -83,6 +83,7 @@ common shared-executable-properties
library
import: shared-properties
exposed-modules:
+ Quasar.Wayland.Client
Quasar.Wayland.Protocol
Quasar.Wayland.TH
build-depends:
@@ -90,8 +91,9 @@ library
--binary,
bytestring,
exceptions,
+ filepath,
--mtl,
- --network,
+ network,
quasar,
template-haskell,
--unix,
diff --git a/src/Quasar/Wayland/Client.hs b/src/Quasar/Wayland/Client.hs
new file mode 100644
index 0000000..762732b
--- /dev/null
+++ b/src/Quasar/Wayland/Client.hs
@@ -0,0 +1,70 @@
+module Quasar.Wayland.Client (
+ connectWaylandClient,
+ newWaylandClient,
+) where
+
+import Control.Monad.Catch
+import Network.Socket qualified as Socket
+import Network.Socket (Socket)
+import Quasar.Disposable
+import Quasar.Prelude
+import Quasar.ResourceManager
+import System.Environment (getEnv, lookupEnv)
+import System.FilePath ((</>), isRelative)
+import Text.Read (readEither)
+
+data WaylandClient = WaylandClient {
+ socket :: Socket,
+ resourceManager :: ResourceManager
+}
+
+instance IsResourceManager WaylandClient where
+ toResourceManager client = client.resourceManager
+
+instance IsDisposable WaylandClient where
+ toDisposable client = toDisposable client.resourceManager
+
+newWaylandClient :: MonadResourceManager m => Socket -> m WaylandClient
+newWaylandClient socket = do
+ resourceManager <- newResourceManager
+ onResourceManager resourceManager do
+ registerDisposeAction (pure () <$ Socket.close socket)
+ pure WaylandClient {
+ socket,
+ resourceManager
+ }
+
+connectWaylandClient :: MonadResourceManager m => m WaylandClient
+connectWaylandClient = mask_ do
+ socket <- liftIO connectWaylandSocket
+ newWaylandClient socket
+ where
+ 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
+
+ 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
--
GitLab