2021-11-07 13:35:08 -05:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | Functions for handling dependencies
|
|
|
|
|
|
|
|
module XMonad.Internal.Dependency
|
2021-11-19 00:35:54 -05:00
|
|
|
( MaybeExe
|
2021-11-07 13:35:08 -05:00
|
|
|
, UnitType(..)
|
|
|
|
, Dependency(..)
|
2021-11-07 20:16:53 -05:00
|
|
|
, DBusMember(..)
|
2021-11-07 13:35:08 -05:00
|
|
|
, 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
|
2021-11-07 13:35:08 -05:00
|
|
|
, exe
|
|
|
|
, systemUnit
|
|
|
|
, userUnit
|
2021-11-07 18:41:25 -05:00
|
|
|
, pathR
|
|
|
|
, pathW
|
|
|
|
, pathRW
|
2021-11-20 01:15:04 -05:00
|
|
|
, featureRun
|
|
|
|
, featureSpawnCmd
|
|
|
|
, featureSpawn
|
2021-11-07 13:35:08 -05:00
|
|
|
, warnMissing
|
|
|
|
, whenInstalled
|
|
|
|
, ifInstalled
|
|
|
|
, fmtCmd
|
|
|
|
, spawnCmd
|
|
|
|
) where
|
|
|
|
|
|
|
|
import Control.Monad.IO.Class
|
|
|
|
|
2021-11-19 00:35:54 -05:00
|
|
|
import Data.List (find)
|
|
|
|
import Data.Maybe (listToMaybe, maybeToList)
|
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
|
2021-11-07 13:35:08 -05:00
|
|
|
|
2021-11-07 18:41:25 -05:00
|
|
|
import System.Directory (findExecutable, readable, writable)
|
2021-11-07 13:35:08 -05:00
|
|
|
import System.Exit
|
|
|
|
|
2021-11-20 01:15:04 -05:00
|
|
|
import XMonad.Core (X)
|
2021-11-07 18:41:25 -05:00
|
|
|
import XMonad.Internal.IO
|
2021-11-07 13:35:08 -05:00
|
|
|
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)
|
|
|
|
|
2021-11-20 11:48:05 -05:00
|
|
|
-- data DependencyData = Executable String
|
|
|
|
data Dependency = Executable String
|
2021-11-07 18:41:25 -05:00
|
|
|
| AccessiblePath FilePath Bool Bool
|
2021-11-19 00:35:54 -05:00
|
|
|
| IOTest (IO (Maybe String))
|
2021-11-07 20:16:53 -05:00
|
|
|
| DBusEndpoint
|
2021-11-08 00:27:39 -05:00
|
|
|
{ ddDbusBus :: BusName
|
|
|
|
, ddDbusSystem :: Bool
|
|
|
|
, ddDbusObject :: ObjectPath
|
2021-11-07 20:16:53 -05:00
|
|
|
, ddDbusInterface :: InterfaceName
|
2021-11-08 00:27:39 -05:00
|
|
|
, ddDbusMember :: DBusMember
|
2021-11-07 20:16:53 -05:00
|
|
|
}
|
2021-11-07 18:41:25 -05:00
|
|
|
| Systemd UnitType String
|
2021-11-11 00:11:15 -05:00
|
|
|
|
2021-11-20 11:48:05 -05:00
|
|
|
-- data Dependency a = SubFeature (Feature a a)
|
|
|
|
-- | Dependency DependencyData
|
2021-11-11 00:11:15 -05:00
|
|
|
|
2021-11-20 11:48:05 -05:00
|
|
|
data Feature a = Feature
|
2021-11-11 00:11:15 -05:00
|
|
|
{ ftrAction :: a
|
|
|
|
, ftrSilent :: Bool
|
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 []
|
2021-11-11 00:11:15 -05:00
|
|
|
evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do
|
2021-11-19 00:35:54 -05:00
|
|
|
es <- mapM go c
|
|
|
|
return $ case concat es of
|
|
|
|
[] -> Right a
|
|
|
|
es' -> Left (if s then [] else es')
|
2021-11-11 00:11:15 -05:00
|
|
|
where
|
2021-11-20 11:48:05 -05:00
|
|
|
go = fmap maybeToList . depInstalled
|
2021-11-07 13:35:08 -05:00
|
|
|
|
2021-11-20 11:48:05 -05:00
|
|
|
exe :: String -> Dependency
|
|
|
|
exe = Executable
|
2021-11-07 18:41:25 -05:00
|
|
|
|
2021-11-20 11:48:05 -05:00
|
|
|
path :: Bool -> Bool -> String -> Dependency
|
|
|
|
path r w n = AccessiblePath n r w
|
2021-11-07 13:35:08 -05:00
|
|
|
|
2021-11-20 11:48:05 -05:00
|
|
|
pathR :: String -> Dependency
|
2021-11-07 18:41:25 -05:00
|
|
|
pathR = path True False
|
|
|
|
|
2021-11-20 11:48:05 -05:00
|
|
|
pathW :: String -> Dependency
|
2021-11-07 18:41:25 -05:00
|
|
|
pathW = path False True
|
|
|
|
|
2021-11-20 11:48:05 -05:00
|
|
|
pathRW :: String -> Dependency
|
2021-11-07 18:41:25 -05:00
|
|
|
pathRW = path True True
|
|
|
|
|
2021-11-20 11:48:05 -05:00
|
|
|
systemUnit :: String -> Dependency
|
|
|
|
systemUnit = Systemd SystemUnit
|
2021-11-07 13:35:08 -05:00
|
|
|
|
2021-11-20 11:48:05 -05:00
|
|
|
userUnit :: String -> Dependency
|
|
|
|
userUnit = Systemd UserUnit
|
2021-11-07 13:35:08 -05:00
|
|
|
|
2021-11-07 18:41:25 -05:00
|
|
|
-- 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
|
2021-11-07 13:35:08 -05:00
|
|
|
|
|
|
|
type MaybeX = MaybeExe (X ())
|
|
|
|
|
2021-11-20 11:48:05 -05:00
|
|
|
featureRun :: [Dependency] -> a -> Feature a
|
2021-11-20 01:15:04 -05:00
|
|
|
featureRun ds x = Feature
|
|
|
|
{ ftrAction = x
|
|
|
|
, ftrSilent = False
|
|
|
|
, ftrChildren = ds
|
|
|
|
}
|
|
|
|
|
2021-11-20 11:48:05 -05:00
|
|
|
featureSpawnCmd :: MonadIO m => String -> [String] -> Feature (m ())
|
2021-11-20 01:15:04 -05:00
|
|
|
featureSpawnCmd cmd args = featureRun [exe cmd] $ spawnCmd cmd args
|
|
|
|
|
2021-11-20 11:48:05 -05:00
|
|
|
featureSpawn :: MonadIO m => String -> Feature (m ())
|
2021-11-20 01:15:04 -05:00
|
|
|
featureSpawn cmd = featureSpawnCmd cmd []
|
|
|
|
|
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-07 13:35:08 -05:00
|
|
|
|
2021-11-19 00:35:54 -05:00
|
|
|
unitInstalled :: UnitType -> String -> IO (Maybe String)
|
2021-11-07 18:41:25 -05:00
|
|
|
unitInstalled u x = do
|
2021-11-07 13:35:08 -05:00
|
|
|
(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"
|
2021-11-07 13:35:08 -05:00
|
|
|
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-07 13:35:08 -05:00
|
|
|
|
2021-11-19 00:35:54 -05:00
|
|
|
pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String)
|
2021-11-07 18:41:25 -05:00
|
|
|
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"
|
2021-11-07 18:41:25 -05:00
|
|
|
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-07 18:41:25 -05:00
|
|
|
|
2021-11-08 00:27:39 -05:00
|
|
|
introspectInterface :: InterfaceName
|
|
|
|
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
|
|
|
|
|
|
|
|
introspectMethod :: MemberName
|
|
|
|
introspectMethod = memberName_ "Introspect"
|
|
|
|
|
2021-11-07 20:16:53 -05:00
|
|
|
dbusInstalled :: BusName -> Bool -> ObjectPath -> InterfaceName -> DBusMember
|
2021-11-19 00:35:54 -05:00
|
|
|
-> IO (Maybe String)
|
2021-11-07 20:16:53 -05:00
|
|
|
dbusInstalled bus usesystem objpath iface mem = do
|
|
|
|
client <- if usesystem then connectSystem else connectSession
|
2021-11-08 00:27:39 -05:00
|
|
|
reply <- call_ client (methodCall objpath introspectInterface introspectMethod)
|
|
|
|
{ methodCallDestination = Just bus }
|
2021-11-07 20:16:53 -05:00
|
|
|
let res = findMem =<< I.parseXML objpath =<< fromVariant
|
|
|
|
=<< listToMaybe (methodReturnBody reply)
|
|
|
|
disconnect client
|
2021-11-19 00:35:54 -05:00
|
|
|
return $ case res of
|
|
|
|
Just _ -> Nothing
|
|
|
|
_ -> Just "some random dbus interface not found"
|
2021-11-07 20:16:53 -05:00
|
|
|
where
|
|
|
|
findMem obj = fmap (matchMem mem)
|
|
|
|
$ find (\i -> I.interfaceName i == iface)
|
|
|
|
$ I.objectInterfaces obj
|
|
|
|
matchMem (Method_ n) = elem n . fmap I.methodName . I.interfaceMethods
|
|
|
|
matchMem (Signal_ n) = elem n . fmap I.signalName . I.interfaceSignals
|
|
|
|
matchMem (Property_ n) = elem n . fmap I.propertyName . I.interfaceProperties
|
|
|
|
|
2021-11-20 11:48:05 -05:00
|
|
|
depInstalled :: Dependency -> IO (Maybe String)
|
2021-11-07 18:41:25 -05:00
|
|
|
depInstalled (Executable n) = exeInstalled n
|
2021-11-19 00:35:54 -05:00
|
|
|
depInstalled (IOTest t) = t
|
2021-11-07 18:41:25 -05:00
|
|
|
depInstalled (Systemd t n) = unitInstalled t n
|
|
|
|
depInstalled (AccessiblePath p r w) = pathAccessible p r w
|
2021-11-07 20:16:53 -05:00
|
|
|
depInstalled DBusEndpoint { ddDbusBus = b
|
|
|
|
, ddDbusSystem = s
|
|
|
|
, ddDbusObject = o
|
|
|
|
, ddDbusInterface = i
|
|
|
|
, ddDbusMember = m
|
|
|
|
} = dbusInstalled b s o i m
|
2021-11-07 18:41:25 -05:00
|
|
|
|
2021-11-07 13:35:08 -05:00
|
|
|
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
|
2021-11-07 13:35:08 -05:00
|
|
|
|
2021-11-07 18:41:25 -05:00
|
|
|
warnMissing :: [MaybeExe a] -> IO ()
|
2021-11-19 00:35:54 -05:00
|
|
|
warnMissing xs = mapM_ putStrLn $ fmap ("[WARNING] "++) $ concat $ [ m | (Left m) <- xs ]
|