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)