desktop-portal (empty) → 0.0.1.0
raw patch · 14 files changed
+1073/−0 lines, 14 filesdep +basedep +binarydep +bytestring
Dependencies added: base, binary, bytestring, containers, data-default-class, dbus, desktop-portal, hspec, process, random, text
Files
- ChangeLog.md +3/−0
- LICENSE +7/−0
- README.md +29/−0
- desktop-portal.cabal +89/−0
- src/Desktop/Portal.hs +14/−0
- src/Desktop/Portal/Account.hs +60/−0
- src/Desktop/Portal/FileChooser.hs +225/−0
- src/Desktop/Portal/Request.hs +3/−0
- src/Desktop/Portal/Request/Internal.hs +152/−0
- src/Desktop/Portal/Util.hs +40/−0
- test/Desktop/Portal/AccountSpec.hs +57/−0
- test/Desktop/Portal/FileChooserSpec.hs +242/−0
- test/Desktop/Portal/TestUtil.hs +151/−0
- test/Spec.hs +1/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+## 0.0.1.0++Initial release.
+ LICENSE view
@@ -0,0 +1,7 @@+Copyright 2023 Gareth Daniel Smith++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,29 @@+# Haskell Desktop Portal++A Haskell wrapper for the [XDG Desktop Portal](https://github.com/flatpak/xdg-desktop-portal) DBUS API. Primarily intended to support applications packaged as Flatpaks (see [monomer-flatpak-example](https://github.com/Dretch/monomer-flatpak-example)).++## Current Status+- Unstable. Functionality and API may change considerably.++## FAQs+- **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.++## Development Guide++### How to contribute+- If you just want to add a wrapper for an API method that is not currently supported, open a PR.+- If you want something less straightforward, open an issue to discuss it.++### 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`.+- `...Options` records should have a `Default` instance.+- Record fields should not have unique prefixes.++### To format the source code+```bash+# This needs at least ormolu 0.5.0.0 to avoid breaking dot-record syntax+ormolu --mode inplace $(find . -name '*.hs')+```
+ desktop-portal.cabal view
@@ -0,0 +1,89 @@+cabal-version: 1.12+name: desktop-portal+version: 0.0.1.0+license: MIT+license-file: LICENSE+maintainer: garethdanielsmith@gmail.com+homepage: https://github.com/Dretch/haskell-desktop-portal#readme+bug-reports: https://github.com/Dretch/haskell-desktop-portal/issues+synopsis: Desktop Portal.+description: A Haskell wrapper for the XDG Desktop Portal DBUS API.+category: GUI, XDG, Flatpak, Desktop, Portal+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/Dretch/haskell-desktop-portal++library+ exposed-modules:+ Desktop.Portal+ Desktop.Portal.Account+ Desktop.Portal.FileChooser+ Desktop.Portal.Request++ hs-source-dirs: src+ other-modules:+ Desktop.Portal.Request.Internal+ Desktop.Portal.Util+ Paths_desktop_portal++ default-language: Haskell2010+ default-extensions:+ DisambiguateRecordFields DuplicateRecordFields FlexibleContexts+ ImportQualifiedPost LambdaCase NamedFieldPuns NoFieldSelectors+ NumericUnderscores OverloadedRecordDot OverloadedStrings+ RecordWildCards ScopedTypeVariables++ ghc-options:+ -Wall -Wcompat -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wredundant-constraints++ build-depends:+ base >=4.7 && <5,+ binary <0.9,+ bytestring <0.12,+ containers <0.7,+ data-default-class <0.2,+ dbus >=1.2.28 && <1.3,+ random <1.3,+ text <1.3++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-tool-depends: hspec-discover:hspec-discover >=2 && <3+ hs-source-dirs: test+ other-modules:+ Desktop.Portal.AccountSpec+ Desktop.Portal.FileChooserSpec+ Desktop.Portal.TestUtil+ Paths_desktop_portal++ default-language: Haskell2010+ default-extensions:+ DisambiguateRecordFields DuplicateRecordFields FlexibleContexts+ ImportQualifiedPost LambdaCase NamedFieldPuns NoFieldSelectors+ NumericUnderscores OverloadedRecordDot OverloadedStrings+ RecordWildCards ScopedTypeVariables++ ghc-options:+ -Wall -Wcompat -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wredundant-constraints -threaded+ -rtsopts -with-rtsopts=-N++ build-depends:+ base >=4.7 && <5,+ binary <0.9,+ bytestring <0.12,+ containers <0.7,+ data-default-class <0.2,+ dbus >=1.2.28 && <1.3,+ desktop-portal,+ hspec >=2 && <3,+ process <1.7,+ random <1.3,+ text <1.3
+ src/Desktop/Portal.hs view
@@ -0,0 +1,14 @@+-- |+-- Wrappers around the XDG Desktop Portal D-BUS API.+--+-- See the documentation for the underlying API: https://flatpak.github.io/xdg-desktop-portal+module Desktop.Portal+ ( module Desktop.Portal.Account,+ module Desktop.Portal.FileChooser,+ module Desktop.Portal.Request,+ )+where++import Desktop.Portal.Account+import Desktop.Portal.FileChooser+import Desktop.Portal.Request
+ src/Desktop/Portal/Account.hs view
@@ -0,0 +1,60 @@+module Desktop.Portal.Account+ ( -- * Get User Information+ GetUserInformationOptions (..),+ GetUserInformationResults (..),+ getUserInformation,+ )+where++import Control.Exception (throwIO)+import DBus (InterfaceName)+import DBus qualified+import DBus.Client qualified as DBus+import Data.Default.Class (Default (def))+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.Util (optionalFromVariant, toVariantPair)++data GetUserInformationOptions = GetUserInformationOptions+ { window :: Maybe Text,+ reason :: Maybe Text+ }+ deriving (Eq, Show)++instance Default GetUserInformationOptions where+ def =+ GetUserInformationOptions+ { window = Nothing,+ reason = Nothing+ }++data GetUserInformationResults = GetUserInformationResults+ { id :: Text,+ name :: Text,+ image :: Maybe Text+ }+ deriving (Eq, Show)++accountInterface :: InterfaceName+accountInterface = "org.freedesktop.portal.Account"++getUserInformation :: GetUserInformationOptions -> IO (Request GetUserInformationResults)+getUserInformation options =+ sendRequest accountInterface "GetUserInformation" [window] optionsArg parseResponse+ where+ window = DBus.toVariant (fromMaybe "" options.window)+ optionsArg =+ Map.fromList . catMaybes $+ [ toVariantPair "reason" options.reason+ ]++ parseResponse = \case+ resMap+ | Just id' <- DBus.fromVariant =<< Map.lookup "id" resMap,+ Just name <- DBus.fromVariant =<< Map.lookup "name" resMap,+ Just image <- optionalFromVariant "image" resMap ->+ pure GetUserInformationResults {id = id', name, image}+ resMap ->+ throwIO . DBus.clientError $ "getUserInformation: could not parse response: " <> show resMap
+ src/Desktop/Portal/FileChooser.hs view
@@ -0,0 +1,225 @@+module Desktop.Portal.FileChooser+ ( -- * Common Types+ Filter (..),+ FilterFileType (..),+ ChoiceCombo (..),+ ChoiceComboOption (..),+ ChoiceComboSelection (..),++ -- * Open File+ OpenFileOptions (..),+ OpenFileResults (..),+ openFile,++ -- * Save File+ SaveFileOptions (..),+ SaveFileResults (..),+ saveFile,+ )+where++import Control.Exception (throwIO)+import DBus (InterfaceName, Variant)+import DBus qualified+import DBus.Client qualified as DBus+import Data.Default.Class (Default (def))+import Data.Map (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (catMaybes, fromMaybe)+import Data.Text (Text)+import Data.Word (Word32)+import Desktop.Portal.Request.Internal (Request, sendRequest)+import Desktop.Portal.Util (encodeNullTerminatedUtf8, mapJust, optionalFromVariant, toVariantPair, toVariantPair')++data Filter = Filter+ { name :: Text,+ fileTypes :: [FilterFileType]+ }+ deriving (Eq, Show)++data FilterFileType+ = GlobFilter Text+ | MimeFilter Text+ deriving (Eq, Show)++data ChoiceCombo = ChoiceCombo+ { id :: Text,+ label_ :: Text,+ choices :: [ChoiceComboOption],+ defaultChoiceId :: Text+ }+ deriving (Eq, Show)++data ChoiceComboOption = ChoiceComboOption+ { id :: Text,+ label_ :: Text+ }+ deriving (Eq, Show)++data ChoiceComboSelection = ChoiceComboSelection+ { comboId :: Text,+ optionId :: Text+ }+ deriving (Eq, Show)++data OpenFileOptions = OpenFileOptions+ { parentWindow :: Maybe Text,+ title :: Maybe Text,+ acceptLabel :: Maybe Text,+ modal :: Maybe Bool,+ multiple :: Maybe Bool,+ directory :: Maybe Bool,+ filters :: Maybe [Filter],+ currentFilter :: Maybe Filter,+ choices :: Maybe [ChoiceCombo]+ }+ deriving (Eq, Show)++instance Default OpenFileOptions where+ def =+ OpenFileOptions+ { parentWindow = Nothing,+ title = Nothing,+ acceptLabel = Nothing,+ modal = Nothing,+ multiple = Nothing,+ directory = Nothing,+ filters = Nothing,+ currentFilter = Nothing,+ choices = Nothing+ }++data OpenFileResults = OpenFileResults+ { uris :: [Text],+ choices :: Maybe [ChoiceComboSelection],+ currentFilter :: Maybe Filter+ }+ deriving (Eq, Show)++data SaveFileOptions = SaveFileOptions+ { parentWindow :: Maybe Text,+ title :: Maybe Text,+ acceptLabel :: Maybe Text,+ modal :: Maybe Bool,+ filters :: Maybe [Filter],+ currentFilter :: Maybe Filter,+ choices :: Maybe [ChoiceCombo],+ currentName :: Maybe Text,+ currentFolder :: Maybe Text,+ currentFile :: Maybe Text+ }+ deriving (Eq, Show)++instance Default SaveFileOptions where+ def =+ SaveFileOptions+ { parentWindow = Nothing,+ title = Nothing,+ acceptLabel = Nothing,+ modal = Nothing,+ filters = Nothing,+ currentFilter = Nothing,+ choices = Nothing,+ currentName = Nothing,+ currentFolder = Nothing,+ currentFile = Nothing+ }++data SaveFileResults = SaveFileResults+ { uris :: [Text],+ choices :: Maybe [ChoiceComboSelection],+ currentFilter :: Maybe Filter+ }+ deriving (Eq, Show)++fileChooserInterface :: InterfaceName+fileChooserInterface = "org.freedesktop.portal.FileChooser"++openFile :: OpenFileOptions -> IO (Request OpenFileResults)+openFile options =+ sendRequest fileChooserInterface "OpenFile" args optionsArg parseOpenFileResponse+ where+ args = [DBus.toVariant parentWindow, DBus.toVariant title]+ parentWindow = fromMaybe "" options.parentWindow+ title = fromMaybe "" options.title+ optionsArg =+ Map.fromList . catMaybes $+ [ toVariantPair "accept_label" options.acceptLabel,+ toVariantPair "modal" options.modal,+ toVariantPair "multiple" options.multiple,+ toVariantPair "directory" options.directory,+ toVariantPair' (fmap encodeFilter) "filters" options.filters,+ toVariantPair' encodeFilter "current_filter" options.currentFilter,+ toVariantPair' (fmap encodeCombo) "choices" options.choices+ ]++saveFile :: SaveFileOptions -> IO (Request SaveFileResults)+saveFile options =+ sendRequest fileChooserInterface "SaveFile" args optionsArgs parseResponse+ where+ args = [DBus.toVariant parentWindow, DBus.toVariant title]+ parentWindow = fromMaybe "" options.parentWindow+ title = fromMaybe "" options.title+ optionsArgs =+ Map.fromList . catMaybes $+ [ toVariantPair "accept_label" options.acceptLabel,+ toVariantPair "modal" options.modal,+ toVariantPair' (fmap encodeFilter) "filters" options.filters,+ toVariantPair' encodeFilter "current_filter" options.currentFilter,+ toVariantPair' (fmap encodeCombo) "choices" options.choices,+ toVariantPair "current_name" options.currentName,+ toVariantPair "current_folder" (encodeNullTerminatedUtf8 <$> options.currentFolder),+ toVariantPair "current_file" (encodeNullTerminatedUtf8 <$> options.currentFile)+ ]++ parseResponse resMap = do+ OpenFileResults {uris, choices, currentFilter} <- parseOpenFileResponse resMap+ pure SaveFileResults {uris, choices, currentFilter}++parseOpenFileResponse :: Map Text Variant -> IO OpenFileResults+parseOpenFileResponse = \case+ resMap+ | Just uris <- DBus.fromVariant =<< Map.lookup "uris" resMap,+ Just choicesRaw <- optionalFromVariant "choices" resMap,+ choices <- fmap decodeChoiceComboSelection <$> choicesRaw,+ Just currentFilterRaw <- optionalFromVariant "current_filter" resMap,+ Just currentFilter <- mapJust decodeFilter currentFilterRaw ->+ pure OpenFileResults {uris, choices, currentFilter}+ resMap ->+ throwIO . DBus.clientError $ "openFile: could not parse response: " <> show resMap++encodeFilter :: Filter -> (Text, [(Word32, Text)])+encodeFilter filtr =+ (filtr.name, encodeFilterFileType <$> filtr.fileTypes)++decodeFilter :: (Text, [(Word32, Text)]) -> Maybe Filter+decodeFilter (name, rawFileTypes) = do+ fileTypes <- traverse decodeFileType rawFileTypes+ pure Filter {name, fileTypes}++encodeFilterFileType :: FilterFileType -> (Word32, Text)+encodeFilterFileType = \case+ GlobFilter pat -> (0, pat)+ MimeFilter mime -> (1, mime)++decodeFileType :: (Word32, Text) -> Maybe FilterFileType+decodeFileType = \case+ (0, pat) -> Just (GlobFilter pat)+ (1, mime) -> Just (MimeFilter mime)+ _ -> Nothing++encodeCombo :: ChoiceCombo -> (Text, Text, [(Text, Text)], Text)+encodeCombo combo =+ ( combo.id,+ combo.label_,+ encodeComboOption <$> combo.choices,+ combo.defaultChoiceId+ )++encodeComboOption :: ChoiceComboOption -> (Text, Text)+encodeComboOption option =+ (option.id, option.label_)++decodeChoiceComboSelection :: (Text, Text) -> ChoiceComboSelection+decodeChoiceComboSelection =+ uncurry ChoiceComboSelection
+ src/Desktop/Portal/Request.hs view
@@ -0,0 +1,3 @@+module Desktop.Portal.Request (module Desktop.Portal.Request.Internal) where++import Desktop.Portal.Request.Internal (Request, await, cancel)
+ src/Desktop/Portal/Request/Internal.hs view
@@ -0,0 +1,152 @@+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
+ src/Desktop/Portal/Util.hs view
@@ -0,0 +1,40 @@+module Desktop.Portal.Util+ ( optionalFromVariant,+ mapJust,+ toVariantPair,+ toVariantPair',+ encodeNullTerminatedUtf8,+ )+where++import DBus (IsVariant, Variant)+import DBus qualified+import Data.Binary.Builder qualified as Binary+import Data.ByteString.Lazy (ByteString)+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Text (Text)+import Data.Text.Encoding qualified as Encoding++-- | Returns @Just Nothing@ if the field does not exist, @Just (Just x)@ if it does exist and+-- can be turned into the expected type, or @Nothing@ if the field exists with the wrong type.+optionalFromVariant :: forall a. IsVariant a => Text -> Map Text Variant -> Maybe (Maybe a)+optionalFromVariant key variants =+ mapJust DBus.fromVariant (Map.lookup key variants)++mapJust :: (a -> Maybe b) -> Maybe a -> Maybe (Maybe b)+mapJust f = \case+ Nothing -> Just Nothing+ Just x -> Just <$> f x++toVariantPair :: IsVariant a => Text -> Maybe a -> Maybe (Text, Variant)+toVariantPair = toVariantPair' id++toVariantPair' :: IsVariant b => (a -> b) -> Text -> Maybe a -> Maybe (Text, Variant)+toVariantPair' f key = \case+ Nothing -> Nothing+ Just x -> Just (key, DBus.toVariant (f x))++encodeNullTerminatedUtf8 :: Text -> ByteString+encodeNullTerminatedUtf8 txt =+ Binary.toLazyByteString (Encoding.encodeUtf8Builder txt <> Binary.singleton 0)
+ test/Desktop/Portal/AccountSpec.hs view
@@ -0,0 +1,57 @@+module Desktop.Portal.AccountSpec (spec) where++import Control.Monad (void)+import DBus (InterfaceName)+import Data.Default.Class (Default (def))+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)++accountInterface :: InterfaceName+accountInterface = "org.freedesktop.portal.Account"++spec :: Spec+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))+ 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")))+ body+ `shouldBe` [ toVariantText "_window",+ toVariantMap [("reason", toVariantText "_reason")]+ ]++ it "should decode response with image" $ \client -> 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+ info `shouldBe` Just (GetUserInformationResults "_id" "_name" (Just "_img"))++ it "should decode response without image" $ \client -> do+ let responseBody =+ successResponse+ [ ("id", toVariantText "_id"),+ ("name", toVariantText "_name")+ ]+ withMethodResponse client accountInterface "GetUserInformation" responseBody $ do+ info <- Portal.getUserInformation 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
+ test/Desktop/Portal/FileChooserSpec.hs view
@@ -0,0 +1,242 @@+module Desktop.Portal.FileChooserSpec (spec) where++import Control.Monad (void)+import DBus (InterfaceName, toVariant)+import Data.ByteString (ByteString)+import Data.Default.Class (def)+import Data.Text (Text)+import Data.Word (Word32)+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)++fileChooserInterface :: InterfaceName+fileChooserInterface = "org.freedesktop.portal.FileChooser"++spec :: Spec+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)+ body+ `shouldBe` [ toVariantText "",+ toVariantText "",+ toVariantMap []+ ]++ it "should encode request with all Justs" $ \client -> do+ body <- savingRequestArguments client fileChooserInterface "OpenFile" $ do+ void . Portal.openFile $+ OpenFileOptions+ { parentWindow = Just "_parentWindow",+ title = Just "_title",+ acceptLabel = Just "_acceptLabel",+ modal = Just True,+ multiple = Just True,+ directory = Just True,+ filters =+ Just+ [ Filter+ { name = "_filterName",+ fileTypes = [GlobFilter "*.txt", MimeFilter "application/json"]+ }+ ],+ currentFilter =+ Just+ ( Filter+ { name = "_currentFilterName",+ fileTypes = [GlobFilter "*.jpg", MimeFilter "image/jpeg"]+ }+ ),+ choices =+ Just+ [ ChoiceCombo+ { id = "_choiceId",+ label_ = "_choiceLabel",+ choices = [ChoiceComboOption {id = "_ccoId", label_ = "_ccoLabel"}],+ defaultChoiceId = "_defaultChoiceId"+ }+ ]+ }+ body+ `shouldBe` [ toVariantText "_parentWindow",+ toVariantText "_title",+ toVariantMap+ [ ("accept_label", toVariantText "_acceptLabel"),+ ("modal", toVariant True),+ ("multiple", toVariant True),+ ("directory", toVariant True),+ ( "filters",+ toVariant+ [ ( "_filterName" :: Text,+ [ (0 :: Word32, "*.txt" :: Text),+ (1 :: Word32, "application/json" :: Text)+ ]+ )+ ]+ ),+ ( "current_filter",+ toVariant+ ( "_currentFilterName" :: Text,+ [ (0 :: Word32, "*.jpg" :: Text),+ (1 :: Word32, "image/jpeg" :: Text)+ ]+ )+ ),+ ( "choices",+ toVariant+ [ ( "_choiceId" :: Text,+ "_choiceLabel" :: Text,+ [("_ccoId" :: Text, "_ccoLabel" :: Text)],+ "_defaultChoiceId" :: Text+ )+ ]+ )+ ]+ ]++ it "should decode response with all Nothings" $ \client -> do+ let responseBody = successResponse [("uris", toVariant ["file:///a/b/c" :: Text])]+ withMethodResponse client fileChooserInterface "OpenFile" responseBody $ do+ info <- Portal.openFile 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+ 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+ info+ `shouldBe` Just+ ( OpenFileResults+ { uris = ["file:///a/b/c"],+ choices = Just [ChoiceComboSelection {comboId = "_comboId", optionId = "_optionId"}],+ currentFilter = Just Filter {name = "_filterId", fileTypes = [GlobFilter "*.md"]}+ }+ )++ it "should fail to decode invalid response" $ \client ->+ withMethodResponse client fileChooserInterface "OpenFile" (successResponse []) $ do+ (Portal.openFile 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)+ body+ `shouldBe` [ toVariantText "",+ toVariantText "",+ toVariantMap []+ ]++ it "should encode request with all Justs" $ \client -> do+ body <- savingRequestArguments client fileChooserInterface "SaveFile" $ do+ void . Portal.saveFile $+ SaveFileOptions+ { parentWindow = Just "_parentWindow",+ title = Just "_title",+ acceptLabel = Just "_acceptLabel",+ modal = Just True,+ filters =+ Just+ [ Filter+ { name = "_filterName",+ fileTypes = [GlobFilter "*.txt", MimeFilter "application/json"]+ }+ ],+ currentFilter =+ Just+ ( Filter+ { name = "_currentFilterName",+ fileTypes = [GlobFilter "*.jpg", MimeFilter "image/jpeg"]+ }+ ),+ choices =+ Just+ [ ChoiceCombo+ { id = "_choiceId",+ label_ = "_choiceLabel",+ choices = [ChoiceComboOption {id = "_ccoId", label_ = "_ccoLabel"}],+ defaultChoiceId = "_defaultChoiceId"+ }+ ],+ currentName = Just "some_name",+ currentFolder = Just "/some/folder",+ currentFile = Just "/some/file"+ }+ body+ `shouldBe` [ toVariantText "_parentWindow",+ toVariantText "_title",+ toVariantMap+ [ ("accept_label", toVariantText "_acceptLabel"),+ ("modal", toVariant True),+ ( "filters",+ toVariant+ [ ( "_filterName" :: Text,+ [ (0 :: Word32, "*.txt" :: Text),+ (1 :: Word32, "application/json" :: Text)+ ]+ )+ ]+ ),+ ( "current_filter",+ toVariant+ ( "_currentFilterName" :: Text,+ [ (0 :: Word32, "*.jpg" :: Text),+ (1 :: Word32, "image/jpeg" :: Text)+ ]+ )+ ),+ ( "choices",+ toVariant+ [ ( "_choiceId" :: Text,+ "_choiceLabel" :: Text,+ [("_ccoId" :: Text, "_ccoLabel" :: Text)],+ "_defaultChoiceId" :: Text+ )+ ]+ ),+ ("current_name", toVariantText "some_name"),+ ("current_folder", toVariant ("/some/folder\0" :: ByteString)),+ ("current_file", toVariant ("/some/file\0" :: ByteString))+ ]+ ]++ it "should decode response with all Nothings" $ \client -> do+ let responseBody = successResponse [("uris", toVariant ["file:///a/b/c" :: Text])]+ withMethodResponse client fileChooserInterface "SaveFile" responseBody $ do+ info <- Portal.saveFile 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+ 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+ info+ `shouldBe` Just+ ( SaveFileResults+ { uris = ["file:///a/b/c"],+ choices = Just [ChoiceComboSelection {comboId = "_comboId", optionId = "_optionId"}],+ currentFilter = Just Filter {name = "_filterId", fileTypes = [GlobFilter "*.md"]}+ }+ )++ it "should fail to decode invalid response" $ \client ->+ withMethodResponse client fileChooserInterface "SaveFile" (successResponse []) $ do+ (Portal.openFile def >>= Portal.await) `shouldThrow` anyException
+ test/Desktop/Portal/TestUtil.hs view
@@ -0,0 +1,151 @@+module Desktop.Portal.TestUtil+ ( successResponse,+ toVariantMap,+ toVariantText,+ TestClient,+ withTestBus,+ withMethodResponse,+ savingRequestArguments,+ )+where++import Control.Concurrent (newEmptyMVar, tryPutMVar, tryReadMVar)+import Control.Exception (finally)+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.Internal.Message (Signal (..))+import DBus.Internal.Types (Atom (AtomText), Signature (..), Value (ValueMap), Variant (Variant))+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Text (Text)+import Data.Word (Word32)+import GHC.IO.Handle (hGetLine)+import System.Environment (lookupEnv, setEnv)+import System.Process (StdStream (..), createProcess, proc, std_out, terminateProcess)++newtype TestClient = TestClient Client++withTestBus :: (TestClient -> IO ()) -> IO ()+withTestBus cmd = do+ let dbusArgs =+ [ "--print-address",+ "--nopidfile",+ "--nofork",+ "--syslog-only",+ "--config-file=test/dbus-config.xml"+ ]+ (_, Just hOut, _, ph) <-+ createProcess (proc "dbus-daemon" dbusArgs) {std_out = CreatePipe}+ oldSessionAddr <- lookupEnv sessionAddressEnv+ flip finally (teardown 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)+ where+ teardown 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+ export+ client+ portalObjectPath+ defaultInterface+ { interfaceName,+ interfaceMethods = [makeMethod methodName (Signature []) (Signature []) handleMethodCall]+ }+ cmd+ unexport client portalObjectPath+ where+ handleMethodCall methodCall = do+ emitResponseSignal client methodCall methodResponse+ pure (ReplyReturn [toVariant (methodRequestHandle methodCall)])++savingRequestArguments :: TestClient -> InterfaceName -> MemberName -> IO () -> IO [Variant]+savingRequestArguments (TestClient client) interfaceName methodName cmd = do+ argsVar <- newEmptyMVar+ export+ client+ portalObjectPath+ defaultInterface+ { interfaceName,+ interfaceMethods = [makeMethod methodName (Signature []) (Signature []) (handleMethodCall argsVar)]+ }+ cmd+ unexport client 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)])++ removeHandleToken = \case+ 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 ->+ args++emitResponseSignal :: MonadIO m => Client -> MethodCall -> [Variant] -> m ()+emitResponseSignal client methodCall signalBody = do+ void . liftIO $+ emit+ client+ Signal+ { signalPath = methodRequestHandle methodCall,+ signalInterface = "org.freedesktop.portal.Request",+ signalMember = "Response",+ signalSender = Just portalBusName,+ signalDestination = methodCallSender methodCall,+ signalBody+ }++methodRequestHandle :: MethodCall -> ObjectPath+methodRequestHandle methodCall =+ objectPath_ $+ "/org/freedesktop/portal/desktop/request/"+ <> escapeClientName senderClientName+ <> "/"+ <> handleToken+ where+ args = methodCallBody methodCall+ Just (optionsArg :: Map Text Variant) = fromVariant (args !! (length args - 1))+ Just (handleToken :: String) = Map.lookup "handle_token" optionsArg >>= fromVariant+ Just senderClientName = methodCall.methodCallSender+ escapeClientName =+ map (\case '.' -> '_'; c -> c) . drop 1 . formatBusName++sessionAddressEnv :: String+sessionAddressEnv = "DBUS_SESSION_BUS_ADDRESS"++portalObjectPath :: ObjectPath+portalObjectPath = "/org/freedesktop/portal/desktop"++portalBusName :: BusName+portalBusName = "org.freedesktop.portal.Desktop"++successResponse :: [(Text, Variant)] -> [Variant]+successResponse pairs =+ [ toVariant (0 :: Word32), -- success code+ toVariantMap pairs+ ]++toVariantMap :: [(Text, Variant)] -> Variant+toVariantMap = toVariant . Map.fromList++-- | Specialised 'toVariant' to avoid need for type assertions.+toVariantText :: Text -> Variant+toVariantText = toVariant
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}