Protocol.hs

-----------------------------------------------------------------------------

---- specification, see
-- See also 'MenuWidget'.
--
-----------------------------------------------------------------------------

-- |
-- Module      : System.Taffybar.Information.XDG.Protocol
-- Copyright   : 2017 Ulf Jasper
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ulf Jasper <ulf.jasper@web.de>
-- Stability   : unstable
-- Portability : unportable
--
-- Implementation of version 1.1 of the XDG "Desktop Menu
-- Specification", see
-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html
module System.Taffybar.Information.XDG.Protocol
  ( XDGMenu (..),
    DesktopEntryCondition (..),
    getApplicationEntries,
    getDirectoryDirs,
    getPreferredLanguages,
    getXDGDesktop,
    getXDGMenuFilenames,
    matchesCondition,
    readXDGMenu,
  )
where

import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Data.Char (toLower)
import Data.List
import Data.Maybe
import GHC.IO.Encoding
import Safe (headMay)
import System.Directory
import System.Environment
import System.Environment.XDG.DesktopEntry
import System.FilePath.Posix
import System.Log.Logger
import System.Posix.Files
import System.Taffybar.Util
import Text.XML.Light
import Text.XML.Light.Helpers

getXDGMenuPrefix :: IO (Maybe String)
getXDGMenuPrefix = lookupEnv "XDG_MENU_PREFIX"

-- | Find filename(s) of the application menu(s).
getXDGMenuFilenames ::
  -- | Overrides the value of the environment variable
  -- XDG_MENU_PREFIX. Specifies the prefix for the menu (e.g.
  -- 'Just "mate-"').
  Maybe String ->
  IO [FilePath]
getXDGMenuFilenames mMenuPrefix = do
  configDirs <-
    liftA2
      (:)
      (getXdgDirectory XdgConfig "")
      (getXdgDirectoryList XdgConfigDirs)
  maybePrefix <- (mMenuPrefix <|>) <$> getXDGMenuPrefix
  let maybeAddDash "" = ""
      maybeAddDash t =
        case unsnoc t of
          Just (_, '-') -> t
          _ -> t ++ "-"
      prefixes =
        case maybePrefix of
          Nothing -> [""]
          Just prefix ->
            let dashedPrefix = maybeAddDash prefix
             in if null dashedPrefix then [""] else [dashedPrefix, ""]
      menuFilename prefix dir =
        dir </> "menus" </> (prefix ++ "applications.menu")
  return [menuFilename prefix dir | prefix <- prefixes, dir <- configDirs]

-- | XDG Menu, cf. "Desktop Menu Specification".
data XDGMenu = XDGMenu
  { xmAppDir :: Maybe String,
    xmDefaultAppDirs :: Bool, -- Use $XDG_DATA_DIRS/applications
    xmDirectoryDir :: Maybe String,
    xmDefaultDirectoryDirs :: Bool, -- Use $XDG_DATA_DIRS/desktop-directories
    xmLegacyDirs :: [String],
    xmName :: String,
    xmDirectory :: String,
    xmOnlyUnallocated :: Bool,
    xmDeleted :: Bool,
    xmInclude :: Maybe DesktopEntryCondition,
    xmExclude :: Maybe DesktopEntryCondition,
    xmSubmenus :: [XDGMenu],
    xmLayout :: [XDGLayoutItem]
  }
  deriving (Show)

data XDGLayoutItem
  = XliFile String
  | XliSeparator
  | XliMenu String
  | XliMerge String
  deriving (Show)

-- | Return a list of all available desktop entries for a given xdg menu.
getApplicationEntries ::
  -- | Preferred languages
  [String] ->
  XDGMenu ->
  IO [DesktopEntry]
getApplicationEntries langs xm = do
  defEntries <-
    if xmDefaultAppDirs xm
      then do
        dataDirs <- getXDGDataDirs
        concat
          <$> mapM
            ( listDesktopEntries ".desktop"
                . (</> "applications")
            )
            dataDirs
      else return []
  return $
    sortBy
      ( \de1 de2 ->
          compare
            (map toLower (deName langs de1))
            (map toLower (deName langs de2))
      )
      defEntries

-- | Parse menu.
parseMenu :: Element -> Maybe XDGMenu
parseMenu elt =
  let appDir = getChildData "AppDir" elt
      defaultAppDirs = isJust $ getChildData "DefaultAppDirs" elt
      directoryDir = getChildData "DirectoryDir" elt
      defaultDirectoryDirs = isJust $ getChildData "DefaultDirectoryDirs" elt
      name = fromMaybe "Name?" $ getChildData "Name" elt
      dir = fromMaybe "Dir?" $ getChildData "Directory" elt
      onlyUnallocated =
        case ( getChildData "OnlyUnallocated" elt,
               getChildData "NotOnlyUnallocated" elt
             ) of
          (Nothing, Nothing) -> False -- ?!
          (Nothing, Just _) -> False
          (Just _, Nothing) -> True
          (Just _, Just _) -> False -- ?!
      deleted = False -- FIXME
      include = parseConditions "Include" elt
      exclude = parseConditions "Exclude" elt
      layout = parseLayout elt
      subMenus = fromMaybe [] $ mapChildren "Menu" elt parseMenu
   in Just
        XDGMenu
          { xmAppDir = appDir,
            xmDefaultAppDirs = defaultAppDirs,
            xmDirectoryDir = directoryDir,
            xmDefaultDirectoryDirs = defaultDirectoryDirs,
            xmLegacyDirs = [],
            xmName = name,
            xmDirectory = dir,
            xmOnlyUnallocated = onlyUnallocated,
            xmDeleted = deleted,
            xmInclude = include,
            xmExclude = exclude,
            xmSubmenus = subMenus,
            xmLayout = layout -- FIXME
          }

