From 8456cd1c8de9a204e329a2ddd79a017790a61ae4 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Wed, 17 Aug 2022 00:30:18 +0200
Subject: [PATCH] Add wl_shm server implementation on top of new buffer api
---
examples/Client.hs | 16 +++--
examples/Server.hs | 9 ++-
quasar-wayland.cabal | 2 +
src/Quasar/Wayland/Client/Buffer.hs | 2 +-
src/Quasar/Wayland/Protocol.hs | 1 +
src/Quasar/Wayland/Protocol/Core.hs | 5 +-
src/Quasar/Wayland/Server/Shm.hs | 46 ++++++++++++++
src/Quasar/Wayland/Shm.hs | 98 +++++++++++++++++++++++++++++
8 files changed, 169 insertions(+), 10 deletions(-)
create mode 100644 src/Quasar/Wayland/Server/Shm.hs
create mode 100644 src/Quasar/Wayland/Shm.hs
diff --git a/examples/Client.hs b/examples/Client.hs
index 2bdb1d1..a809077 100644
--- a/examples/Client.hs
+++ b/examples/Client.hs
@@ -126,6 +126,7 @@ main = do
}
wlrLayerSurface.set_size 512 512
+ -- Commit role
wlSurface.commit
-- Should await first `configure` event
@@ -137,12 +138,17 @@ main = do
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 (Nothing) 0 0
- -- --wlSurface.damage 0 0 100 100
- -- wlSurface.commit
+ 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 100 100 42 42
+ wlSurface.commit
traceIO . ("shm buffer formats: " <>) . mconcat . intersperse ", " . fmap show . toList =<< await shm.formats
diff --git a/examples/Server.hs b/examples/Server.hs
index 4044cf9..2b6bfb4 100644
--- a/examples/Server.hs
+++ b/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 ()
}
diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal
index cf63fae..e57de7a 100644
--- a/quasar-wayland.cabal
+++ b/quasar-wayland.cabal
@@ -87,8 +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
diff --git a/src/Quasar/Wayland/Client/Buffer.hs b/src/Quasar/Wayland/Client/Buffer.hs
index 3041ea3..ae3c9f3 100644
--- a/src/Quasar/Wayland/Client/Buffer.hs
+++ b/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
diff --git a/src/Quasar/Wayland/Protocol.hs b/src/Quasar/Wayland/Protocol.hs
index 11a880b..644010d 100644
--- a/src/Quasar/Wayland/Protocol.hs
+++ b/src/Quasar/Wayland/Protocol.hs
@@ -11,6 +11,7 @@ module Quasar.Wayland.Protocol (
getMessageHandler,
setInterfaceData,
getInterfaceData,
+ isDestroyed,
-- ** Wayland types
WlFixed(..),
diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs
index 6332cc5..d97afa7 100644
--- a/src/Quasar/Wayland/Protocol/Core.hs
+++ b/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
diff --git a/src/Quasar/Wayland/Server/Shm.hs b/src/Quasar/Wayland/Server/Shm.hs
new file mode 100644
index 0000000..504c346
--- /dev/null
+++ b/src/Quasar/Wayland/Server/Shm.hs
@@ -0,0 +1,46 @@
+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
diff --git a/src/Quasar/Wayland/Shm.hs b/src/Quasar/Wayland/Shm.hs
new file mode 100644
index 0000000..f45bef1
--- /dev/null
+++ b/src/Quasar/Wayland/Shm.hs
@@ -0,0 +1,98 @@
+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
--
GitLab