ENH use typesafe dbus client
This commit is contained in:
parent
f968078c06
commit
cfde8865c1
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue