examples/Client.hs

@@ -6,10 +6,12 @@ import Quasar
 import Quasar.Prelude
 import Quasar.Timer
 import Quasar.Wayland.Client
-import Quasar.Wayland.Client.Buffer
 import Quasar.Wayland.Client.JuicyPixels
+import Quasar.Wayland.Client.Surface
 import Quasar.Wayland.Protocol
 import Quasar.Wayland.Protocol.Generated
+import Quasar.Wayland.Shm
+import Quasar.Wayland.Surface
 
 import Codec.Picture
 
@@ -39,8 +41,8 @@ mkDimensions width height = Dimensions { width, height, aspect }
 mkPosition :: Dimensions -> Int -> Int -> Position
 mkPosition dimensions pixelX pixelY = Position { dimensions, pixelX, pixelY, u, v, x, y }
   where
-    width' = width dimensions
-    height' = height dimensions
+    width' = dimensions.width
+    height' = dimensions.height
     u :: Double
     u = (fromIntegral pixelX) / (fromIntegral width')
     v :: Double
@@ -52,9 +54,10 @@ mkPosition dimensions pixelX pixelY = Position { dimensions, pixelX, pixelY, u,
     y :: Double
     y = (fromIntegral $ pixelY - (div height' 2)) / (fromIntegral innerRadius)
 
-color :: RealFrac a => a -> a -> a -> PixelRGBA8
+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
@@ -78,22 +81,24 @@ mkImage fn = generateImage pixel width height
 
 main :: IO ()
 main = do
-  runQuasarAndExit (stderrLogger LogLevelWarning) do
+  _ <- runQuasarAndExit (stderrLogger LogLevelWarning) do
     traceIO "Connecting"
     client <- connectWaylandClient
     traceIO "Connected"
 
     join $ liftIO $ atomically do
 
-      wlCompositor <- bindSingleton @Interface_wl_compositor client.registry
+      -- wlSurface <- wlCompositor.create_surface
+      -- setMessageHandler wlSurface EventHandler_wl_surface {
+      --   enter = \_ -> pure (),
+      --   leave = \_ -> pure ()
+      -- }
 
-      shm <- newShmBufferManager client
-
-      wlSurface <- wlCompositor.create_surface
-      setMessageHandler wlSurface EventHandler_wl_surface {
-        enter = \_ -> pure (),
-        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 {
@@ -113,52 +118,80 @@ main = do
       --xdgToplevel.set_title "foobar"
 
 
+      (surface, wlSurface) <- newClientSurface @ShmBufferBackend client
+      (surface2, wlSurface2) <- newClientSurface @ShmBufferBackend client
+
+
       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 {
-        configure = \serial width height -> do
+        configure = \serial _width _height -> do
             wlrLayerSurface.ack_configure serial
             writeTVar configuredVar True,
         closed = pure ()
       }
       wlrLayerSurface.set_size 512 512
+      wlrLayerSurface.set_anchor 1
+
+      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
+      wlrLayerSurface2.set_anchor 2
 
       -- Commit role
       wlSurface.commit
+      wlSurface2.commit
       -- Should await first `configure` event
 
       pure do
-        buffer <- liftIO $ toImageBuffer shm (mkImage gradient)
+        buffer <- liftIO $ toImageBuffer (mkImage gradient)
+        buffer2 <- liftIO $ toImageBuffer (mkImage solidColor)
 
         liftIO $ atomically do
           check =<< readTVar configuredVar
-          wlSurface.attach (Just buffer) 0 0
-          wlSurface.commit
-
-        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
+          check =<< readTVar configuredVar2
+          commitSurface surface SurfaceCommit {
+            buffer = Just buffer,
+            offset = (0, 0),
+            bufferDamage = DamageAll
+          }
+          commitSurface surface2 SurfaceCommit {
+            buffer = Just buffer2,
+            offset = (0, 0),
+            bufferDamage = DamageList [Rectangle 0 0 42 42]
+          }
+          --destroyBuffer buffer
+          --destroyBuffer buffer2
+
+        await =<< newDelay 100000
+        traceIO "Waiting 2s"
+        await =<< newDelay 2000000
 
         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
+          commitSurface surface SurfaceCommit {
+            buffer = Nothing,
+            offset = (0, 0),
+            bufferDamage = DamageList []
+          }
+          commitSurface surface2 SurfaceCommit {
+            buffer = Nothing,
+            offset = (0, 0),
+            bufferDamage = DamageList []
+          }
+
+        -- traceIO . ("shm buffer formats: " <>) . mconcat . intersperse ", " . fmap show . toList =<< await shm.formats
 
         pure ()
 
-    traceIO "Waiting 2s"
-    await =<< newDelay 2000000
+    await =<< newDelay 1000000
     traceIO "Closing"
   traceIO "Closed"

quasar-wayland.cabal

@@ -75,7 +75,7 @@ library
   import: shared-properties
   exposed-modules:
     Quasar.Wayland.Client
-    Quasar.Wayland.Client.Buffer
+    Quasar.Wayland.Client.ShmBuffer
     Quasar.Wayland.Client.JuicyPixels
     Quasar.Wayland.Client.Registry
     Quasar.Wayland.Client.Socket
@@ -96,6 +96,7 @@ library
   other-modules:
     Quasar.Wayland.Protocol.Core
     Quasar.Wayland.Utils.InlineC
+    Quasar.Wayland.Utils.Once
     Quasar.Wayland.Utils.SharedMemory
     Quasar.Wayland.Utils.Socket
   build-depends:

src/Quasar/Wayland/Client.hs

@@ -7,10 +7,15 @@ module Quasar.Wayland.Client (
   Registry,
   bindSingleton,
   tryBindSingleton,
+
+  getClientComponent
 ) where
 
-import Control.Concurrent.STM
 import Control.Monad.Catch
+import Data.Dynamic
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+import Data.Proxy
 import GHC.Records
 import Network.Socket (Socket)
 import Quasar
@@ -21,12 +26,14 @@ import Quasar.Wayland.Client.Socket
 import Quasar.Wayland.Connection
 import Quasar.Wayland.Protocol
 import Quasar.Wayland.Protocol.Generated
+import Type.Reflection (SomeTypeRep, someTypeRep)
 
 
 data WaylandClient = WaylandClient {
   connection :: WaylandConnection 'Client,
   wlDisplay :: Object 'Client Interface_wl_display,
-  registry :: Registry
+  registry :: Registry,
+  globals :: TVar (Map SomeTypeRep Dynamic)
 }
 
 instance Resource WaylandClient where
@@ -41,10 +48,13 @@ newWaylandClient :: (MonadIO m, MonadQuasar m) => Socket -> m WaylandClient
 newWaylandClient socket = do
   ((wlDisplay, registry), connection) <- newWaylandConnection newClientDisplay socket
 
+  globals <- newTVarIO mempty
+
   pure WaylandClient {
     connection,
     wlDisplay,
-    registry
+    registry,
+    globals
   }
   where
     newClientDisplay :: STM ((Object 'Client Interface_wl_display, Registry), ProtocolHandle 'Client)
@@ -65,3 +75,20 @@ newWaylandClient socket = do
 
 instance HasField "sync" WaylandClient (STM (Future ())) where
   getField client = lowLevelSyncFuture client.wlDisplay
+
+
+-- | Get or create a client component; only one component of the same type will be created.
+getClientComponent :: forall a. Typeable a => STM a -> WaylandClient -> STM a
+getClientComponent initFn client = do
+  globals <- readTVar client.globals
+  case Map.lookup key globals of
+    Just dyn ->
+      case (fromDynamic @a dyn) of
+        Just global -> pure global
+        Nothing -> unreachableCodePathM
+    Nothing -> do
+      global <- initFn
+      writeTVar client.globals (Map.insert key (toDyn global) globals)
+      pure global
+  where
+    key = someTypeRep (Proxy @a)

src/Quasar/Wayland/Client/Buffer.hs

-module Quasar.Wayland.Client.Buffer (
-  -- * wl_shm
-  ShmBufferManager(formats),
-  newShmBufferManager,
-  newShmPool,
-  newShmBuffer,
-) where
-
-import Control.Monad.Catch
-import Data.Set qualified as Set
-import Foreign
-import Quasar
-import Quasar.Prelude
-import Quasar.Wayland.Client
-import Quasar.Wayland.Protocol
-import Quasar.Wayland.Protocol.Generated
-import Quasar.Wayland.Utils.SharedMemory
-import System.Posix.IO (closeFd)
-import System.Posix.Types (Fd)
-
-
-data ShmBufferManager = ShmBufferManager {
-  wlShm :: Object 'Client Interface_wl_shm,
-  formats :: Future (Set.Set Word32)
-}
-
-newShmBufferManager :: WaylandClient -> STM ShmBufferManager
-newShmBufferManager client = do
-  formatsVar <- newTVar mempty
-
-  wlShm <- bindSingleton @Interface_wl_shm client.registry
-  setEventHandler wlShm $ EventHandler_wl_shm {
-    format = modifyTVar formatsVar . Set.insert
-  }
-
-  -- Formats are emittet all at once; sync ensures the list is complete
-  formatListComplete <- client.sync
-  let formats = formatListComplete >> unsafeAwaitSTM (readTVar formatsVar)
-
-  pure ShmBufferManager {
-    wlShm,
-    formats
-  }
-
-data ShmPool = ShmPool {
-  wlShmPool :: Object 'Client Interface_wl_shm_pool,
-  shmPtr :: TVar (Maybe (ForeignPtr Word8))
-}
-
-newShmPool :: ShmBufferManager -> Int32 -> IO ShmPool
-newShmPool shm size = do
-  (wlShmPool, ptr) <- trySendShm size (\fd -> shm.wlShm.create_pool fd size)
-
-  shmPtr <- newTVarIO (Just ptr)
-
-  pure ShmPool {
-    wlShmPool,
-    shmPtr
-  }
-
-
-newShmBuffer
-  :: ShmBufferManager
-  -> Int32
-  -> Int32
-  -> IO (Object 'Client Interface_wl_buffer, ForeignPtr Word32)
-newShmBuffer shm width height = do
-  (wlShmPool, ptr) <- trySendShm size (\fd -> shm.wlShm.create_pool fd size)
-
-  wlBuffer <- liftIO $ atomically do
-    wlBuffer <- wlShmPool.create_buffer offset width height stride pixelFormat
-    setEventHandler wlBuffer EventHandler_wl_buffer {
-      -- TODO
-      release = pure () -- wlBuffer.destroy
-    }
-    pure wlBuffer
-
-  atomically wlShmPool.destroy
-
-  pure (wlBuffer, castForeignPtr ptr)
-
-  where
-    bytePerPixel = 4
-    offset = 0
-    stride = width * bytePerPixel
-    size = width * height * bytePerPixel
-    pixelFormat = 0 -- argb8888
-
-
-trySendShm :: Int32 -> (Fd -> STM a) -> IO (a, ForeignPtr Word8)
-trySendShm size sendAction = do
-  fd <- memfdCreate $ fromIntegral size
-
-  -- Has to be created before sending since the fd will be closed when sent
-  ptr <- mmap fd $ fromIntegral size
-
-  -- Fd ownership is transferred to the outbox (it will be closed after it has
-  -- been sent)
-  result <- atomically (sendAction fd)
-    `onException`
-      (closeFd fd >> finalizeForeignPtr ptr)
-
-  pure (result, ptr)

src/Quasar/Wayland/Client/JuicyPixels.hs

@@ -7,18 +7,18 @@ module Quasar.Wayland.Client.JuicyPixels (
 import Codec.Picture
 import Foreign
 import Quasar.Prelude
-import Quasar.Wayland.Client.Buffer
-import Quasar.Wayland.Protocol
-import Quasar.Wayland.Protocol.Generated
+import Quasar.Wayland.Client.ShmBuffer
+import Quasar.Wayland.Shm
+import Quasar.Wayland.Surface
 
-loadImageBuffer :: ShmBufferManager -> FilePath -> IO (Object 'Client Interface_wl_buffer)
-loadImageBuffer shm path = do
+loadImageBuffer :: FilePath -> IO (Buffer ShmBufferBackend)
+loadImageBuffer path = do
   image <- either fail (pure . convertRGBA8) =<< readImage path
-  toImageBuffer shm image
+  toImageBuffer image
 
-toImageBuffer :: ShmBufferManager -> Image PixelRGBA8 -> IO (Object 'Client Interface_wl_buffer)
-toImageBuffer shm image = do
-  (buffer, ptr) <- newShmBuffer shm (fromIntegral (imageWidth image)) (fromIntegral (imageHeight image))
+toImageBuffer :: Image PixelRGBA8 -> IO (Buffer ShmBufferBackend)
+toImageBuffer image = do
+  (buffer, ptr) <- newLocalShmBuffer (fromIntegral (imageWidth image)) (fromIntegral (imageHeight image))
   let
     width = imageWidth image
     height = imageHeight image

src/Quasar/Wayland/Client/ShmBuffer.hs

+module Quasar.Wayland.Client.ShmBuffer (
+  -- * wl_shm
+  newLocalShmPool,
+  newLocalShmBuffer,
+) where
+
+import Control.Monad.Catch
+import Foreign
+import Quasar.Prelude
+import Quasar.Wayland.Shm
+import Quasar.Wayland.Surface
+import Quasar.Wayland.Utils.SharedMemory
+import System.Posix.IO (closeFd)
+
+
+newLocalShmPool :: Int32 -> IO (ShmPool, ForeignPtr Word8)
+newLocalShmPool size = do
+  fd <- memfdCreate $ fromIntegral size
+
+  ptr <- mmap fd $ fromIntegral size
+
+  -- Passes ownership of the fd to the pool
+  pool <- atomically (newShmPool fd size)
+    `onException`
+      (closeFd fd >> finalizeForeignPtr ptr)
+
+  pure (pool, ptr)
+
+
+newLocalShmBuffer
+  :: Int32
+  -> Int32
+  -> IO (Buffer ShmBufferBackend, ForeignPtr Word32)
+newLocalShmBuffer width height = do
+  (pool, ptr) <- newLocalShmPool size
+
+  atomically do
+    buffer <- newShmBuffer pool offset width height stride pixelFormat
+
+    -- Pool won't be reused
+    destroyShmPool pool
+
+    pure (buffer, castForeignPtr ptr)
+
+  where
+    bytePerPixel = 4
+    offset = 0
+    stride = width * bytePerPixel
+    size = width * height * bytePerPixel
+    pixelFormat = 0 -- argb8888
+

src/Quasar/Wayland/Client/Surface.hs

 module Quasar.Wayland.Client.Surface (
   -- * Buffer backend
   ClientBufferBackend(..),
+  getClientBufferManager,
 
   -- * Surface
   ClientSurfaceManager,
-  newClientSurfaceManager,
+  getClientSurfaceManager,
 
   newClientSurface,
-  newMirroredClientSurface,
+  exportWlSurface,
 ) where
 
+import Control.Monad.Catch
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
+import Data.Typeable (Typeable)
 import Quasar.Prelude
+import Quasar.Wayland.Client
 import Quasar.Wayland.Protocol
 import Quasar.Wayland.Protocol.Generated
-import Quasar.Wayland.Surface
 import Quasar.Wayland.Region (appRect)
+import Quasar.Wayland.Surface
 
 
-class BufferBackend b => ClientBufferBackend b where
+class (BufferBackend b, Typeable (ClientBufferManager b)) => ClientBufferBackend b where
   type ClientBufferManager b
-  exportWlBuffer :: ClientBufferManager b -> Buffer b -> STM (Object 'Client Interface_wl_buffer)
+  newClientBufferManager :: WaylandClient -> STM (ClientBufferManager b)
+  -- | Called by the `Surface`-implementation when a buffer should be created on a wayland client.
+  -- The caller takes ownership of the resulting wl_buffer and will attach the event handler.
+  exportWlBuffer :: ClientBufferManager b -> Buffer b -> STM (NewObject 'Client Interface_wl_buffer)
+
+getClientBufferManager :: forall b. ClientBufferBackend b => WaylandClient -> STM (ClientBufferManager b)
+getClientBufferManager client =
+  getClientComponent (newClientBufferManager @b client) client
 
-getClientWlBuffer :: ClientBufferBackend b => ClientSurfaceManager b -> Buffer b -> STM (Object 'Client Interface_wl_buffer)
-getClientWlBuffer surfaceManager buffer = do
-  buffers <- readTVar bufferMap
+
+
+-- | Requests a wl_buffer for a `Buffer` and changes it's state to attached.
+requestClientBuffer :: ClientBufferBackend b => ClientSurfaceManager b -> Buffer b -> STM (Object 'Client Interface_wl_buffer)
+requestClientBuffer client buffer = do
+  buffers <- readTVar client.bufferMap
   case HM.lookup buffer buffers of
-    Just wlBuffer -> pure wlBuffer
+    Just clientBuffer -> do
+      readTVar clientBuffer.state >>= \case
+        Released -> useClientBuffer clientBuffer
+        -- TODO using (z)wp_linux_buffer_release a buffer could be attached to multiple surfaces
+        Attached _ -> newSingleUseClientBuffer client buffer
     Nothing -> do
-      wlBuffer <- exportWlBuffer surfaceManager.bufferManager buffer
-      -- TODO register finalizer (on `buffer` and `wlBuffer`) to remove from map
-      writeTVar bufferMap (HM.insert buffer wlBuffer buffers)
-      pure wlBuffer
+      clientBuffer <- newClientBuffer client buffer
+      writeTVar client.bufferMap (HM.insert buffer clientBuffer buffers)
+      useClientBuffer clientBuffer
   where
-    bufferMap = surfaceManager.bufferMap
+    useClientBuffer :: ClientBuffer b -> STM (Object 'Client Interface_wl_buffer)
+    useClientBuffer clientBuffer = do
+      unlockFn <- lockBuffer buffer
+      writeTVar clientBuffer.state (Attached unlockFn)
+      pure clientBuffer.wlBuffer
+
+
+-- | Create a reusable client buffer.
+newClientBuffer :: ClientBufferBackend b => ClientSurfaceManager b -> Buffer b -> STM (ClientBuffer b)
+newClientBuffer client buffer = do
+  whenM (isBufferDestroyed buffer) $ throwM (userError "newClientBuffer was called with a destroyed buffer")
+
+  state <- newTVar Released
+  wlBuffer <- exportWlBuffer client.bufferManager buffer
+  -- TODO register finalizer on wl_buffer to unlock `Buffer` if the client is disconnected before release
+  -- TODO in both cases, the `ClientBuffer` should be removed from the `bufferMap`
+  destroyed <- newTVar False
+  let clientBuffer = ClientBuffer {
+    wlBuffer,
+    state,
+    destroyed
+  }
+  setEventHandler wlBuffer EventHandler_wl_buffer {
+    release = releaseClientBuffer clientBuffer
+  }
+  addBufferDestroyedCallback buffer (destroyClientBuffer clientBuffer)
+  pure clientBuffer
+
+releaseClientBuffer :: ClientBuffer b -> STM ()
+releaseClientBuffer clientBuffer = do
+  swapTVar clientBuffer.state Released >>= \case
+    Attached releaseFn -> releaseFn
+    Released -> traceM "ClientBuffer: Duplicate release"
+
+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
+
+
+-- | Since `release` is undefined when a buffer is attached to multiple surfaces,
+-- using multiple wl_buffer objects for the same `Buffer` might be required.
+--
+-- This function creates single-use buffers, that is, buffers that are destroyed
+-- as soon as they receive a `release`-event.
+newSingleUseClientBuffer :: ClientBufferBackend b => ClientSurfaceManager b -> Buffer b -> STM (Object 'Client Interface_wl_buffer)
+newSingleUseClientBuffer surfaceManager buffer = do
+  unlockFn <- lockBuffer buffer
+  wlBuffer <- exportWlBuffer surfaceManager.bufferManager buffer
+  setEventHandler wlBuffer EventHandler_wl_buffer {
+    release = wlBuffer.destroy >> unlockFn
+  }
+  -- TODO register finalizer to release lock when client is disconnected
+  pure wlBuffer
 
 
 data ClientSurfaceManager b = ClientSurfaceManager {
   bufferManager :: ClientBufferManager b,
   wlCompositor :: Object 'Client Interface_wl_compositor,
-  bufferMap :: TVar (HashMap (Buffer b) (Object 'Client Interface_wl_buffer))
+  bufferMap :: TVar (HashMap (Buffer b) (ClientBuffer b))
 }
 
 data ClientSurface b = ClientSurface {
@@ -48,39 +122,78 @@ data ClientSurface b = ClientSurface {
   wlSurface :: Object 'Client Interface_wl_surface
 }
 
-newClientSurfaceManager :: ClientBufferManager b -> Object 'Client Interface_wl_compositor -> STM (ClientSurfaceManager b)
-newClientSurfaceManager bufferManager wlCompositor = do
+data ClientBufferState = Attached (STM ()) | Released
+
+data ClientBuffer b = ClientBuffer {
+  wlBuffer :: Object 'Client Interface_wl_buffer,
+  state :: TVar ClientBufferState,
+  destroyed :: TVar Bool
+}
+
+getClientSurfaceManager :: ClientBufferBackend b => WaylandClient -> STM (ClientSurfaceManager b)
+getClientSurfaceManager client =
+  getClientComponent (newClientSurfaceManager client) client
+
+newClientSurfaceManager :: forall b. ClientBufferBackend b => WaylandClient -> STM (ClientSurfaceManager b)
+newClientSurfaceManager client = do
+  bufferManager <- getClientBufferManager @b client
+  wlCompositor <- getClientComponent @(Object 'Client Interface_wl_compositor) (newWlCompositor client) client
   bufferMap <- newTVar mempty
-  pure ClientSurfaceManager { bufferManager, wlCompositor, bufferMap }
+  pure ClientSurfaceManager {
+    bufferManager,
+    wlCompositor,
+    bufferMap
+  }
+
+newWlCompositor :: WaylandClient -> STM (Object 'Client Interface_wl_compositor)
+newWlCompositor client = do
+  wlCompositor <- bindSingleton client.registry
+  -- wl_compositor does not have any events. Setting `()` as the event handler will produce a type error if that changes in the future.
+  setEventHandler wlCompositor ()
+  pure wlCompositor
+
 
-newClientSurface :: ClientBufferBackend b => ClientSurfaceManager b -> STM (Surface b)
-newClientSurface surfaceManager = do
+newClientSurface :: ClientBufferBackend b => WaylandClient -> STM (Surface b, Object 'Client Interface_wl_surface)
+newClientSurface client = do
+  surfaceManager <- getClientSurfaceManager client
   surface <- newSurface
-  -- TODO this is quite useless if the wl_surface is dropped, since it can'tbe
-  _ <- newMirroredClientSurface surfaceManager surface
-  pure surface
+  wlSurface <- exportWlSurface surfaceManager surface
+  pure (surface, wlSurface)
 
 -- | Creates a wl_surface object that mirrors the content of a `Surface`.
-newMirroredClientSurface :: ClientBufferBackend b => ClientSurfaceManager b -> Surface b -> STM (Object 'Client Interface_wl_surface)
-newMirroredClientSurface surfaceManager surface = do
+exportWlSurface :: ClientBufferBackend b => ClientSurfaceManager b -> Surface b -> STM (Object 'Client Interface_wl_surface)
+exportWlSurface surfaceManager surface = do
   wlSurface <- surfaceManager.wlCompositor.create_surface
   let clientSurface = ClientSurface { surfaceManager, wlSurface }
   connectSurfaceDownstream surface (surfaceDownstream clientSurface)
   -- TODO: add finalizer, so that the surface is destroyed with the wlSurface
+  -- TODO event handling
+  setEventHandler wlSurface EventHandler_wl_surface {
+    enter = \_ -> pure (),
+    leave = \_ -> pure ()
+  }
   pure wlSurface
 
 surfaceDownstream :: ClientBufferBackend b => ClientSurface b -> SurfaceDownstream b
 surfaceDownstream surface = onSurfaceCommit surface
 
 onSurfaceCommit :: ClientBufferBackend b => ClientSurface b -> SurfaceCommit b -> STM ()
-onSurfaceCommit surface commit = do
+onSurfaceCommit surface (commit@SurfaceCommit{buffer = Nothing}) = do
   -- TODO catch exceptions and redirect to client owner (so the shared surface can continue to work when one backend fails)
-  wlBuffer <- mapM (getClientWlBuffer surface.surfaceManager) commit.buffer
-  wlSurface.attach wlBuffer (fst commit.offset) (snd commit.offset)
+
+  surface.wlSurface.attach Nothing (fst commit.offset) (snd commit.offset)
+  -- TODO damage might not be required when removing a buffer?
   addBufferDamage surface.wlSurface commit.bufferDamage
-  wlSurface.commit
-  where
-    wlSurface = surface.wlSurface
+  surface.wlSurface.commit
+onSurfaceCommit surface commit@SurfaceCommit{buffer = Just buffer} = do
+  -- TODO catch exceptions and redirect to client owner (so the shared surface can continue to work when one backend fails)
+
+  wlBuffer <- requestClientBuffer surface.surfaceManager buffer
+  -- NOTE Alternative which does not leak buffer objects (until TODOs are fixed) by never reusing buffers
+  --wlBuffer <- newSingleUseClientBuffer surface.surfaceManager buffer
+  surface.wlSurface.attach (Just wlBuffer) (fst commit.offset) (snd commit.offset)
+  addBufferDamage surface.wlSurface commit.bufferDamage
+  surface.wlSurface.commit
 
 addBufferDamage :: Object 'Client Interface_wl_surface -> Damage -> STM ()
 addBufferDamage wlSurface DamageAll = wlSurface.damage_buffer minBound minBound maxBound maxBound

src/Quasar/Wayland/Protocol/Core.hs

@@ -764,7 +764,9 @@ getNullableObject oId = Just <$> getObject oId
 -- | Handle a wl_display.error message. Because this is part of the core protocol but generated from the xml it has to
 -- be called from the client module.
 handleWlDisplayError :: ProtocolHandle 'Client -> GenericObjectId -> Word32 -> WlString -> STM ()
-handleWlDisplayError _protocol _oId code message = throwM $ ServerError code (toString message)
+handleWlDisplayError _protocol _oId code message =
+  -- TODO lookup object id
+  throwM $ ServerError code (toString message)
 
 -- | Handle a wl_display.delete_id message. Because this is part of the core protocol but generated from the xml it has
 -- to be called from the client module.

src/Quasar/Wayland/Server/Surface.hs

@@ -43,7 +43,7 @@ newServerSurface = do
     pendingSurfaceDamage
   }
 
-commitServerSurface :: forall b. BufferBackend b => ServerSurface b -> STM ()
+commitServerSurface :: ServerSurface b -> STM ()
 commitServerSurface surface = do
   serverBuffer <- swapTVar surface.pendingBuffer Nothing
   offset <- swapTVar surface.pendingOffset (0, 0)

src/Quasar/Wayland/Shm.hs

@@ -8,8 +8,18 @@ module Quasar.Wayland.Shm (
 ) where
 
 import Control.Monad.Catch
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
+import Data.HashSet (HashSet)
+import Data.HashSet qualified as HS
+import Data.Hashable (Hashable(hash, hashWithSalt))
+import Data.Set (Set)
+import Data.Set qualified as Set
+import Quasar.Future
 import Quasar.Prelude
+import Quasar.Wayland.Client
 import Quasar.Wayland.Protocol
+import Quasar.Wayland.Protocol.Generated
 import Quasar.Wayland.Surface
 import Quasar.Wayland.Client.Surface
 import System.Posix (Fd)
@@ -17,31 +27,38 @@ import System.Posix (Fd)
 data ShmBufferBackend
 
 instance BufferBackend ShmBufferBackend where
-  type BufferContent ShmBufferBackend = ShmBuffer
-  releaseBufferStorage buffer = do
-    modifyTVar buffer.pool.bufferCount pred
-    traceM "Finalized ShmBuffer"
-    tryFinalizeShmPool buffer.pool
-
-instance ClientBufferBackend ShmBufferBackend where
-  type ClientBufferManager ShmBufferBackend = ShmClient
-  exportWlBuffer = undefined
-
-data ShmClient = ShmClient {
-}
-
-
+  type BufferStorage ShmBufferBackend = ShmBuffer
 
+releaseShmBuffer :: ShmBuffer -> STM ()
+releaseShmBuffer buffer = do
+  modifyTVar buffer.pool.bufferCount pred
+  traceM "Finalized ShmBuffer"
+  tryFinalizeShmPool buffer.pool
 
 -- | Wrapper for an externally managed shm pool
 data ShmPool = ShmPool {
+  key :: Unique,
   fd :: TVar (Maybe Fd),
   size :: TVar Int32,
   bufferCount :: TVar Word32,
+  destroyRequested :: TVar Bool,
   destroyed :: TVar Bool,
   downstreams :: TVar [DownstreamShmPool]
 }
 
+instance Eq ShmPool where
+  x == y = x.key == y.key
+
+instance Hashable ShmPool where
+  hash pool = hash pool.key
+  hashWithSalt salt pool = hashWithSalt salt pool.key
+
+data DownstreamShmPool = DownstreamShmPool {
+  destroy :: STM (),
+  resize :: Int32 -> STM ()
+}
+
+
 data ShmBuffer = ShmBuffer {
   pool :: ShmPool,
   offset :: Int32,
@@ -54,15 +71,19 @@ data ShmBuffer = ShmBuffer {
 -- | Create an `ShmPool` for externally managed memory. Takes ownership of the passed file descriptor.
 newShmPool :: Fd -> Int32 -> STM ShmPool
 newShmPool fd size = do
+  key <- newUniqueSTM
   fdVar <- newTVar (Just fd)
   sizeVar <- newTVar size
   bufferCount <- newTVar 0
+  destroyRequested <- newTVar False
   destroyed <- newTVar False
   downstreams <- newTVar mempty
   pure ShmPool {
+    key,
     fd = fdVar,
     size = sizeVar,
     bufferCount,
+    destroyRequested,
     destroyed,
     downstreams
   }
@@ -73,24 +94,33 @@ 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
+  downstreams <- readTVar pool.downstreams
+  mapM_ (\downstream -> downstream.resize size) downstreams
 
--- | Destroy an externally managed shm pool. Memory shared to this pool will be deallocated after the last buffer is released.
+-- | Request destruction of an an externally managed shm pool. Memory shared with 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
+  writeTVar pool.destroyRequested True
+  tryFinalizeShmPool pool
 
 tryFinalizeShmPool :: ShmPool -> STM ()
 tryFinalizeShmPool pool = do
-  destroyed <- readTVar pool.destroyed
+  destroyRequested <- readTVar pool.destroyRequested
   bufferCount <- readTVar pool.bufferCount
-  when (destroyed && bufferCount == 0) do
+  when (destroyRequested && bufferCount == 0) do
+    writeTVar pool.destroyed True
     fd <- swapTVar pool.fd Nothing
+    downstreams <- swapTVar pool.downstreams mempty
+    mapM_ (.destroy) downstreams
     traceM "Finalized ShmPool"
     -- TODO close fd
     traceM $ "leaking fd " <> show fd <> " (closing fd is not implemented yet)"
 
+connectDownstreamShmPool :: ShmPool -> DownstreamShmPool -> STM ()
+connectDownstreamShmPool pool downstream = do
+  whenM (readTVar pool.destroyed) $ throwM $ userError "ShmPool: Cannot attach downstream since the pool has been destroyed"
+  modifyTVar pool.downstreams (downstream:)
+
 
 -- | Create a new buffer for an externally managed pool
 newShmBuffer :: ShmPool -> Int32 -> Int32 -> Int32 -> Int32 -> Word32 -> STM (Buffer ShmBufferBackend)
@@ -98,9 +128,80 @@ newShmBuffer pool offset width height stride format = do
   -- TODO check arguments
   modifyTVar pool.bufferCount succ
   let shmBuffer = ShmBuffer pool offset width height stride format
-  newBuffer @ShmBufferBackend shmBuffer
+  newBuffer @ShmBufferBackend shmBuffer (releaseShmBuffer shmBuffer)
 
-data DownstreamShmPool = DownstreamShmPool
 
-connectDownstreamShmPool :: ShmPool -> DownstreamShmPool -> STM ()
-connectDownstreamShmPool pool downstream = undefined
+-- * Wayland client
+
+instance ClientBufferBackend ShmBufferBackend where
+
+  type ClientBufferManager ShmBufferBackend = ClientShmManager
+
+  newClientBufferManager = newClientShmManager
+
+  exportWlBuffer :: ClientShmManager -> Buffer ShmBufferBackend -> STM (NewObject 'Client Interface_wl_buffer)
+  exportWlBuffer client buffer = do
+    let shmBuffer = buffer.storage
+    wlShmPool <- getClientShmPool client shmBuffer.pool
+    -- NOTE no event handlers are attached here, since the caller (usually `Quasar.Wayland.Surface`) has that responsibility.
+    wlShmPool.create_buffer shmBuffer.offset shmBuffer.width shmBuffer.height shmBuffer.stride shmBuffer.format
+
+data ClientShmManager = ClientShmManager {
+  key :: Unique,
+  wlShm :: Object 'Client Interface_wl_shm,
+  wlShmPools :: TVar (HashMap ShmPool (Object 'Client Interface_wl_shm_pool)),
+  formats :: Future (Set Word32)
+}
+
+instance Eq ClientShmManager where
+  x == y = x.key == y.key
+
+instance Hashable ClientShmManager where
+  hash x = hash x.key
+  hashWithSalt salt x = hashWithSalt salt x.key
+
+
+newClientShmManager :: WaylandClient -> STM ClientShmManager
+newClientShmManager client = do
+  key <- newUniqueSTM
+  wlShm <- bindSingleton client.registry
+  wlShmPools <- newTVar mempty
+  formatsVar <- newTVar mempty
+  setEventHandler wlShm $ EventHandler_wl_shm {
+    format = \fmt -> modifyTVar formatsVar (Set.insert fmt)
+  }
+  -- Formats are emittet all at once; sync ensures the list is complete
+  formatListComplete <- client.sync
+  -- Create awaitable from formats
+  let formats = formatListComplete >> unsafeAwaitSTM (readTVar formatsVar)
+
+  pure ClientShmManager {
+    key,
+    wlShm,
+    wlShmPools,
+    formats
+  }
+
+getClientShmPool :: ClientShmManager -> ShmPool -> STM (Object 'Client Interface_wl_shm_pool)
+getClientShmPool client pool = do
+  HM.lookup pool <$> readTVar client.wlShmPools >>= \case
+    Just wlShmPool -> pure wlShmPool
+    Nothing -> do
+      wlShmPool <- exportClientShmPool client pool
+      modifyTVar client.wlShmPools (HM.insert pool wlShmPool)
+      pure wlShmPool
+
+exportClientShmPool :: ClientShmManager -> ShmPool -> STM (Object 'Client Interface_wl_shm_pool)
+exportClientShmPool client pool = do
+  readTVar pool.fd >>= \case
+    Nothing -> throwM $ userError "Cannot export finalized ShmPool"
+    Just fd -> do
+      size <- readTVar pool.size
+      -- TODO attach downstream to propagate size changes and pool destruction
+      -- TODO (then: remove downstream when client is closed)
+      wlShmPool <- client.wlShm.create_pool fd size
+      connectDownstreamShmPool pool DownstreamShmPool {
+        destroy = wlShmPool.destroy,
+        resize = wlShmPool.resize
+      }
+      pure wlShmPool

src/Quasar/Wayland/Surface.hs

 module Quasar.Wayland.Surface (
   -- * Buffer backend
   BufferBackend(..),
-  Buffer,
+  Buffer(storage),
   newBuffer,
   lockBuffer,
   destroyBuffer,
+  isBufferDestroyed,
   addBufferReleaseCallback,
+  addBufferDestroyedCallback,
 
   -- * Surface
   Damage(..),
@@ -17,6 +19,9 @@ module Quasar.Wayland.Surface (
   assignSurfaceRole,
   commitSurface,
   connectSurfaceDownstream,
+
+  -- * Reexports
+  Rectangle(..),
 ) where
 
 import Control.Monad.Catch
@@ -25,22 +30,23 @@ import Data.Typeable
 import Quasar.Prelude
 import Quasar.Wayland.Protocol
 import Quasar.Wayland.Region (Rectangle(..))
+import Quasar.Wayland.Utils.Once (once)
 
 type BufferBackend :: Type -> Constraint
 class Typeable b => BufferBackend b where
-  type BufferContent b
-  -- | A destroyed buffer has been released, so the buffer storage can be freed by the owner.
-  releaseBufferStorage :: BufferContent b -> STM ()
+  type BufferStorage b
 
 
 data Buffer b = Buffer {
   key :: Unique,
-  content :: BufferContent b,
+  storage :: BufferStorage b,
   -- | Buffer has been released by all current users and can be reused by the owner.
-  releaseBuffer :: TVar (STM ()),
+  releaseBufferCallback :: TVar (STM ()),
   -- | Refcount that tracks how many times the buffer is locked by consumers.
   lockCount :: TVar Int,
-  destroyed :: TVar Bool
+  destroyRequested :: TVar Bool,
+  destroyed :: TVar Bool,
+  destroyedCallback :: TVar (STM ())
 }
 
 instance Eq (Buffer b) where
@@ -50,53 +56,64 @@ instance Hashable (Buffer b) where
   hash x = hash x.key
   hashWithSalt salt x = hashWithSalt salt x.key
 
-newBuffer :: forall b. BufferContent b -> STM (Buffer b)
-newBuffer content = do
+newBuffer :: forall b. BufferStorage b -> STM () -> STM (Buffer b)
+newBuffer storage bufferDestroyedFn = do
   key <- newUniqueSTM
-  releaseBuffer <- newTVar (pure ())
+  releaseBufferCallback <- newTVar (pure ())
   lockCount <- newTVar 0
+  destroyRequested <- newTVar False
   destroyed <- newTVar False
+  destroyedCallback <- newTVar bufferDestroyedFn
   pure Buffer {
     key,
-    content,
-    releaseBuffer,
+    storage,
+    releaseBufferCallback,
     lockCount,
-    destroyed
+    destroyRequested,
+    destroyed,
+    destroyedCallback
   }
 
-
 addBufferReleaseCallback :: Buffer b -> STM () -> STM ()
 addBufferReleaseCallback buffer releaseFn =
-  modifyTVar buffer.releaseBuffer (>> releaseFn)
+  modifyTVar buffer.releaseBufferCallback (>> releaseFn)
 
+addBufferDestroyedCallback :: Buffer b -> STM () -> STM ()
+addBufferDestroyedCallback buffer callback =
+  modifyTVar buffer.destroyedCallback (>> callback)
 
 -- | Prevents the buffer from being released. Returns an unlock action.
-lockBuffer :: forall b. BufferBackend b => Buffer b -> STM (STM ())
+lockBuffer :: Buffer b -> STM (STM ())
 lockBuffer buffer = do
   modifyTVar buffer.lockCount succ
-  pure unlockBuffer
+  once unlockBuffer
   where
     unlockBuffer :: STM ()
     unlockBuffer = do
       lockCount <- stateTVar buffer.lockCount (dup . pred)
       when (lockCount == 0) do
-        join $ swapTVar buffer.releaseBuffer (pure ())
-        tryFinalizeBuffer @b buffer
+        join $ swapTVar buffer.releaseBufferCallback (pure ())
+        tryFinalizeBuffer 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 ()
+-- | 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 finalization, e.g. `addBufferDestroyedCallback`).
+destroyBuffer :: Buffer b -> STM ()
 destroyBuffer buffer = do
-  alreadyDestroyed <- readTVar buffer.destroyed
-  unless alreadyDestroyed do
-    writeTVar buffer.destroyed True
+  alreadyRequested <- readTVar buffer.destroyRequested
+  unless alreadyRequested do
+    writeTVar buffer.destroyRequested True
     tryFinalizeBuffer buffer
 
-tryFinalizeBuffer :: forall b. BufferBackend b => Buffer b -> STM ()
+tryFinalizeBuffer :: Buffer b -> STM ()
 tryFinalizeBuffer buffer = do
-  destroyed <- readTVar buffer.destroyed
+  destroyRequested <- readTVar buffer.destroyRequested
   lockCount <- readTVar buffer.lockCount
-  when (destroyed && lockCount == 0) do
-    releaseBufferStorage @b buffer.content
+  when (destroyRequested && lockCount == 0) do
+    writeTVar buffer.destroyed True
+    -- Run callbacks
+    join $ swapTVar buffer.destroyedCallback (pure ())
+
+isBufferDestroyed :: Buffer b -> STM Bool
+isBufferDestroyed buffer = readTVar buffer.destroyed
 
 
 class SurfaceRole a where
@@ -132,6 +149,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
@@ -156,7 +180,7 @@ newSurface = do
 
 assignSurfaceRole :: SurfaceRole a => Surface b -> a -> STM ()
 assignSurfaceRole surface role = do
-  readTVar surface.surfaceRole >>= \case
+  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)
@@ -164,13 +188,13 @@ assignSurfaceRole surface role = do
 
   writeTVar surface.surfaceRole (Just (SomeSurfaceRole role))
 
-commitSurface :: forall b. BufferBackend b => Surface b -> SurfaceCommit b -> STM ()
+commitSurface :: Surface b -> SurfaceCommit b -> STM ()
 commitSurface surface commit = do
   join $ readTVar surface.lastBufferUnlockFn
 
   unlockFn <-
     case commit.buffer of
-      Just buffer -> lockBuffer @b buffer
+      Just buffer -> lockBuffer buffer
       Nothing -> pure (pure ())
 
   writeTVar surface.lastBufferUnlockFn unlockFn
@@ -181,5 +205,5 @@ commitSurface surface commit = do
 
 connectSurfaceDownstream :: forall b. Surface b -> SurfaceDownstream b -> STM ()
 connectSurfaceDownstream surface downstream = do
-  modifyTVar surface.downstreams $ (downstream:)
+  modifyTVar surface.downstreams (downstream:)
   -- TODO commit downstream

src/Quasar/Wayland/Utils/Once.hs

+module Quasar.Wayland.Utils.Once (once) where
+
+import Quasar.Prelude
+
+-- TODO use no-throw STM wrapper
+once :: MonadSTM m => STM a -> m (STM a)
+once fn = runOnce <$> newTVar (Left fn)
+
+runOnce :: TVar (Either (STM a) a) -> STM a
+runOnce var = do
+  readTVar var >>= \case
+    Left fn -> do
+      result <- fn
+      writeTVar var (Right result)
+      pure result
+    Right result -> pure result