examples/Client.hs

 module Main (main) where
 
-import Data.List (intersperse)
-import Data.Foldable (toList)
 import Quasar
 import Quasar.Prelude
 import Quasar.Timer
@@ -16,69 +14,6 @@ import Quasar.Wayland.Surface
 import Codec.Picture
 
 
-data Dimensions = Dimensions {
-  width :: Int,
-  height :: Int,
-  aspect :: Double
-}
-
-data Position = Position {
-  dimensions :: Dimensions,
-  pixelX :: Int,
-  pixelY :: Int,
-  u :: Double,
-  v :: Double,
-  x :: Double,
-  y :: Double
-}
-
-mkDimensions :: Int -> Int -> Dimensions
-mkDimensions width height = Dimensions { width, height, aspect }
-  where
-    aspect :: Double
-    aspect = (fromIntegral width) / (fromIntegral height)
-
-mkPosition :: Dimensions -> Int -> Int -> Position
-mkPosition dimensions pixelX pixelY = Position { dimensions, pixelX, pixelY, u, v, x, y }
-  where
-    width' = dimensions.width
-    height' = dimensions.height
-    u :: Double
-    u = (fromIntegral pixelX) / (fromIntegral width')
-    v :: Double
-    v = (fromIntegral pixelY) / (fromIntegral height')
-    innerRadius :: Int
-    innerRadius = div (min width' height') 2
-    x :: Double
-    x = (fromIntegral $ pixelX - (div width' 2)) / (fromIntegral innerRadius)
-    y :: Double
-    y = (fromIntegral $ pixelY - (div height' 2)) / (fromIntegral innerRadius)
-
-color :: forall a. RealFrac a => a -> a -> a -> PixelRGBA8
-color r g b = PixelRGBA8 (toWord r) (toWord g) (toWord b) 255
-  where
-    toWord :: a -> Word8
-    toWord = truncate . (* 255) . (max 0) . (min 1)
-
-gradient :: Position -> PixelRGBA8
-gradient p = color (u p) 0 (v p)
-
-solidColor :: Position -> PixelRGBA8
-solidColor p = color 255 0 0
-
-mkImage :: (Position -> PixelRGBA8) -> Image PixelRGBA8
-mkImage fn = generateImage pixel width height
-  where
-    width :: Int
-    width = 512
-    height :: Int
-    height = 512
-    dimensions :: Dimensions
-    dimensions = mkDimensions width height
-    pixel :: Int -> Int -> PixelRGBA8
-    pixel x y = fn $ mkPosition dimensions x y
-
-
 main :: IO ()
 main = do
   _ <- runQuasarAndExit (stderrLogger LogLevelWarning) do
@@ -86,26 +21,11 @@ main = do
     client <- connectWaylandClient
     traceIO "Connected"
 
-    join $ liftIO $ atomically do
-
-      --xdgWmBase <- bindSingleton @Interface_xdg_wm_base client.registry
-      --setMessageHandler xdgWmBase EventHandler_xdg_wm_base {
-      --  ping = \serial -> xdgWmBase.pong serial
-      --}
-
-      --xdgToplevel <- xdgSurface.get_toplevel
-      --setMessageHandler xdgToplevel EventHandler_xdg_toplevel {
-      --  configure = \_ _ _ -> pure (),
-      --  close = pure ()
-      --}
-
-      --xdgToplevel.set_title "foobar"
-
+    join $ atomically do
 
       (surface, wlSurface) <- newClientSurface @ShmBufferBackend client
       (surface2, wlSurface2) <- newClientSurface @ShmBufferBackend client
 
-
       wlrLayerShell <- bindSingleton @Interface_zwlr_layer_shell_v1 client.registry
 
       configuredVar <- newTVar False
@@ -140,7 +60,7 @@ main = do
         buffer <- liftIO $ toImageBuffer (mkImage gradient)
         buffer2 <- liftIO $ toImageBuffer (mkImage solidColor)
 
-        liftIO $ atomically do
+        atomically do
           check =<< readTVar configuredVar
           check =<< readTVar configuredVar2
           commitSurface surface SurfaceCommit {
@@ -153,29 +73,93 @@ main = do
             offset = (0, 0),
             bufferDamage = DamageList [Rectangle 0 0 42 42]
           }
-          --destroyBuffer buffer
-          --destroyBuffer buffer2
+          destroyBuffer buffer
+          destroyBuffer buffer2
 
         await =<< newDelay 100000
         traceIO "Waiting 2s"
         await =<< newDelay 2000000
 
-        liftIO $ atomically do
+        atomically do
           commitSurface surface SurfaceCommit {
             buffer = Nothing,
             offset = (0, 0),
             bufferDamage = DamageList []
           }
+
+        -- await =<< newDelay 100000
+        atomically do
           commitSurface surface2 SurfaceCommit {
             buffer = Nothing,
             offset = (0, 0),
             bufferDamage = DamageList []
           }
 
-        -- traceIO . ("shm buffer formats: " <>) . mconcat . intersperse ", " . fmap show . toList =<< await shm.formats
-
-        pure ()
-
     await =<< newDelay 1000000
     traceIO "Closing"
   traceIO "Closed"
+
+
+-- * Buffer content generation (using JuicyPixels)
+
+data Dimensions = Dimensions {
+  width :: Int,
+  height :: Int,
+  aspect :: Double
+}
+
+data Position = Position {
+  dimensions :: Dimensions,
+  pixelX :: Int,
+  pixelY :: Int,
+  u :: Double,
+  v :: Double,
+  x :: Double,
+  y :: Double
+}
+
+mkDimensions :: Int -> Int -> Dimensions
+mkDimensions width height = Dimensions { width, height, aspect }
+  where
+    aspect :: Double
+    aspect = (fromIntegral width) / (fromIntegral height)
+
+mkPosition :: Dimensions -> Int -> Int -> Position
+mkPosition dimensions pixelX pixelY = Position { dimensions, pixelX, pixelY, u, v, x, y }
+  where
+    width' = dimensions.width
+    height' = dimensions.height
+    u :: Double
+    u = (fromIntegral pixelX) / (fromIntegral width')
+    v :: Double
+    v = (fromIntegral pixelY) / (fromIntegral height')
+    innerRadius :: Int
+    innerRadius = div (min width' height') 2
+    x :: Double
+    x = (fromIntegral $ pixelX - (div width' 2)) / (fromIntegral innerRadius)
+    y :: Double
+    y = (fromIntegral $ pixelY - (div height' 2)) / (fromIntegral innerRadius)
+
+color :: forall a. RealFrac a => a -> a -> a -> PixelRGBA8
+color r g b = PixelRGBA8 (toWord r) (toWord g) (toWord b) 255
+  where
+    toWord :: a -> Word8
+    toWord = truncate . (* 255) . (max 0) . (min 1)
+
+gradient :: Position -> PixelRGBA8
+gradient p = color (u p) 0 (v p)
+
+solidColor :: Position -> PixelRGBA8
+solidColor _p = color (255 :: Double) 0 0
+
+mkImage :: (Position -> PixelRGBA8) -> Image PixelRGBA8
+mkImage fn = generateImage pixel width height
+  where
+    width :: Int
+    width = 512
+    height :: Int
+    height = 512
+    dimensions :: Dimensions
+    dimensions = mkDimensions width height
+    pixel :: Int -> Int -> PixelRGBA8
+    pixel x y = fn $ mkPosition dimensions x y

examples/Server.hs

@@ -5,15 +5,18 @@ import Quasar.Prelude
 import Quasar.Wayland.Server
 import Quasar.Wayland.Server.Registry
 import Quasar.Wayland.Server.Shm
+import Quasar.Wayland.Server.XdgShell
 import Quasar.Wayland.Shm
 import Quasar.Wayland.Protocol
 import Quasar.Wayland.Protocol.Generated
 
 main :: IO ()
 main = runQuasarAndExit (stderrLogger LogLevelWarning) do
+  wm <- atomically newServerWindowManager
   let
     layerShellGlobal = createGlobal @Interface_zwlr_layer_shell_v1 maxVersion (\x -> setRequestHandler x layerShellHandler)
-  registry <- newRegistry [compositorGlobal @ShmBufferBackend, shmGlobal, layerShellGlobal]
+    wmGlobal = xdgShellGlobal @ShmBufferBackend wm
+  registry <- newRegistry [compositorGlobal @ShmBufferBackend, shmGlobal, layerShellGlobal, wmGlobal]
   server <- newWaylandServer registry
   listenAt "example.socket" server
   sleepForever

quasar-wayland.cabal

@@ -91,6 +91,7 @@ library
     Quasar.Wayland.Server.Shm
     Quasar.Wayland.Server.Socket
     Quasar.Wayland.Server.Surface
+    Quasar.Wayland.Server.XdgShell
     Quasar.Wayland.Shm
     Quasar.Wayland.Surface
   other-modules:

src/Quasar/Wayland/Client/Registry.hs

@@ -7,6 +7,7 @@ module Quasar.Wayland.Client.Registry (
 
 import Control.Monad.Catch
 import Data.HashMap.Strict qualified as HM
+import Data.String (IsString(..))
 import Quasar
 import Quasar.Prelude
 import Quasar.Wayland.Client.Sync
@@ -74,14 +75,14 @@ tryBindSingleton registry = do
   globals <- filterInterface . HM.elems <$> readTVar registry.globalsVar
 
   case globals of
-    [] -> pure $ Left $ mconcat ["No global named ", toString (interfaceName @i), " is available"]
+    [] -> pure $ Left $ mconcat ["No global named ", interfaceName @i, " is available"]
     (global:[]) -> do
       let version = min global.version (interfaceVersion @i)
       (object, newId) <- bindNewObject registry.wlRegistry.objectProtocol version Nothing
       registry.wlRegistry.bind global.name newId
       pure $ Right object
-    _ -> pure $ Left $ mconcat ["Cannot bind singleton: multiple globals with type ", toString (interfaceName @i), " are available"]
+    _ -> pure $ Left $ mconcat ["Cannot bind singleton: multiple globals with type ", interfaceName @i, " are available"]
 
   where
     filterInterface :: [Global] -> [Global]
-    filterInterface = filter \global -> global.interface == interfaceName @i
+    filterInterface = filter \global -> global.interface == fromString (interfaceName @i)

src/Quasar/Wayland/Client/Surface.hs

@@ -87,12 +87,8 @@ releaseClientBuffer clientBuffer = do
 
 destroyClientBuffer :: ClientBuffer b -> STM ()
 destroyClientBuffer clientBuffer = do
-  clientBuffer.wlBuffer.destroy
   writeTVar clientBuffer.destroyed True
-  state <- readTVar clientBuffer.state
-  case state of
-    Attached _ -> traceM "ClientBuffer: Destroyed while attached (this is a bug somewhere in the buffer locking logic)"
-    Released -> clientBuffer.wlBuffer.destroy
+  clientBuffer.wlBuffer.destroy
 
 
 -- | Since `release` is undefined when a buffer is attached to multiple surfaces,

src/Quasar/Wayland/Connection.hs

@@ -9,7 +9,10 @@ module Quasar.Wayland.Connection (
 import Control.Monad.Catch
 import Data.Bits ((.&.))
 import Data.ByteString qualified as BS
+import Data.ByteString.Internal qualified as BS
 import Data.ByteString.Lazy qualified as BSL
+import Data.List (singleton)
+import Foreign (Storable, peekElemOff, pokeElemOff, withForeignPtr, sizeOf, castPtr)
 import Language.C.Inline qualified as C
 import Language.C.Inline.Unsafe qualified as CU
 import Network.Socket (Socket)
@@ -19,7 +22,7 @@ import Quasar.Prelude
 import Quasar.Wayland.Protocol
 import Quasar.Wayland.Utils.Socket
 import System.Posix.IO (closeFd)
-import System.Posix.Types (Fd)
+import System.Posix.Types (Fd(Fd))
 
 
 C.include "<sys/socket.h>"
@@ -85,7 +88,7 @@ sendThread connection = mask_ $ forever do
   (msg, fds) <- takeOutbox connection.protocolHandle
   finally
     do
-      traceIO $ "Sending " <> show (BSL.length msg) <> " bytes"
+      traceIO $ "Sending " <> show (BSL.length msg) <> " bytes" <> describeFds fds
 
       -- TODO limit max fds
       send (fromIntegral (BSL.length msg)) (BSL.toChunks msg) fds
@@ -96,7 +99,10 @@ sendThread connection = mask_ $ forever do
     send :: Int -> [BS.ByteString] -> [Fd] -> IO ()
     send remaining chunks fds = do
       -- TODO add MSG_NOSIGNAL (not exposed by `network`)
-      sent <- sendMsg connection.socket chunks (Socket.encodeCmsg <$> fds) mempty
+      cmsgs <- case fds of
+        [] -> pure []
+        _ -> singleton <$> encodeFds fds
+      sent <- sendMsg connection.socket chunks cmsgs mempty
       let nowRemaining = remaining - sent
       when (nowRemaining > 0) do
         send nowRemaining (dropL sent chunks) []
@@ -114,23 +120,45 @@ receiveThread connection = forever do
   -- TODO add MSG_CMSG_CLOEXEC (not exposed by `network`)
   (chunk, cmsgs, flags) <- recvMsg connection.socket 4096 cmsgBufferSize mempty
 
-  let fds = catMaybes (Socket.decodeCmsg @Fd <$> cmsgs)
+  fds <- mconcat <$> (mapM decodeFds cmsgs)
 
-  when (flags .&. Socket.MSG_CTRUNC > 0) do
+  when (any (\cmsg -> cmsg.cmsgId /= Socket.CmsgIdFd) cmsgs) do
     -- TODO close fds
-    fail "Wayland connection: Ancillary data was truncated"
+    fail "Wayland connection: Received unexpected ancillary message (only SCM_RIGHTS is supported)"
 
-  when (length fds /= length cmsgs) do
+  when (flags .&. Socket.MSG_CTRUNC > 0) do
     -- TODO close fds
-    fail "Wayland connection: Received unexpected ancillary message (only SCM_RIGHTS is supported)"
+    fail "Wayland connection: Ancillary data was truncated"
 
   when (BS.null chunk) do
     throwM SocketClosed
 
-  traceIO $ "Received " <> show (BS.length chunk) <> " bytes"
+  traceIO $ "Received " <> show (BS.length chunk) <> " bytes" <> describeFds fds
 
   feedInput connection.protocolHandle chunk fds
 
 
+decodeFds :: Socket.Cmsg -> IO [Fd]
+decodeFds Socket.Cmsg{cmsgId, cmsgData=BS.BS fptr len}
+  | cmsgId == Socket.CmsgIdFd =
+    withForeignPtr fptr \ptr ->
+      mapM (peekElemOff (castPtr ptr)) [0..(len `div` sizeOf' @Fd - 1)]
+  | otherwise = pure []
+
+encodeFds :: [Fd] -> IO Socket.Cmsg
+encodeFds fds =
+  Socket.Cmsg Socket.CmsgIdFd <$>
+      BS.create (length fds * sizeOf' @Fd) \ptr ->
+        mapM_ (\(fd, i) -> (pokeElemOff (castPtr ptr) i fd)) (zip fds [0..])
+
+sizeOf' :: forall a. Storable a => Int
+sizeOf' = sizeOf @a unreachableCodePath
+
+
+describeFds :: [Fd] -> String
+describeFds [] = ""
+describeFds fds = " (" <> (intercalate ", " ((\(Fd fd) -> "fd@" <> show fd) <$> fds)) <> ")"
+
+
 closeConnection :: WaylandConnection s -> IO ()
 closeConnection connection = Socket.close connection.socket

src/Quasar/Wayland/Protocol/Core.hs

@@ -11,7 +11,6 @@ module Quasar.Wayland.Protocol.Core (
   doubleToFixed,
   WlString(..),
   toString,
-  fromString,
   IsSide(..),
   Side(..),
   IsInterface(..),
@@ -248,8 +247,8 @@ class (
   type InterfaceName i :: Symbol
   type InterfaceVersion i :: Nat
 
-interfaceName :: forall i. IsInterface i => WlString
-interfaceName = fromString $ symbolVal @(InterfaceName i) Proxy
+interfaceName :: forall i. IsInterface i => String
+interfaceName = symbolVal @(InterfaceName i) Proxy
 
 interfaceVersion :: forall i. IsInterface i => Word32
 interfaceVersion = fromIntegral $ natVal @(InterfaceVersion i) Proxy
@@ -364,9 +363,9 @@ instance IsInterface i => Show (Object s i) where
 
 class IsObject a where
   genericObjectId :: a -> GenericObjectId
-  objectInterfaceName :: a -> WlString
+  objectInterfaceName :: a -> String
   showObject :: a -> String
-  showObject object = toString (objectInterfaceName object) <> "@" <> show (genericObjectId object)
+  showObject object = objectInterfaceName object <> "@" <> show (genericObjectId object)
 
 class IsObjectSide a where
   describeUpMessage :: a -> Opcode -> BSL.ByteString -> String
@@ -378,11 +377,11 @@ instance forall s i. IsInterface i => IsObject (Object s i) where
 
 instance forall s i. IsInterfaceSide s i => IsObjectSide (Object s i) where
   describeUpMessage object opcode body = mconcat [
-    toString (objectInterfaceName object), "@", show (genericObjectId object),
+    objectInterfaceName object, "@", show (genericObjectId object),
     ".", fromMaybe "[invalidOpcode]" (opcodeName @(WireUp s i) opcode),
     " (", show (BSL.length body), "B)"]
   describeDownMessage object opcode body = mconcat [
-    toString (objectInterfaceName object), "@", show (genericObjectId object),
+    objectInterfaceName object, "@", show (genericObjectId object),
     ".", fromMaybe "[invalidOpcode]" (opcodeName @(WireDown s i) opcode),
     " (", show (BSL.length body), "B)"]
 
@@ -413,7 +412,7 @@ buildMessage opcode parts = (opcode,) . mconcat <$> sequence parts
 
 invalidOpcode :: IsInterface i => Object s i -> Opcode -> Get a
 invalidOpcode object opcode = fail $ mconcat [
-  "Invalid opcode ", show opcode, " on ", toString (objectInterfaceName object),
+  "Invalid opcode ", show opcode, " on ", objectInterfaceName object,
   "@", show (genericObjectId object)]
 
 showObjectMessage :: (IsObject a, IsMessage b) => a -> b -> String
@@ -703,7 +702,7 @@ bindNewObject
 bindNewObject protocol version messageHandler =
   runProtocolM protocol do
     (object, NewId (ObjectId newId)) <- newObject messageHandler
-    pure (object, GenericNewId (interfaceName @i) version newId)
+    pure (object, GenericNewId (fromString (interfaceName @i)) version newId)
 
 -- | Create an object from a received id.
 -- object).
@@ -724,8 +723,8 @@ fromSomeObject
 fromSomeObject (SomeObject someObject) =
   case cast someObject of
     Nothing -> Left $ mconcat ["Expected object with type ",
-      toString (interfaceName @i), ", but object has type ",
-      toString (objectInterfaceName someObject)]
+      interfaceName @i, ", but object has type ",
+      objectInterfaceName someObject]
     Just object -> pure object
 
 

src/Quasar/Wayland/Server/Registry.hs

@@ -11,6 +11,7 @@ import Data.Foldable (toList)
 import Data.HashMap.Strict qualified as HM
 import Data.Sequence (Seq)
 import Data.Sequence qualified as Seq
+import Data.String (IsString(..))
 import Quasar.Prelude
 import Quasar.Wayland.Protocol
 import Quasar.Wayland.Protocol.Core
@@ -39,7 +40,7 @@ data RegistryConnection = RegistryConnection {
 createGlobal :: forall i. IsInterfaceSide 'Server i => Version -> (Object 'Server i -> STM ()) -> Global
 createGlobal supportedVersion bindFn =
   Global {
-    interface = interfaceName @i,
+    interface = fromString (interfaceName @i),
     version = min supportedVersion (interfaceVersion @i),
     bindObject
   }

src/Quasar/Wayland/Server/Surface.hs

 module Quasar.Wayland.Server.Surface (
+  ServerSurface,
   initializeServerSurface,
+  getServerSurface,
+  connectServerSurfaceDownstream,
+  assignSurfaceRole,
+  removeSurfaceRole,
   initializeWlBuffer,
   getBuffer,
 ) where
@@ -8,12 +13,14 @@ import Control.Monad.Catch
 import Quasar.Prelude
 import Quasar.Wayland.Protocol
 import Quasar.Wayland.Protocol.Generated
-import Quasar.Wayland.Region (Rectangle(..), appAsRect)
+import Quasar.Wayland.Region (appAsRect)
 import Quasar.Wayland.Surface
 
 
 data ServerSurface b = ServerSurface {
   surface :: Surface b,
+  lastRole :: TVar (Maybe String),
+  hasActiveRole :: TVar Bool,
   pendingBuffer :: TVar (Maybe (ServerBuffer b)),
   pendingOffset :: TVar (Int32, Int32),
   pendingBufferDamage :: TVar Damage,
@@ -30,6 +37,8 @@ data ServerBuffer b = ServerBuffer {
 newServerSurface :: forall b. STM (ServerSurface b)
 newServerSurface = do
   surface <- newSurface @b
+  lastRole <- newTVar Nothing
+  hasActiveRole <- newTVar False
   pendingBuffer <- newTVar Nothing
   pendingOffset <- newTVar (0, 0)
   pendingBufferDamage <- newTVar mempty
@@ -37,12 +46,21 @@ newServerSurface = do
 
   pure ServerSurface {
     surface,
+    lastRole,
+    hasActiveRole,
     pendingBuffer,
     pendingOffset,
     pendingBufferDamage,
     pendingSurfaceDamage
   }
 
+getServerSurface :: forall b. BufferBackend b => Object 'Server Interface_wl_surface -> STM (Maybe (ServerSurface b))
+getServerSurface wlSurface = getInterfaceData @(ServerSurface b) wlSurface
+
+connectServerSurfaceDownstream :: forall b. ServerSurface b -> SurfaceDownstream b -> STM ()
+connectServerSurfaceDownstream serverSurface downstream =
+  connectSurfaceDownstream serverSurface.surface downstream
+
 commitServerSurface :: ServerSurface b -> STM ()
 commitServerSurface surface = do
   serverBuffer <- swapTVar surface.pendingBuffer Nothing
@@ -86,23 +104,23 @@ damageBuffer surface rect =
 
 initializeServerSurface :: forall b. BufferBackend b => Object 'Server Interface_wl_surface -> STM ()
 initializeServerSurface wlSurface = do
-  surface <- newServerSurface @b
+  serverSurface <- newServerSurface @b
   -- TODO missing requests
   setMessageHandler wlSurface RequestHandler_wl_surface {
     -- TODO ensure role is destroyed before surface
+    -- TODO destroy associated surface
     destroy = pure (),
-    attach = attachToSurface surface,
-    damage = appAsRect (damageSurface surface),
+    attach = attachToSurface serverSurface,
+    damage = appAsRect (damageSurface serverSurface),
     frame = \callback -> pure (),
     set_opaque_region = \region -> pure (),
     set_input_region = \region -> pure (),
-    commit = commitServerSurface surface,
+    commit = commitServerSurface serverSurface,
     set_buffer_transform = \transform -> pure (),
     set_buffer_scale = \scale -> pure (),
-    damage_buffer = appAsRect (damageBuffer surface)
+    damage_buffer = appAsRect (damageBuffer serverSurface)
   }
-  setInterfaceData wlSurface surface
-  traceM "wl_surface not implemented"
+  setInterfaceData wlSurface serverSurface
 
 initializeWlBuffer :: forall b. BufferBackend b => NewObject 'Server Interface_wl_buffer -> Buffer b -> STM ()
 initializeWlBuffer wlBuffer buffer = do
@@ -126,3 +144,23 @@ getServerBuffer wlBuffer = do
 
 getBuffer :: forall b. BufferBackend b => Object 'Server Interface_wl_buffer -> STM (Buffer b)
 getBuffer wlBuffer = (.buffer) <$> getServerBuffer wlBuffer
+
+
+assignSurfaceRole :: forall i b. IsInterfaceSide 'Server i => ServerSurface b -> STM ()
+assignSurfaceRole surface = do
+  let role = interfaceName @i
+
+  hasActiveRole <- readTVar surface.hasActiveRole
+  if hasActiveRole
+    then throwM (ProtocolUsageError "Cannot assign wl_surface a new role, since it already has an active role.")
+    else writeTVar surface.hasActiveRole True
+
+  readTVar surface.lastRole >>= \x -> (flip ($)) x \case
+    Just ((== role) -> True) -> pure ()
+    Just currentRole ->
+      let msg = mconcat ["Cannot change wl_surface role. The last role was ", currentRole, "; new role is ", role]
+      in throwM (ProtocolUsageError msg)
+    Nothing -> writeTVar surface.lastRole (Just role)
+
+removeSurfaceRole :: ServerSurface b -> STM ()
+removeSurfaceRole surface = writeTVar surface.hasActiveRole False

src/Quasar/Wayland/Server/XdgShell.hs

+module Quasar.Wayland.Server.XdgShell (
+  ServerWindowManager,
+  newServerWindowManager,
+  xdgShellGlobal,
+) where
+
+import Control.Monad.Catch
+import Quasar.Prelude
+import Quasar.Wayland.Protocol
+import Quasar.Wayland.Protocol.Generated
+import Quasar.Wayland.Server.Registry
+import Quasar.Wayland.Server.Surface
+import Quasar.Wayland.Surface
+
+data ServerWindowManager b = ServerWindowManager
+
+newServerWindowManager :: STM (ServerWindowManager b)
+newServerWindowManager = pure ServerWindowManager
+
+xdgShellGlobal :: forall b. BufferBackend b => ServerWindowManager b -> Global
+xdgShellGlobal wm =
+  createGlobal @Interface_xdg_wm_base maxVersion (initializeXdgWmBase wm)
+
+initializeXdgWmBase ::
+  forall b.
+  BufferBackend b =>
+  ServerWindowManager b -> Object 'Server Interface_xdg_wm_base -> STM ()
+initializeXdgWmBase wm wlXdgWm =
+  setRequestHandler wlXdgWm RequestHandler_xdg_wm_base {
+    -- TODO raise error if any surface derived from this xdg_wm_base is still
+    -- alive
+    destroy = pure (),
+    create_positioner = undefined,
+    get_xdg_surface = initializeXdgSurface wm,
+    pong = const (pure ())
+  }
+
+
+data XdgSurface b = XdgSurface {
+  wlXdgSurface :: Object 'Server Interface_xdg_surface,
+  serverSurface :: ServerSurface b,
+  surfaceRole :: TVar (Maybe Role)
+}
+
+data Role = Toplevel | Popup
+
+initializeXdgSurface ::
+  forall b.
+  BufferBackend b =>
+  ServerWindowManager b ->
+  NewObject 'Server Interface_xdg_surface ->
+  Object 'Server Interface_wl_surface ->
+  STM ()
+initializeXdgSurface wm wlXdgSurface wlSurface = do
+  getServerSurface @b wlSurface >>= \case
+    Just serverSurface -> initializeXdgSurface' wm wlXdgSurface serverSurface
+    Nothing -> throwM (userError "Invalid server surface")
+
+initializeXdgSurface' ::
+  forall b.
+  ServerWindowManager b ->
+  NewObject 'Server Interface_xdg_surface ->
+  ServerSurface b ->
+  STM ()
+initializeXdgSurface' wm wlXdgSurface serverSurface = do
+  -- The spec says that "It is illegal to create an xdg_surface for a wl_surface
+  -- which already has an assigned role and this will result in a protocol
+  -- error."
+  --
+  -- In practice it's not as easy as just checking for an assigned role, since
+  -- this might also occur the other way round (an xdg_surface is created and
+  -- then the surface is assigned another role), or multiple xdg_surface objects
+  -- might be created for the same wl_surface.
+  --
+  -- Instead, since an xdg_surface has no effect in itself (in version 5 of
+  -- xdg_surface), this part of the spec is ignored in this implementation. A
+  -- role object is only set when creating a toplevel- or popup surface.
+
+  surfaceRole <- newTVar Nothing
+  let xdgSurface = XdgSurface { wlXdgSurface, serverSurface, surfaceRole }
+
+  setRequestHandler wlXdgSurface RequestHandler_xdg_surface {
+    destroy = destroyXdgSurface xdgSurface,
+    get_toplevel = initializeXdgToplevel xdgSurface,
+    get_popup = undefined,
+    set_window_geometry = undefined,
+    ack_configure = undefined
+  }
+
+destroyXdgSurface :: XdgSurface b -> STM ()
+destroyXdgSurface surface = do
+  readTVar surface.surfaceRole >>= \case
+    Just _ -> throwM (userError "Cannot destroy xdg_surface before its role object has been destroyed.")
+    Nothing -> pure ()
+
+data XdgToplevel b = XdgToplevel {
+  xdgSurface :: XdgSurface b
+}
+
+initializeXdgToplevel :: XdgSurface b -> NewObject 'Server Interface_xdg_toplevel -> STM ()
+initializeXdgToplevel xdgSurface wlXdgToplevel = do
+  -- NOTE this throws if the surface role is changed
+  -- TODO change error type to a corret ServerError if that happens
+  assignSurfaceRole @Interface_xdg_toplevel xdgSurface.serverSurface
+  writeTVar xdgSurface.surfaceRole (Just Toplevel)
+
+  let xdgToplevel = XdgToplevel {
+    xdgSurface
+  }
+
+  setRequestHandler wlXdgToplevel RequestHandler_xdg_toplevel {
+    destroy = destroyXdgToplevel xdgToplevel,
+    set_parent = undefined,
+    set_title = \title -> pure (),
+    set_app_id = undefined,
+    show_window_menu = undefined,
+    move = undefined,
+    resize = undefined,
+    set_max_size = undefined,
+    set_min_size = undefined,
+    set_maximized = undefined,
+    unset_maximized = undefined,
+    set_fullscreen = undefined,
+    unset_fullscreen = undefined,
+    set_minimized = undefined
+  }
+
+destroyXdgToplevel :: XdgToplevel b -> STM ()
+destroyXdgToplevel xdgToplevel = do
+  removeSurfaceRole xdgToplevel.xdgSurface.serverSurface
+  writeTVar xdgToplevel.xdgSurface.surfaceRole Nothing
+  undefined

src/Quasar/Wayland/Surface.hs

@@ -16,7 +16,6 @@ module Quasar.Wayland.Surface (
   SurfaceDownstream,
   defaultSurfaceCommit,
   newSurface,
-  assignSurfaceRole,
   commitSurface,
   connectSurfaceDownstream,
 
@@ -24,11 +23,9 @@ module Quasar.Wayland.Surface (
   Rectangle(..),
 ) where
 
-import Control.Monad.Catch
 import Data.Hashable (Hashable(..))
 import Data.Typeable
 import Quasar.Prelude
-import Quasar.Wayland.Protocol
 import Quasar.Wayland.Region (Rectangle(..))
 import Quasar.Wayland.Utils.Once (once)
 
@@ -116,15 +113,6 @@ isBufferDestroyed :: Buffer b -> STM Bool
 isBufferDestroyed buffer = readTVar buffer.destroyed
 
 
-class SurfaceRole a where
-  surfaceRoleName :: a -> String
-
-data SomeSurfaceRole = forall a. SurfaceRole a => SomeSurfaceRole a
-
-instance SurfaceRole SomeSurfaceRole where
-  surfaceRoleName (SomeSurfaceRole role) = surfaceRoleName role
-
-
 data Damage = DamageAll | DamageList [Rectangle]
 
 instance Semigroup Damage where
@@ -137,7 +125,6 @@ instance Monoid Damage where
 
 
 data Surface b = Surface {
-  surfaceRole :: TVar (Maybe SomeSurfaceRole),
   surfaceState :: TVar (SurfaceCommit b),
   lastBufferUnlockFn :: TVar (STM ()),
   downstreams :: TVar [SurfaceDownstream b]
@@ -167,27 +154,15 @@ defaultSurfaceCommit bufferDamage = SurfaceCommit {
 
 newSurface :: forall b. STM (Surface b)
 newSurface = do
-  surfaceRole <- newTVar Nothing
   surfaceState <- newTVar (defaultSurfaceCommit DamageAll)
   lastBufferUnlockFn <- newTVar (pure ())
   downstreams <- newTVar []
   pure Surface {
-    surfaceRole,
     surfaceState,
     lastBufferUnlockFn,
     downstreams
   }
 
-assignSurfaceRole :: SurfaceRole a => Surface b -> a -> STM ()
-assignSurfaceRole surface role = do
-  readTVar surface.surfaceRole >>= \x -> (flip ($)) x \case
-    Just currentRole ->
-      let msg = mconcat ["Cannot change wl_surface role. Current role is ", surfaceRoleName currentRole, "; new role is ", surfaceRoleName role]
-      in throwM (ProtocolUsageError msg)
-    Nothing -> pure ()
-
-  writeTVar surface.surfaceRole (Just (SomeSurfaceRole role))
-
 commitSurface :: Surface b -> SurfaceCommit b -> STM ()
 commitSurface surface commit = do
   join $ readTVar surface.lastBufferUnlockFn