WIP use DBus dependency API everywhere
This commit is contained in:
parent
197f303111
commit
23098420aa
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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"
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue