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.Control (pathExists)
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 Xmobar
@ -226,6 +227,19 @@ toJust x b = if b then Just x else Nothing
whenDBusPath :: Bool -> BusName -> ObjectPath -> CmdSpec -> IO (Maybe CmdSpec)
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
-- which case ethernet interfaces always start with "en" and wireless
-- interfaces always start with "wl"
@ -275,8 +289,11 @@ getVPN = do
where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
getBt :: IO (Maybe CmdSpec)
getBt = whenDBusPath True btBus btPath btCmd
getBt :: IO (MaybeExe CmdSpec)
-- getBt = whenDBusPath True btBus btPath btCmd
getBt = runIfInstalled [dep] btCmd
where
dep = dbusDep True btBus btPath btInterface $ Property_ btPowered
getAlsa :: IO (Maybe CmdSpec)
getAlsa = toJust alsaCmd . isJust <$> findExecutable "alsactl"
@ -289,6 +306,10 @@ getSs = whenDBusPath False xmonadBus ssPath ssCmd
getAllCommands :: IO BarRegions
getAllCommands = do
getBt' <- getBt
let bt = case getBt' of
(Installed x _) -> Just x
_ -> Nothing
let left =
[ CmdSpec
{ csAlias = "UnsafeStdinReader"
@ -299,7 +320,8 @@ getAllCommands = do
[ getWireless
, getEthernet
, getVPN
, getBt
-- , getBt
, return bt
, getAlsa
, getBattery
, getBl

View File

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

View File

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

View File

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

View File

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

View File

@ -42,8 +42,8 @@ import Control.Arrow ((***))
import Control.Monad (filterM, join)
import Control.Monad.IO.Class
import Data.List (partition, find)
import Data.Maybe (isJust, listToMaybe, fromMaybe)
import Data.List (find, partition)
import Data.Maybe (fromMaybe, isJust, listToMaybe)
import DBus
import DBus.Client
@ -174,15 +174,18 @@ pathAccessible p testread testwrite = do
-- (_, Just False) -> Just "file not writable"
-- _ -> Nothing
introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect"
dbusInstalled :: BusName -> Bool -> ObjectPath -> InterfaceName -> DBusMember
-> IO Bool
dbusInstalled bus usesystem objpath iface mem = do
client <- if usesystem then connectSystem else connectSession
reply <- call_ client (methodCall objpath
(interfaceName_ "org.freedesktop.DBus.Introspectable")
(memberName_ "Introspect"))
{ methodCallDestination = Just bus
}
reply <- call_ client (methodCall objpath introspectInterface introspectMethod)
{ methodCallDestination = Just bus }
let res = findMem =<< I.parseXML objpath =<< fromVariant
=<< listToMaybe (methodReturnBody reply)
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 = 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
(req, opt) <- checkInstalled ds
return $ createInstalled req opt x

View File

@ -11,6 +11,8 @@ module Xmobar.Plugins.Bluetooth
, btAlias
, btBus
, btPath
, btPowered
, btInterface
) where
import DBus
@ -24,9 +26,17 @@ data Bluetooth = Bluetooth (String, String, String) Int
callGetPowered :: Client -> IO (Either MethodError Variant)
callGetPowered client =
getProperty client (methodCall btPath "org.bluez.Adapter1" "Powered")
getProperty client (methodCall btPath btInterface $ memberName_ btPowered)
{ 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 = "org.bluez"