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,25 @@ 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)
+        await =<< newDelay 1000000
+
+        buffer2 <- liftIO $ toImageBuffer shm (mkImage solidColor)
+
+        liftIO $ atomically do
+          wlSurface.attach (Just buffer2) 0 0
+          wlSurface.damage 0 0 42 42
+          wlSurface.commit
+
+        await =<< newDelay 1000000
 
-        --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

@@ -4,10 +4,40 @@ import Quasar
 import Quasar.Prelude
 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
-  registry <- newRegistry
+  let
+    layerShellGlobal = createGlobal @Interface_zwlr_layer_shell_v1 maxVersion (\x -> setRequestHandler x layerShellHandler)
+  registry <- newRegistry [compositorGlobal @ShmBufferBackend, shmGlobal, layerShellGlobal]
   server <- newWaylandServer registry
   listenAt "example.socket" server
   sleepForever
+
+layerShellHandler :: RequestHandler_zwlr_layer_shell_v1
+layerShellHandler =
+  RequestHandler_zwlr_layer_shell_v1 {
+    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 ()
+  }
+
+layerSurfaceHandler :: RequestHandler_zwlr_layer_surface_v1
+layerSurfaceHandler =
+  RequestHandler_zwlr_layer_surface_v1 {
+    set_size = \_ _ -> pure (),
+    set_anchor = \_ -> pure (),
+    set_exclusive_zone = \_ -> pure (),
+    set_margin = \_ _ _ _ -> pure (),
+    set_keyboard_interactivity = \_ -> pure (),
+    get_popup = \_ -> pure (),
+    ack_configure = \_ -> pure (),
+    destroy = pure (),
+    set_layer = \_ -> pure ()
+  }

flake.lock

@@ -2,11 +2,11 @@
   "nodes": {
     "nixpkgs": {
       "locked": {
-        "lastModified": 1659077768,
-        "narHash": "sha256-P0XIHBVty6WIuIrk2DZNvLcYev9956y1prT4zL212H8=",
+        "lastModified": 1660396586,
+        "narHash": "sha256-ePuWn7z/J5p2lO7YokOG1o01M0pDDVL3VrStaPpS5Ig=",
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "2a93ea177c3d7700b934bf95adfe00c435f696b8",
+        "rev": "e105167e98817ba9fe079c6c3c544c6ef188e276",
         "type": "github"
       },
       "original": {
@@ -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": {

flake.nix

@@ -21,7 +21,7 @@
       ]; };
     in rec {
       default = quasar-wayland;
-      quasar-wayland = pkgs.haskell.packages.ghc923.quasar-wayland;
+      quasar-wayland = pkgs.haskell.packages.ghc924.quasar-wayland;
     }
     );
 

quasar-wayland.cabal

@@ -47,6 +47,7 @@ common shared-properties
     RankNTypes
     ScopedTypeVariables
     StandaloneDeriving
+    StandaloneKindSignatures
     TupleSections
     TypeApplications
     TypeFamilies
@@ -83,9 +84,14 @@ library
     Quasar.Wayland.Protocol
     Quasar.Wayland.Protocol.Generated
     Quasar.Wayland.Protocol.TH
+    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
     Quasar.Wayland.Utils.InlineC

src/Quasar/Wayland/Client/Buffer.hs

@@ -19,12 +19,6 @@ import System.Posix.IO (closeFd)
 import System.Posix.Types (Fd)
 
 
