WIP use DBus dependency API everywhere

This commit is contained in:
Nathan Dwarshuis 2021-11-08 00:27:39 -05:00
parent 197f303111
commit 23098420aa
7 changed files with 78 additions and 47 deletions

View File

@ -42,7 +42,8 @@ import XMonad.Internal.DBus.Brightness.IntelBacklight (blPath)
import XMonad.Internal.DBus.Common (xmonadBus) import XMonad.Internal.DBus.Common (xmonadBus)
import XMonad.Internal.DBus.Control (pathExists) import XMonad.Internal.DBus.Control (pathExists)
import XMonad.Internal.DBus.Screensaver (ssPath) import XMonad.Internal.DBus.Screensaver (ssPath)
import XMonad.Internal.Shell (fmtCmd) import XMonad.Internal.Dependency
-- import XMonad.Internal.Shell (fmtCmd)
import qualified XMonad.Internal.Theme as T import qualified XMonad.Internal.Theme as T
import Xmobar import Xmobar
@ -226,6 +227,19 @@ toJust x b = if b then Just x else Nothing
whenDBusPath :: Bool -> BusName -> ObjectPath -> CmdSpec -> IO (Maybe CmdSpec) whenDBusPath :: Bool -> BusName -> ObjectPath -> CmdSpec -> IO (Maybe CmdSpec)
whenDBusPath usesys b p cs = toJust cs <$> pathExists usesys b p whenDBusPath usesys b p cs = toJust cs <$> pathExists usesys b p
dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency
dbusDep usesys bus obj iface mem =
Dependency { depRequired = True, depData = d }
where
d = DBusEndpoint
{ ddDbusBus = bus
, ddDbusSystem = usesys
, ddDbusObject = obj
, ddDbusInterface = iface
, ddDbusMember = 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"
@ -275,8 +289,11 @@ getVPN = do
where where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"] args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
getBt :: IO (Maybe CmdSpec) getBt :: IO (MaybeExe CmdSpec)
getBt = whenDBusPath True btBus btPath btCmd -- getBt = whenDBusPath True btBus btPath btCmd
getBt = runIfInstalled [dep] btCmd
where
dep = dbusDep True btBus btPath btInterface $ Property_ btPowered
getAlsa :: IO (Maybe CmdSpec) getAlsa :: IO (Maybe CmdSpec)
getAlsa = toJust alsaCmd . isJust <$> findExecutable "alsactl" getAlsa = toJust alsaCmd . isJust <$> findExecutable "alsactl"
@ -289,6 +306,10 @@ getSs = whenDBusPath False xmonadBus ssPath ssCmd
getAllCommands :: IO BarRegions getAllCommands :: IO BarRegions
getAllCommands = do getAllCommands = do
getBt' <- getBt
let bt = case getBt' of
(Installed x _) -> Just x
_ -> Nothing
let left = let left =
[ CmdSpec [ CmdSpec
{ csAlias = "UnsafeStdinReader" { csAlias = "UnsafeStdinReader"
@ -299,7 +320,8 @@ getAllCommands = do
[ getWireless [ getWireless
, getEthernet , getEthernet
, getVPN , getVPN
, getBt -- , getBt
, return bt
, getAlsa , getAlsa
, getBattery , getBattery
, getBl , getBl

View File

@ -73,10 +73,8 @@ main = do
, dxScreensaverCtrl = sc , dxScreensaverCtrl = sc
} <- startXMonadService } <- startXMonadService
(h, p) <- spawnPipe "xmobar" (h, p) <- spawnPipe "xmobar"
powermonAction <- runPowermon depActions <- sequence [runPowermon, runRemovableMon]
removableAction <- runRemovableMon mapM_ (mapM_ forkIO) depActions
mapM_ forkIO powermonAction
mapM_ forkIO removableAction
_ <- forkIO $ runWorkspaceMon allDWs _ <- forkIO $ runWorkspaceMon allDWs
let ts = ThreadState let ts = ThreadState
{ client = cl { client = cl
@ -84,13 +82,12 @@ main = do
, childHandles = [h] , childHandles = [h]
} }
ext <- evalExternal $ externalBindings bc sc ts ext <- evalExternal $ externalBindings bc sc ts
let ekbs = filterExternal ext warnMissing $ externalToMissing ext ++ fmap (io <$>) depActions
warnMissing $ externalToMissing ext ++ fmap (fmap io) [powermonAction, removableAction]
-- IDK why this is necessary; nothing prior to this line will print if missing -- IDK why this is necessary; nothing prior to this line will print if missing
hFlush stdout hFlush stdout
launch launch
$ ewmh $ ewmh
$ addKeymap ekbs $ addKeymap (filterExternal ext)
$ def { terminal = myTerm $ def { terminal = myTerm
, modMask = myModMask , modMask = myModMask
, layoutHook = myLayouts , layoutHook = myLayouts
@ -507,9 +504,7 @@ flagKeyBinding k@KeyBinding{ kbDesc = d, kbAction = a } = case a of
Missing _ _ -> Just $ k{ kbDesc = "[!!!]" ++ d, kbAction = skip } Missing _ _ -> Just $ k{ kbDesc = "[!!!]" ++ d, kbAction = skip }
Ignore -> Nothing Ignore -> Nothing
externalBindings :: BrightnessControls externalBindings :: BrightnessControls -> SSControls -> ThreadState
-> MaybeExe SSControls
-> ThreadState
-> [KeyGroup (IO MaybeX)] -> [KeyGroup (IO MaybeX)]
externalBindings bc sc ts = externalBindings bc sc ts =
[ KeyGroup "Launchers" [ KeyGroup "Launchers"
@ -571,7 +566,7 @@ externalBindings bc sc ts =
, 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" $ return $ fmap (io . ssToggle) sc , KeyBinding "M-<F11>" "toggle screensaver" $ return $ io <$> ssToggle sc
, KeyBinding "M-<F12>" "switch gpu" runOptimusPrompt , KeyBinding "M-<F12>" "switch gpu" runOptimusPrompt
] ]
] ]

View File

@ -49,16 +49,15 @@ exportBrightnessControls :: RealFrac b => [Dependency] -> BrightnessConfig a b
-> Client -> IO BrightnessControls -> Client -> IO BrightnessControls
exportBrightnessControls deps bc client = do exportBrightnessControls deps bc client = do
(req, opt) <- checkInstalled deps (req, opt) <- checkInstalled deps
let callBacklight' = createInstalled req opt . callBacklight bc
when (null req) $ when (null req) $
exportBrightnessControls' bc client exportBrightnessControls' bc client
return $ BrightnessControls return $ BrightnessControls
{ bctlMax = callBacklight' req opt memMax { bctlMax = callBacklight' memMax
, bctlMin = callBacklight' req opt memMin , bctlMin = callBacklight' memMin
, bctlInc = callBacklight' req opt memInc , bctlInc = callBacklight' memInc
, bctlDec = callBacklight' req opt memDec , bctlDec = callBacklight' memDec
} }
where
callBacklight' r o = createInstalled r o . callBacklight bc
callGetBrightness :: Num c => BrightnessConfig a b -> IO (Maybe c) callGetBrightness :: Num c => BrightnessConfig a b -> IO (Maybe c)
callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } = do callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } = do

View File

@ -33,7 +33,7 @@ data DBusXMonad = DBusXMonad
{ dxClient :: Client { dxClient :: Client
, dxIntelBacklightCtrl :: BrightnessControls , dxIntelBacklightCtrl :: BrightnessControls
-- , dxClevoBacklightCtrl :: MaybeExe BrightnessControls -- , dxClevoBacklightCtrl :: MaybeExe BrightnessControls
, dxScreensaverCtrl :: MaybeExe SSControls , dxScreensaverCtrl :: SSControls
} }
blankControls :: BrightnessControls blankControls :: BrightnessControls
@ -44,6 +44,9 @@ blankControls = BrightnessControls
, bctlDec = Ignore , bctlDec = Ignore
} }
blankSSToggle :: SSControls
blankSSToggle = SSControls { ssToggle = Ignore }
startXMonadService :: IO DBusXMonad startXMonadService :: IO DBusXMonad
startXMonadService = do startXMonadService = do
client <- connectSession client <- connectSession
@ -52,7 +55,7 @@ startXMonadService = do
-- different -- different
(i, s) <- if requestResult /= NamePrimaryOwner then do (i, s) <- if requestResult /= NamePrimaryOwner then do
putStrLn "Another service owns \"org.xmonad\"" putStrLn "Another service owns \"org.xmonad\""
return (blankControls, Ignore) return (blankControls, blankSSToggle)
else do else do
putStrLn "Started xmonad dbus client" putStrLn "Started xmonad dbus client"
bc <- exportIntelBacklight client bc <- exportIntelBacklight client

