examples/Client.hs

@@ -115,13 +115,18 @@ main = do
 
       wlrLayerShell <- bindSingleton @Interface_zwlr_layer_shell_v1 client.registry
 
+      configuredVar <- newTVar False
+
       wlrLayerSurface <- wlrLayerShell.get_layer_surface wlSurface Nothing 2 "demo"
       setMessageHandler wlrLayerSurface EventHandler_zwlr_layer_surface_v1 {
-        configure = \serial width height -> wlrLayerSurface.ack_configure serial,
+        configure = \serial width height -> do
+            wlrLayerSurface.ack_configure serial
+            writeTVar configuredVar True,
         closed = pure ()
       }
       wlrLayerSurface.set_size 512 512
 
+      -- Commit role
       wlSurface.commit
       -- Should await first `configure` event
 
@@ -129,15 +134,21 @@ main = do
         buffer <- liftIO $ toImageBuffer shm (mkImage gradient)
 
         liftIO $ atomically do
+          check =<< readTVar configuredVar
           wlSurface.attach (Just buffer) 0 0
           wlSurface.commit
 
-        -- buffer2 <- liftIO $ toImageBuffer shm (wallpaperImage wallpaper)
+        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 (Nothing) 0 0
-        --  --wlSurface.damage 0 0 100 100
-        --  wlSurface.commit
+        liftIO $ atomically do
+          wlSurface.attach (Nothing) 0 0
+          wlSurface.damage 100 100 42 42
+          wlSurface.commit
 
         traceIO . ("shm buffer formats: " <>) . mconcat . intersperse ", " . fmap show . toList =<< await shm.formats
 

examples/Server.hs

@@ -2,16 +2,16 @@ module Main (main) where
 
 import Quasar
 import Quasar.Prelude
-import Quasar.Wayland.Surface
 import Quasar.Wayland.Server
 import Quasar.Wayland.Server.Registry
+import Quasar.Wayland.Server.Shm
+import Quasar.Wayland.Shm
 import Quasar.Wayland.Protocol
 import Quasar.Wayland.Protocol.Generated
 
 main :: IO ()
 main = runQuasarAndExit (stderrLogger LogLevelWarning) do
   let
-    shmGlobal = createGlobal @Interface_wl_shm maxVersion (\_ -> traceM "wl_shm not implemented")
     layerShellGlobal = createGlobal @Interface_zwlr_layer_shell_v1 maxVersion (\x -> setRequestHandler x layerShellHandler)
   registry <- newRegistry [compositorGlobal @ShmBufferBackend, shmGlobal, layerShellGlobal]
   server <- newWaylandServer registry
@@ -21,7 +21,10 @@ main = runQuasarAndExit (stderrLogger LogLevelWarning) do
 layerShellHandler :: RequestHandler_zwlr_layer_shell_v1
 layerShellHandler =
   RequestHandler_zwlr_layer_shell_v1 {
-    get_layer_surface = \wlLayerSurface _ _ _ _ -> setRequestHandler wlLayerSurface layerSurfaceHandler,
+    get_layer_surface = \wlLayerSurface _ _ _ _ -> do
+      setRequestHandler wlLayerSurface layerSurfaceHandler
+      -- Just send a "correct" configure event for the demo client to get things rolling
+      wlLayerSurface.configure 0 512 512,
     destroy = pure ()
   }
 

flake.lock

@@ -24,11 +24,11 @@
       },
       "locked": {
         "host": "git.c3pb.de",
-        "lastModified": 1659338987,
-        "narHash": "sha256-ysZhQq4A3bkXm3euWVvBlkuVtVv6srSmWN1U50rAhgE=",
+        "lastModified": 1660518832,
+        "narHash": "sha256-nH+6BCO9VnKJz3gmqXjGkzsCNr+J4NrUQEIY90HhwS0=",
         "owner": "jens",
         "repo": "quasar",
-        "rev": "f80139a337b62d2e61e18b78530928b20da2dafc",
+        "rev": "7038f65573387fc86f4c856fa5b34a8e03f134c3",
         "type": "gitlab"
       },
       "original": {

quasar-wayland.cabal

@@ -47,6 +47,7 @@ common shared-properties
     RankNTypes
     ScopedTypeVariables
     StandaloneDeriving
+    StandaloneKindSignatures
     TupleSections
     TypeApplications
     TypeFamilies
@@ -86,7 +87,10 @@ library
     Quasar.Wayland.Region
     Quasar.Wayland.Server
     Quasar.Wayland.Server.Registry
+    Quasar.Wayland.Server.Shm
     Quasar.Wayland.Server.Socket
+    Quasar.Wayland.Server.Surface
+    Quasar.Wayland.Shm
     Quasar.Wayland.Surface
   other-modules:
     Quasar.Wayland.Protocol.Core

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 = pure ()
+      release = wlBuffer.destroy
     }
     pure wlBuffer
 

src/Quasar/Wayland/Protocol.hs

@@ -11,6 +11,7 @@ module Quasar.Wayland.Protocol (
   getMessageHandler,
   setInterfaceData,
   getInterfaceData,
+  isDestroyed,
 
   -- ** Wayland types
   WlFixed(..),

src/Quasar/Wayland/Protocol/Core.hs

@@ -26,6 +26,7 @@ module Quasar.Wayland.Protocol.Core (
   getMessageHandler,
   setInterfaceData,
   getInterfaceData,
+  isDestroyed,
   NewObject,
   IsObject,
   IsMessage(..),
@@ -325,7 +326,6 @@ data Object s i = IsInterfaceSide s i => Object {
   destroyed :: TVar Bool
 }
 
-
 getMessageHandler :: IsInterfaceSide s i => Object s i -> STM (MessageHandler s i)
 getMessageHandler object = maybe (throwM (InternalError ("No message handler attached to " <> showObject object))) pure =<< readTVar object.messageHandler
 
@@ -346,6 +346,9 @@ setInterfaceData object value = writeTVar object.interfaceData (toDyn value)
 getInterfaceData :: Typeable a => Object s i -> STM (Maybe a)
 getInterfaceData object = fromDynamic <$> readTVar object.interfaceData
 
+isDestroyed :: Object s i -> STM Bool
+isDestroyed object = readTVar object.destroyed
+
 -- | Type alias to indicate an object is created with a message.
 type NewObject s i = Object s i
 

src/Quasar/Wayland/Server.hs

@@ -17,6 +17,7 @@ import Quasar.Wayland.Protocol.Generated
 import Quasar.Wayland.Region
 import Quasar.Wayland.Server.Registry
 import Quasar.Wayland.Server.Socket
+import Quasar.Wayland.Server.Surface
 import Quasar.Wayland.Surface
 
 

src/Quasar/Wayland/Server/Shm.hs

+module Quasar.Wayland.Server.Shm (
+  shmGlobal,
+) where
+
+import Quasar.Prelude
+import Quasar.Wayland.Protocol
+import Quasar.Wayland.Protocol.Generated
+import Quasar.Wayland.Server.Registry
+import Quasar.Wayland.Shm
+import Quasar.Wayland.Server.Surface
+import System.Posix (Fd)
+
+
+shmGlobal :: Global
+shmGlobal = createGlobal @Interface_wl_shm maxVersion initializeWlShm
+
+shmRequestHandler :: RequestHandler_wl_shm
+shmRequestHandler = RequestHandler_wl_shm {
+  create_pool = initializeWlShmPool
+}
+
+initializeWlShm :: NewObject 'Server Interface_wl_shm -> STM ()
+initializeWlShm wlShm = do
+  setRequestHandler wlShm shmRequestHandler
+  -- argb8888 (0) and xrgb8888 (1) are required by the spec
+  -- TODO add more formats later (i.e. 10bit formats are missing right now)
+  wlShm.format 0
+  wlShm.format 1
+
+initializeWlShmPool :: NewObject 'Server Interface_wl_shm_pool -> Fd -> Int32 -> STM ()
+initializeWlShmPool wlShmPool fd size = do
+  pool <- newShmPool fd size
+  setRequestHandler wlShmPool RequestHandler_wl_shm_pool {
+    create_buffer = initializeWlShmBuffer pool,
+    destroy = destroyShmPool pool,
+    resize = resizeShmPool pool
+  }
+
+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

src/Quasar/Wayland/Server/Surface.hs

+module Quasar.Wayland.Server.Surface (
+  initializeServerSurface,
+  initializeWlBuffer,
+) where
+
+import Quasar.Prelude
+import Quasar.Wayland.Protocol
+import Quasar.Wayland.Protocol.Generated
+import Quasar.Wayland.Region (Rectangle(..), appAsRect)
+import Quasar.Wayland.Surface
+
+
+data ServerSurface b = ServerSurface {
+  surface :: Surface b,
+  pendingSurfaceCommit :: TVar (SurfaceCommit b),
+  -- 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]
+}
+
+newServerSurface :: forall b. STM (ServerSurface b)
+newServerSurface = do
+  surface <- newSurface @b
+  pendingSurfaceCommit <- newTVar (defaultSurfaceCommit (DamageList []))
+  pendingSurfaceDamage <- newTVar []
+  pure ServerSurface {
+    surface,
+    pendingSurfaceCommit,
+    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
+
+  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
+
+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)
+    }
+
+damageSurface :: forall b. ServerSurface b -> Rectangle -> STM ()
+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) }
+
+
+initializeServerSurface :: forall b. BufferBackend b => Object 'Server Interface_wl_surface -> STM ()
+initializeServerSurface wlSurface = do
+  surface <- newServerSurface @b
+  -- TODO missing requests
+  setMessageHandler wlSurface RequestHandler_wl_surface {
+    -- TODO ensure role is destroyed before surface
+    destroy = pure (),
+    attach = attachToSurface surface,
+    damage = appAsRect (damageSurface surface),
+    frame = \callback -> pure (),
+    set_opaque_region = \region -> pure (),
+    set_input_region = \region -> pure (),
+    commit = commitServerSurface surface,
+    set_buffer_transform = \transform -> pure (),
+    set_buffer_scale = \scale -> pure (),
+    damage_buffer = appAsRect (damageBuffer surface)
+  }
+  setInterfaceData wlSurface surface
+  traceM "wl_surface not implemented"
+
+initializeWlBuffer :: forall b. BufferBackend b => NewObject 'Server Interface_wl_buffer -> Buffer b -> STM ()
+initializeWlBuffer wlBuffer buffer = do
+  setInterfaceData wlBuffer buffer
+  setRequestHandler wlBuffer RequestHandler_wl_buffer {
+    -- TODO propagate buffer destruction
+    destroy = destroyBuffer buffer
+  }

