taffybar-3.2.2: src/System/Taffybar/Information/XDG/Protocol.hs
-----------------------------------------------------------------------------
-- |
-- 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
---- specification, see
-- See also 'MenuWidget'.
--
-----------------------------------------------------------------------------
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 Prelude
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
:: Maybe String -- ^ Overrides the value of the environment variable
-- XDG_MENU_PREFIX. Specifies the prefix for the menu (e.g.
-- 'Just "mate-"').
-> 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
:: [String] -- ^ Preferred languages
-> 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" -> case parseSingleItem (head (elChildren e)) of
Nothing -> Nothing
Just rule -> Just $ Not rule
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 (/= '@') (if null _cm then "" else tail _cm)
modifier = if null _m then "" else tail _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)