diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 90326e9..878823b 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -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 diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 3907954..f5cd0c5 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -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 diff --git a/lib/DBus/Internal.hs b/lib/DBus/Internal.hs index 541b729..6bb7895 100644 --- a/lib/DBus/Internal.hs +++ b/lib/DBus/Internal.hs @@ -3,10 +3,10 @@ module DBus.Internal ( addMatchCallback - , getDBusClient - , fromDBusClient - , withDBusClient - , withDBusClient_ + -- , getDBusClient + -- , fromDBusClient + -- , withDBusClient + -- , withDBusClient_ , matchProperty , matchPropertyFull , matchPropertyChanged @@ -28,11 +28,11 @@ module DBus.Internal , bodyToMaybe ) where -import Control.Exception +-- import Control.Exception import Control.Monad import Data.Bifunctor -import qualified Data.Map.Strict as M +import qualified Data.Map.Strict as M import Data.Maybe import DBus @@ -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 diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index ddd7c6d..f02dd7a 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -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 diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index 920d90e..d3e83e2 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs index 09e617f..680b3f9 100644 --- a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs +++ b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 903c27c..9bc0354 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -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) diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index e10335b..f2f33cc 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index 406512d..5ce7dc7 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -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 () diff --git a/lib/XMonad/Internal/DBus/Removable.hs b/lib/XMonad/Internal/DBus/Removable.hs index d608cd6..c00bbb7 100644 --- a/lib/XMonad/Internal/DBus/Removable.hs +++ b/lib/XMonad/Internal/DBus/Removable.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 1d09a32..69fe3f9 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -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 diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 6659699..61e18d9 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -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 @@ -548,9 +595,9 @@ 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_ - , cFont :: H.HashMap String (Result FontBuilder) + cIO_ :: H.HashMap IODependency_ Result_ + -- , cDBus_ :: forall c. H.HashMap (DBusDependency_ c) Result_ + , cFont :: H.HashMap String (Result FontBuilder) } getParams :: IO XParams @@ -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 diff --git a/lib/Xmobar/Plugins/BacklightCommon.hs b/lib/Xmobar/Plugins/BacklightCommon.hs index 25e3168..9dbef05 100644 --- a/lib/Xmobar/Plugins/BacklightCommon.hs +++ b/lib/Xmobar/Plugins/BacklightCommon.hs @@ -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 diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index e536307..f2b8c30 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -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 diff --git a/lib/Xmobar/Plugins/Common.hs b/lib/Xmobar/Plugins/Common.hs index 06ad8fe..bc08ea6 100644 --- a/lib/Xmobar/Plugins/Common.hs +++ b/lib/Xmobar/Plugins/Common.hs @@ -20,7 +20,8 @@ import DBus import DBus.Client import DBus.Internal -import XMonad.Hooks.DynamicLog (xmobarColor) +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 diff --git a/lib/Xmobar/Plugins/Device.hs b/lib/Xmobar/Plugins/Device.hs index 866a48e..ce82abf 100644 --- a/lib/Xmobar/Plugins/Device.hs +++ b/lib/Xmobar/Plugins/Device.hs @@ -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) diff --git a/lib/Xmobar/Plugins/Screensaver.hs b/lib/Xmobar/Plugins/Screensaver.hs index d44913c..804e57d 100644 --- a/lib/Xmobar/Plugins/Screensaver.hs +++ b/lib/Xmobar/Plugins/Screensaver.hs @@ -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) diff --git a/lib/Xmobar/Plugins/VPN.hs b/lib/Xmobar/Plugins/VPN.hs index 6b52cb9..51525ff 100644 --- a/lib/Xmobar/Plugins/VPN.hs +++ b/lib/Xmobar/Plugins/VPN.hs @@ -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