ENH use typesafe dbus client

This commit is contained in:
Nathan Dwarshuis 2022-07-09 17:08:10 -04:00
parent f968078c06
commit cfde8865c1
18 changed files with 250 additions and 206 deletions

View File

@ -14,8 +14,6 @@ module Main (main) where
import Data.List
import Data.Maybe
import DBus.Client
import System.Exit
import System.IO
import System.IO.Error
@ -183,7 +181,7 @@ getWireless :: BarFeature
getWireless = Sometimes "wireless status indicator" xpfWireless
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
getEthernet :: Maybe Client -> BarFeature
getEthernet :: Maybe SysClient -> BarFeature
getEthernet cl = iconDBus "ethernet status indicator" (const True) root tree
where
root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl
@ -196,14 +194,14 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree
tree = Only_ $ IOTest_ "Test if battery is present" []
$ fmap (Msg Error) <$> hasBattery
getVPN :: Maybe Client -> BarFeature
getVPN :: Maybe SysClient -> BarFeature
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
where
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present"
networkManagerPkgs vpnPresent
getBt :: Maybe Client -> BarFeature
getBt :: Maybe SysClient -> BarFeature
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
getAlsa :: BarFeature
@ -212,15 +210,15 @@ getAlsa = iconIO_ "volume level indicator" (const True) root
where
root useIcon = IORoot_ (alsaCmd useIcon)
getBl :: Maybe Client -> BarFeature
getBl :: Maybe SesClient -> BarFeature
getBl = xmobarDBus "Intel backlight indicator" xpfIntelBacklight
intelBacklightSignalDep blCmd
getCk :: Maybe Client -> BarFeature
getCk :: Maybe SesClient -> BarFeature
getCk = xmobarDBus "Clevo keyboard indicator" xpfClevoBacklight
clevoKeyboardSignalDep ckCmd
getSs :: Maybe Client -> BarFeature
getSs :: Maybe SesClient -> BarFeature
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
getLock :: Always CmdSpec
@ -231,8 +229,8 @@ getLock = always1 "lock indicator" "icon indicator" root $ lockCmd fontifyAlt
--------------------------------------------------------------------------------
-- | bar feature constructors
xmobarDBus :: String -> XPQuery -> DBusDependency_ -> (Fontifier -> CmdSpec)
-> Maybe Client -> BarFeature
xmobarDBus :: SafeClient c => String -> XPQuery -> DBusDependency_ c
-> (Fontifier -> CmdSpec) -> Maybe c -> BarFeature
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
where
root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl
@ -241,12 +239,12 @@ iconIO_ :: String -> XPQuery -> (Fontifier -> IOTree_ -> Root CmdSpec)
-> IOTree_ -> BarFeature
iconIO_ = iconSometimes' And_ Only_
iconDBus :: String -> XPQuery -> (Fontifier -> DBusTree p -> Root CmdSpec)
-> DBusTree p -> BarFeature
iconDBus :: SafeClient c => String -> XPQuery
-> (Fontifier -> DBusTree c p -> Root CmdSpec) -> DBusTree c p -> BarFeature
iconDBus = iconSometimes' And1 $ Only_ . DBusIO
iconDBus_ :: String -> XPQuery -> (Fontifier -> DBusTree_ -> Root CmdSpec)
-> DBusTree_ -> BarFeature
iconDBus_ :: SafeClient c => String -> XPQuery
-> (Fontifier -> DBusTree_ c -> Root CmdSpec) -> DBusTree_ c -> BarFeature
iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> String -> XPQuery

View File

