----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Information.XDG.Protocol -- Copyright : 2017 Ulf Jasper -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ulf Jasper -- 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)