REF move bus to endpoint type

This commit is contained in:
Nathan Dwarshuis 2021-11-21 23:55:19 -05:00
parent 27189cb335
commit 866d2cbb75
7 changed files with 32 additions and 82 deletions

View File

@ -41,7 +41,6 @@ import XMonad.Hooks.DynamicLog
import XMonad.Internal.Command.Power (hasBattery) import XMonad.Internal.Command.Power (hasBattery)
import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common
import XMonad.Internal.DBus.Control import XMonad.Internal.DBus.Control
import XMonad.Internal.Shell import XMonad.Internal.Shell
-- import XMonad.Internal.DBus.Common (xmonadBus) -- import XMonad.Internal.DBus.Common (xmonadBus)
@ -230,9 +229,6 @@ dateCmd = CmdSpec
-- some commands depend on the presence of interfaces that can only be -- some commands depend on the presence of interfaces that can only be
-- determined at runtime; define these checks here -- determined at runtime; define these checks here
-- dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency
-- dbusDep usesys bus obj iface mem = DBusEndpoint (Bus usesys bus) (Endpoint obj iface mem)
-- in the case of network interfaces, assume that the system uses systemd in -- in the case of network interfaces, assume that the system uses systemd in
-- which case ethernet interfaces always start with "en" and wireless -- which case ethernet interfaces always start with "en" and wireless
-- interfaces always start with "wl" -- interfaces always start with "wl"
@ -316,20 +312,22 @@ type BarFeature = Feature CmdSpec
getVPN :: Maybe Client -> BarFeature getVPN :: Maybe Client -> BarFeature
getVPN client = Feature getVPN client = Feature
{ ftrMaybeAction = DBusEndpoint_ (const vpnCmd) vpnBus client { ftrMaybeAction = DBusEndpoint_ (const vpnCmd) client [ep] [dp]
[Endpoint vpnPath vpnInterface $ Property_ vpnConnType]
[IOTest vpnPresent]
, ftrName = "VPN status indicator" , ftrName = "VPN status indicator"
, ftrWarning = Default , ftrWarning = Default
} }
where
ep = Endpoint vpnBus vpnPath vpnInterface $ Property_ vpnConnType
dp = IOTest vpnPresent
getBt :: Maybe Client -> BarFeature getBt :: Maybe Client -> BarFeature
getBt client = Feature getBt client = Feature
{ ftrMaybeAction = DBusEndpoint_ (const btCmd) btBus client { ftrMaybeAction = DBusEndpoint_ (const btCmd) client [ep] []
[Endpoint btPath btInterface $ Property_ btPowered] []
, ftrName = "bluetooth status indicator" , ftrName = "bluetooth status indicator"
, ftrWarning = Default , ftrWarning = Default
} }
where
ep = Endpoint btBus btPath btInterface $ Property_ btPowered
getAlsa :: BarFeature getAlsa :: BarFeature
getAlsa = Feature getAlsa = Feature
@ -340,21 +338,21 @@ getAlsa = Feature
getBl :: Maybe Client -> BarFeature getBl :: Maybe Client -> BarFeature
getBl client = Feature getBl client = Feature
{ ftrMaybeAction = DBusEndpoint_ (const blCmd) xmonadBusName client [intelBacklightSignalDep] [] { ftrMaybeAction = DBusEndpoint_ (const blCmd) client [intelBacklightSignalDep] []
, ftrName = "Intel backlight indicator" , ftrName = "Intel backlight indicator"
, ftrWarning = Default , ftrWarning = Default
} }
getCk :: Maybe Client -> BarFeature getCk :: Maybe Client -> BarFeature
getCk client = Feature getCk client = Feature
{ ftrMaybeAction = DBusEndpoint_ (const ckCmd) xmonadBusName client [clevoKeyboardSignalDep] [] { ftrMaybeAction = DBusEndpoint_ (const ckCmd) client [clevoKeyboardSignalDep] []
, ftrName = "Clevo keyboard indicator" , ftrName = "Clevo keyboard indicator"
, ftrWarning = Default , ftrWarning = Default
} }
getSs :: Maybe Client -> BarFeature getSs :: Maybe Client -> BarFeature
getSs client = Feature getSs client = Feature
{ ftrMaybeAction = DBusEndpoint_ (const ssCmd) xmonadBusName client [ssSignalDep] [] { ftrMaybeAction = DBusEndpoint_ (const ssCmd) client [ssSignalDep] []
, ftrName = "screensaver indicator" , ftrName = "screensaver indicator"
, ftrWarning = Default , ftrWarning = Default
} }

