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

376 lines
12 KiB
Haskell
Raw Normal View History

{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
--------------------------------------------------------------------------------
-- | Functions for handling dependencies
module XMonad.Internal.Dependency
2021-11-21 10:26:28 -05:00
( MaybeAction
, MaybeX
2021-11-22 23:02:23 -05:00
, DepTree(..)
, Action(..)
2021-11-22 23:02:23 -05:00
, DBusDep(..)
2021-11-20 01:15:04 -05:00
, FeatureX
, FeatureIO
2021-11-11 00:11:15 -05:00
, Feature(..)
2021-11-21 10:26:28 -05:00
, Warning(..)
, Dependency(..)
, UnitType(..)
, DBusMember(..)
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-21 10:26:28 -05:00
, featureDefault
, featureExeArgs
, featureExe
, featureEndpoint
2021-11-21 10:26:28 -05:00
, whenSatisfied
, ifSatisfied
2021-11-20 15:20:22 -05:00
, executeFeature
, executeFeature_
2021-11-22 23:46:51 -05:00
, executeFeatureWith
, executeFeatureWith_
2021-11-21 16:58:01 -05:00
, callMethod
) where
import Control.Monad.IO.Class
2021-11-22 23:02:23 -05:00
import Control.Monad.Identity
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
--------------------------------------------------------------------------------
2021-11-21 10:26:28 -05:00
-- | Features
--
2021-11-22 23:46:51 -05:00
-- A 'feature' is composed of a 'dependency tree' which at the root has an
-- 'action' to be performed with a number of 'dependencies' below it.
2021-11-21 10:26:28 -05:00
--
-- NOTE: there is no way to make a feature depend on another feature. This is
-- very complicated to implement and would only be applicable to a few instances
2021-11-22 23:46:51 -05:00
-- (notably the dbus interfaces). In order to implement a dependency tree, use
2021-11-21 10:26:28 -05:00
-- dependencies that target the output/state of another feature; this is more
-- robust anyways, at the cost of being a bit slower.
data Feature a = Feature
2021-11-22 23:46:51 -05:00
{ ftrDepTree :: DepTree a
2021-11-22 00:08:12 -05:00
, ftrName :: String
, ftrWarning :: Warning
2021-11-20 01:15:04 -05:00
}
| ConstFeature a
2021-11-21 10:26:28 -05:00
-- TODO this is silly as is, and could be made more useful by representing
-- loglevels
data Warning = Silent | Default
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
ioFeature :: MonadIO m => Feature (IO b) -> Feature (m b)
ioFeature (ConstFeature a) = ConstFeature $ liftIO a
ioFeature Feature {..} =
-- HACK just doing a normal record update here will make GHC complain about
-- an 'insufficiently polymorphic record update' ...I guess because my
-- GADT isn't polymorphic enough (which is obviously BS)
2021-11-22 23:28:54 -05:00
Feature {ftrDepTree = liftIO <$> ftrDepTree, ..}
2021-11-21 10:26:28 -05:00
featureDefault :: String -> [Dependency] -> a -> Feature a
featureDefault n ds x = Feature
2021-11-22 23:28:54 -05:00
{ ftrDepTree = GenTree (Single x) ds
2021-11-21 10:26:28 -05:00
, ftrName = n
, ftrWarning = Default
}
featureExe :: MonadIO m => String -> String -> Feature (m ())
featureExe n cmd = featureExeArgs n cmd []
featureExeArgs :: MonadIO m => String -> String -> [String] -> Feature (m ())
featureExeArgs n cmd args =
featureDefault n [Executable cmd] $ spawnCmd cmd args
featureEndpoint :: BusName -> ObjectPath -> InterfaceName -> MemberName
-> Maybe Client -> FeatureIO
featureEndpoint busname path iface mem client = Feature
2021-11-22 23:28:54 -05:00
{ ftrDepTree = DBusTree (Single cmd) client deps []
, ftrName = "screensaver toggle"
, ftrWarning = Default
}
where
cmd = \c -> void $ callMethod c busname path iface mem
2021-11-21 23:55:19 -05:00
deps = [Endpoint busname path iface $ Method_ mem]
2021-11-22 23:46:51 -05:00
--------------------------------------------------------------------------------
-- | Dependency Trees
--
-- Dependency trees have two subtypes: general and DBus. The latter require a
-- DBus client to evaluate (and will automatically fail if this is missing).
-- The former can be evaluated independently.
data DepTree a = GenTree (Action a) [Dependency]
| DBusTree (Action (Client -> a)) (Maybe Client) [DBusDep] [Dependency]
instance Functor DepTree where
fmap f (GenTree a ds) = GenTree (f <$> a) ds
fmap f (DBusTree a c es ds) = DBusTree (fmap (fmap f) a) c es ds
--------------------------------------------------------------------------------
-- | Actions
--
-- Actions have two subtypes: single and double. Single actions are just one
-- independent action. Double actions have one dependent pre-step which the
-- main action consumes (and fails if the pre-step fails).
data Action a = Single a | forall b. Double (b -> a) (IO (Either [String] b))
instance Functor Action where
fmap f (Single a) = Single (f a)
fmap f (Double a b) = Double (f . a) b
2021-11-21 10:26:28 -05:00
--------------------------------------------------------------------------------
-- | Feature evaluation
--
-- Evaluate a feature by testing if its dependencies are satisfied, and return
-- either the action of the feature or 0 or more error messages that signify
-- what dependencies are missing and why.
type MaybeAction a = Maybe a
2021-11-19 00:35:54 -05:00
2021-11-21 10:26:28 -05:00
type MaybeX = MaybeAction (X ())
2021-11-22 23:46:51 -05:00
evalFeature :: Feature a -> IO (MaybeAction a)
evalFeature (ConstFeature x) = return $ Just x
evalFeature Feature
{ ftrDepTree = a
, ftrName = n
, ftrWarning = w
} = do
procName <- getProgName
res <- evalTree a
either (printWarnings procName) (return . Just) res
where
printWarnings procName es = do
case w of
Silent -> skip
Default -> let prefix = n ++ " disabled; "
es' = fmap (fmtMsg procName . (prefix ++)) es in
mapM_ putStrLn es'
return Nothing
fmtMsg procName msg = unwords [bracket procName, bracket "WARNING", msg]
bracket s = "[" ++ s ++ "]"
evalTree :: DepTree a -> IO (Either [String] a)
2021-11-22 23:02:23 -05:00
evalTree (GenTree action ds) = do
es <- catMaybes <$> mapM evalDependency ds
2021-11-22 23:02:23 -05:00
case es of
[] -> do
action' <- evalAction action
return $ case action' of
Right f -> Right f
Left es' -> Left es'
es' -> return $ Left es'
evalTree (DBusTree _ Nothing _ _) = return $ Left ["client not available"]
evalTree (DBusTree action (Just client) es ds) = do
eperrors <- mapM (dbusDepSatisfied client) es
dperrors <- mapM evalDependency ds
2021-11-22 23:02:23 -05:00
case catMaybes (eperrors ++ dperrors) of
[] -> do
action' <- evalAction action
return $ case action' of
Right f -> Right $ f client
Left es' -> Left es'
es' -> return $ Left es'
evalAction :: Action a -> IO (Either [String] a)
evalAction (Single a) = return $ Right a
evalAction (Double a b) = fmap a <$> b
2021-11-22 23:46:51 -05:00
executeFeatureWith :: MonadIO m => (m a -> m a) -> a -> Feature (IO a) -> m a
executeFeatureWith iof def ftr = do
2021-11-21 10:26:28 -05:00
a <- io $ evalFeature ftr
maybe (return def) (iof . io) a
2021-11-21 10:26:28 -05:00
2021-11-22 23:46:51 -05:00
executeFeatureWith_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m ()
executeFeatureWith_ iof = executeFeatureWith iof ()
2021-11-21 10:26:28 -05:00
executeFeature :: MonadIO m => a -> Feature (IO a) -> m a
2021-11-22 23:46:51 -05:00
executeFeature = executeFeatureWith id
2021-11-21 10:26:28 -05:00
executeFeature_ :: Feature (IO ()) -> IO ()
executeFeature_ = executeFeature ()
whenSatisfied :: Monad m => MaybeAction (m ()) -> m ()
whenSatisfied = flip ifSatisfied skip
ifSatisfied :: MaybeAction a -> a -> a
ifSatisfied (Just x) _ = x
ifSatisfied _ alt = alt
2021-11-21 10:26:28 -05:00
--------------------------------------------------------------------------------
2021-11-22 23:46:51 -05:00
-- | Dependencies (General)
2021-11-21 10:26:28 -05:00
data Dependency = Executable String
| AccessiblePath FilePath Bool Bool
| IOTest (IO (Maybe String))
| Systemd UnitType String
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
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
2021-11-21 10:26:28 -05:00
--------------------------------------------------------------------------------
2021-11-22 23:46:51 -05:00
-- | Dependencies (DBus)
data DBusMember = Method_ MemberName
| Signal_ MemberName
| Property_ String
deriving (Eq, Show)
data DBusDep =
Bus BusName
| Endpoint BusName ObjectPath InterfaceName DBusMember
deriving (Eq, Show)
--------------------------------------------------------------------------------
-- | Dependency evaluation (General)
2021-11-21 10:26:28 -05:00
--
-- Test the existence of dependencies and return either Nothing (which actually
-- means success) or Just <error message>.
2021-11-20 01:15:04 -05:00
2021-11-21 10:26:28 -05:00
evalDependency :: Dependency -> IO (Maybe String)
evalDependency (Executable n) = exeSatisfied n
evalDependency (IOTest t) = t
evalDependency (Systemd t n) = unitSatisfied t n
evalDependency (AccessiblePath p r w) = pathSatisfied p r w
2021-11-20 01:15:04 -05:00
2021-11-21 10:26:28 -05:00
exeSatisfied :: String -> IO (Maybe String)
exeSatisfied x = do
2021-11-19 00:35:54 -05:00
r <- findExecutable x
return $ case r of
(Just _) -> Nothing
_ -> Just $ "executable '" ++ x ++ "' not found"
2021-11-21 10:26:28 -05:00
unitSatisfied :: UnitType -> String -> IO (Maybe String)
unitSatisfied 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-21 10:26:28 -05:00
pathSatisfied :: FilePath -> Bool -> Bool -> IO (Maybe String)
pathSatisfied 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-22 23:46:51 -05:00
--------------------------------------------------------------------------------
-- | Dependency evaluation (DBus)
2021-11-08 00:27:39 -05:00
introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect"
2021-11-21 16:58:01 -05:00
-- TODO this belongs somewhere else, IDK where tho for now
2021-11-21 17:54:00 -05:00
callMethod :: Client -> BusName -> ObjectPath -> InterfaceName -> MemberName
-> IO (Either String [Variant])
callMethod client bus path iface mem = do
reply <- call client (methodCall path iface mem)
2021-11-08 00:27:39 -05:00
{ methodCallDestination = Just bus }
return $ bimap methodErrorMessage methodReturnBody reply
2021-11-22 23:02:23 -05:00
dbusDepSatisfied :: Client -> DBusDep -> IO (Maybe String)
dbusDepSatisfied client (Bus bus) = do
2021-11-21 17:54:00 -05:00
ret <- callMethod client 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 _ = []
2021-11-22 23:02:23 -05:00
dbusDepSatisfied client (Endpoint busname objpath iface mem) = do
ret <- callMethod client busname 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 busname
]