desktop-portal 0.3.1.0 → 0.3.2.0

raw patch · 9 files changed

+115/−9 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• README.md +1/−1
• desktop-portal.cabal +3/−1
• src/Desktop/Portal.hs +2/−0
• src/Desktop/Portal/Camera.hs +37/−0
• src/Desktop/Portal/Internal.hs +11/−1
• src/Desktop/Portal/Util.hs +3/−3
• test/Desktop/Portal/CameraSpec.hs +38/−0
• test/Desktop/Portal/TestUtil.hs +16/−3

@@ -1,3 +1,7 @@+## 0.3.2.0+### Added+- Add Camera Portal support.+ ## 0.3.1.0 ### Added - Add Secret Portal support.

@@ -33,6 +33,6 @@  ### To format the source code ```bash-# This needs at least ormolu 0.5.0.0 to avoid breaking dot-record syntax+# Should use Ormolu 0.7.1.0 ormolu --mode inplace $(find . -name '*.hs') ```

@@ -1,6 +1,6 @@ cabal-version:      1.12 name:               desktop-portal-version:            0.3.1.0+version:            0.3.2.0 license:            MIT license-file:       LICENSE maintainer:         garethdanielsmith@gmail.com@@ -22,6 +22,7 @@     exposed-modules:         Desktop.Portal         Desktop.Portal.Account+        Desktop.Portal.Camera         Desktop.Portal.Directories         Desktop.Portal.Documents         Desktop.Portal.FileChooser@@ -69,6 +70,7 @@     hs-source-dirs:     test     other-modules:         Desktop.Portal.AccountSpec+        Desktop.Portal.CameraSpec         Desktop.Portal.DocumentsSpec         Desktop.Portal.FileChooserSpec         Desktop.Portal.NotificationSpec

@@ -23,6 +23,7 @@      -- * Portal Interfaces     module Desktop.Portal.Account,+    module Desktop.Portal.Camera,     module Desktop.Portal.Directories,     module Desktop.Portal.FileChooser,     module Desktop.Portal.Notification,@@ -32,6 +33,7 @@ where  import Desktop.Portal.Account+import Desktop.Portal.Camera import Desktop.Portal.Directories import Desktop.Portal.FileChooser import Desktop.Portal.Internal qualified as Internal

@@ -0,0 +1,37 @@+module Desktop.Portal.Camera+  ( accessCamera,+    openPipeWireRemote,+    isCameraPresent,+  )+where++import Control.Exception (throwIO)+import DBus (InterfaceName, Variant, fromVariant, toVariant)+import DBus.Client qualified as DBus+import Data.Map (Map)+import Data.Text (Text)+import Desktop.Portal.Internal (Client, Request, callMethod, getPropertyValue, sendRequest)+import System.Posix (Fd)++cameraInterface :: InterfaceName+cameraInterface = "org.freedesktop.portal.Camera"++-- | Requests access to the camera.+--+-- If access is granted, then request will return '()', otherwise it will be cancelled.+accessCamera :: Client -> IO (Request ())+accessCamera client = do+  sendRequest client cameraInterface "AccessCamera" [] mempty (const (pure ()))++openPipeWireRemote :: Client -> IO Fd+openPipeWireRemote client = do+  res <- callMethod client cameraInterface "OpenPipeWireRemote" [toVariant (mempty :: Map Text Variant)]+  case res of+    [fromVariant -> Just fd] ->+      pure fd+    _ ->+      throwIO . DBus.clientError $ "openPipeWireRemote: could not parse response: " <> show res++isCameraPresent :: Client -> IO Bool+isCameraPresent client = do+  getPropertyValue client cameraInterface "IsCameraPresent"

@@ -9,6 +9,7 @@     cancel,     callMethod,     callMethod_,+    getPropertyValue,     SignalHandler,     handleSignal,     cancelSignalHandler,@@ -22,7 +23,7 @@ import Control.Concurrent.MVar (newEmptyMVar) import Control.Exception (SomeException, bracket, catch, throwIO) import Control.Monad (void, when)-import DBus (BusName, InterfaceName, MemberName, MethodCall, ObjectPath)+import DBus (BusName, InterfaceName, IsValue, MemberName, MethodCall, ObjectPath) import DBus qualified import DBus.Client (ClientError, MatchRule (..)) import DBus.Client qualified as DBus@@ -223,6 +224,15 @@             DBus.methodCallBody           }   DBus.methodReturnBody <$> DBus.call_ client.dbusClient methodCall++getPropertyValue :: (IsValue a) => Client -> InterfaceName -> MemberName -> IO a+getPropertyValue client interface memberName = do+  let methodCall = portalMethodCall interface memberName+  DBus.getPropertyValue client.dbusClient methodCall >>= \case+    Left err ->+      throwIO . DBus.clientError $ "getPropertyValue failed: " <> show err+    Right a ->+      pure a  handleSignal :: Client -> InterfaceName -> MemberName -> ([Variant] -> IO ()) -> IO SignalHandler handleSignal client interface memberName handler = do

