packages feed

desktop-portal 0.1.0.0 → 0.1.1.0

raw patch · 11 files changed

+304/−58 lines, 11 filesdep +hspec-expectationsPVP ok

version bump matches the API change (PVP)

Dependencies added: hspec-expectations

API changes (from Hackage documentation)

+ Desktop.Portal.Settings: ColorSchemeDark :: ColorScheme
+ Desktop.Portal.Settings: ColorSchemeLight :: ColorScheme
+ Desktop.Portal.Settings: ColorSchemeNoPreference :: ColorScheme
+ Desktop.Portal.Settings: ReadAllOptions :: [Text] -> ReadAllOptions
+ Desktop.Portal.Settings: ReadAllResults :: [SettingValue] -> ReadAllResults
+ Desktop.Portal.Settings: ReadOptions :: Text -> Text -> ReadOptions
+ Desktop.Portal.Settings: ReadResults :: Variant -> Maybe StandardSetting -> ReadResults
+ Desktop.Portal.Settings: SettingColorScheme :: ColorScheme -> StandardSetting
+ Desktop.Portal.Settings: SettingValue :: Text -> Text -> Variant -> Maybe StandardSetting -> SettingValue
+ Desktop.Portal.Settings: [$sel:key:ReadOptions] :: ReadOptions -> Text
+ Desktop.Portal.Settings: [$sel:key:SettingValue] :: SettingValue -> Text
+ Desktop.Portal.Settings: [$sel:namespace:ReadOptions] :: ReadOptions -> Text
+ Desktop.Portal.Settings: [$sel:namespace:SettingValue] :: SettingValue -> Text
+ Desktop.Portal.Settings: [$sel:namespaces:ReadAllOptions] :: ReadAllOptions -> [Text]
+ Desktop.Portal.Settings: [$sel:standardValue:ReadResults] :: ReadResults -> Maybe StandardSetting
+ Desktop.Portal.Settings: [$sel:standardValue:SettingValue] :: SettingValue -> Maybe StandardSetting
+ Desktop.Portal.Settings: [$sel:value:ReadResults] :: ReadResults -> Variant
+ Desktop.Portal.Settings: [$sel:value:SettingValue] :: SettingValue -> Variant
+ Desktop.Portal.Settings: [$sel:values:ReadAllResults] :: ReadAllResults -> [SettingValue]
+ Desktop.Portal.Settings: data ColorScheme
+ Desktop.Portal.Settings: data ReadOptions
+ Desktop.Portal.Settings: data ReadResults
+ Desktop.Portal.Settings: data SettingValue
+ Desktop.Portal.Settings: instance Data.Default.Class.Default Desktop.Portal.Settings.ReadAllOptions
+ Desktop.Portal.Settings: instance GHC.Classes.Eq Desktop.Portal.Settings.ColorScheme
+ Desktop.Portal.Settings: instance GHC.Classes.Eq Desktop.Portal.Settings.ReadAllOptions
+ Desktop.Portal.Settings: instance GHC.Classes.Eq Desktop.Portal.Settings.ReadAllResults
+ Desktop.Portal.Settings: instance GHC.Classes.Eq Desktop.Portal.Settings.ReadOptions
+ Desktop.Portal.Settings: instance GHC.Classes.Eq Desktop.Portal.Settings.ReadResults
+ Desktop.Portal.Settings: instance GHC.Classes.Eq Desktop.Portal.Settings.SettingValue
+ Desktop.Portal.Settings: instance GHC.Classes.Eq Desktop.Portal.Settings.StandardSetting
+ Desktop.Portal.Settings: instance GHC.Show.Show Desktop.Portal.Settings.ColorScheme
+ Desktop.Portal.Settings: instance GHC.Show.Show Desktop.Portal.Settings.ReadAllOptions
+ Desktop.Portal.Settings: instance GHC.Show.Show Desktop.Portal.Settings.ReadAllResults
+ Desktop.Portal.Settings: instance GHC.Show.Show Desktop.Portal.Settings.ReadOptions
+ Desktop.Portal.Settings: instance GHC.Show.Show Desktop.Portal.Settings.ReadResults
+ Desktop.Portal.Settings: instance GHC.Show.Show Desktop.Portal.Settings.SettingValue
+ Desktop.Portal.Settings: instance GHC.Show.Show Desktop.Portal.Settings.StandardSetting
+ Desktop.Portal.Settings: newtype ReadAllOptions
+ Desktop.Portal.Settings: newtype ReadAllResults
+ Desktop.Portal.Settings: newtype StandardSetting
+ Desktop.Portal.Settings: read :: Client -> ReadOptions -> IO ReadResults
+ Desktop.Portal.Settings: readAll :: Client -> ReadAllOptions -> IO ReadAllResults

