{-# LANGUAGE QuasiQuotes #-}
module Documents (documents) where
import Control.Exception (SomeException, catch)
import Control.Monad (forM, forM_, void, when)
import Data.Bool (bool)
import Data.Default (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, FileSpec (..))
import Desktop.Portal qualified as Portal
import Desktop.Portal.Documents (DocumentId (..))
import Desktop.Portal.Documents qualified as Documents
import Desktop.Portal.FileChooser (OpenFileOptions (..), OpenFileResults)
import Monomer
import Monomer.Hagrid
import System.Directory.OsPath (doesDirectoryExist, getDirectoryContents)
import System.File.OsPath (writeFile)
import System.OsPath (OsPath, osp, (</>))
import System.OsPath qualified as OsPath
import Util (getXdgDataDir, osPathToText)
import Prelude hiding (writeFile)
data DocumentsModel = DocumentsModel
{ portalClient :: Client,
mountPoint :: OsPath,
documents :: Seq Document
}
deriving (Eq, Show)
data Document = Document
{ id :: DocumentId,
ls :: Text,
selected :: Bool
}
deriving (Eq, Show)
data DocumentsEvent
= RefreshDocuments
| RefreshDocumentsFinish OsPath (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 = [osp|...|],
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 from $XDG_DATA_HOME" 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 <- (</> [osp|hello.txt|]) <$> getXdgDataDir
writeFile filePath "Hello!"
catchErrors "Add File Failed" emit $ do
void (Documents.add model.portalClient (FileSpecPath 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 ", " (osPathToText <$> results.uris)
<> "\n"
<> "Selected Choices: "
<> pack (show results.choices)
getDocuments :: OsPath -> IO (Seq Document)
getDocuments storePath = do
paths <- getDirectoryContents storePath
flip foldMap paths $ \path -> do
let fullPath = storePath </> path
isDir <- doesDirectoryExist fullPath
if isDir && path /= [osp|by-app|] && path /= [osp|.|] && path /= [osp|..|]
then do
ls <- lsRecursive fullPath
docId <- pack <$> OsPath.decodeUtf path
pure (Seq.singleton Document {id = DocumentId docId, ls, selected = False})
else pure mempty
lsRecursive :: OsPath -> IO Text
lsRecursive path = do
displayPath <- withSlashIfDir path path
childOutputs <- lsRecursive' "" path mempty
pure . toStrict . Builder.toLazyText $
displayPath <> "\n" <> childOutputs
where
lsRecursive' :: Builder -> OsPath -> OsPath -> 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 == [osp|.|] || childPath == [osp|..|]
then pure ""
else lsRecursive' (indent <> " ") fullPath childPath
displayPath <- withSlashIfDir fullPath fileName
if fileName == mempty
then pure (mconcat childOutputs)
else pure (indent <> displayPath <> "\n" <> mconcat childOutputs)
withSlashIfDir :: OsPath -> OsPath -> IO Builder
withSlashIfDir fullPath displayPath = do
slash <- bool "" "/" <$> doesDirectoryExist fullPath
filePath <- OsPath.decodeUtf displayPath
pure (Builder.fromString filePath <> slash)