monomer-flatpak-example 0.0.9.0 → 0.0.10.0
raw patch · 4 files changed
+223/−52 lines, 4 filesdep ~dbusdep ~text
Dependency ranges changed: dbus, text
Files
- app/Documents.hs +188/−0
- app/Main.hs +27/−48
- assets/io.github.Dretch.MonomerFlatpakExample.metainfo.xml +1/−0
- monomer-flatpak-example.cabal +7/−4
+ app/Documents.hs view
@@ -0,0 +1,188 @@+module Documents (documents) where++import Control.Exception (SomeException, catch)+import Control.Monad (forM, forM_, void, when)+import Data.Bool (bool)+import Data.Default.Class (def)+import Data.Sequence (Seq)+import Data.Sequence qualified as Seq+import Data.Text (Text, intercalate, pack)+import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder (Builder)+import Data.Text.Lazy.Builder qualified as Builder+import Desktop.Portal (Client, directory)+import Desktop.Portal qualified as Portal+import Desktop.Portal.Documents (DocumentId (..), FileIdentifier (..))+import Desktop.Portal.Documents qualified as Documents+import Desktop.Portal.FileChooser (OpenFileResults)+import Monomer+import Monomer.Hagrid+import System.Directory (doesDirectoryExist, getDirectoryContents)++data DocumentsModel = DocumentsModel+ { portalClient :: Client,+ mountPoint :: FilePath,+ documents :: Seq Document+ }+ deriving (Eq, Show)++data Document = Document+ { id :: DocumentId,+ ls :: Text,+ selected :: Bool+ }+ deriving (Eq, Show)++data DocumentsEvent+ = RefreshDocuments+ | RefreshDocumentsFinish FilePath (Seq Document)+ | SetDocumentSelected DocumentId Bool+ | DeleteSelectedDocuments+ | OpenFile+ | OpenDirectory+ | AddFile+ | ShowAlert {title :: Text, body :: Text}++documents :: (CompParentModel s, CompositeEvent e) => Client -> (Text -> Text -> e) -> WidgetNode s e+documents portalClient parentAlert =+ compositeD_ "MonomerFlatpakExample.Documents" (WidgetValue initialModel) buildUI (handleEvent parentAlert) cfg+ where+ cfg = [onInit RefreshDocuments]+ initialModel =+ DocumentsModel+ { portalClient,+ mountPoint = "...",+ documents = mempty+ }++buildUI :: UIBuilder DocumentsModel DocumentsEvent+buildUI _wenv model =+ vstack_+ [childSpacing]+ [ label_ "This shows the documents outside the sandbox that the app has access to. Open files/directories to make them accessible." [multiline]+ `styleBasic` [paddingV 1],+ hstack_+ [childSpacing]+ [ button "Open File" OpenFile,+ button "Open Directory" OpenDirectory,+ button "Add File (~/.var/app/$appId/data/hello.txt)" AddFile,+ button "Delete Selected" DeleteSelectedDocuments+ `nodeEnabled` (Seq.filter (.selected) model.documents /= mempty)+ ],+ hagrid+ [ widgetColumn "" selectedCell,+ textColumn "Id" (\Document {id = DocumentId di} -> di),+ (widgetColumn "Files" filesCell) {initialWidth = 700}+ ]+ model.documents+ `styleBasic` [height 400, width 800]+ ]++selectedCell :: Int -> Document -> WidgetNode s DocumentsEvent+selectedCell _i doc =+ checkboxV doc.selected (SetDocumentSelected doc.id)++filesCell :: Int -> Document -> WidgetNode s DocumentsEvent+filesCell _i doc =+ label_ doc.ls [multiline]++handleEvent :: (Text -> Text -> ep) -> EventHandler DocumentsModel DocumentsEvent sp ep+handleEvent parentAlert _env _node model = \case+ RefreshDocuments ->+ [ Task $ do+ mountPoint <- Documents.getMountPoint model.portalClient+ docs <- getDocuments mountPoint+ pure (RefreshDocumentsFinish mountPoint docs)+ ]+ RefreshDocumentsFinish mountPoint docs ->+ [Model model {mountPoint, documents = docs}]+ SetDocumentSelected docId selected ->+ [Model model {documents = (\doc -> if doc.id == docId then doc {selected} else doc) <$> model.documents}]+ DeleteSelectedDocuments ->+ [ Producer $ \emit -> do+ catchErrors "Delete Failed" emit $ do+ forM_ model.documents $ \doc -> do+ when doc.selected $ do+ Documents.delete model.portalClient doc.id+ emit RefreshDocuments+ ]+ OpenFile ->+ [ Producer $ \emit -> do+ catchErrors "Open Directory Failed" emit $ do+ req <- Portal.openFile model.portalClient def+ Portal.await req >>= \case+ Nothing -> pure () -- user cancelled dialog+ Just result ->+ emit (ShowAlert "Open File Response" (openFileResponseAlert result))+ ]+ OpenDirectory ->+ [ Producer $ \emit -> do+ catchErrors "Open Directory Failed" emit $ do+ req <- Portal.openFile model.portalClient def {directory = Just True}+ Portal.await req >>= \case+ Nothing -> pure () -- user cancelled dialog+ Just result ->+ emit (ShowAlert "Open Directory Response" (openFileResponseAlert result))+ ]+ AddFile ->+ [ Producer $ \emit -> do+ filePath <- (<> "/hello.txt") <$> Portal.getXdgDataHome+ writeFile filePath "Hello!"+ catchErrors "Add File Failed" emit $ do+ void (Documents.add model.portalClient (DocumentFilePath filePath) True True)+ emit RefreshDocuments+ ]+ ShowAlert {title, body} ->+ [Report (parentAlert title body)]++catchErrors :: Text -> (DocumentsEvent -> IO ()) -> IO () -> IO ()+catchErrors title emit cmd = catch cmd handler+ where+ handler (e :: SomeException) =+ emit (ShowAlert title (pack (show e)))++openFileResponseAlert :: OpenFileResults -> Text+openFileResponseAlert results =+ "Request successful.\n\n"+ <> "Selected Files: "+ <> intercalate ", " (pack <$> results.uris)+ <> "\n"+ <> "Selected Choices: "+ <> pack (show results.choices)++getDocuments :: FilePath -> IO (Seq Document)+getDocuments storePath = do+ paths <- getDirectoryContents storePath+ flip foldMap paths $ \path -> do+ let fullPath = storePath <> "/" <> path+ isDir <- doesDirectoryExist fullPath+ if isDir && path /= "by-app" && path /= "." && path /= ".."+ then do+ ls <- lsRecursive fullPath+ pure (Seq.singleton Document {id = DocumentId (pack path), ls, selected = False})+ else pure mempty++lsRecursive :: FilePath -> IO Text+lsRecursive path = do+ displayPath <- withSlashIfDir path path+ childOutputs <- lsRecursive' "" path ""+ pure . toStrict . Builder.toLazyText $+ displayPath <> "\n" <> childOutputs+ where+ lsRecursive' :: Builder -> FilePath -> FilePath -> IO Builder+ lsRecursive' indent dirPath fileName = do+ let fullPath = dirPath <> "/" <> fileName+ childPaths <- doesDirectoryExist fullPath >>= bool (pure []) (getDirectoryContents fullPath)+ childOutputs <- forM childPaths $ \childPath -> do+ if childPath == "." || childPath == ".."+ then pure ""+ else lsRecursive' (indent <> " ") fullPath childPath+ displayPath <- withSlashIfDir fullPath fileName+ case fileName of+ "" -> pure (mconcat childOutputs)+ _ -> pure (indent <> displayPath <> "\n" <> mconcat childOutputs)++withSlashIfDir :: FilePath -> FilePath -> IO Builder+withSlashIfDir fullPath displayPath = do+ slash <- bool "" "/" <$> doesDirectoryExist fullPath+ pure (Builder.fromString displayPath <> slash)
app/Main.hs view
@@ -8,24 +8,25 @@ import Data.Default.Class (def) import Data.Sequence (Seq) import Data.Sequence qualified as Seq-import Data.Text (Text, intercalate, pack, unpack)+import Data.Text (Text, pack, unpack) import Data.Word (Word32)-import Desktop.Portal (AddNotificationOptions (..), Client, GetUserInformationOptions (..), GetUserInformationResults (..), NotificationButton (..), NotificationIcon (..), NotificationPriority (..), OpenFileResults (..), Request, addNotificationOptions, openURIOptions)+import Desktop.Portal (AddNotificationOptions (..), Client, GetUserInformationOptions (..), GetUserInformationResults (..), NotificationButton (..), NotificationIcon (..), NotificationPriority (..), Request, addNotificationOptions, openURIOptions) import Desktop.Portal qualified as Portal import Desktop.Portal.Settings (ReadAllOptions (..), ReadAllResults) import Desktop.Portal.Settings qualified as Settings+import Documents (documents) import Monomer import Monomer.Hagrid import Paths_monomer_flatpak_example (getDataFileName) import System.Directory (getCurrentDirectory, getHomeDirectory, listDirectory) import System.Environment (getEnvironment) import Text.URI.QQ (uri)-import Prelude hiding (unwords) data AppModel = AppModel { portalClient :: Client, fileSystem :: Seq EnvironmentInfo, environmentVariables :: Seq EnvironmentInfo,+ showDocuments :: Bool, alertContents :: AlertContents } deriving (Eq, Show)@@ -40,10 +41,8 @@ = AlertNotShown | AlertRequestingUserInformation (Request GetUserInformationResults) | AlertUserInformation GetUserInformationResults- | AlertRequestingOpenFile (Request OpenFileResults)- | AlertOpenFile OpenFileResults | AlertSettings ReadAllResults- | AlertRequestFailed Text+ | AlertMessage {title :: Text, body :: Text} deriving (Eq, Show) data AppEvent@@ -52,13 +51,12 @@ | GetUserInformation | GetUserInformationStart (Request GetUserInformationResults) | GetUserInformationFinish GetUserInformationResults- | OpenFile- | OpenFileStart (Request OpenFileResults)- | OpenFileFinish OpenFileResults+ | ShowAlertMessage {title :: Text, body :: Text} | AddNotification | ReadSettings | ReadSettingsFinish ReadAllResults | OpenURI+ | SetShowDocuments Bool | RequestFailed Text | CancelRequest | CloseAlert@@ -77,6 +75,7 @@ { portalClient, fileSystem = mempty, environmentVariables = mempty,+ showDocuments = False, alertContents = AlertNotShown } config regularFontPath boldFontPath iconPath =@@ -105,7 +104,7 @@ [childSpacing] [ label "Portals:", button "Get User Information" GetUserInformation,- button "Open File" OpenFile,+ button "Documents" (SetShowDocuments True), button "Add Notification" AddNotification, button "Read Settings" ReadSettings, button "Open URI" OpenURI@@ -122,10 +121,19 @@ ] model.environmentVariables ],+ maybeDocuments, -- nodeKey to workaround https://github.com/fjvallarino/monomer/issues/265 maybeAlert `nodeKey` pack (show model.alertContents) ] + maybeDocuments+ | model.showDocuments =+ alert_+ (SetShowDocuments False)+ [titleCaption "Documents"]+ (documents model.portalClient ShowAlertMessage `styleBasic` [padding 20])+ | otherwise = spacer `nodeVisible` False+ maybeAlert = case model.alertContents of AlertNotShown -> spacer `nodeVisible` False@@ -134,31 +142,21 @@ CancelRequest [titleCaption "Getting User Information"] (label "Wait or cancel by closing this alert..." `styleBasic` [padding 20])- AlertRequestingOpenFile _ ->+ AlertMessage {title, body} -> alert_- CancelRequest- [titleCaption "Opening File..."]- (label "Wait or cancel by closing this alert..." `styleBasic` [padding 20])+ CloseAlert+ [titleCaption title]+ (label_ body [multiline] `styleBasic` [padding 20]) AlertUserInformation info -> alert_ CloseAlert [titleCaption "Get User Information Response"] (userInfoAlertContents info `styleBasic` [padding 20])- AlertOpenFile results ->- alert_- CloseAlert- [titleCaption "Open File Response"]- (openFileAlertContents results `styleBasic` [padding 20]) AlertSettings results -> alert_ CloseAlert [titleCaption "Read Settings Response"] (settingsAlertContents results `styleBasic` [height 400, width 800, padding 10])- AlertRequestFailed msg ->- alert_- CloseAlert- [titleCaption "Portal error"]- (label_ msg [multiline] `styleBasic` [padding 20]) userInfoAlertContents results = vstack_@@ -169,14 +167,6 @@ label ("User Image: " <> maybe "[none]" pack results.image) ] - openFileAlertContents results =- vstack_- [childSpacing]- [ label "Request successful.",- label ("Selected Files: " <> intercalate ", " (pack <$> results.uris)),- label ("Selected Choices: " <> pack (show results.choices))- ]- settingsAlertContents :: ReadAllResults -> WidgetNode () AppEvent settingsAlertContents results = hagrid@@ -233,19 +223,8 @@ [Model model {alertContents = AlertRequestingUserInformation res}] GetUserInformationFinish info -> [Model model {alertContents = AlertUserInformation info}]- OpenFile ->- [ Producer $ \emit -> do- catchRequestErrors emit $ do- req <- Portal.openFile model.portalClient def- emit (OpenFileStart req)- Portal.await req >>= \case- Nothing -> emit CloseAlert- Just result -> emit (OpenFileFinish result)- ]- OpenFileStart res ->- [Model model {alertContents = AlertRequestingOpenFile res}]- OpenFileFinish results ->- [Model model {alertContents = AlertOpenFile results}]+ SetShowDocuments showDocuments ->+ [Model model {showDocuments}] AddNotification -> [ Producer $ \emit -> do catchRequestErrors emit $@@ -273,10 +252,10 @@ catchRequestErrors emit $ do void (Portal.openURI model.portalClient (openURIOptions [uri|https://www.bbc.com/weather|])) ]+ ShowAlertMessage {title, body} ->+ [Model model {alertContents = AlertMessage {title, body}}] CancelRequest -> let cancel = case model.alertContents of- AlertRequestingOpenFile res ->- [Producer (const (Portal.cancel res))] AlertRequestingUserInformation res -> [Producer (const (Portal.cancel res))] _ -> []@@ -284,7 +263,7 @@ CloseAlert -> [Model model {alertContents = AlertNotShown}] RequestFailed msg ->- [Model model {alertContents = AlertRequestFailed msg}]+ [Model model {alertContents = AlertMessage "Portal Error" msg}] catchRequestErrors :: (AppEvent -> IO ()) -> IO () -> IO () catchRequestErrors emit cmd = catch cmd handler
assets/io.github.Dretch.MonomerFlatpakExample.metainfo.xml view
@@ -23,6 +23,7 @@ </screenshots> <releases>+ <release version="0.0.10.0" date="2023-08-27"/> <release version="0.0.9.0" date="2023-06-03"/> <release version="0.0.8.0" date="2023-05-26"/> <release version="0.0.7.0" date="2023-05-03"/>
monomer-flatpak-example.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: monomer-flatpak-example-version: 0.0.9.0+version: 0.0.10.0 license: MIT license-file: LICENSE maintainer: garethdanielsmith@gmail.com@@ -27,7 +27,10 @@ executable monomer-flatpak-example main-is: Main.hs hs-source-dirs: app- other-modules: Paths_monomer_flatpak_example+ other-modules:+ Documents+ Paths_monomer_flatpak_example+ default-language: Haskell2010 default-extensions: DisambiguateRecordFields DuplicateRecordFields FlexibleContexts@@ -44,11 +47,11 @@ base >=4.7 && <5, containers <0.7, data-default-class <0.2,- dbus <1.3,+ dbus <1.4, desktop-portal <0.3, directory <1.4, modern-uri <0.4, monomer <1.6, monomer-hagrid <0.4, random <1.3,- text <1.3+ text <2.1