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 qualified Debug.Trace as D
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 t = if last t == '-' then t else t ++ "-"
      dashedPrefix = maybe "" maybeAddDash maybePrefix
  return $ map (</> "menus" </> dashedPrefix ++ "applications.menu") 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))
      unknown -> D.trace ("Unknown Condition item: " ++ unknown) 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
      unknown -> D.trace ("Unknown layout item: " ++ unknown) 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
    )