diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal index 59a9904a6436a8a1b69ee12455c4d8dd9ec3a4f9..61b01560c297328c0c62529ffdc7bcfdd2d68933 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 0000000000000000000000000000000000000000..762732b59015779c8d8c9a6e171636c7c94263c0 --- /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