xmonad-config/lib/XMonad/Internal/Dependency.hs

288 lines
9.0 KiB
Haskell
Raw Normal View History

--------------------------------------------------------------------------------
-- | Functions for handling dependencies
module XMonad.Internal.Dependency
2021-11-19 00:35:54 -05:00
( MaybeExe
, UnitType(..)
, Dependency(..)
, Bus(..)
, Endpoint(..)
2021-11-07 20:16:53 -05:00
, DBusMember(..)
, Warning(..)
, MaybeX
2021-11-20 01:15:04 -05:00
, FeatureX
, FeatureIO
2021-11-11 00:11:15 -05:00
, Feature(..)
2021-11-20 01:15:04 -05:00
, ioFeature
2021-11-11 00:11:15 -05:00
, evalFeature
, systemUnit
, userUnit
, pathR
, pathW
, pathRW
2021-11-20 01:15:04 -05:00
, featureRun
, featureSpawnCmd
, featureSpawn
, warnMissing
, whenInstalled
, ifInstalled
, fmtCmd
, spawnCmd
2021-11-20 15:20:22 -05:00
, executeFeature
, executeFeature_
, applyFeature
, applyFeature_
) where
import Control.Monad.IO.Class
import Data.Bifunctor (bimap)
2021-11-19 00:35:54 -05:00
import Data.List (find)
import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
2021-11-07 20:16:53 -05:00
import DBus
import DBus.Client
2021-11-08 00:27:39 -05:00
import qualified DBus.Introspection as I
import System.Directory (findExecutable, readable, writable)
import System.Environment
import System.Exit
2021-11-20 15:20:22 -05:00
import XMonad.Core (X, io)
import XMonad.Internal.IO
import XMonad.Internal.Process
import XMonad.Internal.Shell
--------------------------------------------------------------------------------
-- | Gracefully handling missing binaries
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
2021-11-07 20:16:53 -05:00
data DBusMember = Method_ MemberName
| Signal_ MemberName
| Property_ String
deriving (Eq, Show)
data Bus = Bus Bool BusName deriving (Eq, Show)
data Endpoint = Endpoint ObjectPath InterfaceName DBusMember deriving (Eq, Show)
2021-11-20 11:48:05 -05:00
data Dependency = Executable String
| AccessiblePath FilePath Bool Bool
2021-11-19 00:35:54 -05:00
| IOTest (IO (Maybe String))
| DBusEndpoint Bus Endpoint
| DBusBus Bus
| Systemd UnitType String
2021-11-11 00:11:15 -05:00
data Warning = Silent | Default
2021-11-20 11:48:05 -05:00
data Feature a = Feature
2021-11-11 00:11:15 -05:00
{ ftrAction :: a
, ftrName :: String
, ftrWarning :: Warning
2021-11-20 11:48:05 -05:00
, ftrChildren :: [Dependency]
2021-11-20 01:15:04 -05:00
}
| ConstFeature a
| BlankFeature
2021-11-20 11:48:05 -05:00
type FeatureX = Feature (X ())
2021-11-11 00:11:15 -05:00
2021-11-20 11:48:05 -05:00
type FeatureIO = Feature (IO ())
2021-11-20 01:15:04 -05:00
2021-11-20 11:48:05 -05:00
ioFeature :: (MonadIO m) => Feature (IO a) -> Feature (m a)
ioFeature f@Feature { ftrAction = a } = f { ftrAction = liftIO a }
ioFeature (ConstFeature f) = ConstFeature $ liftIO f
ioFeature BlankFeature = BlankFeature
2021-11-19 00:35:54 -05:00
2021-11-20 11:48:05 -05:00
evalFeature :: Feature a -> IO (MaybeExe a)
2021-11-19 00:35:54 -05:00
evalFeature (ConstFeature x) = return $ Right x
2021-11-20 01:15:04 -05:00
evalFeature BlankFeature = return $ Left []
evalFeature Feature
{ ftrAction = a
, ftrName = n
, ftrWarning = w
, ftrChildren = c
} = do
procName <- getProgName
es <- catMaybes <$> mapM evalDependency c
return $ case es of
2021-11-19 00:35:54 -05:00
[] -> Right a
es' -> Left $ fmtWarnings procName es'
2021-11-11 00:11:15 -05:00
where
fmtWarnings procName es = case w of
Silent -> []
Default -> fmap (fmtMsg procName "WARNING" . ((n ++ " disabled; ") ++)) es
2021-11-20 11:48:05 -05:00
pathR :: String -> Dependency
pathR n = AccessiblePath n True False
2021-11-20 11:48:05 -05:00
pathW :: String -> Dependency
pathW n = AccessiblePath n False True
2021-11-20 11:48:05 -05:00
pathRW :: String -> Dependency
pathRW n = AccessiblePath n True True
2021-11-20 11:48:05 -05:00
systemUnit :: String -> Dependency
systemUnit = Systemd SystemUnit
2021-11-20 11:48:05 -05:00
userUnit :: String -> Dependency
userUnit = Systemd UserUnit
-- TODO this is poorly named. This actually represents an action that has
-- one or more dependencies (where "action" is not necessarily executing an exe)
2021-11-19 00:35:54 -05:00
type MaybeExe a = Either [String] a
type MaybeX = MaybeExe (X ())
featureRun :: String -> [Dependency] -> a -> Feature a
featureRun n ds x = Feature
2021-11-20 01:15:04 -05:00
{ ftrAction = x
, ftrName = n
, ftrWarning = Default
2021-11-20 01:15:04 -05:00
, ftrChildren = ds
}
featureSpawnCmd :: MonadIO m => String -> String -> [String] -> Feature (m ())
featureSpawnCmd n cmd args = featureRun n [Executable cmd] $ spawnCmd cmd args
2021-11-20 01:15:04 -05:00
featureSpawn :: MonadIO m => String -> String -> Feature (m ())
featureSpawn n cmd = featureSpawnCmd n cmd []
2021-11-20 01:15:04 -05:00
2021-11-19 00:35:54 -05:00
exeInstalled :: String -> IO (Maybe String)
exeInstalled x = do
r <- findExecutable x
return $ case r of
(Just _) -> Nothing
_ -> Just $ "executable '" ++ x ++ "' not found"
2021-11-19 00:35:54 -05:00
unitInstalled :: UnitType -> String -> IO (Maybe String)
unitInstalled u x = do
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
return $ case rc of
2021-11-19 00:35:54 -05:00
ExitSuccess -> Nothing
_ -> Just $ "systemd " ++ unitType u ++ " unit '" ++ x ++ "' not found"
where
cmd = fmtCmd "systemctl" $ ["--user" | u == UserUnit] ++ ["status", x]
2021-11-19 00:35:54 -05:00
unitType SystemUnit = "system"
unitType UserUnit = "user"
2021-11-19 00:35:54 -05:00
pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String)
pathAccessible p testread testwrite = do
res <- getPermissionsSafe p
let msg = permMsg res
return msg
where
testPerm False _ _ = Nothing
testPerm True f r = Just $ f r
2021-11-19 00:35:54 -05:00
permMsg NotFoundError = Just "file not found"
permMsg PermError = Just "could not get permissions"
permMsg (PermResult r) =
case (testPerm testread readable r, testPerm testwrite writable r) of
2021-11-19 00:35:54 -05:00
(Just False, Just False) -> Just "file not readable or writable"
(Just False, _) -> Just "file not readable"
(_, Just False) -> Just "file not writable"
_ -> Nothing
2021-11-08 00:27:39 -05:00
introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect"
callMethod :: Bus -> ObjectPath -> InterfaceName -> MemberName -> IO (Either String [Variant])
callMethod (Bus usesys bus) path iface mem = do
client <- if usesys then connectSystem else connectSession
reply <- call client (methodCall path iface mem)
2021-11-08 00:27:39 -05:00
{ methodCallDestination = Just bus }
2021-11-07 20:16:53 -05:00
disconnect client
return $ bimap methodErrorMessage methodReturnBody reply
dbusBusExists :: Bus -> IO (Maybe String)
dbusBusExists (Bus usesystem bus) = do
ret <- callMethod (Bus usesystem queryBus) queryPath queryIface queryMem
return $ case ret of
Left e -> Just e
Right b -> let ns = bodyGetNames b in
if bus' `elem` ns then Nothing
else Just $ unwords ["name", singleQuote bus', "not found on dbus"]
2021-11-07 20:16:53 -05:00
where
bus' = formatBusName bus
queryBus = busName_ "org.freedesktop.DBus"
queryIface = interfaceName_ "org.freedesktop.DBus"
queryPath = objectPath_ "/"
queryMem = memberName_ "ListNames"
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
bodyGetNames _ = []
dbusEndpointExists :: Bus -> Endpoint -> IO (Maybe String)
dbusEndpointExists b@(Bus _ bus) (Endpoint objpath iface mem) = do
ret <- callMethod b objpath introspectInterface introspectMethod
return $ case ret of
Left e -> Just e
Right body -> procBody body
where
procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
=<< listToMaybe body in
case res of
Just True -> Nothing
_ -> Just $ fmtMsg' mem
findMem = fmap (matchMem mem)
. find (\i -> I.interfaceName i == iface)
. I.objectInterfaces
matchMem (Method_ n) = elemMember n I.methodName I.interfaceMethods
matchMem (Signal_ n) = elemMember n I.signalName I.interfaceSignals
matchMem (Property_ n) = elemMember n I.propertyName I.interfaceProperties
elemMember n fname fmember = elem n . fmap fname . fmember
fmtMem (Method_ n) = "method " ++ singleQuote (formatMemberName n)
fmtMem (Signal_ n) = "signal " ++ singleQuote (formatMemberName n)
fmtMem (Property_ n) = "property " ++ singleQuote n
fmtMsg' m = unwords
[ "could not find"
, fmtMem m
, "on interface"
, singleQuote $ formatInterfaceName iface
, "on bus"
, formatBusName bus
]
evalDependency :: Dependency -> IO (Maybe String)
evalDependency (Executable n) = exeInstalled n
evalDependency (IOTest t) = t
evalDependency (Systemd t n) = unitInstalled t n
evalDependency (AccessiblePath p r w) = pathAccessible p r w
evalDependency (DBusEndpoint b e) = dbusEndpointExists b e
evalDependency (DBusBus b) = dbusBusExists b
whenInstalled :: Monad m => MaybeExe (m ()) -> m ()
whenInstalled = flip ifInstalled skip
ifInstalled :: MaybeExe a -> a -> a
2021-11-19 00:35:54 -05:00
ifInstalled (Right x) _ = x
ifInstalled _ alt = alt
warnMissing :: [MaybeExe a] -> IO ()
warnMissing xs = warnMissing' $ concat $ [ m | (Left m) <- xs ]
2021-11-20 15:20:22 -05:00
warnMissing' :: [String] -> IO ()
warnMissing' = mapM_ putStrLn
applyFeature :: MonadIO m => (m a -> m a) -> a -> Feature (IO a) -> m a
applyFeature iof def ftr = do
a <- io $ evalFeature ftr
either (\es -> io $ warnMissing' es >> return def) (iof . io) a
applyFeature_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m ()
applyFeature_ iof = applyFeature iof ()
executeFeature :: MonadIO m => a -> Feature (IO a) -> m a
executeFeature = applyFeature id
executeFeature_ :: Feature (IO ()) -> IO ()
executeFeature_ = executeFeature ()
fmtMsg :: String -> String -> String -> String
fmtMsg procName level msg = unwords [bracket procName, bracket level, msg]
where
bracket s = "[" ++ s ++ "]"