@ -90,9 +90,9 @@ run = do
data FeatureSet = FeatureSet
{ fsKeys :: ThreadState -> DBusState -> [KeyGroup FeatureX]
, fsDBusExporters :: [Maybe Client -> SometimesIO]
, fsDBusExporters :: [Maybe SesClient -> SometimesIO]
, fsPowerMon :: SometimesIO
, fsRemovableMon :: Maybe Client -> SometimesIO
, fsRemovableMon :: Maybe SysClient -> SometimesIO
, fsDaemons :: [Sometimes (IO ProcessHandle)]
, fsACPIHandler :: Always (String -> X ())
, fsTabbedTheme :: Always Theme
@ -107,7 +107,7 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
niceTheme = IORoot T.tabbedTheme $ fontTree T.defFontFamily defFontPkgs
fallback = Always_ $ FallbackAlone $ T.tabbedTheme T.fallbackFont
features :: Maybe Client -> FeatureSet
features :: Maybe SysClient -> FeatureSet
features cl = FeatureSet
{ fsKeys = externalBindings
, fsDBusExporters = dbusExporters

View File

@ -3,10 +3,10 @@
module DBus.Internal
( addMatchCallback
, getDBusClient
, fromDBusClient
, withDBusClient
, withDBusClient_
-- , getDBusClient
-- , fromDBusClient
-- , withDBusClient
-- , withDBusClient_
, matchProperty
, matchPropertyFull
, matchPropertyChanged
@ -28,7 +28,7 @@ module DBus.Internal
, bodyToMaybe
) where
import Control.Exception
-- import Control.Exception
import Control.Monad
import Data.Bifunctor
@ -144,26 +144,26 @@ matchPropertyChanged _ _ _ = Failure
--------------------------------------------------------------------------------
-- | Client requests
getDBusClient :: Bool -> IO (Maybe Client)
getDBusClient sys = do
res <- try $ if sys then connectSystem else connectSession
case res of
Left e -> putStrLn (clientErrorMessage e) >> return Nothing
Right c -> return $ Just c
-- getDBusClient :: Bool -> IO (Maybe Client)
-- getDBusClient sys = do
-- res <- try $ if sys then connectSystem else connectSession
-- case res of
-- Left e -> putStrLn (clientErrorMessage e) >> return Nothing
-- Right c -> return $ Just c
withDBusClient :: Bool -> (Client -> IO a) -> IO (Maybe a)
withDBusClient sys f = do
client <- getDBusClient sys
forM client $ \c -> do
r <- f c
disconnect c
return r
-- withDBusClient :: Bool -> (c -> IO a) -> IO (Maybe a)
-- withDBusClient sys f = do
-- client <- getDBusClient sys
-- forM client $ \c -> do
-- r <- f c
-- disconnect c
-- return r
withDBusClient_ :: Bool -> (Client -> IO ()) -> IO ()
withDBusClient_ sys = void . withDBusClient sys
-- withDBusClient_ :: Bool -> (Client -> IO ()) -> IO ()
-- withDBusClient_ sys = void . withDBusClient sys
fromDBusClient :: Bool -> (Client -> a) -> IO (Maybe a)
fromDBusClient sys f = withDBusClient sys (return . f)
-- fromDBusClient :: Bool -> (Client -> a) -> IO (Maybe a)
-- fromDBusClient sys f = withDBusClient sys (return . f)
--------------------------------------------------------------------------------
-- | Object Manager

View File

@ -18,7 +18,6 @@ module XMonad.Internal.Command.DMenu
import Control.Monad.Reader
import DBus
import DBus.Client
import Graphics.X11.Types
@ -137,7 +136,7 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
runWinMenu :: SometimesX
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
runNetMenu :: Maybe Client -> SometimesX
runNetMenu :: Maybe SysClient -> SometimesX
runNetMenu cl =
sometimesDBus cl "network control menu" "rofi NetworkManager" tree cmd
where
@ -155,7 +154,7 @@ runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
--------------------------------------------------------------------------------
-- | Password manager
runBwMenu :: Maybe Client -> SometimesX
runBwMenu :: Maybe SesClient -> SometimesX
runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
where
cmd _ = spawnCmd myDmenuPasswords

View File

@ -43,7 +43,6 @@ import Control.Monad (void)
import Control.Monad.IO.Class
import DBus
import DBus.Client
import System.Directory
import System.Environment
@ -215,7 +214,7 @@ runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return
--------------------------------------------------------------------------------
-- | Notification control
runNotificationCmd :: String -> FilePath -> Maybe Client -> SometimesX
runNotificationCmd :: String -> FilePath -> Maybe SesClient -> SometimesX
runNotificationCmd n arg cl =
sometimesDBus cl (n ++ " control") "dunstctl" tree cmd
where
@ -224,18 +223,18 @@ runNotificationCmd n arg cl =
$ Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0")
$ Method_ $ memberName_ "NotificationAction"
runNotificationClose :: Maybe Client -> SometimesX
runNotificationClose :: Maybe SesClient -> SometimesX
runNotificationClose = runNotificationCmd "close notification" "close"
runNotificationCloseAll :: Maybe Client -> SometimesX
runNotificationCloseAll :: Maybe SesClient -> SometimesX
runNotificationCloseAll =
runNotificationCmd "close all notifications" "close-all"
runNotificationHistory :: Maybe Client -> SometimesX
runNotificationHistory :: Maybe SesClient -> SometimesX
runNotificationHistory =
runNotificationCmd "see notification history" "history-pop"
runNotificationContext :: Maybe Client -> SometimesX
runNotificationContext :: Maybe SesClient -> SometimesX
runNotificationContext =
runNotificationCmd "open notification context" "context"
@ -243,7 +242,7 @@ runNotificationContext =
-- | System commands
-- this is required for some vpn's to work properly with network-manager
runNetAppDaemon :: Maybe Client -> Sometimes (IO ProcessHandle)
runNetAppDaemon :: Maybe SysClient -> Sometimes (IO ProcessHandle)
runNetAppDaemon cl = Sometimes "network applet" xpfVPN
[Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
where
@ -251,7 +250,7 @@ runNetAppDaemon cl = Sometimes "network applet" xpfVPN
app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
cmd _ = snd <$> spawnPipe "nm-applet"
runToggleBluetooth :: Maybe Client -> SometimesX
runToggleBluetooth :: Maybe SysClient -> SometimesX
runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
[Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
where
@ -306,7 +305,7 @@ getCaptureDir = do
where
fallback = (</> ".local/share") <$> getHomeDirectory
runFlameshot :: String -> String -> Maybe Client -> SometimesX
runFlameshot :: String -> String -> Maybe SesClient -> SometimesX
runFlameshot n mode cl = sometimesDBus cl n myCapture tree cmd
where
cmd _ = spawnCmd myCapture [mode]
@ -315,15 +314,15 @@ runFlameshot n mode cl = sometimesDBus cl n myCapture tree cmd
-- TODO this will steal focus from the current window (and puts it
-- in the root window?) ...need to fix
runAreaCapture :: Maybe Client -> SometimesX
runAreaCapture :: Maybe SesClient -> SometimesX
runAreaCapture = runFlameshot "screen area capture" "gui"
-- myWindowCap = "screencap -w" --external script
runDesktopCapture :: Maybe Client -> SometimesX
runDesktopCapture :: Maybe SesClient -> SometimesX
runDesktopCapture = runFlameshot "fullscreen capture" "full"
runScreenCapture :: Maybe Client -> SometimesX
runScreenCapture :: Maybe SesClient -> SometimesX
runScreenCapture = runFlameshot "screen capture" "screen"
runCaptureBrowser :: SometimesX

View File

@ -15,7 +15,6 @@ import Control.Monad (when)
import Data.Int (Int32)
import DBus
import DBus.Client
import System.FilePath.Posix
@ -113,18 +112,18 @@ stateFileDep = pathRW stateFile [Package AUR "tuxedo-keyboard"]
brightnessFileDep :: IODependency_
brightnessFileDep = pathR brightnessFile [Package AUR "tuxedo-keyboard"]
clevoKeyboardSignalDep :: DBusDependency_
clevoKeyboardSignalDep :: DBusDependency_ SesClient
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
exportClevoKeyboard :: Maybe Client -> SometimesIO
exportClevoKeyboard :: Maybe SesClient -> SometimesIO
exportClevoKeyboard = brightnessExporter xpfClevoBacklight []
[stateFileDep, brightnessFileDep] clevoKeyboardConfig
clevoKeyboardControls :: Maybe Client -> BrightnessControls
clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
callGetBrightnessCK :: Client -> IO (Maybe Brightness)
callGetBrightnessCK = callGetBrightness clevoKeyboardConfig
callGetBrightnessCK :: SesClient -> IO (Maybe Brightness)
callGetBrightnessCK = callGetBrightness clevoKeyboardConfig . toClient
matchSignalCK :: (Maybe Brightness -> IO ()) -> Client -> IO ()
matchSignalCK = matchSignal clevoKeyboardConfig
matchSignalCK :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
matchSignalCK cb = matchSignal clevoKeyboardConfig cb . toClient

View File

@ -52,9 +52,9 @@ data BrightnessControls = BrightnessControls
, bctlDec :: SometimesIO
}
brightnessControls :: XPQuery -> BrightnessConfig a b -> Maybe Client
brightnessControls :: XPQuery -> BrightnessConfig a b -> Maybe SesClient
-> BrightnessControls
brightnessControls q bc client =
brightnessControls q bc cl =
BrightnessControls
{ bctlMax = cb "max brightness" memMax
, bctlMin = cb "min brightness" memMin
@ -62,14 +62,14 @@ brightnessControls q bc client =
, bctlDec = cb "decrease brightness" memDec
}
where
cb = callBacklight q client bc
cb = callBacklight q cl bc
callGetBrightness :: Num c => BrightnessConfig a b -> Client -> IO (Maybe c)
callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client =
either (const Nothing) bodyGetBrightness
<$> callMethod client xmonadBusName p i memGet
signalDep :: BrightnessConfig a b -> DBusDependency_
signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient
signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
Endpoint [] xmonadBusName p i $ Signal_ memCur
@ -88,20 +88,21 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
-- | Internal DBus Crap
brightnessExporter :: RealFrac b => XPQuery -> [Fulfillment] -> [IODependency_]
-> BrightnessConfig a b -> Maybe Client -> SometimesIO
-> BrightnessConfig a b -> Maybe SesClient -> SometimesIO
brightnessExporter q ful deps bc@BrightnessConfig { bcName = n } cl =
Sometimes (n ++ " DBus Interface") q [Subfeature root "exporter"]
where
root = DBusRoot_ (exportBrightnessControls' bc) tree cl
tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
exportBrightnessControls' bc client = do
exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> SesClient -> IO ()
exportBrightnessControls' bc cl = do
let ses = toClient cl
maxval <- bcGetMax bc -- assume the max value will never change
let bounds = (bcMinRaw bc, maxval)
let autoMethod' m f = autoMethod m $ emitBrightness bc client =<< f bc bounds
let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds
let funget = bcGet bc
export client (bcPath bc) defaultInterface
export ses (bcPath bc) defaultInterface
{ interfaceName = bcInterface bc
, interfaceMethods =
[ autoMethod' memMax bcMax
@ -130,7 +131,7 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
where
sig = signal p i memCur
callBacklight :: XPQuery -> Maybe Client -> BrightnessConfig a b -> String
callBacklight :: XPQuery -> Maybe SesClient -> BrightnessConfig a b -> String
-> MemberName -> SometimesIO
callBacklight q cl BrightnessConfig { bcPath = p
, bcInterface = i
@ -138,7 +139,7 @@ callBacklight q cl BrightnessConfig { bcPath = p
Sometimes (unwords [n, controlName]) q [Subfeature root "method call"]
where
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
cmd c = io $ void $ callMethod c xmonadBusName p i m
cmd c = io $ void $ callMethod (toClient c) xmonadBusName p i m
bodyGetBrightness :: Num a => [Variant] -> Maybe a
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)

View File

@ -13,7 +13,6 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
import Data.Int (Int32)
import DBus
import DBus.Client
import System.FilePath.Posix
@ -95,18 +94,18 @@ curFileDep = pathRW curFile []
maxFileDep :: IODependency_
maxFileDep = pathR maxFile []
intelBacklightSignalDep :: DBusDependency_
intelBacklightSignalDep :: DBusDependency_ SesClient
intelBacklightSignalDep = signalDep intelBacklightConfig
exportIntelBacklight :: Maybe Client -> SometimesIO
exportIntelBacklight :: Maybe SesClient -> SometimesIO
exportIntelBacklight = brightnessExporter xpfIntelBacklight []
[curFileDep, maxFileDep] intelBacklightConfig
intelBacklightControls :: Maybe Client -> BrightnessControls
intelBacklightControls :: Maybe SesClient -> BrightnessControls
intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
callGetBrightnessIB :: Client -> IO (Maybe Brightness)
callGetBrightnessIB = callGetBrightness intelBacklightConfig
callGetBrightnessIB :: SesClient -> IO (Maybe Brightness)
callGetBrightnessIB = callGetBrightness intelBacklightConfig . toClient
matchSignalIB :: (Maybe Brightness -> IO ()) -> Client -> IO ()
matchSignalIB = matchSignal intelBacklightConfig
matchSignalIB :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
matchSignalIB cb = matchSignal intelBacklightConfig cb . toClient

View File

@ -21,7 +21,6 @@ import Control.Monad
import DBus
import DBus.Client
import DBus.Internal
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight
@ -31,36 +30,37 @@ import XMonad.Internal.Dependency
-- | Current connections to the DBus (session and system buses)
data DBusState = DBusState
{ dbSesClient :: Maybe Client
, dbSysClient :: Maybe Client
{ dbSesClient :: Maybe SesClient
, dbSysClient :: Maybe SysClient
}
-- | Connect to the DBus
connectDBus :: IO DBusState
connectDBus = do
ses <- getDBusClient False
sys <- getDBusClient True
ses <- getDBusClient
sys <- getDBusClient
return DBusState { dbSesClient = ses, dbSysClient = sys }
-- TODO why is this only the session client?
-- | Disconnect from the DBus
disconnectDBus :: DBusState -> IO ()
disconnectDBus db = forM_ (dbSysClient db) disconnect
disconnectDBus db = forM_ (toClient <$> dbSysClient db) disconnect
-- | Connect to the DBus and request the XMonad name
connectDBusX :: IO DBusState
connectDBusX = do
db <- connectDBus
forM_ (dbSesClient db) requestXMonadName
forM_ (toClient <$> dbSesClient db) requestXMonadName
return db
-- | Disconnect from DBus and release the XMonad name
disconnectDBusX :: DBusState -> IO ()
disconnectDBusX db = do
forM_ (dbSesClient db) releaseXMonadName
forM_ (toClient <$> dbSesClient db) releaseXMonadName
disconnectDBus db
-- | All exporter features to be assigned to the DBus
dbusExporters :: [Maybe Client -> SometimesIO]
dbusExporters :: [Maybe SesClient -> SometimesIO]
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
releaseXMonadName :: Client -> IO ()

View File

@ -32,13 +32,13 @@ memAdded = memberName_ "InterfacesAdded"
memRemoved :: MemberName
memRemoved = memberName_ "InterfacesRemoved"
dbusDep :: MemberName -> DBusDependency_
dbusDep :: MemberName -> DBusDependency_ SysClient
dbusDep m = Endpoint [Package Official "udisks2"] bus path interface $ Signal_ m
addedDep :: DBusDependency_
addedDep :: DBusDependency_ SysClient
addedDep = dbusDep memAdded
removedDep :: DBusDependency_
removedDep :: DBusDependency_ SysClient
removedDep = dbusDep memRemoved
driveInsertedSound :: FilePath
@ -73,15 +73,15 @@ playSoundMaybe p b = when b $ io $ playSound p
-- If it not already, we won't see any signals from the dbus until it is
-- started (it will work after it is started however). It seems safe to simply
-- enable the udisks2 service at boot; however this is not default behavior.
listenDevices :: Client -> IO ()
listenDevices client = do
listenDevices :: SysClient -> IO ()
listenDevices cl = do
addMatch' memAdded driveInsertedSound addedHasDrive
addMatch' memRemoved driveRemovedSound removedHasDrive
where
addMatch' m p f = void $ addMatch client ruleUdisks { matchMember = Just m }
addMatch' m p f = void $ addMatch (toClient cl) ruleUdisks { matchMember = Just m }
$ playSoundMaybe p . f . signalBody
runRemovableMon :: Maybe Client -> SometimesIO
runRemovableMon :: Maybe SysClient -> SometimesIO
runRemovableMon cl =
sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
where

View File

@ -94,14 +94,15 @@ bodyGetCurrentState _ = Nothing
--------------------------------------------------------------------------------
-- | Exported haskell API
exportScreensaver :: Maybe Client -> SometimesIO
exportScreensaver client =
sometimesDBus client "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
exportScreensaver :: Maybe SesClient -> SometimesIO
exportScreensaver ses =
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
where
cmd cl = export cl ssPath defaultInterface
cmd cl = let cl' = toClient cl in
export cl' ssPath defaultInterface
{ interfaceName = interface
, interfaceMethods =
[ autoMethod memToggle $ emitState cl =<< toggle
[ autoMethod memToggle $ emitState cl' =<< toggle
, autoMethod memQuery query
]
, interfaceSignals = [sig]
@ -119,7 +120,7 @@ exportScreensaver client =
bus = Bus [] xmonadBusName
ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
callToggle :: Maybe Client -> SometimesIO
callToggle :: Maybe SesClient -> SometimesIO
callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" []
xmonadBusName ssPath interface memToggle
@ -128,9 +129,9 @@ callQuery client = do
reply <- callMethod client xmonadBusName ssPath interface memQuery
return $ either (const Nothing) bodyGetCurrentState reply
matchSignal :: (Maybe SSState -> IO ()) -> Client -> IO ()
matchSignal cb =
fmap void . addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
matchSignal :: (Maybe SSState -> IO ()) -> SesClient -> IO ()
matchSignal cb ses = void $ addMatchCallback ruleCurrentState
(cb . bodyGetCurrentState) $ toClient ses
ssSignalDep :: DBusDependency_
ssSignalDep :: DBusDependency_ SesClient
ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState

View File

@ -40,6 +40,9 @@ module XMonad.Internal.Dependency
, IOTree_
, DBusTree
, DBusTree_
, SafeClient(..)
, SysClient(..)
, SesClient(..)
, IODependency(..)
, IODependency_(..)
, SystemDependency(..)
@ -109,6 +112,7 @@ module XMonad.Internal.Dependency
, shellTest
) where
import Control.Exception hiding (bracket)
import Control.Monad.IO.Class
import Control.Monad.Identity
import Control.Monad.Reader
@ -293,8 +297,49 @@ type SubfeatureRoot a = Subfeature (Root a)
-- needed
data Root a = forall p. IORoot (p -> a) (IOTree p)
| IORoot_ a IOTree_
| forall p. DBusRoot (p -> Client -> a) (DBusTree p) (Maybe Client)
| DBusRoot_ (Client -> a) DBusTree_ (Maybe Client)
| forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
| forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c)
class SafeClient c where
toClient :: c -> Client
getDBusClient :: IO (Maybe c)
withDBusClient :: (c -> IO a) -> IO (Maybe a)
withDBusClient f = do
client <- getDBusClient
forM client $ \c -> do
r <- f c
disconnect (toClient c)
return r
withDBusClient_ :: (c -> IO ()) -> IO ()
withDBusClient_ = void . withDBusClient
fromDBusClient :: (c -> a) -> IO (Maybe a)
fromDBusClient f = withDBusClient (return . f)
newtype SysClient = SysClient Client
instance SafeClient SysClient where
toClient (SysClient cl) = cl
getDBusClient = fmap SysClient <$> getDBusClient' True
newtype SesClient = SesClient Client
instance SafeClient SesClient where
toClient (SesClient cl) = cl
getDBusClient = fmap SesClient <$> getDBusClient' False
getDBusClient' :: Bool -> IO (Maybe Client)
getDBusClient' sys = do
res <- try $ if sys then connectSystem else connectSession
case res of
Left e -> putStrLn (clientErrorMessage e) >> return Nothing
Right c -> return $ Just c
-- | The dependency tree with rule to merge results when needed
data Tree d d_ p =
@ -309,9 +354,9 @@ data Tree_ d = And_ (Tree_ d) (Tree_ d) | Or_ (Tree_ d) (Tree_ d) | Only_ d
-- | Shorthand tree types for lazy typers
type IOTree p = Tree IODependency IODependency_ p
type DBusTree p = Tree IODependency DBusDependency_ p
type DBusTree c p = Tree IODependency (DBusDependency_ c) p
type IOTree_ = Tree_ IODependency_
type DBusTree_ = Tree_ DBusDependency_
type DBusTree_ c = Tree_ (DBusDependency_ c)
-- | A dependency that only requires IO to evaluate (with payload)
data IODependency p =
@ -325,12 +370,12 @@ data IODependency p =
| forall a. IOSometimes (Sometimes a) (a -> p)
-- | A dependency pertaining to the DBus
data DBusDependency_ = Bus [Fulfillment] BusName
data DBusDependency_ c = Bus [Fulfillment] BusName
| Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember
| DBusIO IODependency_
deriving (Eq, Generic)
instance Hashable DBusDependency_ where
instance Hashable (DBusDependency_ c) where
hashWithSalt s (Bus f b) = s `hashWithSalt` f
`hashWithSalt` formatBusName b
hashWithSalt s (Endpoint f b o i m) = s `hashWithSalt` f
@ -445,7 +490,8 @@ data PostFail = PostFail [Msg] | PostMissing Msg
-- that the results will always be the same.
emptyCache :: Cache
emptyCache = Cache H.empty H.empty H.empty
-- emptyCache = Cache H.empty H.empty H.empty
emptyCache = Cache H.empty H.empty
memoizeIO_ :: (IODependency_ -> FIO Result_) -> IODependency_ -> FIO Result_
memoizeIO_ f d = do
@ -458,16 +504,17 @@ memoizeIO_ f d = do
modify (\s -> s { cIO_ = H.insert d r (cIO_ s) })
return r
memoizeDBus_ :: (DBusDependency_ -> FIO Result_) -> DBusDependency_ -> FIO Result_
memoizeDBus_ f d = do
m <- gets cDBus_
case H.lookup d m of
(Just r) -> return r
Nothing -> do
-- io $ putStrLn $ "not using cache for " ++ show d
r <- f d
modify (\s -> s { cDBus_ = H.insert d r (cDBus_ s) })
return r
-- memoizeDBus_ :: SafeClient c => (DBusDependency_ c -> FIO Result_)
-- -> DBusDependency_ c -> FIO Result_
-- memoizeDBus_ get f d = do
-- m <- gets cDBus_
-- case H.lookup d m of
-- (Just r) -> return r
-- Nothing -> do
-- -- io $ putStrLn $ "not using cache for " ++ show d
-- r <- f d
-- modify (\s -> s { cDBus_ = H.insert d r (cDBus_ s) })
-- return r
memoizeFont :: (String -> IO (Result FontBuilder)) -> String -> FIO (Result FontBuilder)
memoizeFont f d = do
@ -549,7 +596,7 @@ type XPQuery = XPFeatures -> Bool
data Cache = Cache
{ --cIO :: forall p. Memoizable p => H.HashMap (IODependency p) (Result p)
cIO_ :: H.HashMap IODependency_ Result_
, cDBus_ :: H.HashMap DBusDependency_ Result_
-- , cDBus_ :: forall c. H.HashMap (DBusDependency_ c) Result_
, cFont :: H.HashMap String (Result FontBuilder)
}
@ -884,12 +931,13 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect"
testDBusDependency_ :: Client -> DBusDependency_ -> FIO Result_
testDBusDependency_ cl = memoizeDBus_ (testDBusDependency'_ cl)
testDBusDependency_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_
-- testDBusDependency_ cl = memoizeDBus_ (testDBusDependency'_ cl)
testDBusDependency_ = testDBusDependency'_
testDBusDependency'_ :: Client -> DBusDependency_ -> FIO Result_
testDBusDependency'_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_
testDBusDependency'_ cl (Bus _ bus) = io $ do
ret <- callMethod cl queryBus queryPath queryIface queryMem
ret <- callMethod (toClient cl) queryBus queryPath queryIface queryMem
return $ case ret of
Left e -> Left [Msg Error e]
Right b -> let ns = bodyGetNames b in
@ -907,7 +955,7 @@ testDBusDependency'_ cl (Bus _ bus) = io $ do
bodyGetNames _ = []
testDBusDependency'_ cl (Endpoint _ busname objpath iface mem) = io $ do
ret <- callMethod cl busname objpath introspectInterface introspectMethod
ret <- callMethod (toClient cl) busname objpath introspectInterface introspectMethod
return $ case ret of
Left e -> Left [Msg Error e]
Right body -> procBody body
@ -996,18 +1044,18 @@ sometimesExeArgs :: MonadIO m => String -> String -> [Fulfillment] -> Bool
sometimesExeArgs fn n ful sys path args =
sometimesIO_ fn n (Only_ (IOSystem_ ful $ Executable sys path)) $ spawnCmd path args
sometimesDBus :: Maybe Client -> String -> String -> Tree_ DBusDependency_
-> (Client -> a) -> Sometimes a
sometimesDBus :: SafeClient c => Maybe c -> String -> String
-> Tree_ (DBusDependency_ c) -> (c -> a) -> Sometimes a
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
sometimesEndpoint :: MonadIO m => String -> String -> [Fulfillment]
-> BusName -> ObjectPath -> InterfaceName -> MemberName -> Maybe Client
-> Sometimes (m ())
sometimesEndpoint :: (SafeClient c, MonadIO m) => String -> String
-> [Fulfillment] -> BusName -> ObjectPath -> InterfaceName -> MemberName
-> Maybe c -> Sometimes (m ())
sometimesEndpoint fn name ful busname path iface mem cl =
sometimesDBus cl fn name deps cmd
where
deps = Only_ $ Endpoint ful busname path iface $ Method_ mem
cmd c = io $ void $ callMethod c busname path iface mem
cmd c = io $ void $ callMethod (toClient c) busname path iface mem
--------------------------------------------------------------------------------
-- | Dependency Tree Constructors
@ -1207,7 +1255,7 @@ dataSysDependency f d = first Q $
f' = ("fulfilment", JSON_UQ $ dataFulfillments f)
dataDBusDependency :: DBusDependency_ -> DependencyData
dataDBusDependency :: DBusDependency_ c -> DependencyData
dataDBusDependency d =
case d of
(DBusIO i) -> dataIODependency_ i

View File

@ -6,14 +6,13 @@
module Xmobar.Plugins.BacklightCommon (startBacklight) where
import DBus.Client
import XMonad.Internal.Dependency
import Xmobar.Plugins.Common
startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> Client -> IO ())
-> (Client -> IO (Maybe a)) -> String -> Callback -> IO ()
startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ())
-> (SesClient -> IO (Maybe a)) -> String -> Callback -> IO ()
startBacklight matchSignal callGetBrightness icon cb = do
withDBusClientConnection False cb $ \c -> do
withDBusClientConnection cb $ \c -> do
matchSignal display c
display =<< callGetBrightness c
where

View File

@ -56,7 +56,7 @@ import Xmobar.Plugins.Common
btAlias :: String
btAlias = "bluetooth"
btDep :: DBusDependency_
btDep :: DBusDependency_ SysClient
btDep = Endpoint [Package Official "bluez"] btBus btOMPath omInterface
$ Method_ getManagedObjects
@ -65,9 +65,9 @@ data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
instance Exec Bluetooth where
alias (Bluetooth _ _) = btAlias
start (Bluetooth icons colors) cb =
withDBusClientConnection True cb $ startAdapter icons colors cb
withDBusClientConnection cb $ startAdapter icons colors cb
startAdapter :: Icons -> Colors -> Callback -> Client -> IO ()
startAdapter :: Icons -> Colors -> Callback -> SysClient -> IO ()
startAdapter is cs cb cl = do
ot <- getBtObjectTree cl
state <- newMVar emptyState
@ -157,29 +157,29 @@ adaptorHasDevice adaptor device = case splitPath device of
splitPath :: ObjectPath -> [String]
splitPath = splitOn "/" . dropWhile (=='/') . formatObjectPath
getBtObjectTree :: Client -> IO ObjectTree
getBtObjectTree client = callGetManagedObjects client btBus btOMPath
getBtObjectTree :: SysClient -> IO ObjectTree
getBtObjectTree sys = callGetManagedObjects (toClient sys) btBus btOMPath
btOMPath :: ObjectPath
btOMPath = objectPath_ "/"
addBtOMListener :: SignalCallback -> Client -> IO ()
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
addBtOMListener :: SignalCallback -> SysClient -> IO ()
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc . toClient
addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO ()
addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
addDeviceAddedListener state display adapter client =
addBtOMListener addDevice client
where
addDevice = pathCallback adapter display $ \d ->
addAndInitDevice state display d client
addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO ()
addDeviceRemovedListener state display adapter client =
addBtOMListener remDevice client
addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
addDeviceRemovedListener state display adapter sys =
addBtOMListener remDevice sys
where
remDevice = pathCallback adapter display $ \d -> do
old <- removeDevice state d
forM_ old $ removeMatch client . btDevSigHandler
forM_ old $ removeMatch (toClient sys) . btDevSigHandler
pathCallback :: ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback
pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
@ -189,25 +189,25 @@ pathCallback _ _ _ _ = return ()
--------------------------------------------------------------------------------
-- | Adapter
initAdapter :: MutableBtState -> ObjectPath -> Client -> IO ()
initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
initAdapter state adapter client = do
reply <- callGetPowered adapter client
putPowered state $ fromSingletonVariant reply
matchBTProperty :: Client -> ObjectPath -> IO (Maybe MatchRule)
matchBTProperty client p = matchPropertyFull client btBus (Just p)
matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
matchBTProperty client p = matchPropertyFull (toClient client) btBus (Just p)
addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> Client
addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
-> IO (Maybe SignalHandler)
addAdaptorListener state display adaptor client = do
rule <- matchBTProperty client adaptor
forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) client
addAdaptorListener state display adaptor sys = do
rule <- matchBTProperty sys adaptor
forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) (toClient sys)
where
procMatch = withSignalMatch $ \b -> putPowered state b >> display
callGetPowered :: ObjectPath -> Client -> IO [Variant]
callGetPowered adapter =
callPropertyGet btBus adapter adapterInterface $ memberName_ adaptorPowered
callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
callGetPowered adapter sys =
callPropertyGet btBus adapter adapterInterface (memberName_ adaptorPowered) $ toClient sys
matchPowered :: [Variant] -> SignalMatch Bool
matchPowered = matchPropertyChanged adapterInterface adaptorPowered
@ -227,25 +227,25 @@ adaptorPowered = "Powered"
--------------------------------------------------------------------------------
-- | Devices
addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> Client -> IO ()
addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
addAndInitDevice state display device client = do
sh <- addDeviceListener state display device client
-- TODO add some intelligent error messages here
forM_ sh $ \s -> initDevice state s device client
initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> Client -> IO ()
initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
initDevice state sh device client = do
reply <- callGetConnected device client
reply <- callGetConnected device (toClient client)
void $ insertDevice state device $
BTDevice { btDevConnected = fromVariant =<< listToMaybe reply
, btDevSigHandler = sh
}
addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> Client
addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
-> IO (Maybe SignalHandler)
addDeviceListener state display device client = do
rule <- matchBTProperty client device
forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) client
forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) (toClient client)
where
procMatch = withSignalMatch $ \c -> updateDevice state device c >> display

View File

@ -21,6 +21,7 @@ import DBus.Client
import DBus.Internal
import XMonad.Hooks.DynamicLog (xmobarColor)
import XMonad.Internal.Dependency
type Callback = String -> IO ()
@ -59,5 +60,5 @@ displayMaybe cb f = cb <=< maybe (return na) f
displayMaybe' :: Callback -> (a -> IO ()) -> Maybe a -> IO ()
displayMaybe' cb = maybe (cb na)
withDBusClientConnection :: Bool -> Callback -> (Client -> IO ()) -> IO ()
withDBusClientConnection sys cb f = displayMaybe' cb f =<< getDBusClient sys
withDBusClientConnection :: SafeClient c => Callback -> (c -> IO ()) -> IO ()
withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient

View File

@ -1,14 +1,14 @@
--------------------------------------------------------------------------------
-- | Device plugin
--
-- Display different text depending on whether or not the interface has
-- connectivity
module Xmobar.Plugins.Device
( Device(..)
, devDep
) where
--------------------------------------------------------------------------------
-- | Devince plugin
--
-- Display different text depending on whether or not the interface has
-- connectivity
import Control.Monad
import Data.Word
@ -18,15 +18,13 @@ import DBus.Client
import DBus.Internal
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import XMonad.Internal.Dependency
import Xmobar
import Xmobar.Plugins.Common
newtype Device = Device (String, String, Colors) deriving (Read, Show)
nmBus :: BusName
nmBus = busName_ "org.freedesktop.NetworkManager"
nmPath :: ObjectPath
nmPath = objectPath_ "/org/freedesktop/NetworkManager"
@ -42,18 +40,19 @@ getByIP = memberName_ "GetDeviceByIpIface"
devSignal :: String
devSignal = "Ip4Connectivity"
devDep :: DBusDependency_
devDep = Endpoint networkManagerPkgs nmBus nmPath nmInterface $ Method_ getByIP
devDep :: DBusDependency_ SysClient
devDep = Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface
$ Method_ getByIP
getDevice :: Client -> String -> IO (Maybe ObjectPath)
getDevice client iface = bodyToMaybe <$> callMethod' client mc
getDevice :: SysClient -> String -> IO (Maybe ObjectPath)
getDevice cl iface = bodyToMaybe <$> callMethod' (toClient cl) mc
where
mc = (methodCallBus nmBus nmPath nmInterface getByIP)
mc = (methodCallBus networkManagerBus nmPath nmInterface getByIP)
{ methodCallBody = [toVariant iface]
}
getDeviceConnected :: ObjectPath -> Client -> IO [Variant]
getDeviceConnected path = callPropertyGet nmBus path nmDeviceInterface
getDeviceConnected path = callPropertyGet networkManagerBus path nmDeviceInterface
$ memberName_ devSignal
matchStatus :: [Variant] -> SignalMatch Word32
@ -62,13 +61,13 @@ matchStatus = matchPropertyChanged nmDeviceInterface devSignal
instance Exec Device where
alias (Device (iface, _, _)) = iface
start (Device (iface, text, colors)) cb = do
withDBusClientConnection True cb $ \client -> do
withDBusClientConnection cb $ \client -> do
path <- getDevice client iface
displayMaybe' cb (listener client) path
where
listener client path = do
rule <- matchPropertyFull client nmBus (Just path)
rule <- matchPropertyFull (toClient client) networkManagerBus (Just path)
-- TODO warn the user here rather than silently drop the listener
forM_ rule $ \r ->
startListener r (getDeviceConnected path) matchStatus chooseColor' cb client
startListener r (getDeviceConnected path) matchStatus chooseColor' cb (toClient client)
chooseColor' = return . (\s -> colorText colors s text) . (> 1)

View File

@ -12,6 +12,7 @@ module Xmobar.Plugins.Screensaver
import Xmobar
import XMonad.Internal.DBus.Screensaver
import XMonad.Internal.Dependency
import Xmobar.Plugins.Common
newtype Screensaver = Screensaver (String, Colors) deriving (Read, Show)
@ -22,9 +23,9 @@ ssAlias = "screensaver"
instance Exec Screensaver where
alias (Screensaver _) = ssAlias
start (Screensaver (text, colors)) cb = do
withDBusClientConnection False cb $ \c -> do
withDBusClientConnection cb $ \c -> do
matchSignal display c
display =<< callQuery c
display =<< callQuery (toClient c)
where
display = displayMaybe cb $ return . (\s -> colorText colors s text)

View File

@ -19,10 +19,10 @@ import Data.Maybe
import qualified Data.Set as S
import DBus
import DBus.Client
import DBus.Internal
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import XMonad.Internal.Dependency
import Xmobar
import Xmobar.Plugins.Common
@ -32,7 +32,7 @@ newtype VPN = VPN (String, Colors) deriving (Read, Show)
instance Exec VPN where
alias (VPN _) = vpnAlias
start (VPN (text, colors)) cb =
withDBusClientConnection True cb $ \c -> do
withDBusClientConnection cb $ \c -> do
state <- initState c
let display = displayMaybe cb iconFormatter . Just =<< readState state
let signalCallback' f = f state display
@ -53,7 +53,7 @@ type VPNState = S.Set ObjectPath
type MutableVPNState = MVar VPNState
initState :: Client -> IO MutableVPNState
initState :: SysClient -> IO MutableVPNState
initState client = do
ot <- getVPNObjectTree client
newMVar $ findTunnels ot
@ -69,17 +69,17 @@ updateState f state op = modifyMVar_ state $ return . f op
-- | Tunnel Device Detection
--
getVPNObjectTree :: Client -> IO ObjectTree
getVPNObjectTree client = callGetManagedObjects client vpnBus vpnPath
getVPNObjectTree :: SysClient -> IO ObjectTree
getVPNObjectTree client = callGetManagedObjects (toClient client) vpnBus vpnPath
findTunnels :: ObjectTree -> VPNState
findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
vpnAddedListener :: SignalCallback -> Client -> IO ()
vpnAddedListener = fmap void . addInterfaceAddedListener vpnBus vpnPath
vpnAddedListener :: SignalCallback -> SysClient -> IO ()
vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb . toClient
vpnRemovedListener :: SignalCallback -> Client -> IO ()
vpnRemovedListener = fmap void . addInterfaceRemovedListener vpnBus vpnPath
vpnRemovedListener :: SignalCallback -> SysClient -> IO ()
vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb . toClient
addedCallback :: MutableVPNState -> IO () -> SignalCallback
addedCallback state display [device, added] = update >> display
@ -119,6 +119,6 @@ vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
vpnAlias :: String
vpnAlias = "vpn"
vpnDep :: DBusDependency_
vpnDep = Endpoint networkManagerPkgs vpnBus vpnPath omInterface
vpnDep :: DBusDependency_ SysClient
vpnDep = Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface
$ Method_ getManagedObjects