View File

@ -36,7 +36,7 @@ memRemoved = memberName_ "InterfacesRemoved"
-- dbusDep :: MemberName -> Dependency -- dbusDep :: MemberName -> Dependency
-- dbusDep m = DBusEndpoint (Bus True bus) (Endpoint path interface $ Signal_ m) -- dbusDep m = DBusEndpoint (Bus True bus) (Endpoint path interface $ Signal_ m)
dbusDep :: MemberName -> Endpoint dbusDep :: MemberName -> Endpoint
dbusDep m = Endpoint path interface $ Signal_ m dbusDep m = Endpoint bus path interface $ Signal_ m
-- addedDep :: Dependency -- addedDep :: Dependency
addedDep :: Endpoint addedDep :: Endpoint
@ -90,7 +90,7 @@ listenDevices = do
runRemovableMon :: Maybe Client -> FeatureIO runRemovableMon :: Maybe Client -> FeatureIO
runRemovableMon client = Feature runRemovableMon client = Feature
{ ftrMaybeAction = DBusEndpoint_ (const listenDevices) bus client [addedDep, removedDep] [] { ftrMaybeAction = DBusEndpoint_ (const listenDevices) client [addedDep, removedDep] []
, ftrName = "removeable device monitor" , ftrName = "removeable device monitor"
, ftrWarning = Default , ftrWarning = Default
} }

View File

@ -70,7 +70,7 @@ callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client = do
-- signalDep :: BrightnessConfig a b -> Dependency -- signalDep :: BrightnessConfig a b -> Dependency
signalDep :: BrightnessConfig a b -> Endpoint signalDep :: BrightnessConfig a b -> Endpoint
signalDep BrightnessConfig { bcPath = p, bcInterface = i } = signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
Endpoint p i $ Signal_ memCur Endpoint xmonadBusName p i $ Signal_ memCur
matchSignal :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> IO SignalHandler matchSignal :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> IO SignalHandler
matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do
@ -135,12 +135,6 @@ callBacklight :: Maybe Client -> BrightnessConfig a b -> String -> MemberName ->
callBacklight client BrightnessConfig { bcPath = p, bcInterface = i, bcName = n } controlName m = callBacklight client BrightnessConfig { bcPath = p, bcInterface = i, bcName = n } controlName m =
(featureEndpoint xmonadBusName p i m client) (featureEndpoint xmonadBusName p i m client)
{ ftrName = unwords [n, controlName] } { ftrName = unwords [n, controlName] }
-- Feature
-- { ftrMaybeAction = void $ callMethod client xmonadBusName p i m
-- , ftrName = unwords [n, controlName]
-- , ftrWarning = Default
-- , ftrChildren = [xDbusDep p i $ Method_ m]
-- }
bodyGetBrightness :: Num a => [Variant] -> Maybe a bodyGetBrightness :: Num a => [Variant] -> Maybe a
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32) bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)

View File

