desktop-portal 0.2.1.0 → 0.2.2.0

raw patch · 12 files changed

+691/−36 lines, 12 filesdep +directorydep +temporarydep +unixdep ~dbusdep ~textPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, temporary, unix

Dependency ranges changed: dbus, text

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• README.md +1/−1
• desktop-portal.cabal +19/−9
• src/Desktop/Portal.hs +2/−0
• src/Desktop/Portal/Directories.hs +28/−0
• src/Desktop/Portal/Documents.hs +270/−0
• src/Desktop/Portal/Internal.hs +25/−8
• src/Desktop/Portal/Notification.hs +4/−3
• src/Desktop/Portal/OpenURI.hs +1/−1
• src/Desktop/Portal/Util.hs +8/−2
• test/Desktop/Portal/DocumentsSpec.hs +251/−0
• test/Desktop/Portal/TestUtil.hs +78/−12

@@ -1,3 +1,7 @@+## 0.2.2.0+### Added+- Add Documents portal support.+ ## 0.2.1.0 ### Added - Add OpenURI portal support.

@@ -22,7 +22,7 @@ ### General Guidelines - 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`.+- API methods that take or return a variable set of values via a vardict should be translated into Haskell functions that take records called `...Options` and return records called `...Results`. - `...Options` records should have a `Default` instance where all fields have a reasonable empty value. - Record fields should not have unique prefixes. - API methods that return URIs that are known to always be `file:` URIs should be wrapped with functions returning [`Prelude.FilePath`](https://hackage.haskell.org/package/base-4.18.0.0/docs/Prelude.html#t:FilePath) (at some point this can be replaced with [`System.OsPath`](https://hackage.haskell.org/package/filepath-1.4.100.3/docs/System-OsPath.html#t:OsPath)). If they are not known to be file URIs, then [`Text.URI.URI`](https://hackage.haskell.org/package/modern-uri-0.3.6.0/docs/Text-URI.html#t:URI) should be returned.

@@ -1,6 +1,6 @@ cabal-version:      1.12 name:               desktop-portal-version:            0.2.1.0+version:            0.2.2.0 license:            MIT license-file:       LICENSE maintainer:         garethdanielsmith@gmail.com@@ -22,6 +22,8 @@     exposed-modules:         Desktop.Portal         Desktop.Portal.Account+        Desktop.Portal.Directories+        Desktop.Portal.Documents         Desktop.Portal.FileChooser         Desktop.Portal.Notification         Desktop.Portal.OpenURI@@ -35,10 +37,11 @@      default-language:   Haskell2010     default-extensions:-        DisambiguateRecordFields DuplicateRecordFields FlexibleContexts+        BinaryLiterals DerivingStrategies DisambiguateRecordFields+        DuplicateRecordFields FlexibleContexts GeneralizedNewtypeDeriving         ImportQualifiedPost LambdaCase NamedFieldPuns NoFieldSelectors         NumericUnderscores OverloadedRecordDot OverloadedStrings-        RecordWildCards ScopedTypeVariables TupleSections+        RecordWildCards ScopedTypeVariables TupleSections ViewPatterns      ghc-options:         -Wall -Wcompat -Wincomplete-record-updates@@ -50,10 +53,12 @@         bytestring <0.12,         containers <0.7,         data-default-class <0.2,-        dbus >=1.2.28 && <1.3,+        dbus >=1.3.0 && <2,+        directory <1.4,         modern-uri <0.4,         random <1.3,-        text <1.3+        text <2.1,+        unix <2.8  test-suite spec     type:               exitcode-stdio-1.0@@ -62,6 +67,7 @@     hs-source-dirs:     test     other-modules:         Desktop.Portal.AccountSpec+        Desktop.Portal.DocumentsSpec         Desktop.Portal.FileChooserSpec         Desktop.Portal.NotificationSpec         Desktop.Portal.OpenURISpec@@ -71,10 +77,11 @@      default-language:   Haskell2010     default-extensions:-        DisambiguateRecordFields DuplicateRecordFields FlexibleContexts+        BinaryLiterals DerivingStrategies DisambiguateRecordFields+        DuplicateRecordFields FlexibleContexts GeneralizedNewtypeDeriving         ImportQualifiedPost LambdaCase NamedFieldPuns NoFieldSelectors         NumericUnderscores OverloadedRecordDot OverloadedStrings-        RecordWildCards ScopedTypeVariables TupleSections+        RecordWildCards ScopedTypeVariables TupleSections ViewPatterns      ghc-options:         -Wall -Wcompat -Wincomplete-record-updates@@ -87,11 +94,14 @@         bytestring <0.12,         containers <0.7,         data-default-class <0.2,-        dbus >=1.2.28 && <1.3,+        dbus >=1.3.0 && <2,         desktop-portal,+        directory <1.4,         hspec >=2 && <3,         hspec-expectations <0.9,         modern-uri <0.4,         process <1.7,         random <1.3,-        text <1.3+        temporary <1.4,+        text <2.1,+        unix <2.8

@@ -20,6 +20,7 @@      -- * Portal Interfaces     module Desktop.Portal.Account,+    module Desktop.Portal.Directories,     module Desktop.Portal.FileChooser,     module Desktop.Portal.Notification,     module Desktop.Portal.OpenURI,@@ -27,6 +28,7 @@ where  import Desktop.Portal.Account+import Desktop.Portal.Directories import Desktop.Portal.FileChooser import Desktop.Portal.Internal qualified as Internal import Desktop.Portal.Notification

@@ -0,0 +1,28 @@+-- | Some helper functions to provide paths to base directories to application data\/cache\/etc.+--+-- See https://docs.flatpak.org/en/latest/conventions.html#xdg-base-directories+module Desktop.Portal.Directories+  ( getXdgConfigHome,+    getXdgDataHome,+    getXdgCacheHome,+    getXdgStateHome,+  )+where++import System.Environment (getEnv)++-- | The directory in which to store user-specific configuration files (@~\/.var\/app\/$appId\/config@ by default).+getXdgConfigHome :: IO FilePath+getXdgConfigHome = getEnv "XDG_CONFIG_HOME"++-- | The directory in which to store user-specific data (@~\/.var\/app\/$appId\/data' by default).+getXdgDataHome :: IO FilePath+getXdgDataHome = getEnv "XDG_DATA_HOME"++-- | The directory in which to store user-specific caches (@~\/.var\/app\/$appId\/cache@ by default).+getXdgCacheHome :: IO FilePath+getXdgCacheHome = getEnv "XDG_CACHE_HOME"++-- | The directory in which to store state data such as undo history (@~\/.var\/app\/$appId\/.local\/state@ by default).+getXdgStateHome :: IO FilePath+getXdgStateHome = getEnv "XDG_STATE_HOME"

@@ -0,0 +1,270 @@+module Desktop.Portal.Documents+  ( -- * Common Types+    FileIdentifier (..),+    ApplicationId (..),+    DocumentId (..),+    AddFlag (..),+    GrantPermission (..),+    ExtraResults (..),++    -- * Documents Portal Methods+    getMountPoint,+    add,+    addFull,+    addNamed,+    addNamedFull,+    grantPermissions,+    revokePermissions,+    delete,+  )+where++import Control.Exception (bracket, throwIO)+import Control.Monad (void)+import DBus (BusName, InterfaceName, MemberName, ObjectPath, Variant)+import DBus qualified+import DBus.Client qualified as DBus+import Data.Bits (Ior (..))+import Data.Map (Map)+import Data.Map qualified as Map+import Data.String (IsString)+import Data.Text (Text, unpack)+import Data.Word (Word32)+import Desktop.Portal.Internal (Client, callMethod_)+import Desktop.Portal.Util (decodeNullTerminatedUtf8, encodeNullTerminatedUtf8)+import System.Posix (Fd)+import System.Posix.IO (OpenMode (..), closeFd, defaultFileFlags, openFd)++-- | Specifies a file, either with a file descriptor or a path (which will be resolved to a+-- file descriptor before passing it to the portals API, since the API requires file descriptors).+data FileIdentifier+  = DocumentFilePath FilePath+  | DocumentFd Fd+  deriving (Eq, Show)++newtype ApplicationId = ApplicationId Text+  deriving newtype (Eq, Ord, Show, IsString)++newtype DocumentId = DocumentId Text+  deriving newtype (Eq, Ord, Show, IsString)++data AddFlag+  = AddReuseExisting+  | AddPersistent+  | AddAsNeededByApp+  | AddExportDirectory+  deriving (Eq, Show)++data GrantPermission+  = GrantRead+  | GrantWrite+  | GrantGrantPermissions+  | GrantDelete+  deriving (Eq, Show)++newtype ExtraResults = ExtraResults {mountpoint :: FilePath}+  deriving (Eq, Show)++documentsInterface :: InterfaceName+documentsInterface = "org.freedesktop.portal.Documents"++documentsBusName :: BusName+documentsBusName = "org.freedesktop.portal.Documents"++documentsObject :: ObjectPath+documentsObject = "/org/freedesktop/portal/documents"++getMountPoint :: Client -> IO FilePath+getMountPoint client = do+  callDocumentsMethod client "GetMountPoint" [] >>= \case+    [toFilePath -> Just path] ->+      pure path+    res ->+      throwIO . DBus.clientError $ "getMountPoint: could not parse response: " <> show res++-- | Add a file to the documents store, with basic configuration options.+add ::+  Client ->+  -- | The file to add to the documents store.+  FileIdentifier ->+  -- | Whether to re-use the existing entry in the documents store, if this file is already there.+  Bool ->+  -- | Whether this file should stay in the documents store after this app shuts down.+  Bool ->+  -- | The id (folder name) of the file in the store.+  IO DocumentId+add client file reuseExisting persistent =+  withFd file $ \fd -> do+    callDocumentsMethod client "Add" (args fd) >>= \case+      [DBus.fromVariant -> Just docId] ->+        pure (DocumentId docId)+      res ->+        throwIO . DBus.clientError $ "add: could not parse response: " <> show res+  where+    args fd =+      [ DBus.toVariant fd,+        DBus.toVariant reuseExisting,+        DBus.toVariant persistent+      ]++-- | Add multiple files to the document store, with full configuration options.+addFull ::+  Client ->+  -- | The files to add to the documents store.+  [FileIdentifier] ->+  -- | The flags to apply to the files.+  [AddFlag] ->+  -- | The id of another application that will be granted access to the files.+  Maybe ApplicationId ->+  -- | The permissions to grant to the other application.+  [GrantPermission] ->+  -- | The id (folder name) of each file in the store.+  IO ([DocumentId], ExtraResults)+addFull client files flags appId permissions =+  withFds files $ \fds -> do+    callDocumentsMethod client "AddFull" (args fds) >>= \case+      [DBus.fromVariant -> Just docIds, toExtraResults -> Just extra] ->+        pure (DocumentId <$> docIds, extra)+      res ->+        throwIO . DBus.clientError $ "addFull: could not parse response: " <> show res+  where+    args fds =+      [ DBus.toVariant fds,+        DBus.toVariant (encodeAddFlags flags),+        DBus.toVariant (maybe "" (\(ApplicationId ai) -> ai) appId),+        DBus.toVariant (encodeGrantPermission <$> permissions)+      ]++-- | Add a file to the document store with a specified name, with basic configuration options.+addNamed ::+  Client ->+  -- | The parent directory of the file to add to the documents store.+  FileIdentifier ->+  -- | The basename of the file.+  Text ->+  -- | Whether to re-use the existing entry in the documents store, if this file is already there.+  Bool ->+  -- | Whether this file should stay in the documents store after this app shuts down.+  Bool ->+  -- | The id (folder name) of the file in the store.+  IO DocumentId+addNamed client parentDir basename reuseExisting persistent =+  withFd parentDir $ \fd -> do+    callDocumentsMethod client "AddNamed" (args fd) >>= \case+      [DBus.fromVariant -> Just docId] ->+        pure (DocumentId docId)+      res ->+        throwIO . DBus.clientError $ "addNamed: could not parse response: " <> show res+  where+    args fd =+      [ DBus.toVariant fd,+        DBus.toVariant (encodeNullTerminatedUtf8 basename),+        DBus.toVariant reuseExisting,+        DBus.toVariant persistent+      ]++-- | Add a file to the document store with a specified name, with full configuration options.+addNamedFull ::+  Client ->+  -- | The parent directory of the file to add to the documents store.+  FileIdentifier ->+  -- | The basename of the file.+  Text ->+  -- | The flags to apply to the file.+  [AddFlag] ->+  -- | The id of another application that will be granted access to the file.+  Maybe ApplicationId ->+  -- | The permissions to grant to the other application.+  [GrantPermission] ->+  -- | The id (folder name) of the file in the store.+  IO (DocumentId, ExtraResults)+addNamedFull client parentDir basename flags appId permissions =+  withFd parentDir $ \fd -> do+    callDocumentsMethod client "AddNamedFull" (args fd) >>= \case+      [DBus.fromVariant -> Just docId, toExtraResults -> Just extra] ->+        pure (DocumentId docId, extra)+      res ->+        throwIO . DBus.clientError $ "addNamedFull: could not parse response: " <> show res+  where+    args fd =+      [ DBus.toVariant fd,+        DBus.toVariant (encodeNullTerminatedUtf8 basename),+        DBus.toVariant (encodeAddFlags flags),+        DBus.toVariant (maybe "" (\(ApplicationId ai) -> ai) appId),+        DBus.toVariant (encodeGrantPermission <$> permissions)+      ]++grantPermissions :: Client -> DocumentId -> ApplicationId -> [GrantPermission] -> IO ()+grantPermissions client (DocumentId docId) (ApplicationId appId) permissions =+  void $ callDocumentsMethod client "GrantPermissions" args+  where+    args =+      [ DBus.toVariant docId,+        DBus.toVariant appId,+        DBus.toVariant (encodeGrantPermission <$> permissions)+      ]++revokePermissions :: Client -> DocumentId -> ApplicationId -> [GrantPermission] -> IO ()+revokePermissions client (DocumentId docId) (ApplicationId appId) permissions =+  void $ callDocumentsMethod client "RevokePermissions" args+  where+    args =+      [ DBus.toVariant docId,+        DBus.toVariant appId,+        DBus.toVariant (encodeGrantPermission <$> permissions)+      ]++delete :: Client -> DocumentId -> IO ()+delete client (DocumentId docId) =+  void $ callDocumentsMethod client "Delete" [DBus.toVariant docId]++callDocumentsMethod :: Client -> MemberName -> [Variant] -> IO [Variant]+callDocumentsMethod client =+  callMethod_ client documentsBusName documentsObject documentsInterface++withFd :: FileIdentifier -> (Fd -> IO a) -> IO a+withFd = \case+  DocumentFd fd ->+    ($ fd)+  DocumentFilePath path ->+    bracket (openFd path ReadOnly Nothing defaultFileFlags) closeFd++withFds :: forall a. [FileIdentifier] -> ([Fd] -> IO a) -> IO a+withFds files cmd = withFdsRec [] files+  where+    withFdsRec fds = \case+      [] ->+        cmd (reverse fds)+      file : files' ->+        withFd file $ \fd -> do+          withFdsRec (fd : fds) files'++encodeAddFlags :: [AddFlag] -> Word32+encodeAddFlags flags =+  getIor (foldMap (Ior . encodeAddFlag) flags)++encodeAddFlag :: AddFlag -> Word32+encodeAddFlag = \case+  AddReuseExisting -> 1+  AddPersistent -> 2+  AddAsNeededByApp -> 4+  AddExportDirectory -> 8++encodeGrantPermission :: GrantPermission -> Text+encodeGrantPermission = \case+  GrantRead -> "read"+  GrantWrite -> "write"+  GrantGrantPermissions -> "grant-permissions"+  GrantDelete -> "delete"++toExtraResults :: Variant -> Maybe ExtraResults+toExtraResults v = case DBus.fromVariant v of+  Just (extraMap :: Map Text Variant)+    | Just mountpoint <- toFilePath =<< Map.lookup "mountpoint" extraMap ->+        Just ExtraResults {mountpoint}+  _ ->+    Nothing++toFilePath :: Variant -> Maybe FilePath+toFilePath v =+  unpack <$> (decodeNullTerminatedUtf8 =<< DBus.fromVariant v)

@@ -25,6 +25,7 @@ import DBus.Client qualified as DBus import DBus.Internal.Message (Signal (..)) import DBus.Internal.Types (Variant)+import DBus.Socket qualified as DBus import Data.Map (Map) import Data.Map.Strict qualified as Map import Data.Text (Text, pack, unpack)@@ -78,7 +79,10 @@   case env of     Nothing -> throwIO (DBus.clientError "connect: session address not found.")     Just addr -> do-      (dbusClient, clientName) <- DBus.connectWithName DBus.defaultClientOptions addr+      let socketAuthenticator = DBus.authenticatorWithUnixFds+          clientSocketOptions = DBus.defaultSocketOptions {DBus.socketAuthenticator}+          clientOptions = DBus.defaultClientOptions {DBus.clientSocketOptions}+      (dbusClient, clientName) <- DBus.connectWithName clientOptions addr       pure Client {dbusClient, clientName}  disconnect :: Client -> IO ()@@ -192,19 +196,29 @@   let methodCall = (portalMethodCall interface memberName) {DBus.methodCallBody}   DBus.methodReturnBody <$> DBus.call_ client.dbusClient methodCall --- | Call a method on the desktop portal D-Bus object, but ignore the response.+-- | Call a method on the specified D-Bus object, and read the response directly+-- rather than asynchronously via a request object. callMethod_ ::   Client ->-  -- | Which portal interface to invoke.+  -- | The client that has the object.+  BusName ->+  -- | Which object to call.+  ObjectPath ->+  -- | Which interface to invoke.   InterfaceName ->   -- | Which method to invoke on that interface.   MemberName ->   -- | Arguments to pass to the method.   [Variant] ->-  IO ()-callMethod_ client interface memberName methodCallBody = do-  let methodCall = (portalMethodCall interface memberName) {DBus.methodCallBody}-  void (DBus.call client.dbusClient methodCall)+  -- | The response from the method call.+  IO [Variant]+callMethod_ client busName object interface memberName methodCallBody = do+  let methodCall =+        (DBus.methodCall object interface memberName)+          { DBus.methodCallDestination = Just busName,+            DBus.methodCallBody+          }+  DBus.methodReturnBody <$> DBus.call_ client.dbusClient methodCall  handleSignal :: Client -> InterfaceName -> MemberName -> ([Variant] -> IO ()) -> IO SignalHandler handleSignal client interface memberName handler = do@@ -240,5 +254,8 @@ portalMethodCall :: InterfaceName -> MemberName -> MethodCall portalMethodCall interface memberName =   (DBus.methodCall "/org/freedesktop/portal/desktop" interface memberName)-    { DBus.methodCallDestination = Just "org.freedesktop.portal.Desktop"+    { DBus.methodCallDestination = Just portalBusName     }++portalBusName :: BusName+portalBusName = "org.freedesktop.portal.Desktop"

@@ -18,6 +18,7 @@ where  import Control.Exception (throwIO)+import Control.Monad (void) import DBus (InterfaceName, Variant) import DBus qualified import DBus.Client qualified as DBus@@ -26,7 +27,7 @@ import Data.Map qualified as Map import Data.Maybe (catMaybes, listToMaybe) import Data.Text (Text)-import Desktop.Portal.Internal (Client, SignalHandler, callMethod_, handleSignal)+import Desktop.Portal.Internal (Client, SignalHandler, callMethod, handleSignal) import Desktop.Portal.Util (toVariantPair, toVariantPair') import Prelude hiding (id) @@ -86,7 +87,7 @@  addNotification :: Client -> AddNotificationOptions -> IO () addNotification client options =-  callMethod_ client notificationInterface "AddNotification" [id, optionsArg]+  void $ callMethod client notificationInterface "AddNotification" [id, optionsArg]   where     id = DBus.toVariant options.id     optionsArg =@@ -102,7 +103,7 @@  removeNotification :: Client -> RemoveNotificationOptions -> IO () removeNotification client options =-  callMethod_ client notificationInterface "RemoveNotification" [id]+  void $ callMethod client notificationInterface "RemoveNotification" [id]   where     id = DBus.toVariant options.id 

@@ -1,5 +1,5 @@ module Desktop.Portal.OpenURI-  ( --- * Open URI+  ( -- * Open URI     OpenURIOptions (..),     openURIOptions,     openURI,

@@ -1,11 +1,10 @@-{-# LANGUAGE ViewPatterns #-}- module Desktop.Portal.Util   ( optionalFromVariant,     mapJust,     toVariantPair,     toVariantPair',     encodeNullTerminatedUtf8,+    decodeNullTerminatedUtf8,     decodeFileUri,     decodeFileUris,   )@@ -15,6 +14,7 @@ import DBus qualified import Data.Binary.Builder qualified as Binary import Data.ByteString.Lazy (ByteString)+import Data.ByteString.Lazy qualified as Bytes import Data.Map (Map) import Data.Map qualified as Map import Data.Text (Text, unpack)@@ -44,6 +44,12 @@ encodeNullTerminatedUtf8 :: Text -> ByteString encodeNullTerminatedUtf8 txt =   Binary.toLazyByteString (Encoding.encodeUtf8Builder txt <> Binary.singleton 0)++decodeNullTerminatedUtf8 :: ByteString -> Maybe Text+decodeNullTerminatedUtf8 bytes =+  case Encoding.decodeUtf8' (Bytes.toStrict (Bytes.dropWhileEnd (== 0) bytes)) of+    Left _err -> Nothing+    Right t -> Just t  decodeFileUri :: Text -> Maybe FilePath decodeFileUri uri =

@@ -0,0 +1,251 @@+module Desktop.Portal.DocumentsSpec (spec) where++import Control.Monad (void)+import DBus (BusName, InterfaceName, MemberName, ObjectPath, Type (..), Variant, fromVariant, toVariant, variantType)+import Data.ByteString (ByteString)+import Data.Text (Text)+import Data.Word (Word32)+import Desktop.Portal.Documents (AddFlag (..), ExtraResults (..), FileIdentifier (..), GrantPermission (..))+import Desktop.Portal.Documents qualified as Documents+import Desktop.Portal.TestUtil+import Desktop.Portal.TestUtil qualified as DBus+import System.Posix (Fd)+import Test.Hspec (Spec, around, describe, it, shouldBe, shouldReturn, shouldSatisfy)++documentsInterface :: InterfaceName+documentsInterface = "org.freedesktop.portal.Documents"++documentsBusName :: BusName+documentsBusName = "org.freedesktop.portal.Documents"++documentsObject :: ObjectPath+documentsObject = "/org/freedesktop/portal/documents"++spec :: Spec+spec = do+  around (withTestBus_ documentsBusName) $ do+    describe "getMountPoint" $ do+      it "should encode request" $ \handle -> do+        let responseBody = [toVariant ("/\0" :: ByteString)]+        body <- savingDocumentsMethodArguments handle "GetMountPoint" responseBody $ do+          void $ Documents.getMountPoint (client handle)+        body `shouldBe` []++      it "should decode response" $ \handle -> do+        let responseBody = [toVariant ("/a/b/c\0" :: ByteString)]+        withDocumentsMethodResponse handle "GetMountPoint" responseBody $ do+          Documents.getMountPoint (client handle) `shouldReturn` "/a/b/c"++    describe "add" $ do+      it "should encode request with file descriptor" $ \handle -> do+        let responseBody = [toVariantText "docId"]+        withTempFd $ \fd -> do+          body <- savingDocumentsMethodArguments handle "Add" responseBody $ do+            void $ Documents.add (client handle) (DocumentFd fd) False True+          head body `shouldSatisfy` isDifferentUnixFd fd+          tail body `shouldBe` [DBus.toVariant False, DBus.toVariant True]++      it "should encode request with file path" $ \handle -> do+        let responseBody = [toVariantText "docId"]+        withTempFilePath $ \path -> do+          body <- savingDocumentsMethodArguments handle "Add" responseBody $ do+            void $ Documents.add (client handle) (DocumentFilePath path) False True+          head body `shouldSatisfy` isUnixFd+          tail body `shouldBe` [DBus.toVariant False, DBus.toVariant True]++      it "should decode response" $ \handle -> do+        let responseBody = [toVariantText "docId"]+        withTempFd $ \fd -> do+          withDocumentsMethodResponse handle "Add" responseBody $ do+            Documents.add (client handle) (DocumentFd fd) False False+              `shouldReturn` "docId"++    describe "addFull" $ do+      it "should encode request with file descriptors" $ \handle -> do+        withTempFds 7 $ \fds -> do+          let responseBody =+                [ DBus.toVariant ["docId" :: Text],+                  toVariantMap [("mountpoint", DBus.toVariant ("/\0" :: ByteString))]+                ]+          body <- savingDocumentsMethodArguments handle "AddFull" responseBody $ do+            void $+              Documents.addFull+                (client handle)+                (DocumentFd <$> fds)+                [AddReuseExisting, AddPersistent, AddAsNeededByApp, AddExportDirectory]+                (Just "appId")+                [GrantRead, GrantWrite, GrantGrantPermissions, GrantDelete]+          head body `shouldSatisfy` isDifferentUnixFds fds+          tail body+            `shouldBe` [ DBus.toVariant (0b1111 :: Word32),+                         toVariantText "appId",+                         DBus.toVariant ["read" :: Text, "write", "grant-permissions", "delete"]+                       ]++      it "should encode request with file paths" $ \handle -> do+        withTempFilePaths 8 $ \paths -> do+          let responseBody =+                [ DBus.toVariant ["docId" :: Text],+                  toVariantMap [("mountpoint", DBus.toVariant ("/\0" :: ByteString))]+                ]+          body <- savingDocumentsMethodArguments handle "AddFull" responseBody $ do+            void $+              Documents.addFull (client handle) (DocumentFilePath <$> paths) [] Nothing []+          head body `shouldSatisfy` isUnixFds 8+          tail body+            `shouldBe` [DBus.toVariant (0 :: Word32), toVariantText "", DBus.toVariant ([] :: [Text])]++      it "should decode response" $ \handle -> do+        let responseBody =+              [ DBus.toVariant ["docId" :: Text],+                toVariantMap [("mountpoint", DBus.toVariant ("/a/b/c\0" :: ByteString))]+              ]+        withDocumentsMethodResponse handle "AddFull" responseBody $ do+          Documents.addFull (client handle) [] [] Nothing []+            `shouldReturn` (["docId"], ExtraResults "/a/b/c")++    describe "addNamed" $ do+      it "should encode request with file descriptor" $ \handle -> do+        withTempDirectoryFd $ \fd -> do+          let responseBody = [toVariantText "docId"]+          body <- savingDocumentsMethodArguments handle "AddNamed" responseBody $ do+            void $ Documents.addNamed (client handle) (DocumentFd fd) "filename" False True+          head body `shouldSatisfy` isDifferentUnixFd fd+          tail body+            `shouldBe` [ DBus.toVariant ("filename\0" :: ByteString),+                         DBus.toVariant False,+                         DBus.toVariant True+                       ]++      it "should encode request with file path" $ \handle -> do+        withTempDirectoryFilePath $ \path -> do+          let responseBody = [toVariantText "docId"]+          body <- savingDocumentsMethodArguments handle "AddNamed" responseBody $ do+            void $ Documents.addNamed (client handle) (DocumentFilePath path) "filename" False True+          head body `shouldSatisfy` isUnixFd+          tail body+            `shouldBe` [ DBus.toVariant ("filename\0" :: ByteString),+                         DBus.toVariant False,+                         DBus.toVariant True+                       ]++      it "should decode response" $ \handle -> do+        withTempDirectoryFd $ \fd -> do+          let responseBody = [DBus.toVariantText "docId"]+          withDocumentsMethodResponse handle "AddNamed" responseBody $ do+            Documents.addNamed (client handle) (DocumentFd fd) "filename\0" False False+              `shouldReturn` "docId"++    describe "addNamedFull" $ do+      it "should encode request with file descriptor" $ \handle -> do+        withTempDirectoryFd $ \fd -> do+          let responseBody =+                [ DBus.toVariantText "docId",+                  toVariantMap [("mountpoint", DBus.toVariant ("/\0" :: ByteString))]+                ]+          body <- savingDocumentsMethodArguments handle "AddNamedFull" responseBody $ do+            void $+              Documents.addNamedFull+                (client handle)+                (DocumentFd fd)+                "filename"+                [AddReuseExisting, AddPersistent, AddAsNeededByApp, AddExportDirectory]+                (Just "appId")+                [GrantRead, GrantWrite, GrantGrantPermissions, GrantDelete]+          head body `shouldSatisfy` isDifferentUnixFd fd+          tail body+            `shouldBe` [ DBus.toVariant ("filename\0" :: ByteString),+                         DBus.toVariant (0b1111 :: Word32),+                         toVariantText "appId",+                         DBus.toVariant ["read" :: Text, "write", "grant-permissions", "delete"]+                       ]++      it "should encode request with file path" $ \handle -> do+        withTempDirectoryFilePath $ \path -> do+          let responseBody =+                [ DBus.toVariantText "docId",+                  toVariantMap [("mountpoint", DBus.toVariant ("/\0" :: ByteString))]+                ]+          body <- savingDocumentsMethodArguments handle "AddNamedFull" responseBody $ do+            void $+              Documents.addNamedFull (client handle) (DocumentFilePath path) "filename" [] Nothing []+          head body `shouldSatisfy` isUnixFd+          tail body+            `shouldBe` [ DBus.toVariant ("filename\0" :: ByteString),+                         DBus.toVariant (0 :: Word32),+                         toVariantText "",+                         DBus.toVariant ([] :: [Text])+                       ]++      it "should decode response" $ \handle -> do+        withTempDirectoryFd $ \fd -> do+          let responseBody =+                [ DBus.toVariantText "docId",+                  toVariantMap [("mountpoint", DBus.toVariant ("/a/b/c\0" :: ByteString))]+                ]+          withDocumentsMethodResponse handle "AddNamedFull" responseBody $ do+            Documents.addNamedFull (client handle) (DocumentFd fd) "filename\0" [] Nothing []+              `shouldReturn` ("docId", ExtraResults "/a/b/c")++    describe "grantPermissions" $ do+      it "should encode request" $ \handle -> do+        body <- savingDocumentsMethodArguments handle "GrantPermissions" [] $ do+          Documents.grantPermissions+            (client handle)+            "docId"+            "appId"+            [GrantRead, GrantWrite, GrantGrantPermissions, GrantDelete]+        body+          `shouldBe` [ toVariantText "docId",+                       toVariantText "appId",+                       DBus.toVariant ["read" :: Text, "write", "grant-permissions", "delete"]+                     ]++    describe "revokePermissions" $ do+      it "should encode request" $ \handle -> do+        body <- savingDocumentsMethodArguments handle "RevokePermissions" [] $ do+          Documents.revokePermissions+            (client handle)+            "docId"+            "appId"+            [GrantRead, GrantWrite, GrantGrantPermissions, GrantDelete]+        body+          `shouldBe` [ toVariantText "docId",+                       toVariantText "appId",+                       DBus.toVariant ["read" :: Text, "write", "grant-permissions", "delete"]+                     ]++    describe "delete" $ do+      it "should encode request" $ \handle -> do+        body <- savingDocumentsMethodArguments handle "Delete" [] $ do+          Documents.delete (client handle) "docId"+        body `shouldBe` [toVariantText "docId"]++savingDocumentsMethodArguments :: TestHandle -> MemberName -> [Variant] -> IO () -> IO [Variant]+savingDocumentsMethodArguments handle =+  savingMethodArguments_ handle documentsObject documentsInterface++withDocumentsMethodResponse :: TestHandle -> MemberName -> [Variant] -> IO () -> IO ()+withDocumentsMethodResponse handle =+  withMethodResponse_ handle documentsObject documentsInterface++-- We send a Fd to DBUS and check that the receiving test portal server end gets it,+-- but the Fd actually received will be a different value, since it gets duplicated+-- as it traverses the Unix sockets: test portal client -> DBUS -> test portal server+isDifferentUnixFd :: Fd -> Variant -> Bool+isDifferentUnixFd fd = \case+  (fromVariant -> Just fd') -> fd' /= fd+  _ -> False++isDifferentUnixFds :: [Fd] -> Variant -> Bool+isDifferentUnixFds fds = \case+  (fromVariant -> Just fds') -> length fds' == length fds && fds' /= fds+  _ -> False++isUnixFd :: Variant -> Bool+isUnixFd v = DBus.variantType v == TypeUnixFd++isUnixFds :: Int -> Variant -> Bool+isUnixFds n v+  | Just (fds :: [Fd]) <- fromVariant v, length fds == n = True+  | otherwise = False

@@ -5,23 +5,33 @@     TestHandle,     client,     withTestBus,+    withTestBus_,     withMethodResponse,+    withMethodResponse_,     withRequestResponse,     savingMethodArguments,+    savingMethodArguments_,     savingRequestArguments,     sendSignal,     dbusClientException,+    withTempFilePath,+    withTempFilePaths,+    withTempFd,+    withTempFds,+    withTempDirectoryFd,+    withTempDirectoryFilePath,   ) where  import Control.Concurrent (newEmptyMVar, tryPutMVar, tryReadMVar)-import Control.Exception (finally)+import Control.Exception (bracket, finally, throwIO) import Control.Monad (unless, void) import Control.Monad.IO.Class (MonadIO (..))-import DBus (BusName, InterfaceName, IsVariant (fromVariant), MemberName, MethodCall (..), ObjectPath, Variant, formatBusName, objectPath_, toVariant)-import DBus.Client (Client, ClientError, Interface (..), Reply (..), RequestNameReply (..), connectSession, defaultInterface, disconnect, emit, export, makeMethod, nameDoNotQueue, requestName, unexport)+import DBus (BusName, InterfaceName, IsVariant (fromVariant), MemberName, MethodCall (..), ObjectPath, Variant, formatBusName, getSessionAddress, objectPath_, toVariant)+import DBus.Client (Client, ClientError, ClientOptions (..), Interface (..), Reply (..), RequestNameReply (..), clientError, connectWith, defaultClientOptions, defaultInterface, disconnect, emit, export, makeMethod, nameDoNotQueue, requestName, unexport) import DBus.Internal.Message (Signal (..)) import DBus.Internal.Types (Atom (AtomText), Signature (..), Value (ValueMap), Variant (Variant))+import DBus.Socket (SocketOptions (..), authenticatorWithUnixFds, defaultSocketOptions) import Data.Map (Map) import Data.Map qualified as Map import Data.Text (Text)@@ -29,6 +39,8 @@ import Desktop.Portal qualified as Portal import GHC.IO.Handle (hGetLine) import System.Environment (lookupEnv, setEnv)+import System.IO.Temp (withSystemTempDirectory, withSystemTempFile)+import System.Posix (Fd, OpenMode (..), closeFd, defaultFileFlags, handleToFd, openFd) import System.Process (StdStream (..), createProcess, proc, std_out, terminateProcess) import Test.Hspec.Expectations (Selector) @@ -41,7 +53,10 @@ client c = c.clientClient  withTestBus :: (TestHandle -> IO ()) -> IO ()-withTestBus cmd = do+withTestBus = withTestBus_ portalBusName++withTestBus_ :: BusName -> (TestHandle -> IO ()) -> IO ()+withTestBus_ busName cmd = do   let dbusArgs =         [ "--print-address",           "--nopidfile",@@ -55,11 +70,11 @@   flip finally (stopDbus oldSessionAddr ph) $ do     addrLine <- hGetLine hOut     setEnv sessionAddressEnv addrLine-    serverClient <- connectSession+    serverClient <- connectSessionWithFds     flip finally (disconnect serverClient) $ do       clientClient <- Portal.connect       flip finally (Portal.disconnect clientClient) $ do-        requestName serverClient portalBusName [nameDoNotQueue] >>= \case+        requestName serverClient busName [nameDoNotQueue] >>= \case           NamePrimaryOwner -> cmd TestHandle {serverClient, clientClient}           reply -> fail ("Can't get portal name: " <> show reply)   where@@ -68,16 +83,20 @@       maybe (pure ()) (setEnv sessionAddressEnv) oldSessionAddr  withMethodResponse :: TestHandle -> InterfaceName -> MemberName -> [Variant] -> IO () -> IO ()-withMethodResponse handle interfaceName methodName methodResponse cmd = do+withMethodResponse handle =+  withMethodResponse_ handle portalObjectPath++withMethodResponse_ :: TestHandle -> ObjectPath -> InterfaceName -> MemberName -> [Variant] -> IO () -> IO ()+withMethodResponse_ handle objectPath interfaceName methodName methodResponse cmd = do   export     handle.serverClient-    portalObjectPath+    objectPath     defaultInterface       { interfaceName,         interfaceMethods = [makeMethod methodName (Signature []) (Signature []) (const . pure . ReplyReturn $ methodResponse)]       }   cmd-  unexport handle.serverClient portalObjectPath+  unexport handle.serverClient objectPath  withRequestResponse :: TestHandle -> InterfaceName -> MemberName -> [Variant] -> IO () -> IO () withRequestResponse handle interfaceName methodName methodResponse cmd = do@@ -96,17 +115,21 @@       pure (ReplyReturn [toVariant (methodRequestHandle methodCall)])  savingMethodArguments :: TestHandle -> InterfaceName -> MemberName -> [Variant] -> IO () -> IO [Variant]-savingMethodArguments handle interfaceName methodName response cmd = do+savingMethodArguments handle =+  savingMethodArguments_ handle portalObjectPath++savingMethodArguments_ :: TestHandle -> ObjectPath -> InterfaceName -> MemberName -> [Variant] -> IO () -> IO [Variant]+savingMethodArguments_ handle objectPath interfaceName methodName response cmd = do   argsVar <- newEmptyMVar   export     handle.serverClient-    portalObjectPath+    objectPath     defaultInterface       { interfaceName,         interfaceMethods = [makeMethod methodName (Signature []) (Signature []) (handleMethodCall argsVar)]       }   cmd-  unexport handle.serverClient portalObjectPath+  unexport handle.serverClient objectPath   tryReadMVar argsVar >>= \case     Just args -> pure args     Nothing -> fail "No method was called during the callback!"@@ -214,3 +237,46 @@  dbusClientException :: Selector ClientError dbusClientException = const True++connectSessionWithFds :: IO Client+connectSessionWithFds = do+  env <- getSessionAddress+  case env of+    Nothing -> throwIO (clientError "connectSessionWithFds: session address not found.")+    Just addr -> do+      let socketAuthenticator = authenticatorWithUnixFds+          clientSocketOptions = defaultSocketOptions {socketAuthenticator}+          clientOptions = defaultClientOptions {clientSocketOptions}+      connectWith clientOptions addr++withTempFilePath :: (FilePath -> IO ()) -> IO ()+withTempFilePath cmd =+  withSystemTempFile "haskell-desktop-portal" $ \path _handle -> cmd path++withTempFilePaths :: Int -> ([FilePath] -> IO ()) -> IO ()+withTempFilePaths n cmd = go [] n+  where+    go acc = \case+      i | i <= 0 -> cmd acc+      i -> withTempFilePath (\path -> go (path : acc) (i - 1))++withTempFd :: (Fd -> IO ()) -> IO ()+withTempFd cmd =+  withSystemTempFile "haskell-desktop-portal" $ \_path handle -> do+    bracket (handleToFd handle) closeFd cmd++withTempFds :: Int -> ([Fd] -> IO ()) -> IO ()+withTempFds n cmd = go [] n+  where+    go acc = \case+      i | i <= 0 -> cmd acc+      i -> withTempFd (\fd -> go (fd : acc) (i - 1))++withTempDirectoryFd :: (Fd -> IO ()) -> IO ()+withTempDirectoryFd cmd =+  withSystemTempDirectory "haskell-desktop-portal" $ \path -> do+    bracket (openFd path ReadOnly Nothing defaultFileFlags) closeFd cmd++withTempDirectoryFilePath :: (FilePath -> IO ()) -> IO ()+withTempDirectoryFilePath =+  withSystemTempDirectory "haskell-desktop-portal"