src/Quasar/Wayland/Shm.hs

+module Quasar.Wayland.Shm (
+  ShmBufferBackend,
+  ShmPool,
+  newShmPool,
+  resizeShmPool,
+  destroyShmPool,
+  newShmBuffer,
+) where
+
+import Control.Monad.Catch
+import Quasar.Prelude
+import Quasar.Wayland.Protocol
+import Quasar.Wayland.Surface
+import System.Posix (Fd)
+
+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"
+    tryFinalizeShmPool buffer.pool
+
+
+-- | Wrapper for an externally managed shm pool
+data ShmPool = ShmPool {
+  fd :: TVar (Maybe Fd),
+  size :: TVar Int32,
+  bufferCount :: TVar Word32,
+  destroyed :: TVar Bool,
+  downstreams :: TVar [DownstreamShmPool]
+}
+
+data ShmBuffer = ShmBuffer {
+  pool :: ShmPool,
+  offset :: Int32,
+  width :: Int32,
+  height :: Int32,
+  stride :: Int32,
+  format :: Word32,
+  releaseFn :: STM ()
+}
+
+-- | Create an `ShmPool` for externally managed memory. Takes ownership of the passed file descriptor.
+newShmPool :: Fd -> Int32 -> STM ShmPool
+newShmPool fd size = do
+  fdVar <- newTVar (Just fd)
+  sizeVar <- newTVar size
+  bufferCount <- newTVar 0
+  destroyed <- newTVar False
+  downstreams <- newTVar mempty
+  pure ShmPool {
+    fd = fdVar,
+    size = sizeVar,
+    bufferCount,
+    destroyed,
+    downstreams
+  }
+
+-- | Resize an externally managed shm pool.
+resizeShmPool :: ShmPool -> Int32 -> STM ()
+resizeShmPool pool size = do
+  oldSize <- readTVar pool.size
+  when (oldSize > size) $ throwM $ ProtocolUsageError (mconcat ["wl_shm: Invalid resize from ", show oldSize, " to ", show size])
+  writeTVar pool.size size
+
+-- | Destroy an externally managed shm pool. Memory shared to this pool will be deallocated after the last buffer is released.
+destroyShmPool :: ShmPool -> STM ()
+destroyShmPool pool = do
+  alreadyDestroyed <- swapTVar pool.destroyed True
+  unless alreadyDestroyed do
+    tryFinalizeShmPool pool
+
+tryFinalizeShmPool :: ShmPool -> STM ()
+tryFinalizeShmPool pool = do
+  destroyed <- readTVar pool.destroyed
+  bufferCount <- readTVar pool.bufferCount
+  when (destroyed && bufferCount == 0) do
+    fd <- swapTVar pool.fd Nothing
+    traceM "Finalized ShmPool"
+    -- TODO close fd
+    traceM $ "leaking fd " <> show fd <> " (closing fd is not implemented yet)"
+
+
+-- | 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
+  -- TODO check arguments
+  modifyTVar pool.bufferCount succ
+  let shmBuffer = ShmBuffer pool offset width height stride format releaseFn
+  newBuffer @ShmBufferBackend shmBuffer
+
+data DownstreamShmPool = DownstreamShmPool
+
+connectDownstreamShmPool :: ShmPool -> DownstreamShmPool -> STM ()
+connectDownstreamShmPool pool downstream = undefined

src/Quasar/Wayland/Surface.hs

 module Quasar.Wayland.Surface (
+  -- * Buffer backend
   BufferBackend(..),
-  ShmBufferBackend(..),
+  Buffer,
+  newBuffer,
+  lockBuffer,
+  destroyBuffer,
+  getBuffer,
+
+  -- * Surface
+  Damage(..),
   Surface,
+  SurfaceCommit(..),
+  defaultSurfaceCommit,
   newSurface,
   assignSurfaceRole,
-  initializeServerSurface,
+  commitSurface,
 ) where
 
 import Control.Monad.Catch
 import Data.Typeable
-import GHC.Records
 import Quasar.Prelude
 import Quasar.Wayland.Protocol
 import Quasar.Wayland.Protocol.Generated
-import Quasar.Wayland.Region (Rectangle(..), appAsRect)
+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,
+  destroyed :: TVar Bool
+}
+
+newBuffer :: forall b. BufferContent b -> STM (Buffer b)
+newBuffer content = do
+  lockCount <- newTVar 0
+  destroyed <- newTVar False
+  pure Buffer {
+    content,
+    lockCount,
+    destroyed
+  }
+
+-- | Prevents the buffer from being released. Returns an unlock action.
+lockBuffer :: forall b. BufferBackend b => Buffer b -> STM (STM ())
+lockBuffer buffer = do
+  modifyTVar buffer.lockCount succ
+  pure unlockBuffer
+  where
+    unlockBuffer :: STM ()
+    unlockBuffer = do
+      lockCount <- stateTVar buffer.lockCount (dup . pred)
+      when (lockCount == 0) do
+        releaseBuffer @b buffer.content
+        tryFinalizeBuffer @b buffer
+
+destroyBuffer :: forall b. BufferBackend b => Buffer b -> STM ()
+destroyBuffer buffer = do
+  alreadyDestroyed <- readTVar buffer.destroyed
+  unless alreadyDestroyed do
+    writeTVar buffer.destroyed True
+    tryFinalizeBuffer buffer
+
+tryFinalizeBuffer :: forall b. BufferBackend b => Buffer b -> STM ()
+tryFinalizeBuffer buffer = do
+  destroyed <- readTVar buffer.destroyed
+  lockCount <- readTVar buffer.lockCount
+  when (destroyed && lockCount == 0) do
+    releaseBufferStorage @b buffer.content
 
-class (Typeable b, Typeable (Buffer b)) => BufferBackend (b :: Type) where
-  type Buffer b
 
 getBuffer :: forall b. BufferBackend b => Object 'Server Interface_wl_buffer -> STM (Buffer b)
 getBuffer wlBuffer = do
@@ -26,13 +84,6 @@ getBuffer wlBuffer = do
     Nothing -> throwM $ InternalError ("Missing interface data on " <> show wlBuffer)
 
 
-data ShmBufferBackend = ShmBufferBackend
-data ShmBuffer = ShmBuffer
-
-instance BufferBackend ShmBufferBackend where
-  type Buffer ShmBufferBackend = ShmBuffer
-
-
 class SurfaceRole a where
   surfaceRoleName :: a -> String
 
@@ -42,45 +93,49 @@ instance SurfaceRole SomeSurfaceRole where
   surfaceRoleName (SomeSurfaceRole role) = surfaceRoleName role
 
 
+data Damage = DamageAll | DamageList [Rectangle]
+
+instance Semigroup Damage where
+  DamageAll <> _ = DamageAll
+  _ <> DamageAll = DamageAll
+  DamageList xs <> DamageList ys = DamageList (xs <> ys)
+
+
 data Surface b = Surface {
   surfaceRole :: TVar (Maybe SomeSurfaceRole),
-  surfaceState :: TVar (SurfaceState b),
-  pendingSurfaceState :: TVar (SurfaceState b),
-  pendingSurfaceDamage :: TVar [Rectangle],
-  pendingBufferDamage :: TVar [Rectangle]
+  surfaceState :: TVar (SurfaceCommit b),
+  lastBufferUnlockFn :: TVar (Maybe (STM ())),
+  downstreams :: TVar [SurfaceDownstream b]
 }
 