@@ -24,7 +24,7 @@  -- | 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 :: forall a. (IsVariant a) => Text -> Map Text Variant -> Maybe (Maybe a) optionalFromVariant key variants =   mapJust DBus.fromVariant (Map.lookup key variants) @@ -33,10 +33,10 @@   Nothing -> Just Nothing   Just x -> Just <$> f x -toVariantPair :: IsVariant a => Text -> Maybe a -> Maybe (Text, Variant)+toVariantPair :: (IsVariant a) => Text -> Maybe a -> Maybe (Text, Variant) toVariantPair = toVariantPair' id -toVariantPair' :: IsVariant b => (a -> b) -> Text -> Maybe a -> Maybe (Text, Variant)+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))

@@ -0,0 +1,38 @@+module Desktop.Portal.CameraSpec (spec) where++import DBus (InterfaceName, IsVariant (toVariant))+import Desktop.Portal qualified as Portal+import Desktop.Portal.TestUtil+import Test.Hspec (Spec, around, describe, it, shouldReturn, shouldThrow)+import Test.Hspec.Expectations (shouldSatisfy)++cameraInterface :: InterfaceName+cameraInterface = "org.freedesktop.portal.Camera"++spec :: Spec+spec = do+  around withTestBus $ do+    describe "accessCamera" $ do+      it "should decode response" $ \handle -> do+        let responseBody = successResponse []+        withRequestResponse handle cameraInterface "AccessCamera" responseBody $ do+          (Portal.accessCamera (client handle) >>= Portal.await)+            `shouldReturn` Just ()++    describe "openPipeWireRemote" $ do+      it "should decode response" $ \handle -> do+        withTempFd $ \fd -> do+          withMethodResponse handle cameraInterface "OpenPipeWireRemote" [toVariant fd] $ do+            fd' <- Portal.openPipeWireRemote (client handle)+            fd' `shouldSatisfy` (/=) fd++      it "should fail to decode invalid response" $ \handle -> do+        withMethodResponse handle cameraInterface "OpenPipeWireRemote" [toVariant False] $ do+          Portal.openPipeWireRemote (client handle)+            `shouldThrow` dbusClientException++    describe "isCameraPresent" $ do+      it "should get property" $ \handle -> do+        withReadOnlyProperty handle cameraInterface "IsCameraPresent" (pure True) $ do+          Portal.isCameraPresent (client handle)+            `shouldReturn` True

@@ -9,6 +9,7 @@     withTestBus_,     withMethodResponse,     withMethodResponse_,+    withReadOnlyProperty,     withRequestResponse,     withRequestAnswer,     savingMethodArguments,@@ -34,8 +35,8 @@ 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, Type (..), Variant, formatBusName, getSessionAddress, objectPath_, toVariant, variantType)-import DBus.Client (Client, ClientError, ClientOptions (..), Interface (..), Reply (..), RequestNameReply (..), clientError, connectWith, defaultClientOptions, defaultInterface, disconnect, emit, export, makeMethod, nameDoNotQueue, requestName, unexport)+import DBus (BusName, InterfaceName, IsValue, IsVariant (fromVariant), MemberName, MethodCall (..), ObjectPath, Type (..), Variant, formatBusName, getSessionAddress, memberName_, objectPath_, toVariant, variantType)+import DBus.Client (Client, ClientError, ClientOptions (..), Interface (..), Property, Reply (..), RequestNameReply (..), clientError, connectWith, defaultClientOptions, defaultInterface, disconnect, emit, export, makeMethod, nameDoNotQueue, readOnlyProperty, requestName, unexport) import DBus.Internal.Message (Signal (..)) import DBus.Internal.Types (Atom (AtomText), Signature (..), Value (ValueMap), Variant (Variant)) import DBus.Socket (SocketOptions (..), authenticatorWithUnixFds, defaultSocketOptions)@@ -105,6 +106,18 @@   cmd   unexport handle.serverClient objectPath +withReadOnlyProperty :: (IsValue a) => TestHandle -> InterfaceName -> MemberName -> IO a -> IO () -> IO ()+withReadOnlyProperty handle interfaceName memberName value cmd = do+  export+    handle.serverClient+    portalObjectPath+    defaultInterface+      { interfaceName,+        interfaceProperties = [readOnlyProperty memberName value]+      }+  cmd+  unexport handle.serverClient portalObjectPath+ withRequestResponse :: TestHandle -> InterfaceName -> MemberName -> [Variant] -> IO () -> IO () withRequestResponse handle interfaceName methodName methodResponse cmd = do   withRequestAnswer handle interfaceName methodName (const (pure methodResponse)) cmd@@ -196,7 +209,7 @@         signalBody       } -emitResponseSignal :: MonadIO m => TestHandle -> MethodCall -> [Variant] -> m ()+emitResponseSignal :: (MonadIO m) => TestHandle -> MethodCall -> [Variant] -> m () emitResponseSignal handle methodCall signalBody = do   void . liftIO $     emit