-data Buffer = Buffer {
-  wlBuffer :: Object 'Client Interface_wl_buffer,
-  currentlyUsed :: TVar Bool
-}
-
-
 data ShmBufferManager = ShmBufferManager {
   wlShm :: Object 'Client Interface_wl_shm,
   formats :: Future (Set.Set Word32)
@@ -73,8 +67,13 @@ newShmBuffer
 newShmBuffer shm width height = do
   (wlShmPool, ptr) <- trySendShm size (\fd -> shm.wlShm.create_pool fd size)
 
-  wlBuffer <- liftIO $ atomically $
-    wlShmPool.create_buffer offset width height stride pixelFormat
+  wlBuffer <- liftIO $ atomically do
+    wlBuffer <- wlShmPool.create_buffer offset width height stride pixelFormat
+    setEventHandler wlBuffer EventHandler_wl_buffer {
+      -- TODO
+      release = wlBuffer.destroy
+    }
+    pure wlBuffer
 
   atomically wlShmPool.destroy
 

src/Quasar/Wayland/Protocol.hs

@@ -4,10 +4,14 @@ module Quasar.Wayland.Protocol (
   -- "Quasar.Wayland.Protocol.TH".
 
   Object(objectProtocol),
+  NewObject,
   setEventHandler,
   setRequestHandler,
   setMessageHandler,
   getMessageHandler,
+  setInterfaceData,
+  getInterfaceData,
+  isDestroyed,
 
   -- ** Wayland types
   WlFixed(..),
@@ -30,6 +34,7 @@ module Quasar.Wayland.Protocol (
   ProtocolUsageError(..),
   MaximumIdReached(..),
   ServerError(..),
+  InternalError(..),
 
   -- ** Classes for generated interfaces
   IsInterface(InterfaceName),

src/Quasar/Wayland/Protocol/Core.hs

@@ -24,6 +24,9 @@ module Quasar.Wayland.Protocol.Core (
   setRequestHandler,
   setMessageHandler,
   getMessageHandler,
+  setInterfaceData,
+  getInterfaceData,
+  isDestroyed,
   NewObject,
   IsObject,
   IsMessage(..),
@@ -64,6 +67,7 @@ module Quasar.Wayland.Protocol.Core (
   ProtocolUsageError(..),
   MaximumIdReached(..),
   ServerError(..),
+  InternalError(..),
 
   -- * Message decoder operations
   WireFormat(..),
@@ -80,11 +84,12 @@ import Data.ByteString (ByteString)
 import Data.ByteString qualified as BS
 import Data.ByteString.Lazy qualified as BSL
 import Data.ByteString.UTF8 qualified as BSUTF8
+import Data.Dynamic (Dynamic, toDyn, fromDynamic)
 import Data.Foldable (toList)
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
 import Data.Proxy
-import Data.Sequence (Seq)
+import Data.Sequence (Seq(Empty, (:<|)))
 import Data.Sequence qualified as Seq
 import Data.String (IsString(..))
 import Data.Typeable (Typeable, cast)
@@ -191,11 +196,13 @@ instance WireFormat BS.ByteString where
 instance KnownSymbol j => WireFormat (ObjectId (j :: Symbol)) where
   putArgument (ObjectId oId) = pure $ MessagePart (putWord32host oId) 4 mempty
   getArgument = pure . ObjectId <$> getWord32host
+  showArgument (ObjectId 0) = "null"
   showArgument (ObjectId oId) = symbolVal @j Proxy <> "@" <> show oId
 
 instance WireFormat GenericObjectId where
   putArgument (GenericObjectId oId) = pure $ MessagePart (putWord32host oId) 4 mempty
   getArgument = pure . GenericObjectId <$> getWord32host
+  showArgument (GenericObjectId 0) = "null"
   showArgument oId = "[unknown]@" <> show oId
 
 instance KnownSymbol j => WireFormat (NewId (j :: Symbol)) where
@@ -214,9 +221,15 @@ instance WireFormat GenericNewId where
 
 instance WireFormat Fd where
   putArgument fd = pure (MessagePart mempty 0 (Seq.singleton fd))
-  getArgument = undefined
+  getArgument = pure getFd
   showArgument (Fd fd) = "fd@" <> show fd
 
+getFd :: ProtocolM s Fd
+getFd =
+  readProtocolVar (.inboxFdsVar) >>= \case
+    (fd :<| fds) -> fd <$ writeProtocolVar (.inboxFdsVar) fds
+    Empty -> throwM $ ProtocolException "Expected fd"
+
 
 -- | Class for a proxy type (in the haskell sense) that describes a Wayland interface.
 class (
@@ -308,12 +321,13 @@ data Object s i = IsInterfaceSide s i => Object {
   objectProtocol :: (ProtocolHandle s),
   objectId :: ObjectId (InterfaceName i),
   messageHandler :: TVar (Maybe (MessageHandler s i)),
+  -- FIXME type-safe variant for `interfaceData`?
+  interfaceData :: TVar Dynamic,
   destroyed :: TVar Bool
 }
 
-
-getMessageHandler :: Object s i -> STM (MessageHandler s i)
-getMessageHandler object = maybe retry pure =<< readTVar object.messageHandler
+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
 
 setMessageHandler :: Object s i -> MessageHandler s i -> STM ()
 setMessageHandler object = writeTVar object.messageHandler . Just
@@ -324,6 +338,17 @@ setRequestHandler = setMessageHandler
 setEventHandler :: Object 'Client i -> EventHandler i -> STM ()
 setEventHandler = setMessageHandler
 
+-- | Attach interface-specific data to the object. Should only be used by the primary interface implementation.
+setInterfaceData :: Typeable a => Object s i -> a -> STM ()
+setInterfaceData object value = writeTVar object.interfaceData (toDyn value)
+
+-- | Get interface-specific data that was attached to the object.
+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
 
@@ -415,6 +440,10 @@ data ServerError = ServerError Word32 String
   deriving stock Show
   deriving anyclass Exception
 
+data InternalError = InternalError String
+  deriving stock Show
+  deriving anyclass Exception
+
 data InvalidObject = InvalidObject String
   deriving stock Show
   deriving anyclass Exception
@@ -504,8 +533,15 @@ initializeProtocol wlDisplayMessageHandler sendWlDisplayDeleteId initializationA
   }
 
   messageHandlerVar <- newTVar (Just (wlDisplayMessageHandler protocol))
+  interfaceData <- newTVar (toDyn ())
   destroyed <- newTVar False
-  let wlDisplay = Object protocol wlDisplayId messageHandlerVar destroyed
+  let wlDisplay = Object {
+        objectProtocol = protocol,
+        objectId = wlDisplayId,
+        messageHandler = messageHandlerVar,
+        interfaceData,
+        destroyed
+      }
 
   let state = ProtocolState {
     protocolHandle = protocol,
@@ -624,9 +660,16 @@ newObjectFromId
 newObjectFromId messageHandler (NewId oId) = do
   protocol <- askProtocol
   messageHandlerVar <- lift $ newTVar messageHandler
+  interfaceDataVar <- lift $ newTVar (toDyn ())
   destroyed <- lift $ newTVar False
   let
-    object = Object protocol oId messageHandlerVar destroyed
+    object = Object {
+      objectProtocol = protocol,
+      objectId = oId,
+      messageHandler = messageHandlerVar,
+      interfaceData = interfaceDataVar,
+      destroyed
+    }
     someObject = SomeObject object
   modifyProtocolVar (.objectsVar) (HM.insert (genericObjectId object) someObject)
   pure object

src/Quasar/Wayland/Region.hs

+module Quasar.Wayland.Region (
+  IsRegion,
+  Region,
+  newRegion,
+  addDownstream,
+  Rectangle(..),
+  appRect,
+  appAsRect,
+  addToRegion,
+  subtractFromRegion,
+  destroyRegion,
+  initializeServerRegion,
+) where
+
+import Control.Monad.Catch
+import Quasar.Prelude
+import Quasar.Wayland.Protocol
+import Quasar.Wayland.Protocol.Generated
+import GHC.Records
+
+
+type IsRegion a = (
+  HasField "destroy" a (STM ()),
+  HasField "add" a (Int32 -> Int32 -> Int32 -> Int32 -> STM ()),
+  HasField "subtract" a (Int32 -> Int32 -> Int32 -> Int32 -> STM ())
+  )
+
+data SomeRegion = forall a. IsRegion a => SomeRegion a
+
+instance HasField "destroy" SomeRegion (STM ()) where
+  getField (SomeRegion region) = region.destroy
+instance HasField "add" SomeRegion (Int32 -> Int32 -> Int32 -> Int32 -> STM ()) where
+  getField (SomeRegion region) = region.add
+instance HasField "subtract" SomeRegion (Int32 -> Int32 -> Int32 -> Int32 -> STM ()) where
+  getField (SomeRegion region) = region.subtract
+
+data Region = Region {
+  operations :: TVar [RegionOperation],
+  downstreams :: TVar [SomeRegion],
+  isDestroyed :: TVar Bool
+}
+
+initializeServerRegion :: Object 'Server Interface_wl_region -> STM ()
+initializeServerRegion wlRegion = do
+  region <- newRegion
+  setMessageHandler wlRegion RequestHandler_wl_region {
+    destroy = region.destroy,
+    add = region.add,
+    subtract = region.subtract
+  }
+  setInterfaceData wlRegion region
+
+instance HasField "destroy" Region (STM ()) where
+  getField = destroyRegion
+instance HasField "add" Region (Int32 -> Int32 -> Int32 -> Int32 -> STM ()) where
+  getField region x y width height = addToRegion region (Rectangle x y width height)
+instance HasField "subtract" Region (Int32 -> Int32 -> Int32 -> Int32 -> STM ()) where
+  getField region x y width height = subtractFromRegion region (Rectangle x y width height)
+
+data RegionOperation = Add Rectangle | Subtract Rectangle
+
+data Rectangle = Rectangle {
+  x :: Int32,
+  y :: Int32,
+  width :: Int32,
+  height :: Int32
+}
+
+contains :: Rectangle -> Rectangle -> Bool
+contains (Rectangle x0 y0 width0 height0) (Rectangle x1 y1 width1 height1) =
+  x0 <= x1 &&
+  y0 <= y1 &&
+  x0 + width0 >= x1 + width1 &&
+  y0 + height0 >= y1 + height1
+
+newRegion :: STM Region
+newRegion = Region <$> newTVar mempty <*> newTVar mempty <*> newTVar False
+
+addDownstream :: IsRegion a => Region -> a -> STM ()
+addDownstream region (SomeRegion -> downstream) = do
+  modifyTVar region.downstreams (downstream:)
+  -- Replay operations for new downstream
+  applyOperations downstream =<< readTVar region.operations
+
+
+applyOperations :: SomeRegion -> [RegionOperation] -> STM ()
+applyOperations region ops = mapM_ (applyOperation region) (reverse ops)
+
+applyOperation :: SomeRegion -> RegionOperation -> STM ()
+applyOperation region (Add rect) = region.add `appRect` rect
+applyOperation region (Subtract rect) = region.subtract `appRect` rect
+
+appRect :: (Int32 -> Int32 -> Int32 -> Int32 -> a) -> Rectangle -> a
+appRect fn (Rectangle x y width height) = fn x y width height
+
+appAsRect :: (Rectangle -> a) -> Int32 -> Int32 -> Int32 -> Int32 -> a
+appAsRect fn x y width height = fn (Rectangle x y width height)
+
+callDownstreams :: (SomeRegion -> STM ()) -> Region -> STM ()
+callDownstreams fn region = do
+  downstreams <- readTVar region.downstreams
+  -- Filter broken (e.g. disconnected) downstreams
+  newDownstreams <- mapM (\downstream -> ((Just downstream <$ fn downstream) `catchAll` \_ -> pure Nothing) ) downstreams
+  writeTVar region.downstreams (catMaybes newDownstreams)
+
+addToRegion :: Region -> Rectangle -> STM ()
+addToRegion region rect = do
+  whenM (readTVar region.isDestroyed) (throwM (ProtocolUsageError "`add` called on destroyed Region"))
+  whenM (addIsRequired rect <$> readTVar region.operations) do
+    modifyTVar region.operations (addNormalized rect)
+    callDownstreams (\downstream -> downstream.add `appRect` rect) region
+
+addIsRequired :: Rectangle -> [RegionOperation] -> Bool
+addIsRequired rect (Add top:_) = not (top `contains` rect)
+addIsRequired _ _ = True
+
+addNormalized :: Rectangle -> [RegionOperation] -> [RegionOperation]
+addNormalized rect [] = [Add rect]
+addNormalized rect old@(Add top:others)
+  | rect `contains` top = addNormalized rect others
+  | otherwise = Add rect : old
+addNormalized rect old@(Subtract top:others)
+  | rect `contains` top = addNormalized rect others
+  | otherwise = Add rect : old
+
+
+subtractFromRegion :: Region -> Rectangle -> STM ()
+subtractFromRegion region rect = do
+  whenM (readTVar region.isDestroyed) (throwM (ProtocolUsageError "`subtract` called on destroyed Region"))
+  whenM (subtractIsRequired rect <$> readTVar region.operations) do
+    modifyTVar region.operations (subtractNormalized rect)
+    callDownstreams (\downstream -> downstream.subtract `appRect` rect) region
+
+subtractIsRequired :: Rectangle -> [RegionOperation] -> Bool
+subtractIsRequired rect (Subtract top:_) = not (top `contains` rect)
+subtractIsRequired _ _ = True
+
+subtractNormalized :: Rectangle -> [RegionOperation] -> [RegionOperation]
+subtractNormalized _rect [] = []
+subtractNormalized rect old@(Add top:others)
+  | rect `contains` top = subtractNormalized rect others
+  | otherwise = Subtract rect : old
+subtractNormalized rect old@(Subtract top:others)
+  | rect `contains` top = subtractNormalized rect others
+  | otherwise = Subtract rect : old
+
+
+destroyRegion :: Region -> STM ()
+destroyRegion region = do
+  unlessM (swapTVar region.isDestroyed True) do
+    callDownstreams (.destroy) region
+    writeTVar region.downstreams mempty

src/Quasar/Wayland/Server.hs

@@ -4,6 +4,7 @@ module Quasar.Wayland.Server (
   newWaylandServer,
   newWaylandServerConnection,
   listenAt,
+  compositorGlobal,
 ) where
 
 import Control.Monad.Catch
@@ -13,8 +14,11 @@ import Quasar.Prelude
 import Quasar.Wayland.Connection
 import Quasar.Wayland.Protocol
 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
 
 
 data WaylandServer = WaylandServer {
@@ -58,3 +62,16 @@ listenAt socketPath server = disposeOnError do
   asyncWithUnmask_ \_ -> forever do
     socket <- atomically $ takeTMVar var
     newWaylandServerConnection server socket
+
+
+compositorGlobal :: forall b. BufferBackend b => Global
+compositorGlobal = createGlobal @Interface_wl_compositor maxVersion bindCompositor
+  where
+    bindCompositor :: Object 'Server Interface_wl_compositor -> STM ()
+    bindCompositor wlCompositor = setMessageHandler wlCompositor handler
+
+    handler :: RequestHandler_wl_compositor
+    handler = RequestHandler_wl_compositor {
+      create_surface = initializeServerSurface @b,
+      create_region = initializeServerRegion
+    }

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

+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,
+  getBuffer,
+) where
+
+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.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
+  }
+
+getBuffer :: forall b. BufferBackend b => Object 'Server Interface_wl_buffer -> STM (Buffer b)
+getBuffer wlBuffer = do
+  ifd <- getInterfaceData @(Buffer b) wlBuffer
+  case ifd of
+    Just buffer -> pure buffer
+    Nothing -> throwM $ InternalError ("Missing interface data on " <> show wlBuffer)

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(..),
+  Buffer,
+  newBuffer,
+  lockBuffer,
+  destroyBuffer,
+
+  -- * Surface
+  Damage(..),
+  Surface,
+  SurfaceCommit(..),
+  defaultSurfaceCommit,
+  newSurface,
+  assignSurfaceRole,
+  commitSurface,
+) 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,
+  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 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
+  DamageAll <> _ = DamageAll
+  _ <> DamageAll = DamageAll
+  DamageList xs <> DamageList ys = DamageList (xs <> ys)
+
+
+data Surface b = Surface {
+  surfaceRole :: TVar (Maybe SomeSurfaceRole),
+  surfaceState :: TVar (SurfaceCommit b),
+  lastBufferUnlockFn :: TVar (Maybe (STM ())),
+  downstreams :: TVar [SurfaceDownstream b]
+}
+
+data SurfaceCommit b = SurfaceCommit {
+  buffer :: Maybe (Buffer b),
+  offset :: (Int32, Int32),
+  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
+defaultSurfaceCommit bufferDamage = SurfaceCommit {
+  buffer = Nothing,
+  offset = (0, 0),
+  bufferDamage
+}
+
+newSurface :: forall b. STM (Surface b)
+newSurface = do
+  surfaceRole <- newTVar Nothing
+  surfaceState <- newTVar (defaultSurfaceCommit DamageAll)
+  lastBufferUnlockFn <- newTVar Nothing
+  downstreams <- newTVar []
+  pure Surface {
+    surfaceRole,
+    surfaceState,
+    lastBufferUnlockFn,
+    downstreams
+  }
+
+assignSurfaceRole :: SurfaceRole a => Surface b -> a -> STM ()
+assignSurfaceRole surface role = do
+  readTVar surface.surfaceRole >>= \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 :: 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
+
+  downstreams <- readTVar surface.downstreams
+  -- TODO handle exceptions, remove failed downstreams
+  mapM_ ($ commit) downstreams
+
+connectSurfaceDownstream :: forall b. Surface b -> SurfaceDownstream b -> STM ()
+connectSurfaceDownstream = undefined