Files

ChangeLog.md view
@@ -1,3 +1,7 @@+## 0.1.1.0+### Added+- Add Settings portal support.+ ## 0.1.0.0 ### Added - Make client connections explicit so they can be shared across requests and signal handlers.
README.md view
@@ -9,6 +9,10 @@ - **Q. Why does this not use Template Haskell to generate interface code from the [XML API definitions](https://github.com/flatpak/xdg-desktop-portal/data)**? - **A.** The Portal API does not lend itself to code generation because inputs and outputs are mostly informally defined via vardicts rather than via simple positional parameters. Also the XML definitions are LGPL, which would make this library LGPL too. +## API Documentation++See the generated docs on [Hackage](https://hackage.haskell.org/package/desktop-portal).+ ## Development Guide  ### How to contribute
desktop-portal.cabal view
@@ -1,6 +1,6 @@ cabal-version:      1.12 name:               desktop-portal-version:            0.1.0.0+version:            0.1.1.0 license:            MIT license-file:       LICENSE maintainer:         garethdanielsmith@gmail.com@@ -24,6 +24,7 @@         Desktop.Portal.Account         Desktop.Portal.FileChooser         Desktop.Portal.Notification+        Desktop.Portal.Settings      hs-source-dirs:     src     other-modules:@@ -61,6 +62,7 @@         Desktop.Portal.AccountSpec         Desktop.Portal.FileChooserSpec         Desktop.Portal.NotificationSpec+        Desktop.Portal.SettingsSpec         Desktop.Portal.TestUtil         Paths_desktop_portal @@ -85,6 +87,7 @@         dbus >=1.2.28 && <1.3,         desktop-portal,         hspec >=2 && <3,+        hspec-expectations <0.9,         process <1.7,         random <1.3,         text <1.3
src/Desktop/Portal/Internal.hs view
@@ -5,9 +5,10 @@     clientName,     Request,     sendRequest,-    sendRequestSansResponse,     await,     cancel,+    callMethod,+    callMethod_,     SignalHandler,     handleSignal,     cancelSignalHandler,@@ -175,8 +176,9 @@     _ ->       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 ::+-- | Call a method on the desktop portal D-Bus object, and read the response directly+-- rather than asynchronously via a request object.+callMethod ::   Client ->   -- | Which portal interface to invoke.   InterfaceName ->@@ -184,10 +186,25 @@   MemberName ->   -- | Arguments to pass to the method.   [Variant] ->+  -- | The response from the method call.+  IO [Variant]+callMethod client interface memberName methodCallBody = do+  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.+callMethod_ ::+  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+callMethod_ client interface memberName methodCallBody = do   let methodCall = (portalMethodCall interface memberName) {DBus.methodCallBody}-  void (DBus.call_ client.dbusClient methodCall)+  void (DBus.call client.dbusClient methodCall)  handleSignal :: Client -> InterfaceName -> MemberName -> ([Variant] -> IO ()) -> IO SignalHandler handleSignal client interface memberName handler = do
src/Desktop/Portal/Notification.hs view
@@ -26,7 +26,7 @@ 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.Internal (Client, SignalHandler, callMethod_, handleSignal) import Desktop.Portal.Util (toVariantPair, toVariantPair') import Prelude hiding (id) @@ -86,7 +86,7 @@  addNotification :: Client -> AddNotificationOptions -> IO () addNotification client options =-  sendRequestSansResponse client notificationInterface "AddNotification" [id, optionsArg]+  callMethod_ client notificationInterface "AddNotification" [id, optionsArg]   where     id = DBus.toVariant options.id     optionsArg =@@ -102,7 +102,7 @@  removeNotification :: Client -> RemoveNotificationOptions -> IO () removeNotification client options =-  sendRequestSansResponse client notificationInterface "RemoveNotification" [id]+  callMethod_ client notificationInterface "RemoveNotification" [id]   where     id = DBus.toVariant options.id 
+ src/Desktop/Portal/Settings.hs view
@@ -0,0 +1,108 @@+module Desktop.Portal.Settings+  ( -- * Common Types+    SettingValue (..),+    StandardSetting (..),+    ColorScheme (..),++    -- * Read All+    ReadAllOptions (..),+    ReadAllResults (..),+    readAll,++    -- * Read+    ReadOptions (..),+    ReadResults (..),+    read,+  )+where++import Control.Exception (throwIO)+import DBus (InterfaceName, Variant)+import DBus qualified+import DBus.Client qualified as DBus+import Data.Default.Class (Default (..))+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Word (Word32)+import Desktop.Portal.Internal (Client, callMethod)+import Prelude hiding (read)++newtype ReadAllOptions = ReadAllOptions+  {namespaces :: [Text]}+  deriving (Eq, Show)++instance Default ReadAllOptions where+  def = ReadAllOptions {namespaces = []}++newtype ReadAllResults = ReadAllResults+  {values :: [SettingValue]}+  deriving (Eq, Show)++data ReadOptions = ReadOptions+  { namespace :: Text,+    key :: Text+  }+  deriving (Eq, Show)++data ReadResults = ReadResults+  { value :: Variant,+    standardValue :: Maybe StandardSetting+  }+  deriving (Eq, Show)++data SettingValue = SettingValue+  { namespace :: Text,+    key :: Text,+    value :: Variant,+    standardValue :: Maybe StandardSetting+  }+  deriving (Eq, Show)++newtype StandardSetting+  = SettingColorScheme ColorScheme+  deriving (Eq, Show)++data ColorScheme+  = ColorSchemeNoPreference+  | ColorSchemeDark+  | ColorSchemeLight+  deriving (Eq, Show)++settingsInterface :: InterfaceName+settingsInterface = "org.freedesktop.portal.Settings"++readAll :: Client -> ReadAllOptions -> IO ReadAllResults+readAll client options =+  callMethod client settingsInterface "ReadAll" args >>= parseResponse+  where+    args = [DBus.toVariant options.namespaces]+    parseResponse = \case+      [resVal] | Just namespaceKeyMap <- DBus.fromVariant resVal -> do+        pure . ReadAllResults $+          flip Map.foldMapWithKey namespaceKeyMap $ \namespace keyMap ->+            flip Map.foldMapWithKey keyMap $ \key value ->+              [SettingValue {namespace, key, value, standardValue = decodeStandardSetting namespace key value}]+      res ->+        throwIO . DBus.clientError $ "readAll: could not parse response: " <> show res++read :: Client -> ReadOptions -> IO ReadResults+read client options =+  callMethod client settingsInterface "Read" args >>= parseResponse+  where+    args = [DBus.toVariant options.namespace, DBus.toVariant options.key]+    parseResponse = \case+      [value] ->+        pure ReadResults {value, standardValue = decodeStandardSetting options.namespace options.key value}+      res ->+        throwIO . DBus.clientError $ "read: could not parse response: " <> show res++decodeStandardSetting :: Text -> Text -> Variant -> Maybe StandardSetting+decodeStandardSetting namespace key value =+  case (namespace, key) of+    ("org.freedesktop.appearance", "color-scheme") -> Just (SettingColorScheme (decodeColorScheme value))+    _ -> Nothing+  where+    decodeColorScheme scheme+      | scheme == DBus.toVariant (1 :: Word32) = ColorSchemeDark+      | scheme == DBus.toVariant (2 :: Word32) = ColorSchemeLight+      | otherwise = ColorSchemeNoPreference
test/Desktop/Portal/AccountSpec.hs view
@@ -6,7 +6,7 @@ import Desktop.Portal (GetUserInformationOptions (..), GetUserInformationResults (..)) import Desktop.Portal qualified as Portal import Desktop.Portal.TestUtil-import Test.Hspec (Spec, anyException, around, describe, it, shouldBe, shouldThrow)+import Test.Hspec (Spec, around, describe, it, shouldBe, shouldReturn, shouldThrow)  accountInterface :: InterfaceName accountInterface = "org.freedesktop.portal.Account"@@ -38,9 +38,9 @@                   ("name", toVariantText "_name"),                   ("image", toVariantText "_img")                 ]-        withMethodResponse handle accountInterface "GetUserInformation" responseBody $ do-          info <- Portal.getUserInformation (client handle) def >>= Portal.await-          info `shouldBe` Just (GetUserInformationResults "_id" "_name" (Just "_img"))+        withRequestResponse handle accountInterface "GetUserInformation" responseBody $ do+          (Portal.getUserInformation (client handle) def >>= Portal.await)+            `shouldReturn` Just (GetUserInformationResults "_id" "_name" (Just "_img"))        it "should decode response without image" $ \handle -> do         let responseBody =@@ -48,10 +48,10 @@                 [ ("id", toVariantText "_id"),                   ("name", toVariantText "_name")                 ]-        withMethodResponse handle accountInterface "GetUserInformation" responseBody $ do-          info <- Portal.getUserInformation (client handle) def >>= Portal.await-          info `shouldBe` Just (GetUserInformationResults "_id" "_name" Nothing)+        withRequestResponse handle accountInterface "GetUserInformation" responseBody $ do+          (Portal.getUserInformation (client handle) def >>= Portal.await)+            `shouldReturn` Just (GetUserInformationResults "_id" "_name" Nothing)        it "should fail to decode invalid response" $ \handle ->-        withMethodResponse handle accountInterface "GetUserInformation" (successResponse []) $ do-          (Portal.getUserInformation (client handle) def >>= Portal.await) `shouldThrow` anyException+        withRequestResponse handle accountInterface "GetUserInformation" (successResponse []) $ do+          (Portal.getUserInformation (client handle) def >>= Portal.await) `shouldThrow` dbusClientException
test/Desktop/Portal/FileChooserSpec.hs view
@@ -9,7 +9,7 @@ import Desktop.Portal (ChoiceCombo (..), ChoiceComboOption (..), ChoiceComboSelection (..), Filter (..), FilterFileType (..), OpenFileOptions (..), OpenFileResults (..), SaveFileOptions (..), SaveFileResults (..)) import Desktop.Portal qualified as Portal import Desktop.Portal.TestUtil-import Test.Hspec (Spec, anyException, around, describe, it, shouldBe, shouldThrow)+import Test.Hspec (Spec, around, describe, it, shouldBe, shouldReturn, shouldThrow)  fileChooserInterface :: InterfaceName fileChooserInterface = "org.freedesktop.portal.FileChooser"@@ -100,10 +100,9 @@        it "should decode response with all Nothings" $ \handle -> do         let responseBody = successResponse [("uris", toVariant ["file:///a/b/c" :: Text])]-        withMethodResponse handle fileChooserInterface "OpenFile" responseBody $ do-          info <- Portal.openFile (client handle) def >>= Portal.await-          info-            `shouldBe` Just+        withRequestResponse handle fileChooserInterface "OpenFile" responseBody $ do+          (Portal.openFile (client handle) def >>= Portal.await)+            `shouldReturn` Just               (OpenFileResults {uris = ["file:///a/b/c"], choices = Nothing, currentFilter = Nothing})        it "should decode response with all Justs" $ \handle -> do@@ -113,10 +112,9 @@                   ("choices", toVariant [("_comboId" :: Text, "_optionId" :: Text)]),                   ("current_filter", toVariant ("_filterId" :: Text, [(0 :: Word32, "*.md" :: Text)]))                 ]-        withMethodResponse handle fileChooserInterface "OpenFile" responseBody $ do-          info <- Portal.openFile (client handle) def >>= Portal.await-          info-            `shouldBe` Just+        withRequestResponse handle fileChooserInterface "OpenFile" responseBody $ do+          (Portal.openFile (client handle) def >>= Portal.await)+            `shouldReturn` Just               ( OpenFileResults                   { uris = ["file:///a/b/c"],                     choices = Just [ChoiceComboSelection {comboId = "_comboId", optionId = "_optionId"}],@@ -125,8 +123,8 @@               )        it "should fail to decode invalid response" $ \handle ->-        withMethodResponse handle fileChooserInterface "OpenFile" (successResponse []) $ do-          (Portal.openFile (client handle) def >>= Portal.await) `shouldThrow` anyException+        withRequestResponse handle fileChooserInterface "OpenFile" (successResponse []) $ do+          (Portal.openFile (client handle) def >>= Portal.await) `shouldThrow` dbusClientException      describe "saveFile" $ do       it "should encode request with all Nothings" $ \handle -> do@@ -213,10 +211,9 @@        it "should decode response with all Nothings" $ \handle -> do         let responseBody = successResponse [("uris", toVariant ["file:///a/b/c" :: Text])]-        withMethodResponse handle fileChooserInterface "SaveFile" responseBody $ do-          info <- Portal.saveFile (client handle) def >>= Portal.await-          info-            `shouldBe` Just+        withRequestResponse handle fileChooserInterface "SaveFile" responseBody $ do+          (Portal.saveFile (client handle) def >>= Portal.await)+            `shouldReturn` Just               (SaveFileResults {uris = ["file:///a/b/c"], choices = Nothing, currentFilter = Nothing})        it "should decode response with all Justs" $ \handle -> do@@ -226,10 +223,9 @@                   ("choices", toVariant [("_comboId" :: Text, "_optionId" :: Text)]),                   ("current_filter", toVariant ("_filterId" :: Text, [(0 :: Word32, "*.md" :: Text)]))                 ]-        withMethodResponse handle fileChooserInterface "SaveFile" responseBody $ do-          info <- Portal.saveFile (client handle) def >>= Portal.await-          info-            `shouldBe` Just+        withRequestResponse handle fileChooserInterface "SaveFile" responseBody $ do+          (Portal.saveFile (client handle) def >>= Portal.await)+            `shouldReturn` Just               ( SaveFileResults                   { uris = ["file:///a/b/c"],                     choices = Just [ChoiceComboSelection {comboId = "_comboId", optionId = "_optionId"}],@@ -238,5 +234,5 @@               )        it "should fail to decode invalid response" $ \handle ->-        withMethodResponse handle fileChooserInterface "SaveFile" (successResponse []) $ do-          (Portal.openFile (client handle) def >>= Portal.await) `shouldThrow` anyException+        withRequestResponse handle fileChooserInterface "SaveFile" (successResponse []) $ do+          (Portal.openFile (client handle) def >>= Portal.await) `shouldThrow` dbusClientException
test/Desktop/Portal/NotificationSpec.hs view
@@ -9,7 +9,7 @@ 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 Test.Hspec (Spec, around, describe, it, shouldBe, shouldReturn) import Prelude hiding (id)  notificationInterface :: InterfaceName@@ -20,7 +20,7 @@   around withTestBus $ do     describe "addNotification" $ do       it "should encode request with all Nothings" $ \handle -> do-        body <- savingRequestArguments_ handle notificationInterface "AddNotification" False $ do+        body <- savingMethodArguments handle notificationInterface "AddNotification" [] $ do           void (Portal.addNotification (client handle) (Portal.addNotificationOptions "id"))         body           `shouldBe` [ toVariantText "id",@@ -28,7 +28,7 @@                      ]        it "should encode request with all Justs" $ \handle -> do-        body <- savingRequestArguments_ handle notificationInterface "AddNotification" False $ do+        body <- savingMethodArguments handle notificationInterface "AddNotification" [] $ do           let options =                 AddNotificationOptions                   { id = "id",@@ -63,7 +63,7 @@      describe "removeNotification" $ do       it "should encode request" $ \handle -> do-        body <- savingRequestArguments_ handle notificationInterface "RemoveNotification" False $ do+        body <- savingMethodArguments handle notificationInterface "RemoveNotification" [] $ do           void (Portal.removeNotification (client handle) (RemoveNotificationOptions "id"))         body           `shouldBe` [toVariantText "id"]@@ -77,5 +77,5 @@             (\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)))+        readMVar decodedSignalVar+          `shouldReturn` ("id", "action", Just (toVariant (42 :: Word32)))
+ test/Desktop/Portal/SettingsSpec.hs view
@@ -0,0 +1,82 @@+module Desktop.Portal.SettingsSpec (spec) where++import Control.Monad (void)+import DBus (InterfaceName, toVariant)+import Data.Default.Class (Default (def))+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Word (Word32)+import Desktop.Portal.Settings (ColorScheme (..), ReadAllOptions (..), ReadAllResults (..), ReadOptions (..), ReadResults (..), SettingValue (..), StandardSetting (..))+import Desktop.Portal.Settings qualified as Settings+import Desktop.Portal.TestUtil+import Test.Hspec (Spec, around, describe, it, shouldBe, shouldReturn, shouldThrow)++settingsInterface :: InterfaceName+settingsInterface = "org.freedesktop.portal.Settings"++spec :: Spec+spec = do+  around withTestBus $ do+    describe "readAll" $ do+      it "should encode request" $ \handle -> do+        let responseBody = [toVariantMap []]+        body <- savingMethodArguments handle settingsInterface "ReadAll" responseBody $ do+          void (Settings.readAll (client handle) (ReadAllOptions ["ns1", "ns2"]))+        body+          `shouldBe` [toVariant ["ns1" :: Text, "ns2"]]++      it "should decode response" $ \handle -> do+        let responseBody =+              [ toVariant . Map.singleton ("namespace" :: Text) . Map.fromList $+                  [ ("key1" :: Text, toVariant (42 :: Word32)),+                    ("key2", toVariant True)+                  ]+              ]+        withMethodResponse handle settingsInterface "ReadAll" responseBody $ do+          Settings.readAll (client handle) def+            `shouldReturn` ReadAllResults+              [ SettingValue+                  { namespace = "namespace",+                    key = "key1",+                    value = toVariant (42 :: Word32),+                    standardValue = Nothing+                  },+                SettingValue+                  { namespace = "namespace",+                    key = "key2",+                    value = toVariant True,+                    standardValue = Nothing+                  }+              ]++      it "should fail to decode invalid response" $ \handle ->+        withMethodResponse handle settingsInterface "ReadAll" [] $ do+          Settings.readAll (client handle) def `shouldThrow` dbusClientException++    describe "read" $ do+      it "should encode request" $ \handle -> do+        let responseBody = [toVariantText "wibble"]+        body <- savingMethodArguments handle settingsInterface "Read" responseBody $ do+          void (Settings.read (client handle) (ReadOptions "namespace" "key"))+        body+          `shouldBe` [toVariantText "namespace", toVariantText "key"]++      it "should decode response" $ \handle -> do+        let responseBody = [toVariant (42 :: Word32)]+        withMethodResponse handle settingsInterface "Read" responseBody $ do+          Settings.read (client handle) (ReadOptions "ns" "key")+            `shouldReturn` ReadResults {value = toVariant (42 :: Word32), standardValue = Nothing}++      it "should fail to decode invalid response" $ \handle ->+        withMethodResponse handle settingsInterface "Read" [] $ do+          Settings.read (client handle) (ReadOptions "ns" "key") `shouldThrow` dbusClientException++    describe "standard settings" $ do+      it "should decode color scheme" $ \handle -> do+        let responseBody = [toVariant (2 :: Word32)]+        withMethodResponse handle settingsInterface "Read" responseBody $ do+          Settings.read (client handle) (ReadOptions "org.freedesktop.appearance" "color-scheme")+            `shouldReturn` ReadResults+              { value = toVariant (2 :: Word32),+                standardValue = Just (SettingColorScheme ColorSchemeLight)+              }
test/Desktop/Portal/TestUtil.hs view
@@ -6,9 +6,11 @@     client,     withTestBus,     withMethodResponse,+    withRequestResponse,+    savingMethodArguments,     savingRequestArguments,-    savingRequestArguments_,     sendSignal,+    dbusClientException,   ) where @@ -17,7 +19,7 @@ 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, Interface (..), Reply (..), RequestNameReply (..), connectSession, defaultInterface, disconnect, emit, export, makeMethod, nameDoNotQueue, requestName, unexport)+import DBus.Client (Client, ClientError, Interface (..), Reply (..), RequestNameReply (..), connectSession, 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 Data.Map (Map)@@ -28,6 +30,7 @@ import GHC.IO.Handle (hGetLine) import System.Environment (lookupEnv, setEnv) import System.Process (StdStream (..), createProcess, proc, std_out, terminateProcess)+import Test.Hspec.Expectations (Selector)  data TestHandle = TestHandle   { serverClient :: Client,@@ -71,6 +74,18 @@     portalObjectPath     defaultInterface       { interfaceName,+        interfaceMethods = [makeMethod methodName (Signature []) (Signature []) (const . pure . ReplyReturn $ methodResponse)]+      }+  cmd+  unexport handle.serverClient portalObjectPath++withRequestResponse :: TestHandle -> InterfaceName -> MemberName -> [Variant] -> IO () -> IO ()+withRequestResponse handle interfaceName methodName methodResponse cmd = do+  export+    handle.serverClient+    portalObjectPath+    defaultInterface+      { interfaceName,         interfaceMethods = [makeMethod methodName (Signature []) (Signature []) handleMethodCall]       }   cmd@@ -80,12 +95,30 @@       emitResponseSignal handle methodCall methodResponse       pure (ReplyReturn [toVariant (methodRequestHandle methodCall)]) +savingMethodArguments :: TestHandle -> InterfaceName -> MemberName -> [Variant] -> IO () -> IO [Variant]+savingMethodArguments handle interfaceName methodName response cmd = do+  argsVar <- newEmptyMVar+  export+    handle.serverClient+    portalObjectPath+    defaultInterface+      { interfaceName,+        interfaceMethods = [makeMethod methodName (Signature []) (Signature []) (handleMethodCall argsVar)]+      }+  cmd+  unexport handle.serverClient portalObjectPath+  tryReadMVar argsVar >>= \case+    Just args -> pure args+    Nothing -> fail "No method was called during the callback!"+  where+    handleMethodCall argsVar methodCall = do+      putSucceeded <- liftIO $ tryPutMVar argsVar (methodCallBody methodCall)+      unless putSucceeded $+        fail "Method arguments already saved: is more than one method being called?"+      pure (ReplyReturn response)+ 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     handle.serverClient@@ -104,16 +137,12 @@       putSucceeded <- liftIO $ tryPutMVar argsVar (methodCallBody methodCall)       unless putSucceeded $         fail "Method arguments already saved: is more than one method being called?"-      if hasResponse-        then do-          emitResponseSignal handle methodCall [toVariant (1 :: Word32)]-          pure (ReplyReturn [toVariant (methodRequestHandle methodCall)])-        else do-          pure (ReplyReturn [])+      emitResponseSignal handle methodCall [toVariant (1 :: Word32)]+      pure (ReplyReturn [toVariant (methodRequestHandle methodCall)])      removeHandleToken = \case       args-        | hasResponse && (not (null args)),+        | 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 ->@@ -182,3 +211,6 @@ -- | Specialised 'toVariant' to avoid need for type assertions. toVariantText :: Text -> Variant toVariantText = toVariant++dbusClientException :: Selector ClientError+dbusClientException = const True