View File

@ -10,7 +10,7 @@ module XMonad.Internal.DBus.Screensaver
, SSControls(..) , SSControls(..)
) where ) where
import Control.Monad (void) import Control.Monad (void, when)
import DBus import DBus
import DBus.Client import DBus.Client
@ -90,17 +90,16 @@ bodyGetCurrentState _ = Nothing
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Exported haskell API -- | Exported haskell API
newtype SSControls = SSControls { ssToggle :: IO () } newtype SSControls = SSControls { ssToggle :: MaybeExe (IO ()) }
exportScreensaver :: Client -> IO (MaybeExe SSControls) exportScreensaver :: Client -> IO SSControls
exportScreensaver client = do exportScreensaver client = do
d <- depInstalled $ depData dep (req, opt) <- checkInstalled [exe "xset"]
if d then flip Installed [] <$> exportScreensaver' client when (null req) $
else return $ Missing [depData dep] [] exportScreensaver' client
where return $ SSControls { ssToggle = createInstalled req opt callToggle }
dep = exe "xset"
exportScreensaver' :: Client -> IO SSControls exportScreensaver' :: Client -> IO ()
exportScreensaver' client = do exportScreensaver' client = do
export client ssPath defaultInterface export client ssPath defaultInterface
{ interfaceName = interface { interfaceName = interface
@ -109,7 +108,6 @@ exportScreensaver' client = do
, autoMethod memQuery query , autoMethod memQuery query
] ]
} }
return $ SSControls { ssToggle = callToggle }
callToggle :: IO () callToggle :: IO ()
callToggle = void $ callMethod $ methodCall ssPath interface memToggle callToggle = void $ callMethod $ methodCall ssPath interface memToggle

