monomer-flatpak-example 0.0.4.0 → 0.0.5.0
raw patch · 5 files changed
+327/−25 lines, 5 filesdep +data-default-classdep +dbusdep +randombinary-added
Dependencies added: data-default-class, dbus, random
Files
- app/Desktop/Portal.hs +183/−0
- app/Main.hs +132/−22
- assets/fonts/Cantarell/Cantarell-Bold.ttf binary
- assets/io.github.Dretch.MonomerFlatpakExample.metainfo.xml +1/−0
- monomer-flatpak-example.cabal +11/−3
+ app/Desktop/Portal.hs view
@@ -0,0 +1,183 @@+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, 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 :: 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 <- DBus.fromVariant =<< Map.lookup "image" resMap ->+ pure GetUserInformationResponse {..}+ _ ->+ throwIO (DBus.clientError "getUserInformation: could not parse response")++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+ _ ->+ throwIO (DBus.clientError "openFile: could not parse response")++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
app/Main.hs view
@@ -1,8 +1,11 @@ module Main (main) where +import Data.Default.Class (def) import Data.Sequence (Seq)-import qualified Data.Sequence as Seq-import Data.Text (Text, pack, unpack)+import Data.Sequence qualified as Seq+import Data.Text (Text, intercalate, pack, unpack)+import Desktop.Portal (GetUserInformationResponse (..), Request)+import Desktop.Portal qualified as Portal import Monomer import Monomer.Hagrid import Paths_monomer_flatpak_example (getDataFileName)@@ -12,7 +15,8 @@ data AppModel = AppModel { fileSystem :: Seq EnvironmentInfo,- environmentVariables :: Seq EnvironmentInfo+ environmentVariables :: Seq EnvironmentInfo,+ alertContents :: AlertContents } deriving (Eq, Show) @@ -22,47 +26,119 @@ } deriving (Eq, Show) +data AlertContents+ = AlertNotShown+ | AlertRequestingUserInformation (Request GetUserInformationResponse)+ | AlertUserInformation GetUserInformationResponse+ | AlertRequestingOpenFile (Request [Text])+ | AlertOpenFile [Text]+ deriving (Eq, Show)+ data AppEvent = AppInit | AppInitFinish (Seq EnvironmentInfo) (Seq EnvironmentInfo)+ | GetUserInformation+ | GetUserInformationStart (Request GetUserInformationResponse)+ | GetUserInformationFinish GetUserInformationResponse+ | OpenFile+ | OpenFileStart (Request [Text])+ | OpenFileFinish [Text]+ | CancelRequest+ | CloseAlert main :: IO () main = do regularFontPath <- pack <$> getDataFileName "/fonts/Cantarell/Cantarell-Regular.ttf"+ boldFontPath <- pack <$> getDataFileName "/fonts/Cantarell/Cantarell-Bold.ttf" iconPath <- pack <$> getDataFileName "/io.github.Dretch.MonomerFlatpakExample.png"- startApp initialModel handleEvent buildUI (config regularFontPath iconPath)+ startApp initialModel handleEvent buildUI (config regularFontPath boldFontPath iconPath) where- initialModel = AppModel {fileSystem = mempty, environmentVariables = mempty}- config regularFontPath iconPath =+ initialModel =+ AppModel+ { fileSystem = mempty,+ environmentVariables = mempty,+ alertContents = AlertNotShown+ }+ config regularFontPath boldFontPath iconPath = [ appTheme darkTheme, appWindowTitle "Monomer Flatpak Example", appWindowIcon iconPath, appWindowState (MainWindowNormal (1000, 800)), appFontDef "Regular" regularFontPath,+ appFontDef "Bold" boldFontPath, appDisableAutoScale True, appInitEvent AppInit ] buildUI :: UIBuilder AppModel AppEvent-buildUI _wenv model =- vstack_- [childSpacing_ 5]- [ label "Monomer Flatpak Example"- `styleBasic` [textSize 40, paddingL 5, paddingT 10, paddingR 10],- label "This is a demo of the monomer framework running inside the Flatpak sandbox."- `styleBasic` [padding 5],- hagrid- [ (textColumn "File System Info" (.key)) {initialWidth = 300},- (widgetColumn "" valueColumn) {initialWidth = 700}+buildUI _wenv model = tree+ where+ tree =+ zstack+ [ vstack_+ [childSpacing_ 5]+ [ label "Monomer Flatpak Example"+ `styleBasic` [textSize 40, paddingL 5, paddingT 10, paddingR 10],+ label "This is a demo of the monomer framework running inside the Flatpak sandbox."+ `styleBasic` [padding 5],+ hstack_+ [childSpacing]+ [ label "Portals:",+ button "Get User Information" GetUserInformation,+ button "Open File" OpenFile+ ]+ `styleBasic` [padding 5],+ hagrid+ [ (textColumn "File System Info" (.key)) {initialWidth = 300},+ (widgetColumn "" valueColumn) {initialWidth = 700}+ ]+ model.fileSystem,+ hagrid+ [ (textColumn "Environment Variable" (.key)) {initialWidth = 300},+ (widgetColumn "" valueColumn) {initialWidth = 700}+ ]+ model.environmentVariables+ ],+ -- nodeKey to workaround https://github.com/fjvallarino/monomer/issues/265+ maybeAlert `nodeKey` pack (show model.alertContents) ]- model.fileSystem,- hagrid- [ (textColumn "Environment Variable" (.key)) {initialWidth = 300},- (widgetColumn "" valueColumn) {initialWidth = 700}++ maybeAlert = case model.alertContents of+ AlertNotShown ->+ spacer `nodeVisible` False+ AlertRequestingUserInformation _ ->+ alert_+ CancelRequest+ [titleCaption "Getting User Information"]+ (label "Wait or cancel by closing this alert..." `styleBasic` [padding 20])+ AlertRequestingOpenFile _ ->+ alert_+ CancelRequest+ [titleCaption "Opening File..."]+ (label "Wait or cancel by closing this alert..." `styleBasic` [padding 20])+ AlertUserInformation info ->+ alert_+ CloseAlert+ [titleCaption "Get User Information Response"]+ (userInfoAlertContents info `styleBasic` [padding 20])+ AlertOpenFile files ->+ alert_+ CloseAlert+ [titleCaption "Open File Response"]+ (openFileAlertContents files `styleBasic` [padding 20])++ userInfoAlertContents response =+ vstack_+ [childSpacing]+ [ label "Request successful.",+ label ("User Id: " <> response.userId),+ label ("User Name: " <> response.userName),+ label ("User Image: " <> response.userImage) ]- model.environmentVariables- ] + openFileAlertContents files =+ label ("Selected files: " <> intercalate ", " files)+ valueColumn :: Int -> EnvironmentInfo -> WidgetNode s e valueColumn _ix model = label_ model.value [multiline, ellipsis]@@ -91,3 +167,37 @@ ] AppInitFinish fileSystem environmentVariables -> [Model model {fileSystem, environmentVariables}]+ GetUserInformation ->+ [ Producer $ \emit -> do+ res <- Portal.getUserInformation "Allows FlatpakMonomerExample to show user information."+ emit (GetUserInformationStart res)+ Portal.await res >>= \case+ Nothing -> emit CloseAlert+ Just result -> emit (GetUserInformationFinish result)+ ]+ GetUserInformationStart res ->+ [Model model {alertContents = AlertRequestingUserInformation res}]+ GetUserInformationFinish info ->+ [Model model {alertContents = AlertUserInformation info}]+ OpenFile ->+ [ Producer $ \emit -> do+ res <- Portal.openFile def+ emit (OpenFileStart res)+ Portal.await res >>= \case+ Nothing -> emit CloseAlert+ Just result -> emit (OpenFileFinish result)+ ]+ OpenFileStart res ->+ [Model model {alertContents = AlertRequestingOpenFile res}]+ OpenFileFinish files ->+ [Model model {alertContents = AlertOpenFile files}]+ CancelRequest ->+ let cancel = case model.alertContents of+ AlertRequestingOpenFile res ->+ [Producer (const (Portal.cancel res))]+ AlertRequestingUserInformation res ->+ [Producer (const (Portal.cancel res))]+ _ -> []+ in cancel <> [Model model {alertContents = AlertNotShown}]+ CloseAlert ->+ [Model model {alertContents = AlertNotShown}]
+ assets/fonts/Cantarell/Cantarell-Bold.ttf view
binary file changed (absent → 46572 bytes)
assets/io.github.Dretch.MonomerFlatpakExample.metainfo.xml view
@@ -23,6 +23,7 @@ </screenshots> <releases>+ <release version="0.0.5.0" date="2023-04-09"/> <release version="0.0.4.0" date="2023-04-07"/> <release version="0.0.3.1" date="2023-03-11"/> <release version="0.0.3.0" date="2023-03-10"/>
monomer-flatpak-example.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: monomer-flatpak-example-version: 0.0.4.0+version: 0.0.5.0 license: MIT license-file: LICENSE maintainer: garethdanielsmith@gmail.com@@ -11,6 +11,7 @@ category: GUI build-type: Simple data-files:+ fonts/Cantarell/Cantarell-Bold.ttf fonts/Cantarell/Cantarell-Regular.ttf fonts/Cantarell/OFL.txt io.github.Dretch.MonomerFlatpakExample.desktop@@ -26,11 +27,15 @@ executable monomer-flatpak-example main-is: Main.hs hs-source-dirs: app- other-modules: Paths_monomer_flatpak_example+ other-modules:+ Desktop.Portal+ Paths_monomer_flatpak_example+ default-language: Haskell2010 default-extensions: DisambiguateRecordFields DuplicateRecordFields FlexibleContexts- LambdaCase NamedFieldPuns OverloadedRecordDot OverloadedStrings+ ImportQualifiedPost LambdaCase NamedFieldPuns OverloadedRecordDot+ OverloadedStrings RecordWildCards ScopedTypeVariables ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat@@ -40,7 +45,10 @@ build-depends: base >=4.7 && <5, containers <0.7,+ data-default-class <0.2,+ dbus <1.3, directory <1.4, monomer <1.6, monomer-hagrid <0.3,+ random <1.3, text <1.3