FileChooser.hs

module Desktop.Portal.FileChooser
  ( -- * Common Types
    Filter (..),
    FilterFileType (..),
    ChoiceCombo (..),
    ChoiceComboOption (..),
    ChoiceComboSelection (..),

    -- * Open File
    OpenFileOptions (..),
    OpenFileResults (..),
    openFile,

    -- * Save File
    SaveFileOptions (..),
    SaveFileResults (..),
    saveFile,
  )
where

import Control.Exception (throwIO)
import DBus (InterfaceName, Variant)
import DBus qualified
import DBus.Client qualified as DBus
import Data.Default (Default (def))
import Data.Map (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import Data.Word (Word32)
import Desktop.Portal.Internal (Client, Request, sendRequest)
import Desktop.Portal.Util (decodeFileUris, encodeNullTerminated, mapJust, optionalFromVariant, toVariantPair, toVariantPair')
import System.OsPath (OsPath)

data Filter = Filter
  { name :: Text,
    fileTypes :: [FilterFileType]
  }
  deriving (Eq, Show)

data FilterFileType
  = GlobFilter Text
  | MimeFilter Text
  deriving (Eq, Show)

data ChoiceCombo = ChoiceCombo
  { id :: Text,
    label_ :: Text,
    choices :: [ChoiceComboOption],
    defaultChoiceId :: Text
  }
  deriving (Eq, Show)

data ChoiceComboOption = ChoiceComboOption
  { id :: Text,
    label_ :: Text
  }
  deriving (Eq, Show)

data ChoiceComboSelection = ChoiceComboSelection
  { comboId :: Text,
    optionId :: Text
  }
  deriving (Eq, Show)

data OpenFileOptions = OpenFileOptions
  { parentWindow :: Maybe Text,
    title :: Maybe Text,
    acceptLabel :: Maybe Text,
    modal :: Maybe Bool,
    multiple :: Maybe Bool,
    directory :: Maybe Bool,
    filters :: Maybe [Filter],
    currentFilter :: Maybe Filter,
    choices :: Maybe [ChoiceCombo]
  }
  deriving (Eq, Show)

instance Default OpenFileOptions where
  def =
    OpenFileOptions
      { parentWindow = Nothing,
        title = Nothing,
        acceptLabel = Nothing,
        modal = Nothing,
        multiple = Nothing,
        directory = Nothing,
        filters = Nothing,
        currentFilter = Nothing,
        choices = Nothing
      }

data OpenFileResults = OpenFileResults
  { uris :: [OsPath],
    choices :: Maybe [ChoiceComboSelection],
    currentFilter :: Maybe Filter
  }
  deriving (Eq, Show)

data SaveFileOptions = SaveFileOptions
  { parentWindow :: Maybe Text,
    title :: Maybe Text,
    acceptLabel :: Maybe Text,
    modal :: Maybe Bool,
    filters :: Maybe [Filter],
    currentFilter :: Maybe Filter,
    choices :: Maybe [ChoiceCombo],
    currentName :: Maybe Text,
    currentFolder :: Maybe OsPath,
    currentFile :: Maybe OsPath
  }
  deriving (Eq, Show)

instance Default SaveFileOptions where
  def =
    SaveFileOptions
      { parentWindow = Nothing,
        title = Nothing,
        acceptLabel = Nothing,
        modal = Nothing,
        filters = Nothing,
        currentFilter = Nothing,
        choices = Nothing,
        currentName = Nothing,
        currentFolder = Nothing,
        currentFile = Nothing
      }

data SaveFileResults = SaveFileResults
  { uris :: [OsPath],
    choices :: Maybe [ChoiceComboSelection],
    currentFilter :: Maybe Filter
  }
  deriving (Eq, Show)

fileChooserInterface :: InterfaceName
fileChooserInterface = "org.freedesktop.portal.FileChooser"

openFile :: Client -> OpenFileOptions -> IO (Request OpenFileResults)
openFile client options =
  sendRequest client fileChooserInterface "OpenFile" args optionsArg parseOpenFileResponse
  where
    args = [DBus.toVariant parentWindow, DBus.toVariant title]
    parentWindow = fromMaybe "" options.parentWindow
    title = fromMaybe "" options.title
    optionsArg =
      Map.fromList . catMaybes $
        [ toVariantPair "accept_label" options.acceptLabel,
          toVariantPair "modal" options.modal,
          toVariantPair "multiple" options.multiple,
          toVariantPair "directory" options.directory,
          toVariantPair' (fmap encodeFilter) "filters" options.filters,
          toVariantPair' encodeFilter "current_filter" options.currentFilter,
          toVariantPair' (fmap encodeCombo) "choices" options.choices
        ]

saveFile :: Client -> SaveFileOptions -> IO (Request SaveFileResults)
saveFile client options =
  sendRequest client fileChooserInterface "SaveFile" args optionsArgs parseResponse
  where
    args = [DBus.toVariant parentWindow, DBus.toVariant title]
    parentWindow = fromMaybe "" options.parentWindow
    title = fromMaybe "" options.title
    optionsArgs =
      Map.fromList . catMaybes $
        [ toVariantPair "accept_label" options.acceptLabel,
          toVariantPair "modal" options.modal,
          toVariantPair' (fmap encodeFilter) "filters" options.filters,
          toVariantPair' encodeFilter "current_filter" options.currentFilter,
          toVariantPair' (fmap encodeCombo) "choices" options.choices,
          toVariantPair "current_name" options.currentName,
          toVariantPair "current_folder" (encodeNullTerminated <$> options.currentFolder),
          toVariantPair "current_file" (encodeNullTerminated <$> options.currentFile)
        ]

    parseResponse resMap = do
      OpenFileResults {uris, choices, currentFilter} <- parseOpenFileResponse resMap
      pure SaveFileResults {uris, choices, currentFilter}

parseOpenFileResponse :: Map Text Variant -> IO OpenFileResults
parseOpenFileResponse = \case
  resMap
    | Just uris <- decodeFileUris =<< DBus.fromVariant =<< Map.lookup "uris" resMap,
      Just choicesRaw <- optionalFromVariant "choices" resMap,
      choices <- fmap decodeChoiceComboSelection <$> choicesRaw,
      Just currentFilterRaw <- optionalFromVariant "current_filter" resMap,
      Just currentFilter <- mapJust decodeFilter currentFilterRaw ->
        pure OpenFileResults {uris, choices, currentFilter}
  resMap ->
    throwIO . DBus.clientError $ "openFile: could not parse response: " <> show resMap

encodeFilter :: Filter -> (Text, [(Word32, Text)])
encodeFilter filtr =
  (filtr.name, encodeFilterFileType <$> filtr.fileTypes)

decodeFilter :: (Text, [(Word32, Text)]) -> Maybe Filter
decodeFilter (name, rawFileTypes) = do
  fileTypes <- traverse decodeFileType rawFileTypes
  pure Filter {name, fileTypes}

encodeFilterFileType :: FilterFileType -> (Word32, Text)
encodeFilterFileType = \case
  GlobFilter pat -> (0, pat)
  MimeFilter mime -> (1, mime)

decodeFileType :: (Word32, Text) -> Maybe FilterFileType
decodeFileType = \case
  (0, pat) -> Just (GlobFilter pat)
  (1, mime) -> Just (MimeFilter mime)
  _ -> Nothing

encodeCombo :: ChoiceCombo -> (Text, Text, [(Text, Text)], Text)
encodeCombo combo =
  ( combo.id,
    combo.label_,
    encodeComboOption <$> combo.choices,
    combo.defaultChoiceId
  )

encodeComboOption :: ChoiceComboOption -> (Text, Text)
encodeComboOption option =
  (option.id, option.label_)

decodeChoiceComboSelection :: (Text, Text) -> ChoiceComboSelection
decodeChoiceComboSelection =
  uncurry ChoiceComboSelection