diff --git a/app/Desktop/Portal.hs b/app/Desktop/Portal.hs deleted file mode 100644 --- a/app/Desktop/Portal.hs +++ /dev/null @@ -1,191 +0,0 @@ -module Desktop.Portal - ( Request, - GetUserInformationResponse (..), - OpenFileOptions (..), - getUserInformation, - openFile, - await, - cancel, - ) -where - -import Control.Concurrent (MVar, readMVar, tryPutMVar) -import Control.Concurrent.MVar (newEmptyMVar) -import Control.Exception (onException, throwIO) -import Control.Monad (when) -import DBus (BusName, InterfaceName, IsVariant, 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.Default.Class (Default (def)) -import Data.Map (Map) -import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe) -import Data.Text (Text, pack, unpack) -import Data.Word (Word32, Word64) -import System.Random.Stateful qualified as R - -data GetUserInformationResponse = GetUserInformationResponse - { userId :: Text, - userName :: Text, - userImage :: Maybe Text - } - deriving (Eq, Show) - -data OpenFileOptions = OpenFileOptions - {title :: Maybe Text} - deriving (Eq, Show) - -instance Default OpenFileOptions where - def = OpenFileOptions {title = Nothing} - --- | A request that may be in-progress, finished, or cancelled. -data Request a = Request - { client :: Client, - methodCall :: MethodCall, - result :: MVar (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=}" - --- | Wait for a request to be finished, and return the result if it succeeded. -await :: Request a -> IO (Maybe a) -await request = do - readMVar request.result - --- | 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 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 - -getUserInformation :: Text -> IO (Request GetUserInformationResponse) -getUserInformation reason = - sendRequest "org.freedesktop.portal.Account" "GetUserInformation" [windowHandle] options parseResponse - where - windowHandle = DBus.toVariant ("" :: Text) - options = Map.singleton "reason" (DBus.toVariant reason) - - parseResponse = \case - resMap - | Just userId <- DBus.fromVariant =<< Map.lookup "id" resMap, - Just userName <- DBus.fromVariant =<< Map.lookup "name" resMap, - Just userImage <- optionalFromVariant resMap "image" -> - pure GetUserInformationResponse {..} - resMap -> - throwIO . DBus.clientError $ "getUserInformation: could not parse response: " <> show resMap - -openFile :: OpenFileOptions -> IO (Request [Text]) -openFile ofOptions = - sendRequest "org.freedesktop.portal.FileChooser" "OpenFile" [windowHandle, DBus.toVariant title] mempty parseResponse - where - windowHandle = DBus.toVariant ("" :: Text) - title = fromMaybe "" ofOptions.title - - parseResponse = \case - resMap - | Just (uris :: [Text]) <- DBus.fromVariant =<< Map.lookup "uris" resMap -> - pure uris - resMap -> - throwIO . DBus.clientError $ "openFile: could not parse response: " <> show resMap - -sendRequest :: - InterfaceName -> - MemberName -> - [Variant] -> - Map Text Variant -> - (Map Text Variant -> IO a) -> - 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 - 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 - Just <$> parseResponse resMap - _ -> do - pure Nothing - -- need to try because cancel might have been called and populated the mvar with Nothing - putSucceeded <- tryPutMVar resultVar val - when putSucceeded $ - DBus.disconnect client -- we only use the connection for a single request, which is now done - ) - - 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 - - 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 ("monomer_flatpak_example_" <> 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 - --- | 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 => Map Text Variant -> Text -> Maybe (Maybe a) -optionalFromVariant key variants = - case Map.lookup variants key of - Nothing -> Just Nothing - Just var -> Just <$> DBus.fromVariant var diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -5,7 +5,7 @@ import Data.Sequence (Seq) import Data.Sequence qualified as Seq import Data.Text (Text, intercalate, pack, unpack) -import Desktop.Portal (GetUserInformationResponse (..), Request) +import Desktop.Portal (GetUserInformationOptions (..), GetUserInformationResults (..), OpenFileResults (..), Request) import Desktop.Portal qualified as Portal import Monomer import Monomer.Hagrid @@ -29,21 +29,21 @@ data AlertContents = AlertNotShown - | AlertRequestingUserInformation (Request GetUserInformationResponse) - | AlertUserInformation GetUserInformationResponse - | AlertRequestingOpenFile (Request [Text]) - | AlertOpenFile [Text] + | AlertRequestingUserInformation (Request GetUserInformationResults) + | AlertUserInformation GetUserInformationResults + | AlertRequestingOpenFile (Request OpenFileResults) + | AlertOpenFile OpenFileResults deriving (Eq, Show) data AppEvent = AppInit | AppInitFinish (Seq EnvironmentInfo) (Seq EnvironmentInfo) | GetUserInformation - | GetUserInformationStart (Request GetUserInformationResponse) - | GetUserInformationFinish GetUserInformationResponse + | GetUserInformationStart (Request GetUserInformationResults) + | GetUserInformationFinish GetUserInformationResults | OpenFile - | OpenFileStart (Request [Text]) - | OpenFileFinish [Text] + | OpenFileStart (Request OpenFileResults) + | OpenFileFinish OpenFileResults | CancelRequest | CloseAlert @@ -122,23 +122,28 @@ CloseAlert [titleCaption "Get User Information Response"] (userInfoAlertContents info `styleBasic` [padding 20]) - AlertOpenFile files -> + AlertOpenFile results -> alert_ CloseAlert [titleCaption "Open File Response"] - (openFileAlertContents files `styleBasic` [padding 20]) + (openFileAlertContents results `styleBasic` [padding 20]) - userInfoAlertContents response = + userInfoAlertContents results = vstack_ [childSpacing] [ label "Request successful.", - label ("User Id: " <> response.userId), - label ("User Name: " <> response.userName), - label ("User Image: " <> fromMaybe "[none]" response.userImage) + label ("User Id: " <> results.id), + label ("User Name: " <> results.name), + label ("User Image: " <> fromMaybe "[none]" results.image) ] - openFileAlertContents files = - label ("Selected files: " <> intercalate ", " files) + openFileAlertContents results = + vstack_ + [childSpacing] + [ label "Request successful.", + label ("Selected URIs: " <> intercalate ", " results.uris), + label ("Selected Choices: " <> pack (show results.choices)) + ] valueColumn :: Int -> EnvironmentInfo -> WidgetNode s e valueColumn _ix model = @@ -170,7 +175,11 @@ [Model model {fileSystem, environmentVariables}] GetUserInformation -> [ Producer $ \emit -> do - res <- Portal.getUserInformation "Allows FlatpakMonomerExample to show user information." + res <- + Portal.getUserInformation + def + { reason = Just "Allows FlatpakMonomerExample to show user information." + } emit (GetUserInformationStart res) Portal.await res >>= \case Nothing -> emit CloseAlert @@ -190,8 +199,8 @@ ] OpenFileStart res -> [Model model {alertContents = AlertRequestingOpenFile res}] - OpenFileFinish files -> - [Model model {alertContents = AlertOpenFile files}] + OpenFileFinish results -> + [Model model {alertContents = AlertOpenFile results}] CancelRequest -> let cancel = case model.alertContents of AlertRequestingOpenFile res -> diff --git a/assets/io.github.Dretch.MonomerFlatpakExample.metainfo.xml b/assets/io.github.Dretch.MonomerFlatpakExample.metainfo.xml --- a/assets/io.github.Dretch.MonomerFlatpakExample.metainfo.xml +++ b/assets/io.github.Dretch.MonomerFlatpakExample.metainfo.xml @@ -23,6 +23,7 @@ + diff --git a/monomer-flatpak-example.cabal b/monomer-flatpak-example.cabal --- a/monomer-flatpak-example.cabal +++ b/monomer-flatpak-example.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: monomer-flatpak-example -version: 0.0.5.1 +version: 0.0.6.0 license: MIT license-file: LICENSE maintainer: garethdanielsmith@gmail.com @@ -8,7 +8,7 @@ bug-reports: https://github.com/Dretch/monomer-flatpak-example/issues synopsis: Monomer Flatpak Example Application. description: An example of how to package Monomer apps with Flatpak. -category: GUI +category: GUI, Flatpak build-type: Simple data-files: fonts/Cantarell/Cantarell-Bold.ttf @@ -27,15 +27,13 @@ executable monomer-flatpak-example main-is: Main.hs hs-source-dirs: app - other-modules: - Desktop.Portal - Paths_monomer_flatpak_example - + other-modules: Paths_monomer_flatpak_example default-language: Haskell2010 default-extensions: DisambiguateRecordFields DuplicateRecordFields FlexibleContexts - ImportQualifiedPost LambdaCase NamedFieldPuns OverloadedRecordDot - OverloadedStrings RecordWildCards ScopedTypeVariables + ImportQualifiedPost LambdaCase NamedFieldPuns NoFieldSelectors + OverloadedRecordDot OverloadedStrings RecordWildCards + ScopedTypeVariables ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat @@ -47,8 +45,9 @@ containers <0.7, data-default-class <0.2, dbus <1.3, + desktop-portal <0.1, directory <1.4, monomer <1.6, - monomer-hagrid <0.3, + monomer-hagrid <0.4, random <1.3, text <1.3