diff --git a/example/Main.hs b/example/Main.hs index d0612ac76fdf474ccc0f1f2ad7859d3360016800..36bc935e855852687a8cafe237a7cd2d9c8ce157 100644 --- a/example/Main.hs +++ b/example/Main.hs @@ -7,7 +7,7 @@ import Quasar.Wayland.Client main :: IO () main = do - withRootResourceManager do + runQuasarAndExit (stderrLogger LogLevelInfo) do traceIO "Connecting" client <- connectWaylandClient traceIO "Connected" diff --git a/flake.lock b/flake.lock index 71c6633883608631bb2686d62b1116a446b393fa..3224e3b01985d1f6b3dde9f0370ddaf3d70e1920 100644 --- a/flake.lock +++ b/flake.lock @@ -14,66 +14,32 @@ "type": "indirect" } }, - "nixpkgs_2": { - "locked": { - "lastModified": 1640408860, - "narHash": "sha256-h2uF3+a8bVfM8SjcS4hLbsOzOuG3qsxuImC0BucWs1Q=", - "path": "/nix/store/m6p4m1rs0xi67kaa25bm1rqkm4633qjr-source", - "rev": "cb372c3b8880e504b06946e8fb2ca9777c685505", - "type": "path" - }, - "original": { - "id": "nixpkgs", - "type": "indirect" - } - }, "quasar": { - "inputs": { - "nixpkgs": "nixpkgs_2" - }, - "locked": { - "host": "git.c3pb.de", - "lastModified": 1639255442, - "narHash": "sha256-zlkViCgmxGlouprrc6RNquXYI3IOCvAUn36IdIAfKek=", - "owner": "jens", - "repo": "quasar", - "rev": "b3a13dd9cf2841811f89812d27a5639f8e60821b", - "type": "gitlab" - }, - "original": { - "host": "git.c3pb.de", - "owner": "jens", - "repo": "quasar", - "type": "gitlab" - } - }, - "quasar-network": { "inputs": { "nixpkgs": [ "nixpkgs" - ], - "quasar": "quasar" + ] }, "locked": { "host": "git.c3pb.de", - "lastModified": 1639499264, - "narHash": "sha256-G6RJ097E31qDEuNDOZle+sOJaMLXA7Xs8vP3gXZmg0g=", + "lastModified": 1658625376, + "narHash": "sha256-A+LbIPqKDimBOGvee/e/CWVZSxX7UI2CYUs7xJ2dMd4=", "owner": "jens", - "repo": "quasar-network", - "rev": "ba958e241cf3286c9a271a08e95fdcadbaeb49bb", + "repo": "quasar", + "rev": "cd71ac69c35e1577438e73a5b5901572520b67b6", "type": "gitlab" }, "original": { "host": "git.c3pb.de", "owner": "jens", - "repo": "quasar-network", + "repo": "quasar", "type": "gitlab" } }, "root": { "inputs": { "nixpkgs": "nixpkgs", - "quasar-network": "quasar-network" + "quasar": "quasar" } } }, diff --git a/flake.nix b/flake.nix index 14c6182394cd5bd5655c6f13535b541f864a26e0..13283f7ab941b9d7f89ab071c571c8568b33aa48 100644 --- a/flake.nix +++ b/flake.nix @@ -1,12 +1,12 @@ { inputs = { - quasar-network = { - url = gitlab:jens/quasar-network?host=git.c3pb.de; + quasar = { + url = gitlab:jens/quasar?host=git.c3pb.de; inputs.nixpkgs.follows = "nixpkgs"; }; }; - outputs = { self, nixpkgs, quasar-network }: + outputs = { self, nixpkgs, quasar }: let lib = nixpkgs.lib; systems = lib.platforms.unix; @@ -15,8 +15,7 @@ packages = forAllSystems (system: let pkgs = import nixpkgs { inherit system; overlays = [ self.overlay - quasar-network.overlay - quasar-network.overlays.quasar + quasar.overlay ]; }; in { inherit (pkgs.haskellPackages) quasar-wayland; @@ -32,8 +31,7 @@ }; overlays = { - quasar = quasar-network.overlays.quasar; - quasar-network = quasar-network.overlay; + quasar = quasar.overlay; }; defaultPackage = forAllSystems (system: self.packages.${system}.quasar-wayland); diff --git a/src/Quasar/Wayland/Client.hs b/src/Quasar/Wayland/Client.hs index 627ccc690ab2e20ee5f6fbafd639dd0d491da206..ac7f70f057920e6d3ce0d8b13eb78cac031d7333 100644 --- a/src/Quasar/Wayland/Client.hs +++ b/src/Quasar/Wayland/Client.hs @@ -29,18 +29,15 @@ data WaylandClient = WaylandClient { registry :: Registry } -instance IsResourceManager WaylandClient where - toResourceManager client = toResourceManager client.connection +instance Resource WaylandClient where + toDisposer client = toDisposer client.connection -instance IsDisposable WaylandClient where - toDisposable client = toDisposable client.connection - -connectWaylandClient :: MonadResourceManager m => m WaylandClient -connectWaylandClient = mask_ do +connectWaylandClient :: (MonadIO m, MonadQuasar m) => m WaylandClient +connectWaylandClient = liftQuasarIO $ mask_ do socket <- liftIO connectWaylandSocket newWaylandClient socket -newWaylandClient :: MonadResourceManager m => Socket -> m WaylandClient +newWaylandClient :: (MonadIO m, MonadQuasar m) => Socket -> m WaylandClient newWaylandClient socket = do ((wlDisplay, registry), connection) <- newWaylandConnection newClientDisplay socket @@ -66,9 +63,8 @@ newWaylandClient socket = do } - -instance HasField "sync" WaylandClient (STM (Awaitable ())) where +instance HasField "sync" WaylandClient (STM (Future ())) where getField client = do - var <- newAsyncVarSTM - lowLevelSync client.wlDisplay \_ -> putAsyncVarSTM_ var () - pure $ toAwaitable var + var <- newPromiseSTM + lowLevelSync client.wlDisplay \_ -> fulfillPromiseSTM var () + pure $ toFuture var diff --git a/src/Quasar/Wayland/Client/Buffer.hs b/src/Quasar/Wayland/Client/Buffer.hs index 6ad8e969cff4fa072771c0e069243852c36000dc..a1fdb55ec6f3b5b14c5500d3114dd2c228e01249 100644 --- a/src/Quasar/Wayland/Client/Buffer.hs +++ b/src/Quasar/Wayland/Client/Buffer.hs @@ -6,12 +6,10 @@ module Quasar.Wayland.Client.Buffer ( 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 @@ -29,7 +27,7 @@ data Buffer = Buffer { data ShmBufferManager = ShmBufferManager { wlShm :: Object 'Client Interface_wl_shm, - formats :: Awaitable (Set.Set Word32) + formats :: Future (Set.Set Word32) } newShmBufferManager :: WaylandClient -> STM ShmBufferManager diff --git a/src/Quasar/Wayland/Client/Registry.hs b/src/Quasar/Wayland/Client/Registry.hs index 32ae64486427a3ed8e65c8bcbdcc17eaf070377c..c461cfff16c2c483ac35e551542b89b98a818312 100644 --- a/src/Quasar/Wayland/Client/Registry.hs +++ b/src/Quasar/Wayland/Client/Registry.hs @@ -5,7 +5,6 @@ module Quasar.Wayland.Client.Registry ( tryBindSingleton, ) where -import Control.Concurrent.STM import Control.Monad.Catch import Data.HashMap.Strict qualified as HM import Data.Tuple (swap) @@ -20,7 +19,7 @@ import Quasar.Wayland.Protocol.Generated data Registry = Registry { wlRegistry :: Object 'Client Interface_wl_registry, globalsVar :: TVar (HM.HashMap Word32 Global), - initialSyncComplete :: Awaitable () + initialSyncComplete :: Future () } data Global = Global { @@ -45,9 +44,9 @@ createRegistry wlDisplay = mfix \clientRegistry -> do setMessageHandler wlRegistry (messageHandler clientRegistry) -- Manual sync (without high-level wrapper) to prevent a dependency loop to the Client module - var <- newAsyncVarSTM - lowLevelSync wlDisplay \_ -> putAsyncVarSTM_ var () - let initialSyncComplete = toAwaitable var + var <- newPromiseSTM + lowLevelSync wlDisplay \_ -> fulfillPromiseSTM var () + let initialSyncComplete = toFuture var pure Registry { wlRegistry, @@ -64,7 +63,7 @@ createRegistry wlDisplay = mfix \clientRegistry -> do global_remove :: Word32 -> STM () global_remove name = do - result <- stateTVar clientRegistry.globalsVar (swap . lookupDelete name) + result <- stateTVar clientRegistry.globalsVar (lookupDelete name) case result of Nothing -> traceM $ "Invalid global removed by server: " <> show name Just _ -> pure () @@ -78,10 +77,10 @@ bindSingleton registry = either (throwM . ProtocolUsageError) pure =<< tryBindSi -- | Try to bind a new client object to a compositor singleton. -- --- Will block until the the registry has sent the initial list of globals. +-- Will retry until the the registry has sent the initial list of globals. tryBindSingleton :: forall i. IsInterfaceSide 'Client i => Registry -> STM (Either String (Object 'Client i)) tryBindSingleton registry = do - await registry.initialSyncComplete + awaitSTM registry.initialSyncComplete globals <- filterInterface . HM.elems <$> readTVar registry.globalsVar diff --git a/src/Quasar/Wayland/Connection.hs b/src/Quasar/Wayland/Connection.hs index faa8c794cc41d2e1e070a6afc80b492baacae8dd..aa3731615e41d0b28231b37565b9a8816e940925 100644 --- a/src/Quasar/Wayland/Connection.hs +++ b/src/Quasar/Wayland/Connection.hs @@ -6,7 +6,6 @@ module Quasar.Wayland.Connection ( newWaylandConnection, ) where -import Control.Concurrent.STM import Control.Monad.Catch import Data.Bits ((.&.)) import Data.ByteString qualified as BS @@ -30,7 +29,7 @@ import System.Posix.Types (Fd) C.include "<sys/socket.h>" maxFds :: C.CInt -maxFds = 28 -- from wayland (connection.c) +maxFds = 28 -- from libwayland (connection.c) cmsgBufferSize :: Int cmsgBufferSize = fromIntegral [CU.pure|int { CMSG_LEN($(int maxFds) * sizeof(int32_t)) }|] @@ -40,51 +39,49 @@ cmsgBufferSize = fromIntegral [CU.pure|int { CMSG_LEN($(int maxFds) * sizeof(int data WaylandConnection s = WaylandConnection { protocolHandle :: ProtocolHandle s, socket :: Socket, - resourceManager :: ResourceManager + quasar :: Quasar } -instance IsResourceManager (WaylandConnection s) where - toResourceManager connection = connection.resourceManager - -instance IsDisposable (WaylandConnection s) where - toDisposable connection = toDisposable connection.resourceManager +instance Resource (WaylandConnection s) where + toDisposer connection = toDisposer connection.quasar data SocketClosed = SocketClosed deriving stock Show deriving anyclass Exception newWaylandConnection - :: forall s m a. (IsSide s, MonadResourceManager m) + :: forall s m a. (IsSide s, MonadIO m, MonadQuasar m) => STM (a, ProtocolHandle s) -> Socket -> m (a, WaylandConnection s) newWaylandConnection initializeProtocolAction socket = do - (result, protocolHandle) <- liftIO $ atomically $ initializeProtocolAction + (result, protocolHandle) <- atomically initializeProtocolAction - resourceManager <- newResourceManager + quasar <- newResourceScopeIO - onResourceManager resourceManager do + runQuasarIO quasar do let connection = WaylandConnection { protocolHandle, socket, - resourceManager + quasar } t1 <- connectionThread connection $ sendThread connection t2 <- connectionThread connection $ receiveThread connection - registerAsyncDisposeAction do + registerDisposeActionIO do await $ isDisposed t1 await $ isDisposed t2 closeConnection connection pure (result, connection) -connectionThread :: MonadResourceManager m => WaylandConnection s -> IO () -> m (Async ()) -connectionThread connection work = asyncWithHandler traceAndDisposeConnection $ liftIO $ work +connectionThread :: (MonadIO m, MonadQuasar m) => WaylandConnection s -> IO () -> m (Async ()) +connectionThread connection work = asyncWithUnmask' \unmask -> work `catch` traceAndDisposeConnection where traceAndDisposeConnection :: SomeException -> IO () - traceAndDisposeConnection ex = traceIO (displayException ex) >> void (dispose connection) + traceAndDisposeConnection (isCancelAsync -> True) = pure () + traceAndDisposeConnection ex = traceIO (displayException ex) >> disposeEventuallyIO_ connection sendThread :: WaylandConnection s -> IO () sendThread connection = mask_ $ forever do diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs index 5d8f7424965775fad7c618bad439d01f5b38826c..b34376809883611d0917ec2d63b2c631b3f9f2d3 100644 --- a/src/Quasar/Wayland/Protocol/Core.hs +++ b/src/Quasar/Wayland/Protocol/Core.hs @@ -68,7 +68,6 @@ module Quasar.Wayland.Protocol.Core ( invalidOpcode, ) where -import Control.Concurrent.STM import Control.Monad.Catch import Control.Monad.Reader (ReaderT, runReaderT, ask, lift) import Data.Binary diff --git a/src/Quasar/Wayland/Protocol/TH.hs b/src/Quasar/Wayland/Protocol/TH.hs index 49d408c1ec13023d81ab20da4c7814ee1958c964..6a45f3d17aee9d045b7be2d365253f6843d28d2c 100644 --- a/src/Quasar/Wayland/Protocol/TH.hs +++ b/src/Quasar/Wayland/Protocol/TH.hs @@ -13,7 +13,7 @@ import Data.Void (absurd) import GHC.Records import Language.Haskell.TH import Language.Haskell.TH.Syntax (addDependentFile) -import Quasar.Prelude +import Quasar.Prelude hiding (Type) import Quasar.Wayland.Protocol.Core import System.Posix.Types (Fd) import Text.Read (readEither)