desktop-portal 0.3.0.0 → 0.3.1.0
raw patch · 7 files changed
+116/−2 lines, 7 filesdep +networkPVP ok
version bump matches the API change (PVP)
Dependencies added: network
API changes (from Hackage documentation)
+ Desktop.Portal.Secret: retrieveSecret :: Client -> IO ByteString
Files
- ChangeLog.md +4/−0
- README.md +5/−1
- desktop-portal.cabal +5/−1
- src/Desktop/Portal.hs +2/−0
- src/Desktop/Portal/Secret.hs +32/−0
- test/Desktop/Portal/SecretSpec.hs +58/−0
- test/Desktop/Portal/TestUtil.hs +10/−0
ChangeLog.md view
@@ -1,3 +1,7 @@+## 0.3.1.0+### Added+- Add Secret Portal support.+ ## 0.3.0.0 ### Fixed - The OpenURI portal now supports OpenFile and OpenDirectory correctly. This uses the file descriptor support added with the Documents portal support.
README.md view
@@ -1,6 +1,6 @@ # 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)).+A Haskell wrapper for the [XDG Desktop Portal](https://github.com/flatpak/xdg-desktop-portal) DBUS API. Like [libportal](https://github.com/flatpak/libportal), but written in Haskell. 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.@@ -12,6 +12,10 @@ ## API Documentation See the generated docs on [Hackage](https://hackage.haskell.org/package/desktop-portal).++## Example Code++The [monomer-flatpak-example](https://github.com/Dretch/monomer-flatpak-example) app includes example code for many of the APIs. ## Development Guide
desktop-portal.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: desktop-portal-version: 0.3.0.0+version: 0.3.1.0 license: MIT license-file: LICENSE maintainer: garethdanielsmith@gmail.com@@ -27,6 +27,7 @@ Desktop.Portal.FileChooser Desktop.Portal.Notification Desktop.Portal.OpenURI+ Desktop.Portal.Secret Desktop.Portal.Settings hs-source-dirs: src@@ -56,6 +57,7 @@ dbus >=1.3.0 && <2, directory <1.4, modern-uri <0.4,+ network <3.2, random <1.3, text <2.1, unix <2.8@@ -71,6 +73,7 @@ Desktop.Portal.FileChooserSpec Desktop.Portal.NotificationSpec Desktop.Portal.OpenURISpec+ Desktop.Portal.SecretSpec Desktop.Portal.SettingsSpec Desktop.Portal.TestUtil Paths_desktop_portal@@ -100,6 +103,7 @@ hspec >=2 && <3, hspec-expectations <0.9, modern-uri <0.4,+ network <3.2, process <1.7, random <1.3, temporary <1.4,
src/Desktop/Portal.hs view
@@ -27,6 +27,7 @@ module Desktop.Portal.FileChooser, module Desktop.Portal.Notification, module Desktop.Portal.OpenURI,+ module Desktop.Portal.Secret, ) where @@ -36,3 +37,4 @@ import Desktop.Portal.Internal qualified as Internal import Desktop.Portal.Notification import Desktop.Portal.OpenURI hiding (OpenFileOptions (..), openFile, openFileOptions) -- avoid conflict with FileChooser.openFile+import Desktop.Portal.Secret
+ src/Desktop/Portal/Secret.hs view
@@ -0,0 +1,32 @@+module Desktop.Portal.Secret (retrieveSecret) where++import Control.Exception (finally, throwIO)+import DBus (InterfaceName, IsVariant (toVariant))+import DBus.Client qualified as DBus+import Data.ByteString (ByteString)+import Desktop.Portal.Internal (Client, await, sendRequest)+import Network.Socket (Family (..), SocketType (..), close, defaultProtocol, socketPair, withFdSocket)+import Network.Socket.ByteString (recv)+import System.Posix (Fd (..))++secretsInterface :: InterfaceName+secretsInterface = "org.freedesktop.portal.Secret"++-- | Retrieve the application-specific secret.+--+-- Currently works in Gnome, but not KDE (see https://bugs.kde.org/show_bug.cgi?id=466197 ).+-- The token parameter that is documented in the portal API specs is not supported either, as+-- it is not clear exactly how this should work and it does not seem to be supported by Gnome.+retrieveSecret :: Client -> IO ByteString+retrieveSecret client = do+ (r, w) <- socketPair AF_UNIX Stream defaultProtocol+ flip finally (close r) $ do+ flip finally (close w) $ do+ withFdSocket w $ \fdInt -> do+ let fd = toVariant (Fd fdInt)+ req <- sendRequest client secretsInterface "RetrieveSecret" [fd] mempty pure+ await req >>= \case+ Nothing ->+ throwIO . DBus.clientError $ "retrieveSecret: request was cancelled."+ Just _tokens -> do+ recv r 4096
+ test/Desktop/Portal/SecretSpec.hs view
@@ -0,0 +1,58 @@+module Desktop.Portal.SecretSpec (spec) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Monad (void)+import DBus (InterfaceName, fromVariant, methodCallBody)+import Desktop.Portal qualified as Portal+import Desktop.Portal.TestUtil+import System.Posix.ByteString (Fd, closeFd, fdWrite)+import Test.Hspec (Spec, around, describe, it, shouldBe)+import Test.Hspec.Expectations (shouldThrow)++secretsInterface :: InterfaceName+secretsInterface = "org.freedesktop.portal.Secret"++spec :: Spec+spec = do+ around withTestBus $ do+ describe "retrieveSecret" $ do+ describe "should read secret from file descriptor" $ do+ it "when secret is written before response is returned" $ \handle -> do+ let answer methodCall = do+ [fromVariant -> Just (fd :: Fd), _opts] <- pure (methodCallBody methodCall)+ void $ fdWrite fd "$secret$"+ closeFd fd+ pure (successResponse [])+ withRequestAnswer handle secretsInterface "RetrieveSecret" answer $ do+ actualSecret <- Portal.retrieveSecret (client handle)+ actualSecret `shouldBe` "$secret$"++ it "when secret is written in multiple chunks" $ \handle -> do+ let answer methodCall = do+ [fromVariant -> Just (fd :: Fd), _opts] <- pure (methodCallBody methodCall)+ void $ fdWrite fd "$sec"+ void $ fdWrite fd "ret$"+ closeFd fd+ pure (successResponse [])+ withRequestAnswer handle secretsInterface "RetrieveSecret" answer $ do+ actualSecret <- Portal.retrieveSecret (client handle)+ actualSecret `shouldBe` "$secret$"++ it "when secret is written after response is returned" $ \handle -> do+ let answer methodCall = do+ [fromVariant -> Just (fd :: Fd), _opts] <- pure (methodCallBody methodCall)+ void $ forkIO $ do+ threadDelay 100_000+ void $ fdWrite fd "$secret$"+ closeFd fd+ pure (successResponse [])+ withRequestAnswer handle secretsInterface "RetrieveSecret" answer $ do+ actualSecret <- Portal.retrieveSecret (client handle)+ actualSecret `shouldBe` "$secret$"++ it "should throw exception on request failure" $ \handle -> do+ let answer _methodCall = do+ pure failureResponse+ withRequestAnswer handle secretsInterface "RetrieveSecret" answer $ do+ Portal.retrieveSecret (client handle)+ `shouldThrow` dbusClientException
test/Desktop/Portal/TestUtil.hs view
@@ -1,5 +1,6 @@ module Desktop.Portal.TestUtil ( successResponse,+ failureResponse, toVariantMap, toVariantText, TestHandle,@@ -9,6 +10,7 @@ withMethodResponse, withMethodResponse_, withRequestResponse,+ withRequestAnswer, savingMethodArguments, savingMethodArguments_, savingRequestArguments,@@ -105,6 +107,10 @@ withRequestResponse :: TestHandle -> InterfaceName -> MemberName -> [Variant] -> IO () -> IO () withRequestResponse handle interfaceName methodName methodResponse cmd = do+ withRequestAnswer handle interfaceName methodName (const (pure methodResponse)) cmd++withRequestAnswer :: TestHandle -> InterfaceName -> MemberName -> (MethodCall -> IO [Variant]) -> IO () -> IO ()+withRequestAnswer handle interfaceName methodName answer cmd = do export handle.serverClient portalObjectPath@@ -116,6 +122,7 @@ unexport handle.serverClient portalObjectPath where handleMethodCall methodCall = do+ methodResponse <- liftIO (answer methodCall) emitResponseSignal handle methodCall methodResponse pure (ReplyReturn [toVariant (methodRequestHandle methodCall)]) @@ -232,6 +239,9 @@ [ toVariant (0 :: Word32), -- success code toVariantMap pairs ]++failureResponse :: [Variant]+failureResponse = [toVariant (1 :: Word32)] toVariantMap :: [(Text, Variant)] -> Variant toVariantMap = toVariant . Map.fromList