@ -5,7 +5,7 @@ module XMonad.Internal.DBus.Common
-- ( callMethod -- ( callMethod
-- , callMethod' -- , callMethod'
( addMatchCallback ( addMatchCallback
, xmonadBus -- , xmonadBus
, xmonadBusName , xmonadBusName
-- , xDbusDep -- , xDbusDep
-- , initControls -- , initControls
@ -14,13 +14,13 @@ module XMonad.Internal.DBus.Common
import DBus import DBus
import DBus.Client import DBus.Client
import XMonad.Internal.Dependency -- import XMonad.Internal.Dependency
xmonadBusName :: BusName xmonadBusName :: BusName
xmonadBusName = busName_ "org.xmonad" xmonadBusName = busName_ "org.xmonad"
xmonadBus :: Bus -- xmonadBus :: Bus
xmonadBus = Bus False xmonadBusName -- xmonadBus = Bus False xmonadBusName
-- xDbusDep :: ObjectPath -> InterfaceName -> DBusMember -> Dependency -- xDbusDep :: ObjectPath -> InterfaceName -> DBusMember -> Dependency
-- xDbusDep o i m = DBusEndpoint xmonadBus $ Endpoint o i m -- xDbusDep o i m = DBusEndpoint xmonadBus $ Endpoint o i m

View File

@ -9,7 +9,7 @@ module XMonad.Internal.DBus.Control
, getDBusClient , getDBusClient
, stopXMonadService , stopXMonadService
, pathExists , pathExists
, xmonadBus -- , xmonadBus
, disconnect , disconnect
) where ) where

View File

@ -123,14 +123,6 @@ callToggle :: Maybe Client -> FeatureIO
callToggle client = callToggle client =
(featureEndpoint xmonadBusName ssPath interface memToggle client) (featureEndpoint xmonadBusName ssPath interface memToggle client)
{ ftrName = "screensaver toggle" } { ftrName = "screensaver toggle" }
-- callToggle client = Feature
-- { ftrMaybeAction = cmd
-- , ftrName = "screensaver toggle"
-- , ftrWarning = Default
-- , ftrChildren = [xDbusDep ssPath interface $ Method_ memToggle]
-- }
-- where
-- cmd = void $ callMethod client xmonadBusName ssPath interface memToggle
callQuery :: Client -> IO (Maybe SSState) callQuery :: Client -> IO (Maybe SSState)
callQuery client = do callQuery client = do
@ -140,8 +132,5 @@ callQuery client = do
matchSignal :: (Maybe SSState -> IO ()) -> IO SignalHandler matchSignal :: (Maybe SSState -> IO ()) -> IO SignalHandler
matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
-- ssSignalDep :: Dependency
ssSignalDep :: Endpoint ssSignalDep :: Endpoint
-- ssSignalDep = DBusEndpoint xmonadBus $ Endpoint ssPath interface ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState
-- $ Signal_ memState
ssSignalDep = Endpoint ssPath interface $ Signal_ memState

View File

@ -14,7 +14,6 @@ module XMonad.Internal.Dependency
, Warning(..) , Warning(..)
, Dependency(..) , Dependency(..)
, UnitType(..) , UnitType(..)
, Bus(..)
, Endpoint(..) , Endpoint(..)
, DBusMember(..) , DBusMember(..)
, ioFeature , ioFeature
@ -80,13 +79,13 @@ data Feature a = Feature
data Action a = Parent a [Dependency] data Action a = Parent a [Dependency]
| forall b. Chain (b -> a) (IO (Either [String] b)) | forall b. Chain (b -> a) (IO (Either [String] b))
| DBusEndpoint_ (Client -> a) BusName (Maybe Client) [Endpoint] [Dependency] | DBusEndpoint_ (Client -> a) (Maybe Client) [Endpoint] [Dependency]
| DBusBus_ (Client -> a) BusName (Maybe Client) [Dependency] | DBusBus_ (Client -> a) BusName (Maybe Client) [Dependency]
instance Functor Action where instance Functor Action where
fmap f (Parent a ds) = Parent (f a) ds fmap f (Parent a ds) = Parent (f a) ds
fmap f (Chain a b) = Chain (f . a) b fmap f (Chain a b) = Chain (f . a) b
fmap f (DBusEndpoint_ a b c es ds) = DBusEndpoint_ (f . a) b c es ds fmap f (DBusEndpoint_ a c es ds) = DBusEndpoint_ (f . a) c es ds
fmap f (DBusBus_ a b c eps) = DBusBus_ (f . a) b c eps fmap f (DBusBus_ a b c eps) = DBusBus_ (f . a) b c eps
-- TODO this is silly as is, and could be made more useful by representing -- TODO this is silly as is, and could be made more useful by representing
@ -122,13 +121,13 @@ featureExeArgs n cmd args =
featureEndpoint :: BusName -> ObjectPath -> InterfaceName -> MemberName featureEndpoint :: BusName -> ObjectPath -> InterfaceName -> MemberName
-> Maybe Client -> FeatureIO -> Maybe Client -> FeatureIO
featureEndpoint busname path iface mem client = Feature featureEndpoint busname path iface mem client = Feature
{ ftrMaybeAction = DBusEndpoint_ cmd busname client deps [] { ftrMaybeAction = DBusEndpoint_ cmd client deps []
, ftrName = "screensaver toggle" , ftrName = "screensaver toggle"
, ftrWarning = Default , ftrWarning = Default
} }
where where
cmd = \c -> void $ callMethod c busname path iface mem cmd = \c -> void $ callMethod c busname path iface mem
deps = [Endpoint path iface $ Method_ mem] deps = [Endpoint busname path iface $ Method_ mem]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Feature evaluation -- | Feature evaluation
@ -151,9 +150,9 @@ evalAction (Parent a ds) = do
evalAction (Chain a b) = second a <$> b evalAction (Chain a b) = second a <$> b
evalAction (DBusEndpoint_ _ _ Nothing _ _) = return $ Left ["client not available"] evalAction (DBusEndpoint_ _ Nothing _ _) = return $ Left ["client not available"]
evalAction (DBusEndpoint_ action busname (Just client) es ds) = do evalAction (DBusEndpoint_ action (Just client) es ds) = do
eperrors <- mapM (endpointSatisfied client busname) es eperrors <- mapM (endpointSatisfied client) es
dperrors <- mapM evalDependency ds dperrors <- mapM evalDependency ds
return $ case catMaybes (eperrors ++ dperrors) of return $ case catMaybes (eperrors ++ dperrors) of
[] -> Right $ action client [] -> Right $ action client
@ -167,34 +166,6 @@ evalAction (DBusBus_ action busname (Just client) deps) = do
[] -> Right $ action client [] -> Right $ action client
es' -> Left es' es' -> Left es'
-- instance Evaluable Parent where
-- eval (Parent a ds) = do
-- es <- catMaybes <$> mapM evalDependency ds
-- return $ case es of
-- [] -> Right a
-- es' -> Left es'
-- instance Evaluable Chain where
-- eval (Chain a b) = second a <$> b
-- instance Evaluable DBusEndpoint_ where
-- eval (DBusEndpoint_ _ _ Nothing _ _) = return $ Left ["client not available"]
-- eval (DBusEndpoint_ action busname (Just client) es ds) = do
-- eperrors <- mapM (endpointSatisfied client busname) es
-- dperrors <- mapM evalDependency ds
-- return $ case catMaybes (eperrors ++ dperrors) of
-- [] -> Right $ action client
-- es' -> Left es'
-- instance Evaluable DBusBus_ where
-- eval (DBusBus_ _ _ Nothing _) = return $ Left ["client not available"]
-- eval (DBusBus_ action busname (Just client) deps) = do
-- res <- busSatisfied client busname
-- es <- catMaybes . (res:) <$> mapM evalDependency deps
-- return $ case es of
-- [] -> Right $ action client
-- es' -> Left es'
evalFeature :: Feature a -> IO (MaybeAction a) evalFeature :: Feature a -> IO (MaybeAction a)
evalFeature (ConstFeature x) = return $ Right x evalFeature (ConstFeature x) = return $ Right x
evalFeature Feature evalFeature Feature
@ -246,9 +217,7 @@ data DBusMember = Method_ MemberName
| Property_ String | Property_ String
deriving (Eq, Show) deriving (Eq, Show)
data Bus = Bus Bool BusName deriving (Eq, Show) data Endpoint = Endpoint BusName ObjectPath InterfaceName DBusMember deriving (Eq, Show)
data Endpoint = Endpoint ObjectPath InterfaceName DBusMember deriving (Eq, Show)
pathR :: String -> Dependency pathR :: String -> Dependency
pathR n = AccessiblePath n True False pathR n = AccessiblePath n True False
@ -345,8 +314,8 @@ busSatisfied client bus = do
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String] bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
bodyGetNames _ = [] bodyGetNames _ = []
endpointSatisfied :: Client -> BusName -> Endpoint -> IO (Maybe String) endpointSatisfied :: Client -> Endpoint -> IO (Maybe String)
endpointSatisfied client busname (Endpoint objpath iface mem) = do endpointSatisfied client (Endpoint busname objpath iface mem) = do
-- client <- if u then connectSystem else connectSession -- client <- if u then connectSystem else connectSession
ret <- callMethod client busname objpath introspectInterface introspectMethod ret <- callMethod client busname objpath introspectInterface introspectMethod
-- disconnect client -- disconnect client