From df552e995b36c26002d4d9824ad880beed4adb55 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Thu, 23 Dec 2021 18:50:11 +0100
Subject: [PATCH] Add initial support for wl_shm-based buffers

---
 quasar-wayland.cabal                |   1 +
 src/Quasar/Wayland/Client/Buffer.hs | 106 ++++++++++++++++++++++++++++
 2 files changed, 107 insertions(+)
 create mode 100644 src/Quasar/Wayland/Client/Buffer.hs

diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal
index 3e31b23..f1b49e3 100644
--- a/quasar-wayland.cabal
+++ b/quasar-wayland.cabal
@@ -75,6 +75,7 @@ library
   import: shared-properties
   exposed-modules:
     Quasar.Wayland.Client
+    Quasar.Wayland.Client.Buffer
     Quasar.Wayland.Client.Registry
     Quasar.Wayland.Client.Socket
     Quasar.Wayland.Client.Sync
diff --git a/src/Quasar/Wayland/Client/Buffer.hs b/src/Quasar/Wayland/Client/Buffer.hs
new file mode 100644
index 0000000..6ad8e96
--- /dev/null
+++ b/src/Quasar/Wayland/Client/Buffer.hs
@@ -0,0 +1,106 @@
+module Quasar.Wayland.Client.Buffer (
+  -- * wl_shm
+  ShmBufferManager(formats),
+  newShmBufferManager,
+  newShmPool,
+  newShmBuffer,
+) where
+
+import Control.Concurrent.STM
+import Control.Monad.Catch
+import Data.Set qualified as Set
+import Foreign
+import Quasar
+import Quasar.Awaitable
+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 Buffer = Buffer {
+  wlBuffer :: Object 'Client Interface_wl_buffer,
+  currentlyUsed :: TVar Bool
+}
+
+
+data ShmBufferManager = ShmBufferManager {
+  wlShm :: Object 'Client Interface_wl_shm,
+  formats :: Awaitable (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 $
+    wlShmPool.create_buffer offset width height stride pixelFormat
+
+  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)
-- 
GitLab