diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal index f210de1af6eab8f7ce6f4dd706df1fc05adcee28..7a329ae86e1e6a19f84bc9207ebe201fc4872004 100644 --- a/quasar-wayland.cabal +++ b/quasar-wayland.cabal @@ -83,6 +83,9 @@ library Quasar.Wayland.Protocol Quasar.Wayland.Protocol.Generated Quasar.Wayland.Protocol.TH + Quasar.Wayland.Server + Quasar.Wayland.Server.Registry + Quasar.Wayland.Server.Socket other-modules: Quasar.Wayland.Protocol.Core Quasar.Wayland.Utils.InlineC @@ -93,6 +96,7 @@ library binary, bytestring, containers, + directory, exceptions, filepath, inline-c, diff --git a/src/Quasar/Wayland/Server.hs b/src/Quasar/Wayland/Server.hs new file mode 100644 index 0000000000000000000000000000000000000000..a3f1c4c4a770b31277d17b0a93ec2d4d4d95af15 --- /dev/null +++ b/src/Quasar/Wayland/Server.hs @@ -0,0 +1,60 @@ +module Quasar.Wayland.Server ( + WaylandServer, + WaylandServerConnection, + newWaylandServer, + newWaylandServerConnection, + listenAt, +) where + +import Control.Monad.Catch +import Network.Socket (Socket) +import Quasar +import Quasar.Prelude +import Quasar.Wayland.Connection +import Quasar.Wayland.Protocol +import Quasar.Wayland.Protocol.Generated +import Quasar.Wayland.Server.Registry +import Quasar.Wayland.Server.Socket + + +data WaylandServer = WaylandServer { + registry :: Registry +} + +newWaylandServer :: Monad m => Registry -> m WaylandServer +newWaylandServer registry = pure WaylandServer { registry } + +data WaylandServerConnection = WaylandConnection { + wlDisplay :: Object 'Server Interface_wl_display, + server :: WaylandServer, + connection :: WaylandConnection 'Server +} + + +newWaylandServerConnection :: (MonadIO m, MonadQuasar m) => WaylandServer -> Socket -> m WaylandServerConnection +newWaylandServerConnection server socket = do + (wlDisplay, connection) <- newWaylandConnection newServerDisplay socket + pure WaylandConnection { + wlDisplay, + server, + connection + } + where + newServerDisplay :: STM (Object 'Server Interface_wl_display, ProtocolHandle 'Server) + newServerDisplay = initializeProtocol wlDisplayRequestHandler pure + + wlDisplayRequestHandler :: ProtocolHandle 'Server -> RequestHandler_wl_display + wlDisplayRequestHandler _protocol = + RequestHandler_wl_display { + sync = (\wlCallback -> wlCallback.done 0), + get_registry = (\wlRegistry -> addRegistryConnection server.registry wlRegistry) + } + + +listenAt :: (MonadIO m, MonadMask m, MonadQuasar m) => FilePath -> WaylandServer -> m () +listenAt socketPath server = disposeOnError do + var <- liftIO newEmptyTMVarIO + async_ $ liftIO $ listenUnixPath socketPath (putTMVar var) + asyncWithUnmask_ \_ -> forever do + socket <- atomically $ takeTMVar var + newWaylandServerConnection server socket diff --git a/src/Quasar/Wayland/Server/Registry.hs b/src/Quasar/Wayland/Server/Registry.hs new file mode 100644 index 0000000000000000000000000000000000000000..b18eefef0f01f042935a61fd1443a92733d04dfb --- /dev/null +++ b/src/Quasar/Wayland/Server/Registry.hs @@ -0,0 +1,46 @@ +module Quasar.Wayland.Server.Registry ( + Registry, + newRegistry, + addRegistryConnection, +) where + +import Data.HashMap.Strict qualified as HM +import Quasar.Prelude +import Quasar.Wayland.Protocol +import Quasar.Wayland.Protocol.Generated + +-- TODO: send registry messages +-- TODO: remove connection when registry is destroyed + +data Registry = Registry { + connections :: TVar [RegistryConnection], + globalsVar :: TVar (HM.HashMap Word32 Global) +} + +newRegistry :: MonadIO m => m Registry +newRegistry = do + connections <- newTVarIO mempty + globalsVar <- newTVarIO mempty + pure Registry { connections, globalsVar } + +data RegistryConnection = RegistryConnection { + registry :: Registry, + wlRegistry :: Object 'Server Interface_wl_registry +} + +addRegistryConnection :: Registry -> Object 'Server Interface_wl_registry -> STM () +addRegistryConnection registry wlRegistry = do + setMessageHandler wlRegistry messageHandler + modifyTVar registry.connections (connection:) + where + connection = RegistryConnection { registry, wlRegistry } + messageHandler :: RequestHandler_wl_registry + messageHandler = RequestHandler_wl_registry { + bind = \name id -> traceM "wl_registry.bind not implemented" + } + +data Global = Global { + name :: Word32, + interface :: WlString, + version :: Word32 +} diff --git a/src/Quasar/Wayland/Server/Socket.hs b/src/Quasar/Wayland/Server/Socket.hs new file mode 100644 index 0000000000000000000000000000000000000000..44e92d6df0b951daf9dd00827e055b60d55702ac --- /dev/null +++ b/src/Quasar/Wayland/Server/Socket.hs @@ -0,0 +1,25 @@ +module Quasar.Wayland.Server.Socket ( + listenUnixPath +) where + +import Control.Monad.Catch +import Network.Socket +import Quasar.Prelude +import System.IO +import System.Directory + +listenUnixPath :: FilePath -> (Socket -> STM ()) -> IO a +listenUnixPath socketPath socketFn = do + hPutStrLn stderr $ "Creating socket at " <> socketPath + socketExists <- doesFileExist socketPath + when socketExists $ removeFile socketPath + bracket aquire release \sock -> do + withFdSocket sock setCloseOnExecIfNeeded + bind sock (SockAddrUnix socketPath) + listen sock 128 + mask_ $ forever $ do + (conn, _) <- accept sock + onException (atomically (socketFn conn)) (close conn) + where + aquire = socket AF_UNIX Stream defaultProtocol + release sock = close sock >> removeFile socketPath