-data SurfaceState b = SurfaceState {
+data SurfaceCommit b = SurfaceCommit {
   buffer :: Maybe (Buffer b),
-  offset :: (Int32, Int32)
+  offset :: (Int32, Int32),
+  bufferDamage :: Damage
 }
 
-defaultSurfaceState :: SurfaceState b
-defaultSurfaceState = SurfaceState {
+type SurfaceDownstream b = SurfaceCommit b -> STM ()
+
+defaultSurfaceCommit :: Damage -> SurfaceCommit b
+defaultSurfaceCommit bufferDamage = SurfaceCommit {
   buffer = Nothing,
-  offset = (0, 0)
+  offset = (0, 0),
+  bufferDamage
 }
 
-newtype ServerSurface b = ServerSurface (Surface b)
-
 newSurface :: forall b. STM (Surface b)
 newSurface = do
   surfaceRole <- newTVar Nothing
-  surfaceState <- newTVar (defaultSurfaceState @b)
-  pendingSurfaceState <- newTVar (defaultSurfaceState @b)
-  pendingSurfaceDamage <- newTVar mempty
-  pendingBufferDamage <- newTVar mempty
+  surfaceState <- newTVar (defaultSurfaceCommit DamageAll)
+  lastBufferUnlockFn <- newTVar Nothing
+  downstreams <- newTVar []
   pure Surface {
     surfaceRole,
     surfaceState,
-    pendingSurfaceState,
-    pendingSurfaceDamage,
-    pendingBufferDamage
+    lastBufferUnlockFn,
+    downstreams
   }
 
-modifyPending :: forall b. Surface b -> (SurfaceState b -> SurfaceState b) -> STM ()
-modifyPending surface fn = modifyTVar surface.pendingSurfaceState fn
-
 assignSurfaceRole :: SurfaceRole a => Surface b -> a -> STM ()
 assignSurfaceRole surface role = do
   readTVar surface.surfaceRole >>= \case
@@ -91,62 +146,14 @@ assignSurfaceRole surface role = do
 
   writeTVar surface.surfaceRole (Just (SomeSurfaceRole role))
 
+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
 
-commitSurface :: forall b. Surface b -> STM ()
-commitSurface surface = do
-  state <- readTVar surface.pendingSurfaceState
-
-  -- TODO propagate damage
-  _surfaceDamage <- swapTVar surface.pendingSurfaceDamage mempty
-  _bufferDamage <- swapTVar surface.pendingBufferDamage mempty
-
-  writeTVar surface.surfaceState state
-  writeTVar surface.pendingSurfaceState $
-    state {
-      buffer = Nothing
-    }
-
-  traceM "committed"
-
-  -- TODO effects
-
-setSurfaceContent :: forall b. Surface b -> Maybe (Buffer b) -> Int32 -> Int32 -> STM ()
-setSurfaceContent surface buffer x y =
-  modifyPending surface \s ->
-    s {
-      buffer,
-      offset = (x, y)
-    }
-
-damageSurface :: forall b. Surface b -> Rectangle -> STM ()
-damageSurface surface rect =
-  modifyTVar surface.pendingSurfaceDamage (rect:)
-
-damageBuffer :: forall b. Surface b -> Rectangle -> STM ()
-damageBuffer surface rect =
-  modifyTVar surface.pendingBufferDamage (rect:)
-
-initializeServerSurface :: forall b. BufferBackend b => Object 'Server Interface_wl_surface -> STM ()
-initializeServerSurface wlSurface = do
-  surface <- newSurface @b
-  traceM "setting message handler"
-  setMessageHandler wlSurface RequestHandler_wl_surface {
-    -- TODO ensure role is destroyed before surface
-    destroy = pure (),
-    attach = attach surface,
-    damage = appAsRect (damageSurface surface),
-    frame = \callback -> pure (),
-    set_opaque_region = \region -> pure (),
-    set_input_region = \region -> pure (),
-    commit = commitSurface surface,
-    set_buffer_transform = \transform -> pure (),
-    set_buffer_scale = \scale -> pure (),
-    damage_buffer = appAsRect (damageBuffer surface)
-  }
-  setInterfaceData wlSurface (ServerSurface @b surface)
-  traceM "wl_surface not implemented"
-  where
-    attach :: Surface b -> Maybe (Object 'Server Interface_wl_buffer) -> Int32 -> Int32 -> STM ()
-    attach surface wlBuffer x y = do
-      buffer <- mapM (getBuffer @b) wlBuffer
-      setSurfaceContent surface buffer x y
+  downstreams <- readTVar surface.downstreams
+  -- TODO handle exceptions, remove failed downstreams
+  mapM_ ($ commit) downstreams
+
+connectSurfaceDownstream :: forall b. Surface b -> SurfaceDownstream b -> STM ()
+connectSurfaceDownstream = undefined