LICENSE

-Copyright Jens Nolte (c) 2021
+Copyright Jens Nolte (c) 2021-2022
 
 All rights reserved.
 

examples/Client.hs

@@ -76,9 +76,9 @@ main = do
           destroyBuffer buffer
           destroyBuffer buffer2
 
-        await =<< newDelay 100000
+        threadDelay 100000
         traceIO "Waiting 2s"
-        await =<< newDelay 2000000
+        threadDelay 2000000
 
         atomically do
           commitSurface surface SurfaceCommit {
@@ -87,7 +87,7 @@ main = do
             bufferDamage = DamageList []
           }
 
-        -- await =<< newDelay 100000
+        -- threadDelay 100000
         atomically do
           commitSurface surface2 SurfaceCommit {
             buffer = Nothing,
@@ -95,7 +95,7 @@ main = do
             bufferDamage = DamageList []
           }
 
-    await =<< newDelay 1000000
+    threadDelay 1000000
     traceIO "Closing"
   traceIO "Closed"
 

flake.lock

@@ -23,19 +23,17 @@
         ]
       },
       "locked": {
-        "host": "git.c3pb.de",
-        "lastModified": 1660518832,
-        "narHash": "sha256-nH+6BCO9VnKJz3gmqXjGkzsCNr+J4NrUQEIY90HhwS0=",
-        "owner": "jens",
+        "lastModified": 1665357154,
+        "narHash": "sha256-jxtz8Skk0X+3FhZMZFthvU7dwpewPiz1ZMQKUPPTrno=",
+        "owner": "queezle42",
         "repo": "quasar",
-        "rev": "7038f65573387fc86f4c856fa5b34a8e03f134c3",
-        "type": "gitlab"
+        "rev": "079a43f42d3f601046d86d5a369f9f9a01365d40",
+        "type": "github"
       },
       "original": {
-        "host": "git.c3pb.de",
-        "owner": "jens",
+        "owner": "queezle42",
         "repo": "quasar",
-        "type": "gitlab"
+        "type": "github"
       }
     },
     "root": {

flake.nix

 {
   inputs = {
     quasar = {
-      url = gitlab:jens/quasar?host=git.c3pb.de;
+      url = github:queezle42/quasar;
       inputs.nixpkgs.follows = "nixpkgs";
     };
 
@@ -16,8 +16,8 @@
   in {
     packages = forAllSystems (system:
     let pkgs = import nixpkgs { inherit system; overlays = [
-        self.overlay
-        quasar.overlay
+        self.overlays.default
+        quasar.overlays.default
       ]; };
     in rec {
       default = quasar-wayland;
@@ -25,15 +25,15 @@
     }
     );
 
-    overlay = final: prev: {
-      haskell = prev.haskell // {
-        packageOverrides = hfinal: hprev: prev.haskell.packageOverrides hfinal hprev // {
-          quasar-wayland = hfinal.callCabal2nix "quasar-wayland" ./. {};
+    overlays = {
+      default = final: prev: {
+        haskell = prev.haskell // {
+          packageOverrides = hfinal: hprev: prev.haskell.packageOverrides hfinal hprev // {
+            quasar-wayland = hfinal.callCabal2nix "quasar-wayland" ./. {};
+          };
         };
       };
-    };
 
-    overlays = {
       quasar = quasar.overlay;
     };
 
@@ -48,6 +48,7 @@
           pkgs.entr
           pkgs.ghcid
           pkgs.haskell-language-server
+          pkgs.hlint
         ];
       }
     );

quasar-wayland.cabal

@@ -6,7 +6,7 @@ category: Wayland, User Interfaces
 description: An implementation of the Wayland protocol.
 author: Jens Nolte
 maintainer: Jens Nolte
-copyright: 2021 Jens Nolte
+copyright: 2021-2022 Jens Nolte
 license: BSD-2-Clause
 license-file: LICENSE
 build-type: Simple
@@ -15,7 +15,7 @@ extra-source-files:
 
 source-repository head
   type: git
