{-# OPTIONS_HADDOCK hide #-}
module System.Taffybar.Menu.XdgMenu (
XdgMenu(..),
DesktopEntryCondition(..),
readXdgMenu,
matchesCondition,
getXdgDesktop,
getDirectoryDirs,
getApplicationEntries,
getPreferredLanguages)
where
import Control.Applicative
import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import Data.Char (toLower)
import Data.List
import Data.Maybe
import qualified Data.Set as S
import qualified Debug.Trace as D
import GHC.IO.Encoding
import Prelude
import Safe (headMay)
import System.Directory
import System.Environment
import System.FilePath.Posix
import System.Posix.Files
import System.Taffybar.Menu.DesktopEntry
import System.Taffybar.Util
import Text.XML.Light
import Text.XML.Light.Helpers
getXdgConfigDirs :: IO [String]
getXdgConfigDirs = do
ch <- lookupEnv "XDG_CONFIG_HOME"
cd <- lookupEnv "XDG_CONFIG_DIRS"
let dirs = catMaybes [ch]
++ maybe [] splitSearchPath cd
exDirs <- existingDirs dirs
return $ if null exDirs
then ["/etc/xdg/"]
else map normalise exDirs
existingDirs :: [FilePath] -> IO [FilePath]
existingDirs dirs = do
exs <- mapM fileExist dirs
return $ S.toList $ S.fromList $ map fst $ filter snd $ zip dirs exs
getXdgMenuPrefix :: IO (Maybe String)
getXdgMenuPrefix = lookupEnv "XDG_MENU_PREFIX"
getXdgDataDirs :: IO [String]
getXdgDataDirs = do
mDh <- lookupEnv "XDG_DATA_HOME"
dh <- case mDh of
Nothing -> do h <- getHomeDirectory
return $ h </> ".local" </> "share"
Just d -> return d
mPf <- lookupEnv "XDG_DATA_DIRS"
let dirs = maybe [] (map normalise . splitSearchPath) mPf
++ ["/usr/local/share", "/usr/share"]
nubBy equalFilePath <$> existingDirs (dh:dirs)
getXdgMenuFilenames :: Maybe String
-> IO [FilePath]
getXdgMenuFilenames mMenuPrefix = do
configDirs <- getXdgConfigDirs
maybePrefix <- (mMenuPrefix <|>) <$> getXdgMenuPrefix
let maybeAddDash t = if last t == '-' then t else t ++ "-"
dashedPrefix = maybe "" maybeAddDash maybePrefix
return $ map (</> "menus" </> dashedPrefix ++ "applications.menu") configDirs
data XdgMenu = XdgMenu {
xmAppDir :: Maybe String,
xmDefaultAppDirs :: Bool,
xmDirectoryDir :: Maybe String,
xmDefaultDirectoryDirs :: Bool,
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)
getApplicationEntries :: [String]
-> XdgMenu
-> IO [DesktopEntry]
getApplicationEntries langs xm = do
defEntries <- if xmDefaultAppDirs xm
then do dataDirs <- getXdgDataDirs
putStrLn $ "DataDirs=" ++ show dataDirs
concat <$> mapM (listDesktopEntries ".desktop" .
(</> "applications")) dataDirs
else return []
return $ sortBy (\de1 de2 -> compare (map toLower (deName langs de1))
(map toLower (deName langs de2))) defEntries
parseMenu :: Element -> Maybe XdgMenu
parseMenu elt =
let appDir = getChildData "AppDir" elt
defaultAppDirs = case getChildData "DefaultAppDirs" elt of
Nothing -> False
Just _ -> True
directoryDir = getChildData "DirectoryDir" elt
defaultDirectoryDirs = case getChildData "DefaultDirectoryDirs" elt of
Nothing -> False
Just _ -> True
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
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}
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
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
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
getPreferredLanguages :: IO [String]
getPreferredLanguages = do
mLcMessages <- lookupEnv "LC_MESSAGES"
lang <- case mLcMessages of
Nothing -> lookupEnv "LANG"
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]
getXdgDesktop :: IO String
getXdgDesktop = do
mCurDt <- lookupEnv "XDG_CURRENT_DESKTOP"
return $ fromMaybe "???" mCurDt
getDirectoryDirs :: IO [FilePath]
getDirectoryDirs = do
dataDirs <- getXdgDataDirs
existingDirs $ map (</> "desktop-directories") dataDirs
readXdgMenu :: Maybe String -> IO (Maybe (XdgMenu, [DesktopEntry]))
readXdgMenu mMenuPrefix = do
setLocaleEncoding utf8
filenames <- getXdgMenuFilenames mMenuPrefix
headMay . catMaybes <$> traverse maybeMenu filenames
maybeMenu :: FilePath -> IO (Maybe (XdgMenu, [DesktopEntry]))
maybeMenu filename =
ifM (doesFileExist filename)
(do
putStrLn $ "Reading " ++ filename
contents <- readFile filename
langs <- getPreferredLanguages
runMaybeT $ do
m <- MaybeT $ return $ parseXMLDoc contents >>= parseMenu
des <- lift $ getApplicationEntries langs m
return (m, des))
(do
putStrLn $ "Error: menu file '" ++ filename ++ "' does not exist!"
return Nothing)