monomer-flatpak-example 0.0.5.1 → 0.0.6.0
raw patch · 4 files changed
+38/−220 lines, 4 filesdep +desktop-portaldep ~monomer-hagrid
Dependencies added: desktop-portal
Dependency ranges changed: monomer-hagrid
Files
- app/Desktop/Portal.hs +0/−191
- app/Main.hs +29/−20
- assets/io.github.Dretch.MonomerFlatpakExample.metainfo.xml +1/−0
- monomer-flatpak-example.cabal +8/−9
− app/Desktop/Portal.hs
@@ -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=<MVar>}"---- | 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
app/Main.hs view
@@ -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 ->
assets/io.github.Dretch.MonomerFlatpakExample.metainfo.xml view
@@ -23,6 +23,7 @@ </screenshots> <releases>+ <release version="0.0.6.0" date="2023-04-22"/> <release version="0.0.5.1" date="2023-04-10"/> <release version="0.0.5.0" date="2023-04-09"/> <release version="0.0.4.0" date="2023-04-07"/>
monomer-flatpak-example.cabal view
@@ -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