examples/Client.hs

@@ -95,6 +95,12 @@ main = do
         leave = \_ -> pure ()
       }
 
+      wlSurface2 <- wlCompositor.create_surface
+      setMessageHandler wlSurface2 EventHandler_wl_surface {
+        enter = \_ -> pure (),
+        leave = \_ -> pure ()
+      }
+
       --xdgWmBase <- bindSingleton @Interface_xdg_wm_base client.registry
       --setMessageHandler xdgWmBase EventHandler_xdg_wm_base {
       --  ping = \serial -> xdgWmBase.pong serial
@@ -116,6 +122,7 @@ main = do
       wlrLayerShell <- bindSingleton @Interface_zwlr_layer_shell_v1 client.registry
 
       configuredVar <- newTVar False
+      configuredVar2 <- newTVar False
 
       wlrLayerSurface <- wlrLayerShell.get_layer_surface wlSurface Nothing 2 "demo"
       setMessageHandler wlrLayerSurface EventHandler_zwlr_layer_surface_v1 {
@@ -126,8 +133,18 @@ main = do
       }
       wlrLayerSurface.set_size 512 512
 
+      wlrLayerSurface2 <- wlrLayerShell.get_layer_surface wlSurface2 Nothing 2 "demo"
+      setMessageHandler wlrLayerSurface2 EventHandler_zwlr_layer_surface_v1 {
+        configure = \serial width height -> do
+            wlrLayerSurface2.ack_configure serial
+            writeTVar configuredVar2 True,
+        closed = pure ()
+      }
+      wlrLayerSurface2.set_size 512 512
+
       -- Commit role
       wlSurface.commit
+      wlSurface2.commit
       -- Should await first `configure` event
 
       pure do
@@ -135,24 +152,30 @@ main = do
 
         liftIO $ atomically do
           check =<< readTVar configuredVar
+          check =<< readTVar configuredVar2
           wlSurface.attach (Just buffer) 0 0
           wlSurface.commit
+          wlSurface2.attach (Just buffer) 0 0
+          wlSurface2.commit
 
         await =<< newDelay 1000000
 
-        buffer2 <- liftIO $ toImageBuffer shm (mkImage solidColor)
+        --buffer2 <- liftIO $ toImageBuffer shm (mkImage solidColor)
 
-        liftIO $ atomically do
-          wlSurface.attach (Just buffer2) 0 0
-          wlSurface.damage 0 0 42 42
-          wlSurface.commit
+        --liftIO $ atomically do
+        --  wlSurface.attach (Just buffer2) 0 0
+        --  wlSurface.damage 0 0 42 42
+        --  wlSurface.commit
 
-        await =<< newDelay 1000000
+        --await =<< newDelay 1000000
 
         liftIO $ atomically do
           wlSurface.attach (Nothing) 0 0
           wlSurface.damage 100 100 42 42
           wlSurface.commit
+          wlSurface2.attach (Nothing) 0 0
+          wlSurface2.damage 100 100 42 42
+          wlSurface2.commit
 
         traceIO . ("shm buffer formats: " <>) . mconcat . intersperse ", " . fmap show . toList =<< await shm.formats
 

quasar-wayland.cabal

@@ -79,6 +79,7 @@ library
     Quasar.Wayland.Client.JuicyPixels
     Quasar.Wayland.Client.Registry
     Quasar.Wayland.Client.Socket
+    Quasar.Wayland.Client.Surface
     Quasar.Wayland.Client.Sync
     Quasar.Wayland.Connection
     Quasar.Wayland.Protocol

src/Quasar/Wayland/Client/Buffer.hs

@@ -71,7 +71,7 @@ newShmBuffer shm width height = do
     wlBuffer <- wlShmPool.create_buffer offset width height stride pixelFormat
     setEventHandler wlBuffer EventHandler_wl_buffer {
       -- TODO
-      release = wlBuffer.destroy
+      release = pure () -- wlBuffer.destroy
     }
     pure wlBuffer
 

src/Quasar/Wayland/Client/Surface.hs

+module Quasar.Wayland.Client.Surface (
+  newClientSurface,
+  initializeClientSurface,
+) where
+
+import Quasar.Prelude
+import Quasar.Wayland.Protocol
+import Quasar.Wayland.Protocol.Generated
+import Quasar.Wayland.Surface
+import Quasar.Wayland.Region (Rectangle, appRect)
+
+newtype ClientSurface b = ClientSurface {
+  wlSurface :: Object 'Client Interface_wl_surface
+}
+
+newClientSurface :: Object 'Client Interface_wl_compositor -> STM (Surface b)
+newClientSurface wlCompositor = do
+  surface <- newSurface
+  wlSurface <- wlCompositor.create_surface
+  initializeClientSurface surface wlSurface
+  -- TODO: add finalizer, so that the surface is destroyed with the wlSurface
+  pure surface
+
+initializeClientSurface :: Surface b -> Object 'Client Interface_wl_surface -> STM ()
+initializeClientSurface surface wlSurface = do
+  connectSurfaceDownstream surface (surfaceDownstream (ClientSurface wlSurface))
+
+surfaceDownstream :: ClientSurface b -> SurfaceDownstream b
+surfaceDownstream surface = commitClientSurface surface
+
+commitClientSurface :: ClientSurface b -> SurfaceCommit b -> STM ()
+commitClientSurface surface commit = do
+  -- TODO catch exceptions and redirect to client owner (so the shared surface can continue to work when one backend fails)
+  wlBuffer <- mapM getClientBuffer commit.buffer
+  wlSurface.attach wlBuffer (fst commit.offset) (snd commit.offset)
+  applyBufferDamage surface.wlSurface commit.bufferDamage
+  wlSurface.commit
+  where
+    wlSurface = surface.wlSurface
+
+applyBufferDamage :: Object 'Client Interface_wl_surface -> Damage -> STM ()
+applyBufferDamage wlSurface DamageAll = wlSurface.damage_buffer minBound minBound maxBound maxBound
+applyBufferDamage wlSurface (DamageList xs) = mapM_ (appRect wlSurface.damage_buffer) xs
+
+
+getClientBuffer :: Buffer b -> STM (Object 'Client Interface_wl_buffer)
+getClientBuffer = undefined

src/Quasar/Wayland/Server/LayerShell.hs

+module Quasar.Wayland.Server.LayerShell (
+) where
+
+import Quasar.Prelude
+
+layerShellGlobal :: Global
+layerShellGlobal = undefined

src/Quasar/Wayland/Server/Shm.hs

@@ -38,9 +38,5 @@ initializeWlShmPool wlShmPool fd size = do
 
 initializeWlShmBuffer :: ShmPool -> NewObject 'Server Interface_wl_buffer -> Int32 -> Int32 -> Int32 -> Int32 -> Word32 -> STM ()
 initializeWlShmBuffer pool wlBuffer offset width height stride format = do
-  shmBuffer <- newShmBuffer pool offset width height stride format releaseFn
-  initializeWlBuffer @ShmBufferBackend wlBuffer shmBuffer
-  where
-    releaseFn :: STM ()
-    -- TODO handle other exceptions (e.g. disconnected)
-    releaseFn = unlessM (isDestroyed wlBuffer) wlBuffer.release
+  buffer <- newShmBuffer pool offset width height stride format
+  initializeWlBuffer @ShmBufferBackend wlBuffer buffer

src/Quasar/Wayland/Server/Surface.hs

@@ -14,69 +14,74 @@ import Quasar.Wayland.Surface
 
 data ServerSurface b = ServerSurface {
   surface :: Surface b,
-  pendingSurfaceCommit :: TVar (SurfaceCommit b),
+  pendingBuffer :: TVar (Maybe (ServerBuffer b)),
+  pendingOffset :: TVar (Int32, Int32),
+  pendingBufferDamage :: TVar Damage,
   -- Damage specified in surface coordinates (i.e. produced by wl_surface.damage instead of wl_surface.damage_buffer).
   -- Damage can be converted to buffer coordinates on commit (NOTE: conversion requires wl_surface version 4)
   pendingSurfaceDamage :: TVar [Rectangle]
 }
 
+data ServerBuffer b = ServerBuffer {
+  buffer :: Buffer b,
+  wlBuffer :: Object 'Server Interface_wl_buffer
+}
+
 newServerSurface :: forall b. STM (ServerSurface b)
 newServerSurface = do
   surface <- newSurface @b
-  pendingSurfaceCommit <- newTVar (defaultSurfaceCommit (DamageList []))
-  pendingSurfaceDamage <- newTVar []
+  pendingBuffer <- newTVar Nothing
+  pendingOffset <- newTVar (0, 0)
+  pendingBufferDamage <- newTVar mempty
+  pendingSurfaceDamage <- newTVar mempty
+
   pure ServerSurface {
     surface,
-    pendingSurfaceCommit,
+    pendingBuffer,
+    pendingOffset,
+    pendingBufferDamage,
     pendingSurfaceDamage
   }
 
-modifyPending :: forall b. ServerSurface b -> (SurfaceCommit b -> SurfaceCommit b) -> STM ()
-modifyPending surface fn = modifyTVar surface.pendingSurfaceCommit fn
-
 commitServerSurface :: forall b. BufferBackend b => ServerSurface b -> STM ()
 commitServerSurface surface = do
-  pendingCommit <- readTVar surface.pendingSurfaceCommit
-
+  serverBuffer <- swapTVar surface.pendingBuffer Nothing
+  offset <- swapTVar surface.pendingOffset (0, 0)
+  bufferDamage <- swapTVar surface.pendingBufferDamage mempty
   surfaceDamage <- swapTVar surface.pendingSurfaceDamage mempty
-  let convertedSurfaceDamage =
-        case surfaceDamage of
-          [] -> DamageList []
-          -- TODO should do a coordinate conversion
-          _ -> DamageAll
-
-  let commit =
-        pendingCommit {
-          bufferDamage = pendingCommit.bufferDamage <> convertedSurfaceDamage
-        }
-
-  writeTVar surface.pendingSurfaceCommit $
-    commit {
-      buffer = Nothing,
-      offset = (0, 0),
-      bufferDamage = DamageList []
-    }
-
-  commitSurface surface.surface commit
+  let
+    convertedSurfaceDamage =
+      case surfaceDamage of
+        [] -> mempty
+        -- TODO should do a coordinate conversion
+        _ -> DamageAll
+    combinedDamage = bufferDamage <> convertedSurfaceDamage
+
+  -- Attach callback for wl_buffer.release
+  forM_ serverBuffer \sb ->
+    addBufferReleaseCallback sb.buffer sb.wlBuffer.release
+
+  commitSurface surface.surface SurfaceCommit {
+    buffer = (.buffer) <$> serverBuffer,
+    offset,
+    bufferDamage = combinedDamage
+  }
+
 
 attachToSurface :: forall b. BufferBackend b => ServerSurface b -> Maybe (Object 'Server Interface_wl_buffer) -> Int32 -> Int32 -> STM ()
 attachToSurface surface wlBuffer x y = do
-  buffer <- mapM (getBuffer @b) wlBuffer
-  modifyPending surface \s ->
-    s {
-      buffer,
-      offset = (x, y)
-    }
+  buffer <- mapM (getServerBuffer @b) wlBuffer
+  writeTVar surface.pendingBuffer buffer
+  writeTVar surface.pendingOffset (x, y)
 
 damageSurface :: forall b. ServerSurface b -> Rectangle -> STM ()
-damageSurface surface rect =
-  modifyTVar surface.pendingSurfaceDamage (rect:)
+damageSurface surface rect = modifyTVar surface.pendingSurfaceDamage (rect:)
 
 damageBuffer :: forall b. ServerSurface b -> Rectangle -> STM ()
 damageBuffer surface rect =
-  modifyPending surface \case
-    commit@SurfaceCommit{bufferDamage = DamageAll} -> commit
-    commit@SurfaceCommit{bufferDamage = DamageList xs} -> commit { bufferDamage = DamageList (rect : xs) }
+  modifyTVar surface.pendingBufferDamage \case
+    DamageAll -> DamageAll
+    DamageList xs -> DamageList (rect : xs)
 
 
 initializeServerSurface :: forall b. BufferBackend b => Object 'Server Interface_wl_surface -> STM ()
@@ -101,15 +106,23 @@ initializeServerSurface wlSurface = do
 
 initializeWlBuffer :: forall b. BufferBackend b => NewObject 'Server Interface_wl_buffer -> Buffer b -> STM ()
 initializeWlBuffer wlBuffer buffer = do
-  setInterfaceData wlBuffer buffer
+  let serverBuffer = ServerBuffer {
+    buffer,
+    wlBuffer
+  }
+  setInterfaceData wlBuffer serverBuffer
   setRequestHandler wlBuffer RequestHandler_wl_buffer {
     -- TODO propagate buffer destruction
     destroy = destroyBuffer buffer
   }
 
-getBuffer :: forall b. BufferBackend b => Object 'Server Interface_wl_buffer -> STM (Buffer b)
-getBuffer wlBuffer = do
-  ifd <- getInterfaceData @(Buffer b) wlBuffer
+
+getServerBuffer :: forall b. BufferBackend b => Object 'Server Interface_wl_buffer -> STM (ServerBuffer b)
+getServerBuffer wlBuffer = do
+  ifd <- getInterfaceData @(ServerBuffer b) wlBuffer
   case ifd of
     Just buffer -> pure buffer
     Nothing -> throwM $ InternalError ("Missing interface data on " <> show wlBuffer)
+
+getBuffer :: forall b. BufferBackend b => Object 'Server Interface_wl_buffer -> STM (Buffer b)
+getBuffer wlBuffer = (.buffer) <$> getServerBuffer wlBuffer

src/Quasar/Wayland/Shm.hs

@@ -17,7 +17,6 @@ data ShmBufferBackend
 
 instance BufferBackend ShmBufferBackend where
   type BufferContent ShmBufferBackend = ShmBuffer
-  releaseBuffer buffer = buffer.releaseFn
   releaseBufferStorage buffer = do
     modifyTVar buffer.pool.bufferCount pred
     traceM "Finalized ShmBuffer"
@@ -39,8 +38,7 @@ data ShmBuffer = ShmBuffer {
   width :: Int32,
   height :: Int32,
   stride :: Int32,
-  format :: Word32,
-  releaseFn :: STM ()
+  format :: Word32
 }
 
 -- | Create an `ShmPool` for externally managed memory. Takes ownership of the passed file descriptor.
@@ -85,11 +83,11 @@ tryFinalizeShmPool pool = do
 
 
 -- | Create a new buffer for an externally managed pool
-newShmBuffer :: ShmPool -> Int32 -> Int32 -> Int32 -> Int32 -> Word32 -> STM () -> STM (Buffer ShmBufferBackend)
-newShmBuffer pool offset width height stride format releaseFn = do
+newShmBuffer :: ShmPool -> Int32 -> Int32 -> Int32 -> Int32 -> Word32 -> STM (Buffer ShmBufferBackend)
+newShmBuffer pool offset width height stride format = do
   -- TODO check arguments
   modifyTVar pool.bufferCount succ
-  let shmBuffer = ShmBuffer pool offset width height stride format releaseFn
+  let shmBuffer = ShmBuffer pool offset width height stride format
   newBuffer @ShmBufferBackend shmBuffer
 
 data DownstreamShmPool = DownstreamShmPool

src/Quasar/Wayland/Surface.hs

@@ -5,48 +5,59 @@ module Quasar.Wayland.Surface (
   newBuffer,
   lockBuffer,
   destroyBuffer,
+  addBufferReleaseCallback,
 
   -- * Surface
   Damage(..),
   Surface,
   SurfaceCommit(..),
+  SurfaceDownstream,
   defaultSurfaceCommit,
   newSurface,
   assignSurfaceRole,
   commitSurface,
+  connectSurfaceDownstream,
 ) where
 
 import Control.Monad.Catch
 import Data.Typeable
 import Quasar.Prelude
 import Quasar.Wayland.Protocol
-import Quasar.Wayland.Protocol.Generated
 import Quasar.Wayland.Region (Rectangle(..))
 
 type BufferBackend :: Type -> Constraint
 class Typeable b => BufferBackend b where
   type BufferContent b
-  -- | Buffer has been released and can be reused by the owner.
-  releaseBuffer :: BufferContent b -> STM ()
   -- | A destroyed buffer has been released, so the buffer storage can be freed by the owner.
   releaseBufferStorage :: BufferContent b -> STM ()
 
 data Buffer b = Buffer {
   content :: BufferContent b,
-  lockCount :: TVar Word32,
+  -- | Buffer has been released by all current users and can be reused by the owner.
+  releaseBuffer :: TVar (STM ()),
+  -- | Refcount that tracks how many times the buffer is locked by consumers.
+  lockCount :: TVar Int,
   destroyed :: TVar Bool
 }
 
 newBuffer :: forall b. BufferContent b -> STM (Buffer b)
 newBuffer content = do
+  releaseBuffer <- newTVar (pure ())
   lockCount <- newTVar 0
   destroyed <- newTVar False
   pure Buffer {
     content,
+    releaseBuffer,
     lockCount,
     destroyed
   }
 
+
+addBufferReleaseCallback :: Buffer b -> STM () -> STM ()
+addBufferReleaseCallback buffer releaseFn =
+  modifyTVar buffer.releaseBuffer (>> releaseFn)
+
+
 -- | Prevents the buffer from being released. Returns an unlock action.
 lockBuffer :: forall b. BufferBackend b => Buffer b -> STM (STM ())
 lockBuffer buffer = do
@@ -57,9 +68,10 @@ lockBuffer buffer = do
     unlockBuffer = do
       lockCount <- stateTVar buffer.lockCount (dup . pred)
       when (lockCount == 0) do
-        releaseBuffer @b buffer.content
+        join $ swapTVar buffer.releaseBuffer (pure ())
         tryFinalizeBuffer @b buffer
 
+-- | Request destruction of the buffer. Since the buffer might still be in use downstream, the backing storage must not be changed until all downstreams release the buffer (signalled by `releaseBufferStorage`).
 destroyBuffer :: forall b. BufferBackend b => Buffer b -> STM ()
 destroyBuffer buffer = do
   alreadyDestroyed <- readTVar buffer.destroyed
@@ -91,11 +103,14 @@ instance Semigroup Damage where
   _ <> DamageAll = DamageAll
   DamageList xs <> DamageList ys = DamageList (xs <> ys)
 
+instance Monoid Damage where
+  mempty = DamageList []
+
 
 data Surface b = Surface {
   surfaceRole :: TVar (Maybe SomeSurfaceRole),
   surfaceState :: TVar (SurfaceCommit b),
-  lastBufferUnlockFn :: TVar (Maybe (STM ())),
+  lastBufferUnlockFn :: TVar (STM ()),
   downstreams :: TVar [SurfaceDownstream b]
 }
 
@@ -105,6 +120,13 @@ data SurfaceCommit b = SurfaceCommit {
   bufferDamage :: Damage
 }
 
+--instance Semigroup (SurfaceCommit b) where
+--  old <> new = SurfaceCommit {
+--    buffer = new.buffer,
+--    offset = new.offset,
+--    bufferDamage = old.bufferDamage <> new.bufferDamage
+--  }
+
 type SurfaceDownstream b = SurfaceCommit b -> STM ()
 
 defaultSurfaceCommit :: Damage -> SurfaceCommit b
@@ -118,7 +140,7 @@ newSurface :: forall b. STM (Surface b)
 newSurface = do
   surfaceRole <- newTVar Nothing
   surfaceState <- newTVar (defaultSurfaceCommit DamageAll)
-  lastBufferUnlockFn <- newTVar Nothing
+  lastBufferUnlockFn <- newTVar (pure ())
   downstreams <- newTVar []
   pure Surface {
     surfaceRole,
@@ -139,12 +161,18 @@ assignSurfaceRole surface role = do
 
 commitSurface :: forall b. BufferBackend b => Surface b -> SurfaceCommit b -> STM ()
 commitSurface surface commit = do
-  mapM_ id =<< readTVar surface.lastBufferUnlockFn
-  writeTVar surface.lastBufferUnlockFn =<< mapM (lockBuffer @b) commit.buffer
+  join $ readTVar surface.lastBufferUnlockFn
+
+  unlockFn <-
+    case commit.buffer of
+      Just buffer -> lockBuffer @b buffer
+      Nothing -> pure (pure ())
+
+  writeTVar surface.lastBufferUnlockFn unlockFn
 
   downstreams <- readTVar surface.downstreams
   -- TODO handle exceptions, remove failed downstreams
   mapM_ ($ commit) downstreams
 
 connectSurfaceDownstream :: forall b. Surface b -> SurfaceDownstream b -> STM ()
-connectSurfaceDownstream = undefined
+connectSurfaceDownstream surface = modifyTVar surface.downstreams . (:)