-- | Parse Desktop Entry conditions for Include/Exclude clauses.
parseConditions :: String -> Element -> Maybe DesktopEntryCondition
parseConditions key elt = case findChild (unqual key) elt of
  Nothing -> Nothing
  Just inc -> doParseConditions (elChildren inc)
  where
    doParseConditions :: [Element] -> Maybe DesktopEntryCondition
    doParseConditions [] = Nothing
    doParseConditions [e] = parseSingleItem e
    doParseConditions elts = Just $ Or $ mapMaybe parseSingleItem elts

    parseSingleItem e = case qName (elName e) of
      "Category" -> Just $ Category $ strContent e
      "Filename" -> Just $ Filename $ strContent e
      "And" ->
        Just $
          And $
            mapMaybe parseSingleItem $
              elChildren e
      "Or" ->
        Just $
          Or $
            mapMaybe parseSingleItem $
              elChildren e
      "Not" -> Not <$> (parseSingleItem =<< listToMaybe (elChildren e))
      _ -> Nothing

-- | Combinable conditions for Include and Exclude statements.
data DesktopEntryCondition
  = Category String
  | Filename String
  | Not DesktopEntryCondition
  | And [DesktopEntryCondition]
  | Or [DesktopEntryCondition]
  | All
  | None
  deriving (Read, Show, Eq)

parseLayout :: Element -> [XDGLayoutItem]
parseLayout elt = case findChild (unqual "Layout") elt of
  Nothing -> []
  Just lt -> mapMaybe parseLayoutItem (elChildren lt)
  where
    parseLayoutItem :: Element -> Maybe XDGLayoutItem
    parseLayoutItem e = case qName (elName e) of
      "Separator" -> Just XliSeparator
      "Filename" -> Just $ XliFile $ strContent e
      _ -> Nothing

-- | Determine whether a desktop entry fulfils a condition.
matchesCondition :: DesktopEntry -> DesktopEntryCondition -> Bool
matchesCondition de (Category cat) = deHasCategory de cat
matchesCondition de (Filename fn) = fn == deFilename de
matchesCondition de (Not cond) = not $ matchesCondition de cond
matchesCondition de (And conds) = all (matchesCondition de) conds
matchesCondition de (Or conds) = any (matchesCondition de) conds
matchesCondition _ All = True
matchesCondition _ None = False

-- | Determine locale language settings
getPreferredLanguages :: IO [String]
getPreferredLanguages = do
  mLcMessages <- lookupEnv "LC_MESSAGES"
  lang <- case mLcMessages of
    Nothing -> lookupEnv "LANG" -- FIXME?
    Just lm -> return (Just lm)
  case lang of
    Nothing -> return []
    Just l ->
      return $
        let woEncoding = takeWhile (/= '.') l
            (language, _cm) = span (/= '_') woEncoding
            (country, _m) = span (/= '@') (drop 1 _cm)
            modifier = drop 1 _m
         in dgl language country modifier
  where
    dgl "" "" "" = []
    dgl l "" "" = [l]
    dgl l c "" = [l ++ "_" ++ c, l]
    dgl l "" m = [l ++ "@" ++ m, l]
    dgl l c m =
      [ l ++ "_" ++ c ++ "@" ++ m,
        l ++ "_" ++ c,
        l ++ "@" ++ m
      ]

-- | Determine current Desktop
getXDGDesktop :: IO String
getXDGDesktop = do
  mCurDt <- lookupEnv "XDG_CURRENT_DESKTOP"
  return $ fromMaybe "???" mCurDt

-- | Return desktop directories
getDirectoryDirs :: IO [FilePath]
getDirectoryDirs = do
  dataDirs <- getXDGDataDirs
  filterM (fileExist . (</> "desktop-directories")) dataDirs

-- | Fetch menus and desktop entries and assemble the XDG menu.
readXDGMenu :: Maybe String -> IO (Maybe (XDGMenu, [DesktopEntry]))
readXDGMenu mMenuPrefix = do
  setLocaleEncoding utf8
  filenames <- getXDGMenuFilenames mMenuPrefix
  headMay . catMaybes <$> traverse maybeMenu filenames

-- | Load and assemble the XDG menu from a specific file, if it exists.
maybeMenu :: FilePath -> IO (Maybe (XDGMenu, [DesktopEntry]))
maybeMenu filename =
  ifM
    (doesFileExist filename)
    ( do
        contents <- readFile filename
        langs <- getPreferredLanguages
        runMaybeT $ do
          m <- MaybeT $ return $ parseXMLDoc contents >>= parseMenu
          des <- lift $ getApplicationEntries langs m
          return (m, des)
    )
    ( do
        logM "System.Taffybar.Information.XDG.Protocol" WARNING $
          "Menu file '" ++ filename ++ "' does not exist!"
        return Nothing
    )