ENH use typeclass to make dependency interface more flexible
This commit is contained in:
parent
7e5a4a57cd
commit
6ce38b7ade
115
bin/xmobar.hs
115
bin/xmobar.hs
|
@ -16,7 +16,7 @@ import Data.Either
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
|
||||||
import DBus
|
import DBus.Client
|
||||||
|
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.Exit
|
import System.Exit
|
||||||
|
@ -41,6 +41,8 @@ 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.Shell
|
import XMonad.Internal.Shell
|
||||||
-- import XMonad.Internal.DBus.Common (xmonadBus)
|
-- import XMonad.Internal.DBus.Common (xmonadBus)
|
||||||
-- import XMonad.Internal.DBus.Control (pathExists)
|
-- import XMonad.Internal.DBus.Control (pathExists)
|
||||||
|
@ -52,12 +54,15 @@ import Xmobar
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
rs <- sequence rightPlugins
|
sysClient <- getDBusClient True
|
||||||
|
sesClient <- getDBusClient False
|
||||||
|
rs <- rightPlugins sysClient sesClient
|
||||||
warnMissing rs
|
warnMissing rs
|
||||||
cs <- getAllCommands rs
|
cs <- getAllCommands rs
|
||||||
d <- getXMonadDir
|
d <- getXMonadDir
|
||||||
-- this is needed to see any printed messages
|
-- this is needed to see any printed messages
|
||||||
hFlush stdout
|
hFlush stdout
|
||||||
|
mapM_ (maybe skip disconnect) [sysClient, sesClient]
|
||||||
xmobar $ config cs d
|
xmobar $ config cs d
|
||||||
|
|
||||||
config :: BarRegions -> String -> Config
|
config :: BarRegions -> String -> Config
|
||||||
|
@ -225,8 +230,8 @@ 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 :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency
|
||||||
dbusDep usesys bus obj iface mem = DBusEndpoint (Bus usesys bus) (Endpoint obj iface mem)
|
-- 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
|
||||||
|
@ -245,15 +250,15 @@ listInterfaces = fromRight [] <$> tryIOError (listDirectory sysfsNet)
|
||||||
sysfsNet :: FilePath
|
sysfsNet :: FilePath
|
||||||
sysfsNet = "/sys/class/net"
|
sysfsNet = "/sys/class/net"
|
||||||
|
|
||||||
readInterface :: (String -> Bool) -> IO (Maybe String)
|
readInterface :: (String -> Bool) -> IO (Either [String] String)
|
||||||
readInterface f = do
|
readInterface f = do
|
||||||
ns <- filter f <$> listInterfaces
|
ns <- filter f <$> listInterfaces
|
||||||
case ns of
|
case ns of
|
||||||
|
[] -> return $ Left ["no interfaces found"]
|
||||||
(x:xs) -> do
|
(x:xs) -> do
|
||||||
unless (null xs) $
|
unless (null xs) $
|
||||||
putStrLn $ "WARNING: extra interfaces found, using " ++ x
|
putStrLn $ "WARNING: extra interfaces found, using " ++ x
|
||||||
return $ Just x
|
return $ Right x
|
||||||
_ -> return Nothing
|
|
||||||
|
|
||||||
vpnPresent :: IO (Maybe String)
|
vpnPresent :: IO (Maybe String)
|
||||||
vpnPresent = do
|
vpnPresent = do
|
||||||
|
@ -265,96 +270,96 @@ vpnPresent = do
|
||||||
where
|
where
|
||||||
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
|
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
|
||||||
|
|
||||||
rightPlugins :: [IO (MaybeAction CmdSpec)]
|
rightPlugins :: Maybe Client -> Maybe Client -> IO [MaybeAction CmdSpec]
|
||||||
rightPlugins =
|
rightPlugins sysClient sesClient = mapM evalFeature
|
||||||
[ getWireless
|
[ getWireless
|
||||||
, getEthernet
|
, getEthernet
|
||||||
, evalFeature getVPN
|
, getVPN
|
||||||
, evalFeature getBt
|
, getBt sysClient
|
||||||
, evalFeature getAlsa
|
, getAlsa
|
||||||
, evalFeature getBattery
|
, getBattery
|
||||||
, evalFeature getBl
|
, getBl sesClient
|
||||||
, evalFeature getCk
|
, getCk sesClient
|
||||||
, evalFeature getSs
|
, getSs sesClient
|
||||||
, nocheck lockCmd
|
, ConstFeature lockCmd
|
||||||
, nocheck dateCmd
|
, ConstFeature dateCmd
|
||||||
]
|
]
|
||||||
where
|
|
||||||
nocheck = return . Right
|
|
||||||
|
|
||||||
getWireless :: IO (MaybeAction CmdSpec)
|
getWireless :: BarFeature
|
||||||
getWireless = do
|
getWireless = Feature
|
||||||
i <- readInterface isWireless
|
{ ftrMaybeAction = Chain wirelessCmd $ readInterface isWireless
|
||||||
return $ maybe (Left []) (Right . wirelessCmd) i
|
, ftrName = "wireless status indicator"
|
||||||
|
, ftrWarning = Default
|
||||||
|
}
|
||||||
|
-- i <- readInterface isWireless
|
||||||
|
-- return $ maybe (Left []) (Right . wirelessCmd) i
|
||||||
|
|
||||||
getEthernet :: IO (MaybeAction CmdSpec)
|
-- TODO this needs a dbus interface
|
||||||
getEthernet = do
|
getEthernet :: BarFeature
|
||||||
i <- readInterface isEthernet
|
getEthernet = Feature
|
||||||
evalFeature $ maybe BlankFeature (featureDefault "ethernet status indicator" [dep] . ethernetCmd) i
|
{ ftrMaybeAction = Chain ethernetCmd (readInterface isEthernet)
|
||||||
where
|
, ftrName = "ethernet status indicator"
|
||||||
dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP
|
, ftrWarning = Default
|
||||||
|
}
|
||||||
|
|
||||||
|
-- i <- readInterface isEthernet
|
||||||
|
-- evalFeature $ maybe BlankFeature (featureDefault "ethernet status indicator" [dep] . ethernetCmd) i
|
||||||
|
-- where
|
||||||
|
-- dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP
|
||||||
|
|
||||||
getBattery :: BarFeature
|
getBattery :: BarFeature
|
||||||
getBattery = Feature
|
getBattery = Feature
|
||||||
{ ftrMaybeAction = batteryCmd
|
{ ftrMaybeAction = Parent batteryCmd [IOTest hasBattery]
|
||||||
, ftrName = "battery level indicator"
|
, ftrName = "battery level indicator"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
, ftrChildren = [IOTest hasBattery]
|
|
||||||
}
|
}
|
||||||
|
|
||||||
type BarFeature = Feature CmdSpec
|
type BarFeature = Feature CmdSpec
|
||||||
|
|
||||||
getVPN :: BarFeature
|
getVPN :: BarFeature
|
||||||
getVPN = Feature
|
getVPN = Feature
|
||||||
{ ftrMaybeAction = vpnCmd
|
{ ftrMaybeAction = Parent vpnCmd [v]
|
||||||
, ftrName = "VPN status indicator"
|
, ftrName = "VPN status indicator"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
, ftrChildren = [d, v]
|
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
d = dbusDep True vpnBus vpnPath vpnInterface $ Property_ vpnConnType
|
-- d = dbusDep True vpnBus vpnPath vpnInterface $ Property_ vpnConnType
|
||||||
v = IOTest vpnPresent
|
v = IOTest vpnPresent
|
||||||
|
|
||||||
getBt :: BarFeature
|
getBt :: Maybe Client -> BarFeature
|
||||||
getBt = Feature
|
getBt client = Feature
|
||||||
{ ftrMaybeAction = btCmd
|
{ ftrMaybeAction = DBusEndpoint_ (const btCmd) btBus client
|
||||||
|
[Endpoint btPath btInterface $ Property_ btPowered]
|
||||||
, ftrName = "bluetooth status indicator"
|
, ftrName = "bluetooth status indicator"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
, ftrChildren = [dep]
|
|
||||||
}
|
}
|
||||||
where
|
|
||||||
dep = dbusDep True btBus btPath btInterface $ Property_ btPowered
|
|
||||||
|
|
||||||
getAlsa :: BarFeature
|
getAlsa :: BarFeature
|
||||||
getAlsa = Feature
|
getAlsa = Feature
|
||||||
{ ftrMaybeAction = alsaCmd
|
{ ftrMaybeAction = Parent alsaCmd [Executable "alsactl"]
|
||||||
, ftrName = "volume level indicator"
|
, ftrName = "volume level indicator"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
, ftrChildren = [Executable "alsactl"]
|
|
||||||
}
|
}
|
||||||
|
|
||||||
getBl :: BarFeature
|
getBl :: Maybe Client -> BarFeature
|
||||||
getBl = Feature
|
getBl client = Feature
|
||||||
{ ftrMaybeAction = blCmd
|
{ ftrMaybeAction = DBusEndpoint_ (const blCmd) xmonadBusName client [intelBacklightSignalDep]
|
||||||
, ftrName = "Intel backlight indicator"
|
, ftrName = "Intel backlight indicator"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
, ftrChildren = [intelBacklightSignalDep]
|
|
||||||
}
|
}
|
||||||
|
|
||||||
getCk :: BarFeature
|
getCk :: Maybe Client -> BarFeature
|
||||||
getCk = Feature
|
getCk client = Feature
|
||||||
{ ftrMaybeAction = ckCmd
|
{ ftrMaybeAction = DBusEndpoint_ (const ckCmd) xmonadBusName client [clevoKeyboardSignalDep]
|
||||||
, ftrName = "Clevo keyboard indicator"
|
, ftrName = "Clevo keyboard indicator"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
, ftrChildren = [clevoKeyboardSignalDep]
|
|
||||||
}
|
}
|
||||||
|
|
||||||
getSs :: BarFeature
|
getSs :: Maybe Client -> BarFeature
|
||||||
getSs = Feature
|
getSs client = Feature
|
||||||
{ ftrMaybeAction = ssCmd
|
{ ftrMaybeAction = DBusEndpoint_ (const ssCmd) xmonadBusName client [ssSignalDep]
|
||||||
, ftrName = "screensaver indicator"
|
, ftrName = "screensaver indicator"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
, ftrChildren = [ssSignalDep]
|
|
||||||
}
|
}
|
||||||
|
|
||||||
getAllCommands :: [MaybeAction CmdSpec] -> IO BarRegions
|
getAllCommands :: [MaybeAction CmdSpec] -> IO BarRegions
|
||||||
|
|
|
@ -76,12 +76,14 @@ import XMonad.Util.WorkspaceCompare
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
cl <- startXMonadService
|
sesClient <- startXMonadService
|
||||||
|
sysClient <- getDBusClient True
|
||||||
(h, p) <- spawnPipe "xmobar"
|
(h, p) <- spawnPipe "xmobar"
|
||||||
mapM_ (applyFeature_ forkIO_) [runPowermon, runRemovableMon]
|
mapM_ (applyFeature_ forkIO_) [runPowermon, runRemovableMon sysClient]
|
||||||
forkIO_ $ runWorkspaceMon allDWs
|
forkIO_ $ runWorkspaceMon allDWs
|
||||||
let ts = ThreadState
|
let ts = ThreadState
|
||||||
{ tsClient = cl
|
{ tsSessionClient = sesClient
|
||||||
|
, tsSystemClient = sysClient
|
||||||
, tsChildPIDs = [p]
|
, tsChildPIDs = [p]
|
||||||
, tsChildHandles = [h]
|
, tsChildHandles = [h]
|
||||||
}
|
}
|
||||||
|
@ -114,7 +116,8 @@ main = do
|
||||||
-- | Concurrency configuration
|
-- | Concurrency configuration
|
||||||
|
|
||||||
data ThreadState = ThreadState
|
data ThreadState = ThreadState
|
||||||
{ tsClient :: Maybe Client
|
{ tsSessionClient :: Maybe Client
|
||||||
|
, tsSystemClient :: Maybe Client
|
||||||
, tsChildPIDs :: [ProcessHandle]
|
, tsChildPIDs :: [ProcessHandle]
|
||||||
, tsChildHandles :: [Handle]
|
, tsChildHandles :: [Handle]
|
||||||
}
|
}
|
||||||
|
@ -123,7 +126,8 @@ data ThreadState = ThreadState
|
||||||
runCleanup :: ThreadState -> X ()
|
runCleanup :: ThreadState -> X ()
|
||||||
runCleanup ts = io $ do
|
runCleanup ts = io $ do
|
||||||
mapM_ killHandle $ tsChildPIDs ts
|
mapM_ killHandle $ tsChildPIDs ts
|
||||||
forM_ (tsClient ts) stopXMonadService
|
forM_ (tsSessionClient ts) stopXMonadService
|
||||||
|
forM_ (tsSystemClient ts) disconnect
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Startuphook configuration
|
-- | Startuphook configuration
|
||||||
|
@ -568,12 +572,12 @@ externalBindings ts lock =
|
||||||
, KeyBinding "M-<F8>" "select autorandr profile" runAutorandrMenu
|
, KeyBinding "M-<F8>" "select autorandr profile" runAutorandrMenu
|
||||||
, KeyBinding "M-<F9>" "toggle ethernet" runToggleEthernet
|
, KeyBinding "M-<F9>" "toggle ethernet" runToggleEthernet
|
||||||
, KeyBinding "M-<F10>" "toggle bluetooth" runToggleBluetooth
|
, KeyBinding "M-<F10>" "toggle bluetooth" runToggleBluetooth
|
||||||
, KeyBinding "M-<F11>" "toggle screensaver" $ maybe BlankFeature (ioFeature . callToggle) cl
|
, KeyBinding "M-<F11>" "toggle screensaver" $ ioFeature $ callToggle cl
|
||||||
, KeyBinding "M-<F12>" "switch gpu" runOptimusPrompt
|
, KeyBinding "M-<F12>" "switch gpu" runOptimusPrompt
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
cl = tsClient ts
|
cl = tsSessionClient ts
|
||||||
brightessControls ctl getter = maybe BlankFeature (ioFeature . getter . ctl) cl
|
brightessControls ctl getter = (ioFeature . getter . ctl) cl
|
||||||
ib = brightessControls intelBacklightControls
|
ib = brightessControls intelBacklightControls
|
||||||
ck = brightessControls clevoKeyboardControls
|
ck = brightessControls clevoKeyboardControls
|
||||||
|
|
|
@ -33,13 +33,17 @@ memAdded = memberName_ "InterfacesAdded"
|
||||||
memRemoved :: MemberName
|
memRemoved :: MemberName
|
||||||
memRemoved = memberName_ "InterfacesRemoved"
|
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 m = Endpoint path interface $ Signal_ m
|
||||||
|
|
||||||
addedDep :: Dependency
|
-- addedDep :: Dependency
|
||||||
|
addedDep :: Endpoint
|
||||||
addedDep = dbusDep memAdded
|
addedDep = dbusDep memAdded
|
||||||
|
|
||||||
removedDep :: Dependency
|
-- removedDep :: Dependency
|
||||||
|
removedDep :: Endpoint
|
||||||
removedDep = dbusDep memRemoved
|
removedDep = dbusDep memRemoved
|
||||||
|
|
||||||
driveInsertedSound :: FilePath
|
driveInsertedSound :: FilePath
|
||||||
|
@ -84,6 +88,9 @@ listenDevices = do
|
||||||
addMatch' client m p f = addMatch client ruleUdisks { matchMember = Just m }
|
addMatch' client m p f = addMatch client ruleUdisks { matchMember = Just m }
|
||||||
$ playSoundMaybe p . f . signalBody
|
$ playSoundMaybe p . f . signalBody
|
||||||
|
|
||||||
runRemovableMon :: FeatureIO
|
runRemovableMon :: Maybe Client -> FeatureIO
|
||||||
runRemovableMon =
|
runRemovableMon client = Feature
|
||||||
featureDefault "removeable device monitor" [addedDep, removedDep] listenDevices
|
{ ftrMaybeAction = DBusEndpoint_ (const listenDevices) bus client [addedDep, removedDep]
|
||||||
|
, ftrName = "removeable device monitor"
|
||||||
|
, ftrWarning = Default
|
||||||
|
}
|
||||||
|
|
|
@ -113,14 +113,15 @@ stateFileDep = pathRW stateFile
|
||||||
brightnessFileDep :: Dependency
|
brightnessFileDep :: Dependency
|
||||||
brightnessFileDep = pathR brightnessFile
|
brightnessFileDep = pathR brightnessFile
|
||||||
|
|
||||||
clevoKeyboardSignalDep :: Dependency
|
-- clevoKeyboardSignalDep :: Dependency
|
||||||
|
clevoKeyboardSignalDep :: Endpoint
|
||||||
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
|
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
|
||||||
|
|
||||||
exportClevoKeyboard :: Client -> FeatureIO
|
exportClevoKeyboard :: Maybe Client -> FeatureIO
|
||||||
exportClevoKeyboard =
|
exportClevoKeyboard =
|
||||||
brightnessExporter [stateFileDep, brightnessFileDep] clevoKeyboardConfig
|
brightnessExporter [stateFileDep, brightnessFileDep] clevoKeyboardConfig
|
||||||
|
|
||||||
clevoKeyboardControls :: Client -> BrightnessControls
|
clevoKeyboardControls :: Maybe Client -> BrightnessControls
|
||||||
clevoKeyboardControls = brightnessControls clevoKeyboardConfig
|
clevoKeyboardControls = brightnessControls clevoKeyboardConfig
|
||||||
|
|
||||||
callGetBrightnessCK :: Client -> IO (Maybe Brightness)
|
callGetBrightnessCK :: Client -> IO (Maybe Brightness)
|
||||||
|
|
|
@ -50,7 +50,7 @@ data BrightnessControls = BrightnessControls
|
||||||
, bctlDec :: FeatureIO
|
, bctlDec :: FeatureIO
|
||||||
}
|
}
|
||||||
|
|
||||||
brightnessControls :: BrightnessConfig a b -> Client -> BrightnessControls
|
brightnessControls :: BrightnessConfig a b -> Maybe Client -> BrightnessControls
|
||||||
brightnessControls bc client =
|
brightnessControls bc client =
|
||||||
BrightnessControls
|
BrightnessControls
|
||||||
{ bctlMax = cb "max brightness" memMax
|
{ bctlMax = cb "max brightness" memMax
|
||||||
|
@ -67,9 +67,10 @@ callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client = do
|
||||||
reply <- callMethod client xmonadBusName p i memGet
|
reply <- callMethod client xmonadBusName p i memGet
|
||||||
return $ either (const Nothing) bodyGetBrightness reply
|
return $ either (const Nothing) bodyGetBrightness reply
|
||||||
|
|
||||||
signalDep :: BrightnessConfig a b -> Dependency
|
-- signalDep :: BrightnessConfig a b -> Dependency
|
||||||
|
signalDep :: BrightnessConfig a b -> Endpoint
|
||||||
signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
|
signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
|
||||||
DBusEndpoint xmonadBus $ Endpoint p i $ Signal_ memCur
|
Endpoint 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
|
||||||
|
@ -88,12 +89,11 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do
|
||||||
-- | Internal DBus Crap
|
-- | Internal DBus Crap
|
||||||
|
|
||||||
brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b
|
brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b
|
||||||
-> Client -> FeatureIO
|
-> Maybe Client -> FeatureIO
|
||||||
brightnessExporter deps bc@BrightnessConfig { bcName = n } client = Feature
|
brightnessExporter deps bc@BrightnessConfig { bcName = n } client = Feature
|
||||||
{ ftrMaybeAction = exportBrightnessControls' bc client
|
{ ftrMaybeAction = DBusBus_ (exportBrightnessControls' bc) xmonadBusName client deps
|
||||||
, ftrName = n ++ " exporter"
|
, ftrName = n ++ " exporter"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
, ftrChildren = DBusBus xmonadBus:deps
|
|
||||||
}
|
}
|
||||||
|
|
||||||
exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
|
exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
|
||||||
|
@ -131,7 +131,7 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
|
||||||
where
|
where
|
||||||
sig = signal p i memCur
|
sig = signal p i memCur
|
||||||
|
|
||||||
callBacklight :: Client -> BrightnessConfig a b -> String -> MemberName -> FeatureIO
|
callBacklight :: Maybe Client -> BrightnessConfig a b -> String -> MemberName -> FeatureIO
|
||||||
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] }
|
||||||
|
|
|
@ -95,14 +95,15 @@ curFileDep = pathRW curFile
|
||||||
maxFileDep :: Dependency
|
maxFileDep :: Dependency
|
||||||
maxFileDep = pathR maxFile
|
maxFileDep = pathR maxFile
|
||||||
|
|
||||||
intelBacklightSignalDep :: Dependency
|
-- intelBacklightSignalDep :: Dependency
|
||||||
|
intelBacklightSignalDep :: Endpoint
|
||||||
intelBacklightSignalDep = signalDep intelBacklightConfig
|
intelBacklightSignalDep = signalDep intelBacklightConfig
|
||||||
|
|
||||||
exportIntelBacklight :: Client -> FeatureIO
|
exportIntelBacklight :: Maybe Client -> FeatureIO
|
||||||
exportIntelBacklight =
|
exportIntelBacklight =
|
||||||
brightnessExporter [curFileDep, maxFileDep] intelBacklightConfig
|
brightnessExporter [curFileDep, maxFileDep] intelBacklightConfig
|
||||||
|
|
||||||
intelBacklightControls :: Client -> BrightnessControls
|
intelBacklightControls :: Maybe Client -> BrightnessControls
|
||||||
intelBacklightControls = brightnessControls intelBacklightConfig
|
intelBacklightControls = brightnessControls intelBacklightConfig
|
||||||
|
|
||||||
callGetBrightnessIB :: Client -> IO (Maybe Brightness)
|
callGetBrightnessIB :: Client -> IO (Maybe Brightness)
|
||||||
|
|
|
@ -7,7 +7,7 @@ module XMonad.Internal.DBus.Common
|
||||||
( addMatchCallback
|
( addMatchCallback
|
||||||
, xmonadBus
|
, xmonadBus
|
||||||
, xmonadBusName
|
, xmonadBusName
|
||||||
, xDbusDep
|
-- , xDbusDep
|
||||||
-- , initControls
|
-- , initControls
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
@ -22,8 +22,8 @@ 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
|
||||||
|
|
||||||
-- -- | Call a method and return its result if successful
|
-- -- | Call a method and return its result if successful
|
||||||
-- callMethod :: MethodCall -> IO (Maybe [Variant])
|
-- callMethod :: MethodCall -> IO (Maybe [Variant])
|
||||||
|
|
|
@ -6,9 +6,11 @@
|
||||||
module XMonad.Internal.DBus.Control
|
module XMonad.Internal.DBus.Control
|
||||||
( Client
|
( Client
|
||||||
, startXMonadService
|
, startXMonadService
|
||||||
|
, getDBusClient
|
||||||
, stopXMonadService
|
, stopXMonadService
|
||||||
, pathExists
|
, pathExists
|
||||||
, xmonadBus
|
, xmonadBus
|
||||||
|
, disconnect
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
|
@ -33,21 +35,21 @@ introspectMethod = memberName_ "Introspect"
|
||||||
|
|
||||||
startXMonadService :: IO (Maybe Client)
|
startXMonadService :: IO (Maybe Client)
|
||||||
startXMonadService = do
|
startXMonadService = do
|
||||||
client <- getDBusClient
|
client <- getDBusClient False
|
||||||
forM_ client $ \c -> do
|
forM_ client requestXMonadName
|
||||||
requestXMonadName c
|
mapM_ (\f -> executeFeature_ $ f client) exporters
|
||||||
mapM_ (\f -> executeFeature_ $ f c)
|
|
||||||
[exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
|
|
||||||
return client
|
return client
|
||||||
|
where
|
||||||
|
exporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
|
||||||
|
|
||||||
stopXMonadService :: Client -> IO ()
|
stopXMonadService :: Client -> IO ()
|
||||||
stopXMonadService client = do
|
stopXMonadService client = do
|
||||||
void $ releaseName client xmonadBusName
|
void $ releaseName client xmonadBusName
|
||||||
disconnect client
|
disconnect client
|
||||||
|
|
||||||
getDBusClient :: IO (Maybe Client)
|
getDBusClient :: Bool -> IO (Maybe Client)
|
||||||
getDBusClient = do
|
getDBusClient sys = do
|
||||||
res <- try connectSession
|
res <- try $ if sys then connectSystem else connectSession
|
||||||
case res of
|
case res of
|
||||||
Left e -> putStrLn (clientErrorMessage e) >> return Nothing
|
Left e -> putStrLn (clientErrorMessage e) >> return Nothing
|
||||||
Right c -> return $ Just c
|
Right c -> return $ Just c
|
||||||
|
|
|
@ -93,18 +93,17 @@ bodyGetCurrentState _ = Nothing
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Exported haskell API
|
-- | Exported haskell API
|
||||||
|
|
||||||
exportScreensaver :: Client -> FeatureIO
|
exportScreensaver :: Maybe Client -> FeatureIO
|
||||||
exportScreensaver client = Feature
|
exportScreensaver client = Feature
|
||||||
{ ftrMaybeAction = cmd
|
{ ftrMaybeAction = DBusBus_ cmd xmonadBusName client [Executable ssExecutable]
|
||||||
, ftrName = "screensaver interface"
|
, ftrName = "screensaver interface"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
, ftrChildren = [Executable ssExecutable, DBusBus xmonadBus]
|
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
cmd = export client ssPath defaultInterface
|
cmd cl = export cl ssPath defaultInterface
|
||||||
{ interfaceName = interface
|
{ interfaceName = interface
|
||||||
, interfaceMethods =
|
, interfaceMethods =
|
||||||
[ autoMethod memToggle $ emitState client =<< toggle
|
[ autoMethod memToggle $ emitState cl =<< toggle
|
||||||
, autoMethod memQuery query
|
, autoMethod memQuery query
|
||||||
]
|
]
|
||||||
, interfaceSignals = [sig]
|
, interfaceSignals = [sig]
|
||||||
|
@ -120,7 +119,7 @@ exportScreensaver client = Feature
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
|
|
||||||
callToggle :: Client -> FeatureIO
|
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" }
|
||||||
|
@ -141,6 +140,8 @@ 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 :: Dependency
|
||||||
ssSignalDep = DBusEndpoint xmonadBus $ Endpoint ssPath interface
|
ssSignalDep :: Endpoint
|
||||||
$ Signal_ memState
|
-- ssSignalDep = DBusEndpoint xmonadBus $ Endpoint ssPath interface
|
||||||
|
-- $ Signal_ memState
|
||||||
|
ssSignalDep = Endpoint ssPath interface $ Signal_ memState
|
||||||
|
|
|
@ -1,9 +1,18 @@
|
||||||
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
|
{-# LANGUAGE GADTs #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Functions for handling dependencies
|
-- | Functions for handling dependencies
|
||||||
|
|
||||||
module XMonad.Internal.Dependency
|
module XMonad.Internal.Dependency
|
||||||
( MaybeAction
|
( MaybeAction
|
||||||
, MaybeX
|
, MaybeX
|
||||||
|
, Parent(..)
|
||||||
|
-- , ConstFeature(..)
|
||||||
|
, Chain(..)
|
||||||
|
, DBusEndpoint_(..)
|
||||||
|
, DBusBus_(..)
|
||||||
, FeatureX
|
, FeatureX
|
||||||
, FeatureIO
|
, FeatureIO
|
||||||
, Feature(..)
|
, Feature(..)
|
||||||
|
@ -37,7 +46,7 @@ module XMonad.Internal.Dependency
|
||||||
import Control.Monad (void)
|
import Control.Monad (void)
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
|
||||||
import Data.Bifunctor (bimap)
|
import Data.Bifunctor (bimap, first, second)
|
||||||
import Data.List (find)
|
import Data.List (find)
|
||||||
import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
|
import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
|
||||||
|
|
||||||
|
@ -67,14 +76,34 @@ import XMonad.Internal.Shell
|
||||||
-- dependencies that target the output/state of another feature; this is more
|
-- dependencies that target the output/state of another feature; this is more
|
||||||
-- robust anyways, at the cost of being a bit slower.
|
-- robust anyways, at the cost of being a bit slower.
|
||||||
|
|
||||||
data Feature a = Feature
|
data Feature a = forall e. Evaluable e => Feature
|
||||||
{ ftrMaybeAction :: a
|
{ ftrMaybeAction :: e a
|
||||||
, ftrName :: String
|
, ftrName :: String
|
||||||
, ftrWarning :: Warning
|
, ftrWarning :: Warning
|
||||||
, ftrChildren :: [Dependency]
|
-- , ftrChildren :: [Dependency]
|
||||||
}
|
}
|
||||||
| ConstFeature a
|
| ConstFeature a
|
||||||
| BlankFeature
|
-- | BlankFeature
|
||||||
|
|
||||||
|
-- TODO this name sucks
|
||||||
|
data Parent a = Parent a [Dependency] deriving (Functor)
|
||||||
|
|
||||||
|
-- newtype ConstFeature a = ConstFeature a deriving (Functor)
|
||||||
|
|
||||||
|
data Chain a = forall b. Chain (b -> a) (IO (Either [String] b))
|
||||||
|
|
||||||
|
instance Functor Chain where
|
||||||
|
fmap f (Chain a b) = Chain (f . a) b
|
||||||
|
|
||||||
|
data DBusEndpoint_ a = DBusEndpoint_ (Client -> a) BusName (Maybe Client) [Endpoint]
|
||||||
|
|
||||||
|
instance Functor DBusEndpoint_ where
|
||||||
|
fmap f (DBusEndpoint_ a b c eps) = DBusEndpoint_ (f . a) b c eps
|
||||||
|
|
||||||
|
data DBusBus_ a = DBusBus_ (Client -> a) BusName (Maybe Client) [Dependency]
|
||||||
|
|
||||||
|
instance Functor DBusBus_ where
|
||||||
|
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
|
||||||
-- loglevels
|
-- loglevels
|
||||||
|
@ -84,17 +113,21 @@ type FeatureX = Feature (X ())
|
||||||
|
|
||||||
type FeatureIO = Feature (IO ())
|
type FeatureIO = Feature (IO ())
|
||||||
|
|
||||||
ioFeature :: (MonadIO m) => Feature (IO a) -> Feature (m a)
|
ioFeature :: MonadIO m => Feature (IO b) -> Feature (m b)
|
||||||
ioFeature f@Feature { ftrMaybeAction = a } = f { ftrMaybeAction = liftIO a }
|
ioFeature (ConstFeature a) = ConstFeature $ liftIO a
|
||||||
ioFeature (ConstFeature f) = ConstFeature $ liftIO f
|
ioFeature Feature {..} =
|
||||||
ioFeature BlankFeature = BlankFeature
|
-- 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)
|
||||||
|
Feature {ftrMaybeAction = liftIO <$> ftrMaybeAction, ..}
|
||||||
|
|
||||||
featureDefault :: String -> [Dependency] -> a -> Feature a
|
featureDefault :: String -> [Dependency] -> a -> Feature a
|
||||||
featureDefault n ds x = Feature
|
featureDefault n ds x = Feature
|
||||||
{ ftrMaybeAction = x
|
-- { ftrMaybeAction = x
|
||||||
|
{ ftrMaybeAction = Parent x ds
|
||||||
, ftrName = n
|
, ftrName = n
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
, ftrChildren = ds
|
-- , ftrChildren = ds
|
||||||
}
|
}
|
||||||
|
|
||||||
featureExe :: MonadIO m => String -> String -> Feature (m ())
|
featureExe :: MonadIO m => String -> String -> Feature (m ())
|
||||||
|
@ -104,17 +137,18 @@ featureExeArgs :: MonadIO m => String -> String -> [String] -> Feature (m ())
|
||||||
featureExeArgs n cmd args =
|
featureExeArgs n cmd args =
|
||||||
featureDefault n [Executable cmd] $ spawnCmd cmd args
|
featureDefault n [Executable cmd] $ spawnCmd cmd args
|
||||||
|
|
||||||
-- TODO the bus and client might refer to different things
|
|
||||||
featureEndpoint :: BusName -> ObjectPath -> InterfaceName -> MemberName
|
featureEndpoint :: BusName -> ObjectPath -> InterfaceName -> MemberName
|
||||||
-> Client -> FeatureIO
|
-> Maybe Client -> FeatureIO
|
||||||
featureEndpoint busname path iface mem client = Feature
|
featureEndpoint busname path iface mem client = Feature
|
||||||
{ ftrMaybeAction = cmd
|
-- { ftrMaybeAction = cmd
|
||||||
|
{ ftrMaybeAction = DBusEndpoint_ cmd busname client deps
|
||||||
, ftrName = "screensaver toggle"
|
, ftrName = "screensaver toggle"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
, ftrChildren = [DBusEndpoint (Bus False busname) $ Endpoint path iface $ Method_ mem]
|
-- , ftrChildren = [DBusEndpoint (Bus False busname) $ Endpoint path iface $ Method_ mem]
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
cmd = void $ callMethod client busname path iface mem
|
cmd = \c -> void $ callMethod c busname path iface mem
|
||||||
|
deps = [Endpoint path iface $ Method_ mem]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Feature evaluation
|
-- | Feature evaluation
|
||||||
|
@ -123,24 +157,62 @@ featureEndpoint busname path iface mem client = Feature
|
||||||
-- either the action of the feature or 0 or more error messages that signify
|
-- either the action of the feature or 0 or more error messages that signify
|
||||||
-- what dependencies are missing and why.
|
-- what dependencies are missing and why.
|
||||||
|
|
||||||
|
class Functor e => Evaluable e where
|
||||||
|
eval :: e a -> IO (MaybeAction a)
|
||||||
|
|
||||||
type MaybeAction a = Either [String] a
|
type MaybeAction a = Either [String] a
|
||||||
|
|
||||||
type MaybeX = MaybeAction (X ())
|
type MaybeX = MaybeAction (X ())
|
||||||
|
|
||||||
|
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 ConstFeature where
|
||||||
|
-- eval (ConstFeature a) = return $ Right a
|
||||||
|
|
||||||
|
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) deps) = do
|
||||||
|
es <- catMaybes <$> mapM (endpointSatisfied client busname) deps
|
||||||
|
return $ case es 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'
|
||||||
|
|
||||||
|
-- instance Evaluable BlankFeature where
|
||||||
|
-- eval (BlankFeature a) = Left ["hopefully a useful error message"]
|
||||||
|
|
||||||
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 BlankFeature = return $ Left []
|
-- evalFeature BlankFeature = return $ Left []
|
||||||
evalFeature Feature
|
evalFeature Feature
|
||||||
{ ftrMaybeAction = a
|
{ ftrMaybeAction = a
|
||||||
, ftrName = n
|
, ftrName = n
|
||||||
, ftrWarning = w
|
, ftrWarning = w
|
||||||
, ftrChildren = c
|
-- , ftrChildren = c
|
||||||
} = do
|
} = do
|
||||||
procName <- getProgName
|
procName <- getProgName
|
||||||
es <- catMaybes <$> mapM evalDependency c
|
res <- eval a
|
||||||
return $ case es of
|
return $ first (fmtWarnings procName) res
|
||||||
[] -> Right a
|
-- es <- catMaybes <$> mapM evalDependency c
|
||||||
es' -> Left $ fmtWarnings procName es'
|
-- return $ case res of
|
||||||
|
-- [] -> Right a
|
||||||
|
-- es' -> Left $ fmtWarnings procName es'
|
||||||
where
|
where
|
||||||
fmtWarnings procName es = case w of
|
fmtWarnings procName es = case w of
|
||||||
Silent -> []
|
Silent -> []
|
||||||
|
@ -173,10 +245,11 @@ ifSatisfied _ alt = alt
|
||||||
data Dependency = Executable String
|
data Dependency = Executable String
|
||||||
| AccessiblePath FilePath Bool Bool
|
| AccessiblePath FilePath Bool Bool
|
||||||
| IOTest (IO (Maybe String))
|
| IOTest (IO (Maybe String))
|
||||||
| DBusEndpoint Bus Endpoint
|
-- | DBusEndpoint Bus Endpoint
|
||||||
| DBusBus Bus
|
-- | DBusBus Bus
|
||||||
| Systemd UnitType String
|
| Systemd UnitType String
|
||||||
|
|
||||||
|
|
||||||
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
|
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
|
||||||
|
|
||||||
data DBusMember = Method_ MemberName
|
data DBusMember = Method_ MemberName
|
||||||
|
@ -214,8 +287,8 @@ evalDependency (Executable n) = exeSatisfied n
|
||||||
evalDependency (IOTest t) = t
|
evalDependency (IOTest t) = t
|
||||||
evalDependency (Systemd t n) = unitSatisfied t n
|
evalDependency (Systemd t n) = unitSatisfied t n
|
||||||
evalDependency (AccessiblePath p r w) = pathSatisfied p r w
|
evalDependency (AccessiblePath p r w) = pathSatisfied p r w
|
||||||
evalDependency (DBusEndpoint b e) = endpointSatisfied b e
|
-- evalDependency (DBusEndpoint b e) = endpointSatisfied b e
|
||||||
evalDependency (DBusBus b) = busSatisfied b
|
-- evalDependency (DBusBus b) = busSatisfied b
|
||||||
|
|
||||||
exeSatisfied :: String -> IO (Maybe String)
|
exeSatisfied :: String -> IO (Maybe String)
|
||||||
exeSatisfied x = do
|
exeSatisfied x = do
|
||||||
|
@ -266,11 +339,11 @@ callMethod client bus path iface mem = do
|
||||||
{ methodCallDestination = Just bus }
|
{ methodCallDestination = Just bus }
|
||||||
return $ bimap methodErrorMessage methodReturnBody reply
|
return $ bimap methodErrorMessage methodReturnBody reply
|
||||||
|
|
||||||
busSatisfied :: Bus -> IO (Maybe String)
|
busSatisfied :: Client -> BusName -> IO (Maybe String)
|
||||||
busSatisfied (Bus usesystem bus) = do
|
busSatisfied client bus = do
|
||||||
client <- if usesystem then connectSystem else connectSession
|
-- client <- if usesystem then connectSystem else connectSession
|
||||||
ret <- callMethod client queryBus queryPath queryIface queryMem
|
ret <- callMethod client queryBus queryPath queryIface queryMem
|
||||||
disconnect client
|
-- disconnect client
|
||||||
return $ case ret of
|
return $ case ret of
|
||||||
Left e -> Just e
|
Left e -> Just e
|
||||||
Right b -> let ns = bodyGetNames b in
|
Right b -> let ns = bodyGetNames b in
|
||||||
|
@ -285,11 +358,11 @@ busSatisfied (Bus usesystem bus) = do
|
||||||
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
|
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
|
||||||
bodyGetNames _ = []
|
bodyGetNames _ = []
|
||||||
|
|
||||||
endpointSatisfied :: Bus -> Endpoint -> IO (Maybe String)
|
endpointSatisfied :: Client -> BusName -> Endpoint -> IO (Maybe String)
|
||||||
endpointSatisfied (Bus u bus) (Endpoint objpath iface mem) = do
|
endpointSatisfied client busname (Endpoint objpath iface mem) = do
|
||||||
client <- if u then connectSystem else connectSession
|
-- client <- if u then connectSystem else connectSession
|
||||||
ret <- callMethod client bus objpath introspectInterface introspectMethod
|
ret <- callMethod client busname objpath introspectInterface introspectMethod
|
||||||
disconnect client
|
-- disconnect client
|
||||||
return $ case ret of
|
return $ case ret of
|
||||||
Left e -> Just e
|
Left e -> Just e
|
||||||
Right body -> procBody body
|
Right body -> procBody body
|
||||||
|
@ -315,7 +388,7 @@ endpointSatisfied (Bus u bus) (Endpoint objpath iface mem) = do
|
||||||
, "on interface"
|
, "on interface"
|
||||||
, singleQuote $ formatInterfaceName iface
|
, singleQuote $ formatInterfaceName iface
|
||||||
, "on bus"
|
, "on bus"
|
||||||
, formatBusName bus
|
, formatBusName busname
|
||||||
]
|
]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
Loading…
Reference in New Issue