-  location: https://git.c3pb.de/jens/quasar-wayland.git
+  location: https://github.com/queezle42/quasar-wayland
 
 common shared-properties
   default-extensions:

src/Quasar/Wayland/Client/Surface.hs

@@ -161,17 +161,18 @@ exportWlSurface :: ClientBufferBackend b => ClientSurfaceManager b -> Surface b
 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 ()
   }
+  -- TODO must not connect before first configure
+  connectSurfaceDownstream surface clientSurface
   pure wlSurface
 
-surfaceDownstream :: ClientBufferBackend b => ClientSurface b -> SurfaceDownstream b
-surfaceDownstream surface = onSurfaceCommit surface
+instance ClientBufferBackend b => IsSurfaceDownstream b (ClientSurface b) where
+  commitSurfaceDownstream = onSurfaceCommit
 
 onSurfaceCommit :: ClientBufferBackend b => ClientSurface b -> SurfaceCommit b -> STM ()
 onSurfaceCommit surface (commit@SurfaceCommit{buffer = Nothing}) = do

src/Quasar/Wayland/Server/Surface.hs

@@ -2,7 +2,6 @@ module Quasar.Wayland.Server.Surface (
   ServerSurface,
   initializeServerSurface,
   getServerSurface,
-  connectServerSurfaceDownstream,
   assignSurfaceRole,
   removeSurfaceRole,
   initializeWlBuffer,
@@ -18,9 +17,17 @@ import Quasar.Wayland.Surface
 
 
 data ServerSurface b = ServerSurface {
+  state :: TVar (ServerSurfaceState b),
+  lastRole :: TVar (Maybe String)
+}
+
+data ServerSurfaceState b =
+  Unmapped |
+  Pending (Surface b -> STM ()) |
+  Mapped (MappedServerSurface b)
+
+data MappedServerSurface b = MappedServerSurface {
   surface :: Surface b,
-  lastRole :: TVar (Maybe String),
-  hasActiveRole :: TVar Bool,
   pendingBuffer :: TVar (Maybe (ServerBuffer b)),
   pendingOffset :: TVar (Int32, Int32),
   pendingBufferDamage :: TVar Damage,
@@ -34,39 +41,54 @@ data ServerBuffer b = ServerBuffer {
   wlBuffer :: Object 'Server Interface_wl_buffer
 }
 
-newServerSurface :: forall b. STM (ServerSurface b)
+newServerSurface :: STM (ServerSurface b)
 newServerSurface = do
-  surface <- newSurface @b
+  state <- newTVar Unmapped
   lastRole <- newTVar Nothing
-  hasActiveRole <- newTVar False
+
+  pure ServerSurface {
+    state,
+    lastRole
+  }
+
+getServerSurface :: forall b. BufferBackend b => Object 'Server Interface_wl_surface -> STM (Maybe (ServerSurface b))
+getServerSurface wlSurface = getInterfaceData @(ServerSurface b) wlSurface
+
+--instance IsSurfaceUpstream b (ServerSurface b) where
+--  connectSurfaceDownstream serverSurface downstream =
+--    connectSurfaceDownstream serverSurface.surface downstream
+
+commitServerSurface :: ServerSurface b -> STM ()
+commitServerSurface serverSurface = do
+  readTVar serverSurface.state >>= \case
+    Unmapped -> throwM $ userError "Cannot commit a surface that does not have a role"
+    Pending surfaceMappedCallback -> do
+      mappedSurface <- mapServerSurface
+      writeTVar serverSurface.state (Mapped mappedSurface)
+      surfaceMappedCallback mappedSurface.surface
+    Mapped mappedSurface -> commitMappedServerSurface mappedSurface
+
+mapServerSurface :: STM (MappedServerSurface b)
+mapServerSurface = do
+  surface <- newSurface
   pendingBuffer <- newTVar Nothing
   pendingOffset <- newTVar (0, 0)
   pendingBufferDamage <- newTVar mempty
   pendingSurfaceDamage <- newTVar mempty
-
-  pure ServerSurface {
+  pure MappedServerSurface {
     surface,
-    lastRole,
-    hasActiveRole,
     pendingBuffer,
     pendingOffset,
     pendingBufferDamage,
     pendingSurfaceDamage
   }
 
-getServerSurface :: forall b. BufferBackend b => Object 'Server Interface_wl_surface -> STM (Maybe (ServerSurface b))
-getServerSurface wlSurface = getInterfaceData @(ServerSurface b) wlSurface
-
-connectServerSurfaceDownstream :: forall b. ServerSurface b -> SurfaceDownstream b -> STM ()
-connectServerSurfaceDownstream serverSurface downstream =
-  connectSurfaceDownstream serverSurface.surface downstream
-
-commitServerSurface :: ServerSurface b -> STM ()
-commitServerSurface surface = do
-  serverBuffer <- swapTVar surface.pendingBuffer Nothing
-  offset <- swapTVar surface.pendingOffset (0, 0)
-  bufferDamage <- swapTVar surface.pendingBufferDamage mempty
-  surfaceDamage <- swapTVar surface.pendingSurfaceDamage mempty
+commitMappedServerSurface :: MappedServerSurface b -> STM ()
+commitMappedServerSurface mapped = do
+  serverBuffer <- swapTVar mapped.pendingBuffer Nothing
+  offset <- swapTVar mapped.pendingOffset (0, 0)
+  bufferDamage <- swapTVar mapped.pendingBufferDamage mempty
+  surfaceDamage <- swapTVar mapped.pendingSurfaceDamage mempty
   let
     convertedSurfaceDamage =
       case surfaceDamage of
@@ -79,25 +101,36 @@ commitServerSurface surface = do
   forM_ serverBuffer \sb ->
     addBufferReleaseCallback sb.buffer sb.wlBuffer.release
 
-  commitSurface surface.surface SurfaceCommit {
+  commitSurface mapped.surface SurfaceCommit {
     buffer = (.buffer) <$> serverBuffer,
     offset,
     bufferDamage = combinedDamage
   }
 
 
+requireMappedSurface :: ServerSurface b -> STM (MappedServerSurface b)
+requireMappedSurface serverSurface = do
+  readTVar serverSurface.state >>= \case
+    Mapped mapped -> pure mapped
+    -- TODO improve exception / propagate error to the client
+    _ -> throwM $ userError "Requested operation requires a mapped surface"
+
 attachToSurface :: forall b. BufferBackend b => ServerSurface b -> Maybe (Object 'Server Interface_wl_buffer) -> Int32 -> Int32 -> STM ()
-attachToSurface surface wlBuffer x y = do
+attachToSurface serverSurface wlBuffer x y = do
+  mappedSurface <- requireMappedSurface serverSurface
   buffer <- mapM (getServerBuffer @b) wlBuffer
-  writeTVar surface.pendingBuffer buffer
-  writeTVar surface.pendingOffset (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 =
-  modifyTVar surface.pendingBufferDamage \case
+  writeTVar mappedSurface.pendingBuffer buffer
+  writeTVar mappedSurface.pendingOffset (x, y)
+
+damageSurface :: ServerSurface b -> Rectangle -> STM ()
+damageSurface serverSurface rect = do
+  mappedSurface <- requireMappedSurface serverSurface
+  modifyTVar mappedSurface.pendingSurfaceDamage (rect:)
+
+damageBuffer :: ServerSurface b -> Rectangle -> STM ()
+damageBuffer serverSurface rect = do
+  mappedSurface <- requireMappedSurface serverSurface
+  modifyTVar mappedSurface.pendingBufferDamage \case
     DamageAll -> DamageAll
     DamageList xs -> DamageList (rect : xs)
 
@@ -146,14 +179,16 @@ getBuffer :: forall b. BufferBackend b => Object 'Server Interface_wl_buffer ->
 getBuffer wlBuffer = (.buffer) <$> getServerBuffer wlBuffer
 
 
-assignSurfaceRole :: forall i b. IsInterfaceSide 'Server i => ServerSurface b -> STM ()
-assignSurfaceRole surface = do
+assignSurfaceRole :: forall i b. IsInterfaceSide 'Server i => ServerSurface b -> (Surface b -> STM ()) -> STM ()
+assignSurfaceRole surface onRoleCommit = do
   let role = interfaceName @i
 
-  hasActiveRole <- readTVar surface.hasActiveRole
-  if hasActiveRole
-    then throwM (ProtocolUsageError "Cannot assign wl_surface a new role, since it already has an active role.")
-    else writeTVar surface.hasActiveRole True
+  readTVar surface.state >>= \case
+    Mapped _ -> throwM (ProtocolUsageError "Cannot assign wl_surface a new role, since it already has an active role.")
+    Pending _ -> throwM (ProtocolUsageError "Cannot assign wl_surface a new role, since it already has a pending role.")
+    Unmapped -> pure ()
+
+  writeTVar surface.state (Pending onRoleCommit)
 
   readTVar surface.lastRole >>= \x -> (flip ($)) x \case
     Just ((== role) -> True) -> pure ()
@@ -163,4 +198,4 @@ assignSurfaceRole surface = do
     Nothing -> writeTVar surface.lastRole (Just role)
 
 removeSurfaceRole :: ServerSurface b -> STM ()
-removeSurfaceRole surface = writeTVar surface.hasActiveRole False
+removeSurfaceRole surface = undefined

src/Quasar/Wayland/Server/XdgShell.hs

@@ -21,17 +21,22 @@ xdgShellGlobal :: forall b. BufferBackend b => ServerWindowManager b -> Global
 xdgShellGlobal wm =
   createGlobal @Interface_xdg_wm_base maxVersion (initializeXdgWmBase wm)
 
+data XdgWmBase b = XdgWmBase {
+  wm :: ServerWindowManager b
+}
+
 initializeXdgWmBase ::
   forall b.
   BufferBackend b =>
   ServerWindowManager b -> Object 'Server Interface_xdg_wm_base -> STM ()
-initializeXdgWmBase wm wlXdgWm =
+initializeXdgWmBase wm wlXdgWm = do
+  let xdgWmBase = XdgWmBase { wm }
   setRequestHandler wlXdgWm RequestHandler_xdg_wm_base {
     -- TODO raise error if any surface derived from this xdg_wm_base is still
     -- alive
     destroy = pure (),
     create_positioner = undefined,
-    get_xdg_surface = initializeXdgSurface wm,
+    get_xdg_surface = initializeXdgSurface xdgWmBase,
     pong = const (pure ())
   }
 
@@ -39,15 +44,14 @@ initializeXdgWmBase wm wlXdgWm =
 data XdgSurface b = XdgSurface {
   wlXdgSurface :: Object 'Server Interface_xdg_surface,
   serverSurface :: ServerSurface b,
-  surfaceRole :: TVar (Maybe Role)
+  hasRoleObject :: TVar Bool,
+  surface :: TVar (Maybe (Surface b))
 }
 
-data Role = Toplevel | Popup
-
 initializeXdgSurface ::
   forall b.
   BufferBackend b =>
-  ServerWindowManager b ->
+  XdgWmBase b ->
   NewObject 'Server Interface_xdg_surface ->
   Object 'Server Interface_wl_surface ->
   STM ()
@@ -58,7 +62,7 @@ initializeXdgSurface wm wlXdgSurface wlSurface = do
 
 initializeXdgSurface' ::
   forall b.
-  ServerWindowManager b ->
+  XdgWmBase b ->
   NewObject 'Server Interface_xdg_surface ->
   ServerSurface b ->
   STM ()
@@ -76,8 +80,15 @@ initializeXdgSurface' wm wlXdgSurface serverSurface = do
   -- xdg_surface), this part of the spec is ignored in this implementation. A
   -- role object is only set when creating a toplevel- or popup surface.
 
-  surfaceRole <- newTVar Nothing
-  let xdgSurface = XdgSurface { wlXdgSurface, serverSurface, surfaceRole }
+  hasRoleObject <- newTVar False
+  surface <- newTVar Nothing
+  let xdgSurface =
+        XdgSurface {
+          wlXdgSurface,
+          serverSurface,
+          hasRoleObject,
+          surface
+        }
 
   setRequestHandler wlXdgSurface RequestHandler_xdg_surface {
     destroy = destroyXdgSurface xdgSurface,
@@ -88,10 +99,10 @@ initializeXdgSurface' wm wlXdgSurface serverSurface = do
   }
 
 destroyXdgSurface :: XdgSurface b -> STM ()
-destroyXdgSurface surface = do
-  readTVar surface.surfaceRole >>= \case
-    Just _ -> throwM (userError "Cannot destroy xdg_surface before its role object has been destroyed.")
-    Nothing -> pure ()
+destroyXdgSurface xdgSurface =
+  whenM (readTVar xdgSurface.hasRoleObject) do
+    -- TODO convert to server error that is relayed to the client
+    throwM (userError "Cannot destroy xdg_surface before its role object has been destroyed.")
 
 data XdgToplevel b = XdgToplevel {
   xdgSurface :: XdgSurface b
@@ -99,15 +110,19 @@ data XdgToplevel b = XdgToplevel {
 
 initializeXdgToplevel :: XdgSurface b -> NewObject 'Server Interface_xdg_toplevel -> STM ()
 initializeXdgToplevel xdgSurface wlXdgToplevel = do
-  -- NOTE this throws if the surface role is changed
-  -- TODO change error type to a corret ServerError if that happens
-  assignSurfaceRole @Interface_xdg_toplevel xdgSurface.serverSurface
-  writeTVar xdgSurface.surfaceRole (Just Toplevel)
+  writeTVar xdgSurface.hasRoleObject True
 
   let xdgToplevel = XdgToplevel {
     xdgSurface
   }
 
+  -- NOTE this throws if the surface role is changed
+  -- TODO change error type to a corret ServerError if that happens
+  assignSurfaceRole
+    @Interface_xdg_toplevel
+    xdgSurface.serverSurface
+    (onInitialSurfaceCommit xdgToplevel)
+
   setRequestHandler wlXdgToplevel RequestHandler_xdg_toplevel {
     destroy = destroyXdgToplevel xdgToplevel,
     set_parent = undefined,
@@ -125,8 +140,15 @@ initializeXdgToplevel xdgSurface wlXdgToplevel = do
     set_minimized = undefined
   }
 
+onInitialSurfaceCommit :: XdgToplevel b -> Surface b -> STM ()
+onInitialSurfaceCommit xdgToplevel surface =
+  writeTVar xdgToplevel.xdgSurface.surface (Just surface)
+
+onNullSurfaceCommit :: XdgToplevel b -> STM ()
+onNullSurfaceCommit = undefined
+
 destroyXdgToplevel :: XdgToplevel b -> STM ()
 destroyXdgToplevel xdgToplevel = do
   removeSurfaceRole xdgToplevel.xdgSurface.serverSurface
-  writeTVar xdgToplevel.xdgSurface.surfaceRole Nothing
-  undefined
+  writeTVar xdgToplevel.xdgSurface.surface Nothing
+  writeTVar xdgToplevel.xdgSurface.hasRoleObject False

src/Quasar/Wayland/Surface.hs

@@ -13,11 +13,13 @@ module Quasar.Wayland.Surface (
   Damage(..),
   Surface,
   SurfaceCommit(..),
+  IsSurfaceDownstream(..),
   SurfaceDownstream,
+  IsSurfaceUpstream(..),
+  SurfaceUpstream,
   defaultSurfaceCommit,
   newSurface,
   commitSurface,
-  connectSurfaceDownstream,
 
   -- * Reexports
   Rectangle(..),
@@ -31,7 +33,7 @@ import Quasar.Wayland.Utils.Once (once)
 
 type BufferBackend :: Type -> Constraint
 class Typeable b => BufferBackend b where
-  type BufferStorage b
+  type BufferStorage b :: Type
 
 
 data Buffer b = Buffer {
@@ -126,7 +128,8 @@ instance Monoid Damage where
 
 data Surface b = Surface {
   surfaceState :: TVar (SurfaceCommit b),
-  lastBufferUnlockFn :: TVar (STM ()),
+  -- Stores an STM action that will release the currently committed buffer.
+  bufferUnlockFn :: TVar (STM ()),
   downstreams :: TVar [SurfaceDownstream b]
 }
 
@@ -143,7 +146,29 @@ data SurfaceCommit b = SurfaceCommit {
 --    bufferDamage = old.bufferDamage <> new.bufferDamage
 --  }
 
-type SurfaceDownstream b = SurfaceCommit b -> STM ()
+data SurfaceDownstream b = forall a. IsSurfaceDownstream b a => SurfaceDownstream a
+
+class IsSurfaceDownstream b a | a -> b where
+  toSurfaceDownstream :: a -> SurfaceDownstream b
+  toSurfaceDownstream = SurfaceDownstream
+  commitSurfaceDownstream :: a -> SurfaceCommit b -> STM ()
+
+instance IsSurfaceDownstream b (SurfaceDownstream b) where
+  toSurfaceDownstream = id
+  commitSurfaceDownstream (SurfaceDownstream x) = commitSurfaceDownstream x
+
+
+data SurfaceUpstream b = forall a. IsSurfaceUpstream b a => SurfaceUpstream a
+
+class IsSurfaceUpstream b a | a -> b where
+  toSurfaceUpstream :: a -> SurfaceUpstream b
+  toSurfaceUpstream = SurfaceUpstream
+  connectSurfaceDownstream :: IsSurfaceDownstream b d => a -> d -> STM ()
+
+instance IsSurfaceUpstream b (SurfaceUpstream b) where
+  toSurfaceUpstream = id
+  connectSurfaceDownstream (SurfaceUpstream x) = connectSurfaceDownstream @b x
+
 
 defaultSurfaceCommit :: Damage -> SurfaceCommit b
 defaultSurfaceCommit bufferDamage = SurfaceCommit {
@@ -155,30 +180,30 @@ defaultSurfaceCommit bufferDamage = SurfaceCommit {
 newSurface :: forall b. STM (Surface b)
 newSurface = do
   surfaceState <- newTVar (defaultSurfaceCommit DamageAll)
-  lastBufferUnlockFn <- newTVar (pure ())
+  bufferUnlockFn <- newTVar (pure ())
   downstreams <- newTVar []
   pure Surface {
     surfaceState,
-    lastBufferUnlockFn,
+    bufferUnlockFn,
     downstreams
   }
 
 commitSurface :: Surface b -> SurfaceCommit b -> STM ()
 commitSurface surface commit = do
-  join $ readTVar surface.lastBufferUnlockFn
-
   unlockFn <-
     case commit.buffer of
       Just buffer -> lockBuffer buffer
       Nothing -> pure (pure ())
 
-  writeTVar surface.lastBufferUnlockFn unlockFn
+  -- Store new unlockFn and then unlock previously used buffer
+  join $ swapTVar surface.bufferUnlockFn unlockFn
 
   downstreams <- readTVar surface.downstreams
   -- TODO handle exceptions, remove failed downstreams
-  mapM_ ($ commit) downstreams
+  mapM_ (\downstream -> commitSurfaceDownstream downstream commit) downstreams
 
-connectSurfaceDownstream :: forall b. Surface b -> SurfaceDownstream b -> STM ()
-connectSurfaceDownstream surface downstream = do
-  modifyTVar surface.downstreams (downstream:)
-  -- TODO commit downstream
+instance IsSurfaceUpstream b (Surface b) where
+  connectSurfaceDownstream surface downstream = do
+    modifyTVar surface.downstreams (toSurfaceDownstream downstream:)
+    -- TODO handle exceptions
+    commitSurfaceDownstream downstream =<< readTVar surface.surfaceState