Add initial server code

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,

src/Quasar/Wayland/Server.hs

+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

src/Quasar/Wayland/Server/Registry.hs

+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
+}

src/Quasar/Wayland/Server/Socket.hs

+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