desktop-portal 0.0.1.0 → 0.1.0.0

raw patch · 14 files changed

+604/−245 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• README.md +1/−1
• desktop-portal.cabal +6/−5
• src/Desktop/Portal.hs +20/−3
• src/Desktop/Portal/Account.hs +4/−4
• src/Desktop/Portal/FileChooser.hs +7/−7
• src/Desktop/Portal/Internal.hs +227/−0
• src/Desktop/Portal/Notification.hs +150/−0
• src/Desktop/Portal/Request.hs +0/−3
• src/Desktop/Portal/Request/Internal.hs +0/−152
• test/Desktop/Portal/AccountSpec.hs +15/−15
• test/Desktop/Portal/FileChooserSpec.hs +30/−30
• test/Desktop/Portal/NotificationSpec.hs +81/−0
• test/Desktop/Portal/TestUtil.hs +58/−25

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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 =

@@ -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

@@ -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=<MVar>}"++-- | 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"+    }

@@ -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+    ]

@@ -1,3 +0,0 @@-module Desktop.Portal.Request (module Desktop.Portal.Request.Internal) where--import Desktop.Portal.Request.Internal (Request, await, cancel)

@@ -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=<MVar>}"---- | 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

@@ -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

@@ -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

@@ -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)))

@@ -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",