View File

@ -42,8 +42,8 @@ import Control.Arrow ((***))
import Control.Monad (filterM, join) import Control.Monad (filterM, join)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Data.List (partition, find) import Data.List (find, partition)
import Data.Maybe (isJust, listToMaybe, fromMaybe) import Data.Maybe (fromMaybe, isJust, listToMaybe)
import DBus import DBus
import DBus.Client import DBus.Client
@ -71,7 +71,7 @@ data DBusMember = Method_ MemberName
data DependencyData = Executable String data DependencyData = Executable String
| AccessiblePath FilePath Bool Bool | AccessiblePath FilePath Bool Bool
| DBusEndpoint | DBusEndpoint
{ ddDbusBus:: BusName { ddDbusBus :: BusName
, ddDbusSystem :: Bool , ddDbusSystem :: Bool
, ddDbusObject :: ObjectPath , ddDbusObject :: ObjectPath
, ddDbusInterface :: InterfaceName , ddDbusInterface :: InterfaceName
@ -174,15 +174,18 @@ pathAccessible p testread testwrite = do
-- (_, Just False) -> Just "file not writable" -- (_, Just False) -> Just "file not writable"
-- _ -> Nothing -- _ -> Nothing
introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect"
dbusInstalled :: BusName -> Bool -> ObjectPath -> InterfaceName -> DBusMember dbusInstalled :: BusName -> Bool -> ObjectPath -> InterfaceName -> DBusMember
-> IO Bool -> IO Bool
dbusInstalled bus usesystem objpath iface mem = do dbusInstalled bus usesystem objpath iface mem = do
client <- if usesystem then connectSystem else connectSession client <- if usesystem then connectSystem else connectSession
reply <- call_ client (methodCall objpath reply <- call_ client (methodCall objpath introspectInterface introspectMethod)
(interfaceName_ "org.freedesktop.DBus.Introspectable") { methodCallDestination = Just bus }
(memberName_ "Introspect"))
{ methodCallDestination = Just bus
}
let res = findMem =<< I.parseXML objpath =<< fromVariant let res = findMem =<< I.parseXML objpath =<< fromVariant
=<< listToMaybe (methodReturnBody reply) =<< listToMaybe (methodReturnBody reply)
disconnect client disconnect client
@ -218,7 +221,8 @@ createInstalled req opt x = if null req then Installed x opt else Missing req op
filterMissing :: [Dependency] -> IO [Dependency] filterMissing :: [Dependency] -> IO [Dependency]
filterMissing = filterM (fmap not . depInstalled . depData) filterMissing = filterM (fmap not . depInstalled . depData)
runIfInstalled :: MonadIO m => [Dependency] -> m a -> IO (MaybeExe (m a)) -- runIfInstalled :: MonadIO m => [Dependency] -> m a -> IO (MaybeExe (m a))
runIfInstalled :: [Dependency] -> a -> IO (MaybeExe a)
runIfInstalled ds x = do runIfInstalled ds x = do
(req, opt) <- checkInstalled ds (req, opt) <- checkInstalled ds
return $ createInstalled req opt x return $ createInstalled req opt x

View File

@ -11,6 +11,8 @@ module Xmobar.Plugins.Bluetooth
, btAlias , btAlias
, btBus , btBus
, btPath , btPath
, btPowered
, btInterface
) where ) where
import DBus import DBus
@ -24,9 +26,17 @@ data Bluetooth = Bluetooth (String, String, String) Int
callGetPowered :: Client -> IO (Either MethodError Variant) callGetPowered :: Client -> IO (Either MethodError Variant)
callGetPowered client = callGetPowered client =
getProperty client (methodCall btPath "org.bluez.Adapter1" "Powered") getProperty client (methodCall btPath btInterface $ memberName_ btPowered)
{ methodCallDestination = Just btBus } { methodCallDestination = Just btBus }
btInterface :: InterfaceName
btInterface = "org.bluez.Adapter1"
-- weird that this is a string when introspecting but a member name when calling
-- a method, not sure if it is supposed to work like that
btPowered :: String
btPowered = "Powered"
btBus :: BusName btBus :: BusName
btBus = "org.bluez" btBus = "org.bluez"