diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +## 0.1.0.0 +### Added +- Make client connections explicit so they can be shared across requests and signal handlers. +- Add Notification portal support. + ## 0.0.1.0 Initial release. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -19,7 +19,7 @@ - Module/function/field names should mimic the underlying portal API as much as possible. - Functions should generally be tested (see existing tests for examples). - Functions should take records called `...Options` and return records called `...Results`. -- `...Options` records should have a `Default` instance. +- `...Options` records should have a `Default` instance where all fields have a reasonable empty value. - Record fields should not have unique prefixes. ### To format the source code diff --git a/desktop-portal.cabal b/desktop-portal.cabal --- a/desktop-portal.cabal +++ b/desktop-portal.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: desktop-portal -version: 0.0.1.0 +version: 0.1.0.0 license: MIT license-file: LICENSE maintainer: garethdanielsmith@gmail.com @@ -23,11 +23,11 @@ Desktop.Portal Desktop.Portal.Account Desktop.Portal.FileChooser - Desktop.Portal.Request + Desktop.Portal.Notification hs-source-dirs: src other-modules: - Desktop.Portal.Request.Internal + Desktop.Portal.Internal Desktop.Portal.Util Paths_desktop_portal @@ -36,7 +36,7 @@ DisambiguateRecordFields DuplicateRecordFields FlexibleContexts ImportQualifiedPost LambdaCase NamedFieldPuns NoFieldSelectors NumericUnderscores OverloadedRecordDot OverloadedStrings - RecordWildCards ScopedTypeVariables + RecordWildCards ScopedTypeVariables TupleSections ghc-options: -Wall -Wcompat -Wincomplete-record-updates @@ -60,6 +60,7 @@ other-modules: Desktop.Portal.AccountSpec Desktop.Portal.FileChooserSpec + Desktop.Portal.NotificationSpec Desktop.Portal.TestUtil Paths_desktop_portal @@ -68,7 +69,7 @@ DisambiguateRecordFields DuplicateRecordFields FlexibleContexts ImportQualifiedPost LambdaCase NamedFieldPuns NoFieldSelectors NumericUnderscores OverloadedRecordDot OverloadedStrings - RecordWildCards ScopedTypeVariables + RecordWildCards ScopedTypeVariables TupleSections ghc-options: -Wall -Wcompat -Wincomplete-record-updates diff --git a/src/Desktop/Portal.hs b/src/Desktop/Portal.hs --- a/src/Desktop/Portal.hs +++ b/src/Desktop/Portal.hs @@ -3,12 +3,29 @@ -- -- See the documentation for the underlying API: https://flatpak.github.io/xdg-desktop-portal module Desktop.Portal - ( module Desktop.Portal.Account, + ( -- * Connection Management + Internal.Client, + Internal.connect, + Internal.disconnect, + Internal.clientName, + + -- * Request Management + Internal.Request, + Internal.await, + Internal.cancel, + + -- * Signal Management + Internal.SignalHandler, + Internal.cancelSignalHandler, + + -- * Portal Interfaces + module Desktop.Portal.Account, module Desktop.Portal.FileChooser, - module Desktop.Portal.Request, + module Desktop.Portal.Notification, ) where import Desktop.Portal.Account import Desktop.Portal.FileChooser -import Desktop.Portal.Request +import Desktop.Portal.Internal qualified as Internal +import Desktop.Portal.Notification diff --git a/src/Desktop/Portal/Account.hs b/src/Desktop/Portal/Account.hs --- a/src/Desktop/Portal/Account.hs +++ b/src/Desktop/Portal/Account.hs @@ -14,7 +14,7 @@ import Data.Map qualified as Map import Data.Maybe (catMaybes, fromMaybe) import Data.Text (Text) -import Desktop.Portal.Request.Internal (Request, sendRequest) +import Desktop.Portal.Internal (Client, Request, sendRequest) import Desktop.Portal.Util (optionalFromVariant, toVariantPair) data GetUserInformationOptions = GetUserInformationOptions @@ -40,9 +40,9 @@ accountInterface :: InterfaceName accountInterface = "org.freedesktop.portal.Account" -getUserInformation :: GetUserInformationOptions -> IO (Request GetUserInformationResults) -getUserInformation options = - sendRequest accountInterface "GetUserInformation" [window] optionsArg parseResponse +getUserInformation :: Client -> GetUserInformationOptions -> IO (Request GetUserInformationResults) +getUserInformation client options = + sendRequest client accountInterface "GetUserInformation" [window] optionsArg parseResponse where window = DBus.toVariant (fromMaybe "" options.window) optionsArg = diff --git a/src/Desktop/Portal/FileChooser.hs b/src/Desktop/Portal/FileChooser.hs --- a/src/Desktop/Portal/FileChooser.hs +++ b/src/Desktop/Portal/FileChooser.hs @@ -28,7 +28,7 @@ import Data.Maybe (catMaybes, fromMaybe) import Data.Text (Text) import Data.Word (Word32) -import Desktop.Portal.Request.Internal (Request, sendRequest) +import Desktop.Portal.Internal (Client, Request, sendRequest) import Desktop.Portal.Util (encodeNullTerminatedUtf8, mapJust, optionalFromVariant, toVariantPair, toVariantPair') data Filter = Filter @@ -135,9 +135,9 @@ fileChooserInterface :: InterfaceName fileChooserInterface = "org.freedesktop.portal.FileChooser" -openFile :: OpenFileOptions -> IO (Request OpenFileResults) -openFile options = - sendRequest fileChooserInterface "OpenFile" args optionsArg parseOpenFileResponse +openFile :: Client -> OpenFileOptions -> IO (Request OpenFileResults) +openFile client options = + sendRequest client fileChooserInterface "OpenFile" args optionsArg parseOpenFileResponse where args = [DBus.toVariant parentWindow, DBus.toVariant title] parentWindow = fromMaybe "" options.parentWindow @@ -153,9 +153,9 @@ toVariantPair' (fmap encodeCombo) "choices" options.choices ] -saveFile :: SaveFileOptions -> IO (Request SaveFileResults) -saveFile options = - sendRequest fileChooserInterface "SaveFile" args optionsArgs parseResponse +saveFile :: Client -> SaveFileOptions -> IO (Request SaveFileResults) +saveFile client options = + sendRequest client fileChooserInterface "SaveFile" args optionsArgs parseResponse where args = [DBus.toVariant parentWindow, DBus.toVariant title] parentWindow = fromMaybe "" options.parentWindow diff --git a/src/Desktop/Portal/Internal.hs b/src/Desktop/Portal/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Desktop/Portal/Internal.hs @@ -0,0 +1,227 @@ +module Desktop.Portal.Internal + ( Client, + connect, + disconnect, + clientName, + Request, + sendRequest, + sendRequestSansResponse, + await, + cancel, + SignalHandler, + handleSignal, + cancelSignalHandler, + ) +where + +import Control.Concurrent (MVar, putMVar, readMVar, tryPutMVar) +import Control.Concurrent.MVar (newEmptyMVar) +import Control.Exception (SomeException, catch, throwIO) +import Control.Monad (void, when) +import DBus (BusName, InterfaceName, MemberName, MethodCall, ObjectPath) +import DBus qualified +import DBus.Client (ClientError, MatchRule (..)) +import DBus.Client qualified as DBus +import DBus.Internal.Message (Signal (..)) +import DBus.Internal.Types (Variant) +import Data.Map (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text, pack, unpack) +import Data.Word (Word32, Word64) +import System.Random.Stateful qualified as R + +-- | A handle for an active desktop portal session. Can send requests and listen for signals. +data Client = Client + { dbusClient :: DBus.Client, + clientName :: BusName + } + +instance Eq Client where + a == b = + a.dbusClient.clientThreadID == b.dbusClient.clientThreadID + +instance Show Client where + show c = + "Client<" <> show c.clientName <> ", " <> show c.dbusClient.clientThreadID <> ">" + +-- | A portal request that may be in-progress, finished, or cancelled. +data Request a = Request + { client :: Client, + methodCall :: MethodCall, + signalHandler :: MVar DBus.SignalHandler, + result :: MVar (Either SomeException (Maybe a)) + } + +instance Eq (Request a) where + a == b = a.result == b.result + +instance Show (Request a) where + show request = + "Request{client=<" + <> show request.client + <> ">, methodCall=" + <> show request.methodCall + <> ", result=}" + +-- | A listener for a particular signal. Can be cancelled with 'cancelSignalHandler'. +data SignalHandler = SignalHandler + { client :: Client, + dbusSignalHandler :: DBus.SignalHandler + } + +-- | Open a new client connection. This can be used to send requests and listen for signals +-- and finally can be closed using 'disconnect'. +connect :: IO Client +connect = do + env <- DBus.getSessionAddress + case env of + Nothing -> throwIO (DBus.clientError "connect: session address not found.") + Just addr -> do + (dbusClient, clientName) <- DBus.connectWithName DBus.defaultClientOptions addr + pure Client {dbusClient, clientName} + +disconnect :: Client -> IO () +disconnect client = do + DBus.disconnect client.dbusClient + +-- | Get the unique name given to the client by D-BUS. +clientName :: Client -> BusName +clientName = (.clientName) + +-- | Wait for a request to be finished, and return the result if it succeeded. If the +-- request is cancelled, either by the user interface or by calling 'cancel', then +-- 'Nothing' will be returned. +await :: Request a -> IO (Maybe a) +await request = do + readMVar request.result >>= \case + Left exn -> throwIO exn + Right res -> pure res + +-- | Cancel a request. This will cause any threads blocked on 'await' to receive 'Nothing'. +-- Has no effect if the client is already cancelled or finished successfully. +cancel :: Request a -> IO () +cancel request = do + putSucceeded <- tryPutMVar request.result (Right Nothing) + when putSucceeded $ do + readMVar request.signalHandler + >>= DBus.removeMatch request.client.dbusClient + +-- | Send a request to the desktop portal D-Bus object and return a handle to the response data. +sendRequest :: + Client -> + -- | Which portal interface to invoke. + InterfaceName -> + -- | Which method to invoke on that interface. + MemberName -> + -- | Positional arguments to pass to the method. + [Variant] -> + -- | Named arguments to pass to the method. + Map Text Variant -> + -- | A function to parse the method response. + (Map Text Variant -> IO a) -> + -- | A handle to the in-progress method call. + IO (Request a) +sendRequest client interface memberName parameters options parseResponse = do + (handle, token) <- requestHandle client.clientName + + signalHandlerVar <- newEmptyMVar + resultVar <- newEmptyMVar + + -- listen before sending the request, to avoid a race condition where the + -- response happens before we get a chance to register the listener for it + signalHandler <- + DBus.addMatch + client.dbusClient + DBus.matchAny + { matchPath = Just handle, + matchInterface = Just "org.freedesktop.portal.Request", + matchMember = Just "Response" + } + ( \Signal {signalBody} -> do + val <- case signalBody of + [code, result] + | Just (0 :: Word32) <- DBus.fromVariant code, + Just (resMap :: Map Text Variant) <- DBus.fromVariant result -> do + -- catch here: it will be re-thrown in the thread that calls 'await' + catch (Right . Just <$> parseResponse resMap) (pure . Left) + _ -> do + pure (Right Nothing) + signalHandler <- readMVar signalHandlerVar + -- removing match can fail because the client is already disconnected, since this happens + -- asynchronously, so we have to ignore that (happens all the time during unit tests!) + catch + (DBus.removeMatch client.dbusClient signalHandler) + (\(_ :: ClientError) -> pure ()) + -- need to try because cancel might have been called and populated the mvar with Nothing + void (tryPutMVar resultVar val) + ) + putMVar signalHandlerVar signalHandler + + let methodCall = + (portalMethodCall interface memberName) + { DBus.methodCallBody = + parameters <> [DBus.toVariant (Map.insert "handle_token" (DBus.toVariant token) options)] + } + + reply <- DBus.call_ client.dbusClient methodCall + case DBus.methodReturnBody reply of + [x] + | Just (objX :: ObjectPath) <- DBus.fromVariant x -> + if objX == handle + then pure (Request client methodCall signalHandlerVar resultVar) + else + let msg = "Unexpected handle: " <> show objX <> " should be " <> show handle <> ". Probably xdg-desktop-portal is too old." + in throwIO (DBus.clientError msg) + _ -> + throwIO (DBus.clientError ("Request reply in unexpected format: " <> show reply)) + +-- | Send a request to the desktop portal D-Bus object, but don't wait for a response. +sendRequestSansResponse :: + Client -> + -- | Which portal interface to invoke. + InterfaceName -> + -- | Which method to invoke on that interface. + MemberName -> + -- | Arguments to pass to the method. + [Variant] -> + IO () +sendRequestSansResponse client interface memberName methodCallBody = do + let methodCall = (portalMethodCall interface memberName) {DBus.methodCallBody} + void (DBus.call_ client.dbusClient methodCall) + +handleSignal :: Client -> InterfaceName -> MemberName -> ([Variant] -> IO ()) -> IO SignalHandler +handleSignal client interface memberName handler = do + dbusSignalHandler <- + DBus.addMatch + client.dbusClient + DBus.matchAny + { matchInterface = Just interface, + matchMember = Just memberName, + matchDestination = Just client.clientName + } + (\Signal {signalBody} -> handler signalBody) + pure SignalHandler {dbusSignalHandler, client} + +-- | Prevent any future invocations of the given signal handler. +cancelSignalHandler :: SignalHandler -> IO () +cancelSignalHandler handler = + DBus.removeMatch handler.client.dbusClient handler.dbusSignalHandler + +requestToken :: IO Text +requestToken = do + (rnd :: Word64) <- R.uniformM R.globalStdGen + pure ("haskell_desktop_portal_" <> pack (show rnd)) + +requestHandle :: BusName -> IO (ObjectPath, Text) +requestHandle clientName = do + token <- requestToken + pure (DBus.objectPath_ ("/org/freedesktop/portal/desktop/request/" <> escapeClientName clientName <> "/" <> unpack token), token) + where + escapeClientName = + map (\case '.' -> '_'; c -> c) . drop 1 . DBus.formatBusName + +portalMethodCall :: InterfaceName -> MemberName -> MethodCall +portalMethodCall interface memberName = + (DBus.methodCall "/org/freedesktop/portal/desktop" interface memberName) + { DBus.methodCallDestination = Just "org.freedesktop.portal.Desktop" + } diff --git a/src/Desktop/Portal/Notification.hs b/src/Desktop/Portal/Notification.hs new file mode 100644 --- /dev/null +++ b/src/Desktop/Portal/Notification.hs @@ -0,0 +1,150 @@ +module Desktop.Portal.Notification + ( -- * Add Notification + AddNotificationOptions (..), + NotificationPriority (..), + NotificationIcon (..), + NotificationButton (..), + addNotificationOptions, + addNotification, + + -- * Remove Notification + RemoveNotificationOptions (..), + removeNotification, + + -- * Signals + NotificationActionInvokedCallback, + handleNotificationActionInvoked, + ) +where + +import Control.Exception (throwIO) +import DBus (InterfaceName, Variant) +import DBus qualified +import DBus.Client qualified as DBus +import Data.ByteString.Lazy (ByteString) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe (catMaybes, listToMaybe) +import Data.Text (Text) +import Desktop.Portal.Internal (Client, SignalHandler, handleSignal, sendRequestSansResponse) +import Desktop.Portal.Util (toVariantPair, toVariantPair') +import Prelude hiding (id) + +data AddNotificationOptions = AddNotificationOptions + { id :: Text, + title :: Maybe Text, + body :: Maybe Text, + priority :: Maybe NotificationPriority, + icon :: Maybe NotificationIcon, + defaultAction :: Maybe Text, + defaultActionTarget :: Maybe Variant, + buttons :: Maybe [NotificationButton] + } + deriving (Eq, Show) + +data NotificationPriority + = NotificationPriorityLow + | NotificationPriorityNormal + | NotificationPriorityHigh + | NotificationPriorityUrgent + deriving (Eq, Show) + +data NotificationIcon + = NotificationIconThemed [Text] + | NotificationIconBytes ByteString + deriving (Eq, Show) + +data NotificationButton = NotificationButton + { label_ :: Text, + action :: Text, + target :: Maybe Variant + } + deriving (Eq, Show) + +addNotificationOptions :: + -- | The id of the notification + Text -> + AddNotificationOptions +addNotificationOptions id = + AddNotificationOptions + { id, + title = Nothing, + body = Nothing, + priority = Nothing, + icon = Nothing, + defaultAction = Nothing, + defaultActionTarget = Nothing, + buttons = Nothing + } + +newtype RemoveNotificationOptions = RemoveNotificationOptions + {id :: Text} + deriving (Eq, Show) + +notificationInterface :: InterfaceName +notificationInterface = "org.freedesktop.portal.Notification" + +addNotification :: Client -> AddNotificationOptions -> IO () +addNotification client options = + sendRequestSansResponse client notificationInterface "AddNotification" [id, optionsArg] + where + id = DBus.toVariant options.id + optionsArg = + DBus.toVariant . Map.fromList . catMaybes $ + [ toVariantPair "title" options.title, + toVariantPair "body" options.body, + toVariantPair' encodePriority "priority" options.priority, + toVariantPair' encodeIcon "icon" options.icon, + toVariantPair "default-action" options.defaultAction, + ("default-action-target",) <$> options.defaultActionTarget, + toVariantPair' (fmap encodeButton) "buttons" options.buttons + ] + +removeNotification :: Client -> RemoveNotificationOptions -> IO () +removeNotification client options = + sendRequestSansResponse client notificationInterface "RemoveNotification" [id] + where + id = DBus.toVariant options.id + +type NotificationActionInvokedCallback = + -- | The id of the notification that was clicked. + Text -> + -- | The name of the action that was invoked. + Text -> + -- | The target parameter that goes along with the action, if any. + Maybe Variant -> + -- | A command to run when the action is invoked. + IO () + +-- | Listen for notification actions being invoked. +handleNotificationActionInvoked :: Client -> NotificationActionInvokedCallback -> IO SignalHandler +handleNotificationActionInvoked client handler = + handleSignal client notificationInterface "ActionInvoked" $ \signalBody -> do + case signalBody of + [notificationId, actionName, parameter] + | Just notificationId' <- DBus.fromVariant notificationId, + Just actionName' <- DBus.fromVariant actionName, + Just parameter' <- DBus.fromVariant parameter -> do + handler notificationId' actionName' (listToMaybe parameter') + _ -> + throwIO . DBus.clientError $ "handleNotificationActionInvoked: could not parse signal body: " <> show signalBody + +encodePriority :: NotificationPriority -> Text +encodePriority = \case + NotificationPriorityLow -> "low" + NotificationPriorityNormal -> "normal" + NotificationPriorityHigh -> "high" + NotificationPriorityUrgent -> "urgent" + +encodeIcon :: NotificationIcon -> (Text, Variant) +encodeIcon = \case + NotificationIconThemed iconNames -> ("themed", DBus.toVariant iconNames) + NotificationIconBytes bytes -> ("bytes", DBus.toVariant bytes) + +encodeButton :: NotificationButton -> Map Text Variant +encodeButton button = + Map.fromList . catMaybes $ + [ toVariantPair "label" (Just button.label_), + toVariantPair "action" (Just button.action), + toVariantPair "target" button.target + ] diff --git a/src/Desktop/Portal/Request.hs b/src/Desktop/Portal/Request.hs deleted file mode 100644 --- a/src/Desktop/Portal/Request.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Desktop.Portal.Request (module Desktop.Portal.Request.Internal) where - -import Desktop.Portal.Request.Internal (Request, await, cancel) diff --git a/src/Desktop/Portal/Request/Internal.hs b/src/Desktop/Portal/Request/Internal.hs deleted file mode 100644 --- a/src/Desktop/Portal/Request/Internal.hs +++ /dev/null @@ -1,152 +0,0 @@ -module Desktop.Portal.Request.Internal - ( Request, - sendRequest, - await, - cancel, - ) -where - -import Control.Concurrent (MVar, putMVar, readMVar, takeMVar, tryPutMVar) -import Control.Concurrent.MVar (newEmptyMVar) -import Control.Exception (SomeException, catch, onException, throwIO) -import Control.Monad (when) -import DBus (BusName, InterfaceName, MemberName, MethodCall, ObjectPath) -import DBus qualified -import DBus.Client (Client, MatchRule (..)) -import DBus.Client qualified as DBus -import DBus.Internal.Message (Signal (..)) -import DBus.Internal.Types (Variant) -import Data.Map (Map) -import Data.Map.Strict qualified as Map -import Data.Text (Text, pack, unpack) -import Data.Word (Word32, Word64) -import System.Random.Stateful qualified as R - --- | A portal request that may be in-progress, finished, or cancelled. -data Request a = Request - { client :: Client, - methodCall :: MethodCall, - result :: MVar (Either SomeException (Maybe a)) - } - -instance Eq (Request a) where - a == b = a.result == b.result - -instance Show (Request a) where - show request = - "Request{client=<" - <> show request.client.clientThreadID - <> ">, methodCall=" - <> show request.methodCall - <> ", result=}" - --- | Wait for a request to be finished, and return the result if it succeeded. If the --- request is cancelled, either by the user interface or by calling 'cancel', then --- 'Nothing' will be returned. -await :: Request a -> IO (Maybe a) -await request = do - readMVar request.result >>= \case - Left exn -> throwIO exn - Right res -> pure res - --- | Cancel a request. This will cause any threads blocked on 'await' to receive 'Nothing'. -cancel :: Request a -> IO () -cancel request = do - putSucceeded <- tryPutMVar request.result (Right Nothing) - when putSucceeded $ do - -- Otherwise the request was already finished/cancelled. Don't bother calling - -- the Close method on the request because disconnection has the same effect. - DBus.disconnect request.client - --- | Send a request to the desktop portal D-Bus object. -sendRequest :: - -- | Which portal interface to invoke. - InterfaceName -> - -- | Which method to invoke on that interface. - MemberName -> - -- | Positional arguments to pass to the method. - [Variant] -> - -- | Named arguments to pass to the method. - Map Text Variant -> - -- | A function to parse the method response. - (Map Text Variant -> IO a) -> - -- | A handle to the in-progress method call. - IO (Request a) -sendRequest interface memberName parameters options parseResponse = do - (client, clientName) <- connect - onException (sendRequest' client clientName) (DBus.disconnect client) - where - sendRequest' client clientName = do - (handle, token) <- requestHandle clientName - - sentRequestVar <- newEmptyMVar - resultVar <- newEmptyMVar - - -- listen before sending the request, to avoid a race condition where the - -- response happens before we get a chance to register the listener for it - _ <- - DBus.addMatch - client - DBus.matchAny - { matchPath = Just handle, - matchInterface = Just "org.freedesktop.portal.Request", - matchMember = Just "Response" - } - ( \Signal {signalBody} -> do - val <- case signalBody of - [code, result] - | Just (0 :: Word32) <- DBus.fromVariant code, - Just (resMap :: Map Text Variant) <- DBus.fromVariant result -> do - -- catch here: it will be re-thrown in the thread that calls 'await' - catch (Right . Just <$> parseResponse resMap) (pure . Left) - _ -> do - pure (Right Nothing) - -- need to try because cancel might have been called and populated the mvar with Nothing - putSucceeded <- tryPutMVar resultVar val - -- we only use the connection for a single request, which is now done - when putSucceeded $ do - -- don't disconnect until we have got the response to the initial - -- request method call, otherwise reading the response will fail - takeMVar sentRequestVar - DBus.disconnect client - ) - - let methodCall = - (DBus.methodCall "/org/freedesktop/portal/desktop" interface memberName) - { DBus.methodCallDestination = Just "org.freedesktop.portal.Desktop", - DBus.methodCallBody = - parameters <> [DBus.toVariant (Map.insert "handle_token" (DBus.toVariant token) options)] - } - - reply <- DBus.call_ client methodCall - putMVar sentRequestVar () - case DBus.methodReturnBody reply of - [x] - | Just (objX :: ObjectPath) <- DBus.fromVariant x -> - if objX == handle - then pure (Request client methodCall resultVar) - else - let msg = "Unexpected handle: " <> show objX <> " should be " <> show handle <> ". Probably xdg-desktop-portal is too old." - in throwIO (DBus.clientError msg) - _ -> - throwIO (DBus.clientError ("Request reply in unexpected format: " <> show reply)) - -connect :: IO (Client, BusName) -connect = do - env <- DBus.getSessionAddress - case env of - Nothing -> throwIO (DBus.clientError "connect: session address not found.") - Just addr -> DBus.connectWithName DBus.defaultClientOptions addr - -requestToken :: IO Text -requestToken = do - (rnd :: Word64) <- R.uniformM R.globalStdGen - pure ("haskell_desktop_portal_" <> pack (show rnd)) - -requestHandle :: BusName -> IO (ObjectPath, Text) -requestHandle clientName = do - token <- requestToken - pure (DBus.objectPath_ ("/org/freedesktop/portal/desktop/request/" <> escapeClientName clientName <> "/" <> unpack token), token) - where - escapeClientName = - map (\case '.' -> '_'; c -> c) . drop 1 . DBus.formatBusName diff --git a/test/Desktop/Portal/AccountSpec.hs b/test/Desktop/Portal/AccountSpec.hs --- a/test/Desktop/Portal/AccountSpec.hs +++ b/test/Desktop/Portal/AccountSpec.hs @@ -15,43 +15,43 @@ spec = do around withTestBus $ do describe "getUserInformation" $ do - it "should encode request with all Nothings" $ \client -> do - body <- savingRequestArguments client accountInterface "GetUserInformation" $ do - void (Portal.getUserInformation (GetUserInformationOptions Nothing Nothing)) + it "should encode request with all Nothings" $ \handle -> do + body <- savingRequestArguments handle accountInterface "GetUserInformation" $ do + void (Portal.getUserInformation (client handle) (GetUserInformationOptions Nothing Nothing)) body `shouldBe` [ toVariantText "", toVariantMap [] ] - it "should encode request with all Justs" $ \client -> do - body <- savingRequestArguments client accountInterface "GetUserInformation" $ do - void (Portal.getUserInformation (GetUserInformationOptions (Just "_window") (Just "_reason"))) + it "should encode request with all Justs" $ \handle -> do + body <- savingRequestArguments handle accountInterface "GetUserInformation" $ do + void (Portal.getUserInformation (client handle) (GetUserInformationOptions (Just "_window") (Just "_reason"))) body `shouldBe` [ toVariantText "_window", toVariantMap [("reason", toVariantText "_reason")] ] - it "should decode response with image" $ \client -> do + it "should decode response with image" $ \handle -> do let responseBody = successResponse [ ("id", toVariantText "_id"), ("name", toVariantText "_name"), ("image", toVariantText "_img") ] - withMethodResponse client accountInterface "GetUserInformation" responseBody $ do - info <- Portal.getUserInformation def >>= Portal.await + withMethodResponse handle accountInterface "GetUserInformation" responseBody $ do + info <- Portal.getUserInformation (client handle) def >>= Portal.await info `shouldBe` Just (GetUserInformationResults "_id" "_name" (Just "_img")) - it "should decode response without image" $ \client -> do + it "should decode response without image" $ \handle -> do let responseBody = successResponse [ ("id", toVariantText "_id"), ("name", toVariantText "_name") ] - withMethodResponse client accountInterface "GetUserInformation" responseBody $ do - info <- Portal.getUserInformation def >>= Portal.await + withMethodResponse handle accountInterface "GetUserInformation" responseBody $ do + info <- Portal.getUserInformation (client handle) def >>= Portal.await info `shouldBe` Just (GetUserInformationResults "_id" "_name" Nothing) - it "should fail to decode invalid response" $ \client -> - withMethodResponse client accountInterface "GetUserInformation" (successResponse []) $ do - (Portal.getUserInformation def >>= Portal.await) `shouldThrow` anyException + it "should fail to decode invalid response" $ \handle -> + withMethodResponse handle accountInterface "GetUserInformation" (successResponse []) $ do + (Portal.getUserInformation (client handle) def >>= Portal.await) `shouldThrow` anyException diff --git a/test/Desktop/Portal/FileChooserSpec.hs b/test/Desktop/Portal/FileChooserSpec.hs --- a/test/Desktop/Portal/FileChooserSpec.hs +++ b/test/Desktop/Portal/FileChooserSpec.hs @@ -18,18 +18,18 @@ spec = do around withTestBus $ do describe "openFile" $ do - it "should encode request with all Nothings" $ \client -> do - body <- savingRequestArguments client fileChooserInterface "OpenFile" $ do - void (Portal.openFile def) + it "should encode request with all Nothings" $ \handle -> do + body <- savingRequestArguments handle fileChooserInterface "OpenFile" $ do + void (Portal.openFile (client handle) def) body `shouldBe` [ toVariantText "", toVariantText "", toVariantMap [] ] - it "should encode request with all Justs" $ \client -> do - body <- savingRequestArguments client fileChooserInterface "OpenFile" $ do - void . Portal.openFile $ + it "should encode request with all Justs" $ \handle -> do + body <- savingRequestArguments handle fileChooserInterface "OpenFile" $ do + void . Portal.openFile (client handle) $ OpenFileOptions { parentWindow = Just "_parentWindow", title = Just "_title", @@ -98,23 +98,23 @@ ] ] - it "should decode response with all Nothings" $ \client -> do + it "should decode response with all Nothings" $ \handle -> do let responseBody = successResponse [("uris", toVariant ["file:///a/b/c" :: Text])] - withMethodResponse client fileChooserInterface "OpenFile" responseBody $ do - info <- Portal.openFile def >>= Portal.await + withMethodResponse handle fileChooserInterface "OpenFile" responseBody $ do + info <- Portal.openFile (client handle) def >>= Portal.await info `shouldBe` Just (OpenFileResults {uris = ["file:///a/b/c"], choices = Nothing, currentFilter = Nothing}) - it "should decode response with all Justs" $ \client -> do + it "should decode response with all Justs" $ \handle -> do let responseBody = successResponse [ ("uris", toVariant ["file:///a/b/c" :: Text]), ("choices", toVariant [("_comboId" :: Text, "_optionId" :: Text)]), ("current_filter", toVariant ("_filterId" :: Text, [(0 :: Word32, "*.md" :: Text)])) ] - withMethodResponse client fileChooserInterface "OpenFile" responseBody $ do - info <- Portal.openFile def >>= Portal.await + withMethodResponse handle fileChooserInterface "OpenFile" responseBody $ do + info <- Portal.openFile (client handle) def >>= Portal.await info `shouldBe` Just ( OpenFileResults @@ -124,23 +124,23 @@ } ) - it "should fail to decode invalid response" $ \client -> - withMethodResponse client fileChooserInterface "OpenFile" (successResponse []) $ do - (Portal.openFile def >>= Portal.await) `shouldThrow` anyException + it "should fail to decode invalid response" $ \handle -> + withMethodResponse handle fileChooserInterface "OpenFile" (successResponse []) $ do + (Portal.openFile (client handle) def >>= Portal.await) `shouldThrow` anyException describe "saveFile" $ do - it "should encode request with all Nothings" $ \client -> do - body <- savingRequestArguments client fileChooserInterface "SaveFile" $ do - void (Portal.saveFile def) + it "should encode request with all Nothings" $ \handle -> do + body <- savingRequestArguments handle fileChooserInterface "SaveFile" $ do + void (Portal.saveFile (client handle) def) body `shouldBe` [ toVariantText "", toVariantText "", toVariantMap [] ] - it "should encode request with all Justs" $ \client -> do - body <- savingRequestArguments client fileChooserInterface "SaveFile" $ do - void . Portal.saveFile $ + it "should encode request with all Justs" $ \handle -> do + body <- savingRequestArguments handle fileChooserInterface "SaveFile" $ do + void . Portal.saveFile (client handle) $ SaveFileOptions { parentWindow = Just "_parentWindow", title = Just "_title", @@ -211,23 +211,23 @@ ] ] - it "should decode response with all Nothings" $ \client -> do + it "should decode response with all Nothings" $ \handle -> do let responseBody = successResponse [("uris", toVariant ["file:///a/b/c" :: Text])] - withMethodResponse client fileChooserInterface "SaveFile" responseBody $ do - info <- Portal.saveFile def >>= Portal.await + withMethodResponse handle fileChooserInterface "SaveFile" responseBody $ do + info <- Portal.saveFile (client handle) def >>= Portal.await info `shouldBe` Just (SaveFileResults {uris = ["file:///a/b/c"], choices = Nothing, currentFilter = Nothing}) - it "should decode response with all Justs" $ \client -> do + it "should decode response with all Justs" $ \handle -> do let responseBody = successResponse [ ("uris", toVariant ["file:///a/b/c" :: Text]), ("choices", toVariant [("_comboId" :: Text, "_optionId" :: Text)]), ("current_filter", toVariant ("_filterId" :: Text, [(0 :: Word32, "*.md" :: Text)])) ] - withMethodResponse client fileChooserInterface "SaveFile" responseBody $ do - info <- Portal.saveFile def >>= Portal.await + withMethodResponse handle fileChooserInterface "SaveFile" responseBody $ do + info <- Portal.saveFile (client handle) def >>= Portal.await info `shouldBe` Just ( SaveFileResults @@ -237,6 +237,6 @@ } ) - it "should fail to decode invalid response" $ \client -> - withMethodResponse client fileChooserInterface "SaveFile" (successResponse []) $ do - (Portal.openFile def >>= Portal.await) `shouldThrow` anyException + it "should fail to decode invalid response" $ \handle -> + withMethodResponse handle fileChooserInterface "SaveFile" (successResponse []) $ do + (Portal.openFile (client handle) def >>= Portal.await) `shouldThrow` anyException diff --git a/test/Desktop/Portal/NotificationSpec.hs b/test/Desktop/Portal/NotificationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Desktop/Portal/NotificationSpec.hs @@ -0,0 +1,81 @@ +module Desktop.Portal.NotificationSpec (spec) where + +import Control.Concurrent (newEmptyMVar, putMVar, readMVar) +import Control.Monad (void) +import DBus (InterfaceName, toVariant) +import Data.Map qualified as Map +import Data.Text (Text) +import Data.Word (Word32) +import Desktop.Portal (AddNotificationOptions (..), NotificationButton (..), NotificationIcon (..), NotificationPriority (..), RemoveNotificationOptions (..)) +import Desktop.Portal qualified as Portal +import Desktop.Portal.TestUtil +import Test.Hspec (Spec, around, describe, it, shouldBe) +import Prelude hiding (id) + +notificationInterface :: InterfaceName +notificationInterface = "org.freedesktop.portal.Notification" + +spec :: Spec +spec = do + around withTestBus $ do + describe "addNotification" $ do + it "should encode request with all Nothings" $ \handle -> do + body <- savingRequestArguments_ handle notificationInterface "AddNotification" False $ do + void (Portal.addNotification (client handle) (Portal.addNotificationOptions "id")) + body + `shouldBe` [ toVariantText "id", + toVariantMap [] + ] + + it "should encode request with all Justs" $ \handle -> do + body <- savingRequestArguments_ handle notificationInterface "AddNotification" False $ do + let options = + AddNotificationOptions + { id = "id", + title = Just "title", + body = Just "body", + priority = Just NotificationPriorityLow, + icon = Just (NotificationIconThemed ["wave"]), + defaultAction = Just "defaultAction", + defaultActionTarget = Just (toVariant (42 :: Word32)), + buttons = Just [NotificationButton {label_ = "buttonLabel", action = "buttonAction", target = Nothing}] + } + void (Portal.addNotification (client handle) options) + body + `shouldBe` [ toVariantText "id", + toVariantMap + [ ("title", toVariantText "title"), + ("body", toVariantText "body"), + ("priority", toVariantText "low"), + ("icon", toVariant ("themed" :: Text, toVariant ["wave" :: Text])), + ("default-action", toVariantText "defaultAction"), + ("default-action-target", toVariant (42 :: Word32)), + ( "buttons", + toVariant + [ Map.fromList + [ ("label" :: Text, toVariantText "buttonLabel"), + ("action", toVariantText "buttonAction") + ] + ] + ) + ] + ] + + describe "removeNotification" $ do + it "should encode request" $ \handle -> do + body <- savingRequestArguments_ handle notificationInterface "RemoveNotification" False $ do + void (Portal.removeNotification (client handle) (RemoveNotificationOptions "id")) + body + `shouldBe` [toVariantText "id"] + + describe "handleNotificationActionInvoked" $ do + it "should decode action invoked signal" $ \handle -> do + decodedSignalVar <- newEmptyMVar + void $ + Portal.handleNotificationActionInvoked + (client handle) + (\id name param -> putMVar decodedSignalVar (id, name, param)) + let signalArgs = [toVariantText "id", toVariantText "action", toVariant [toVariant (42 :: Word32)]] + sendSignal handle notificationInterface "ActionInvoked" signalArgs + decoded <- readMVar decodedSignalVar + decoded `shouldBe` ("id", "action", Just (toVariant (42 :: Word32))) diff --git a/test/Desktop/Portal/TestUtil.hs b/test/Desktop/Portal/TestUtil.hs --- a/test/Desktop/Portal/TestUtil.hs +++ b/test/Desktop/Portal/TestUtil.hs @@ -2,10 +2,13 @@ ( successResponse, toVariantMap, toVariantText, - TestClient, + TestHandle, + client, withTestBus, withMethodResponse, savingRequestArguments, + savingRequestArguments_, + sendSignal, ) where @@ -21,13 +24,20 @@ import Data.Map qualified as Map import Data.Text (Text) import Data.Word (Word32) +import Desktop.Portal qualified as Portal import GHC.IO.Handle (hGetLine) import System.Environment (lookupEnv, setEnv) import System.Process (StdStream (..), createProcess, proc, std_out, terminateProcess) -newtype TestClient = TestClient Client +data TestHandle = TestHandle + { serverClient :: Client, + clientClient :: Portal.Client + } -withTestBus :: (TestClient -> IO ()) -> IO () +client :: TestHandle -> Portal.Client +client c = c.clientClient + +withTestBus :: (TestHandle -> IO ()) -> IO () withTestBus cmd = do let dbusArgs = [ "--print-address", @@ -39,71 +49,94 @@ (_, Just hOut, _, ph) <- createProcess (proc "dbus-daemon" dbusArgs) {std_out = CreatePipe} oldSessionAddr <- lookupEnv sessionAddressEnv - flip finally (teardown oldSessionAddr ph) $ do + flip finally (stopDbus oldSessionAddr ph) $ do addrLine <- hGetLine hOut setEnv sessionAddressEnv addrLine - client <- connectSession - flip finally (disconnect client) $ do - requestName client portalBusName [nameDoNotQueue] >>= \case - NamePrimaryOwner -> cmd (TestClient client) - reply -> fail ("Can't get portal name: " <> show reply) + serverClient <- connectSession + flip finally (disconnect serverClient) $ do + clientClient <- Portal.connect + flip finally (Portal.disconnect clientClient) $ do + requestName serverClient portalBusName [nameDoNotQueue] >>= \case + NamePrimaryOwner -> cmd TestHandle {serverClient, clientClient} + reply -> fail ("Can't get portal name: " <> show reply) where - teardown oldSessionAddr ph = do + stopDbus oldSessionAddr ph = do terminateProcess ph maybe (pure ()) (setEnv sessionAddressEnv) oldSessionAddr -withMethodResponse :: TestClient -> InterfaceName -> MemberName -> [Variant] -> IO () -> IO () -withMethodResponse (TestClient client) interfaceName methodName methodResponse cmd = do +withMethodResponse :: TestHandle -> InterfaceName -> MemberName -> [Variant] -> IO () -> IO () +withMethodResponse handle interfaceName methodName methodResponse cmd = do export - client + handle.serverClient portalObjectPath defaultInterface { interfaceName, interfaceMethods = [makeMethod methodName (Signature []) (Signature []) handleMethodCall] } cmd - unexport client portalObjectPath + unexport handle.serverClient portalObjectPath where handleMethodCall methodCall = do - emitResponseSignal client methodCall methodResponse + emitResponseSignal handle methodCall methodResponse pure (ReplyReturn [toVariant (methodRequestHandle methodCall)]) -savingRequestArguments :: TestClient -> InterfaceName -> MemberName -> IO () -> IO [Variant] -savingRequestArguments (TestClient client) interfaceName methodName cmd = do +savingRequestArguments :: TestHandle -> InterfaceName -> MemberName -> IO () -> IO [Variant] +savingRequestArguments handle interfaceName methodName cmd = do + savingRequestArguments_ handle interfaceName methodName True cmd + +savingRequestArguments_ :: TestHandle -> InterfaceName -> MemberName -> Bool -> IO () -> IO [Variant] +savingRequestArguments_ handle interfaceName methodName hasResponse cmd = do argsVar <- newEmptyMVar export - client + handle.serverClient portalObjectPath defaultInterface { interfaceName, interfaceMethods = [makeMethod methodName (Signature []) (Signature []) (handleMethodCall argsVar)] } cmd - unexport client portalObjectPath + unexport handle.serverClient portalObjectPath tryReadMVar argsVar >>= \case Just args -> pure (removeHandleToken args) Nothing -> fail "No method was called during the callback!" where handleMethodCall argsVar methodCall = do - emitResponseSignal client methodCall [toVariant (1 :: Word32)] putSucceeded <- liftIO $ tryPutMVar argsVar (methodCallBody methodCall) unless putSucceeded $ fail "Method arguments already saved: is more than one method being called?" - pure (ReplyReturn [toVariant (methodRequestHandle methodCall)]) + if hasResponse + then do + emitResponseSignal handle methodCall [toVariant (1 :: Word32)] + pure (ReplyReturn [toVariant (methodRequestHandle methodCall)]) + else do + pure (ReplyReturn []) removeHandleToken = \case args - | (not (null args)), + | hasResponse && (not (null args)), Variant (ValueMap kt vt argsMap) <- args !! (length args - 1) -> take (length args - 1) args <> [Variant (ValueMap kt vt (Map.delete (AtomText "handle_token") argsMap))] | otherwise -> args -emitResponseSignal :: MonadIO m => Client -> MethodCall -> [Variant] -> m () -emitResponseSignal client methodCall signalBody = do +sendSignal :: TestHandle -> InterfaceName -> MemberName -> [Variant] -> IO () +sendSignal handle signalInterface signalMember signalBody = + emit + handle.serverClient + Signal + { signalPath = "/org/freedesktop/portal/desktop", + signalInterface, + signalMember, + signalSender = Just portalBusName, + signalDestination = Just (Portal.clientName handle.clientClient), + signalBody + } + +emitResponseSignal :: MonadIO m => TestHandle -> MethodCall -> [Variant] -> m () +emitResponseSignal handle methodCall signalBody = do void . liftIO $ emit - client + handle.serverClient Signal { signalPath = methodRequestHandle methodCall, signalInterface = "org.freedesktop.portal.Request",