ndwarshuis
/
xmonad-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

ENH use names for dbus connections

This commit is contained in:
Nathan Dwarshuis 2023-10-27 23:12:22 -04:00
parent 171fa489ca
commit cc5670f2f1
20 changed files with 292 additions and 176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
bin/xmobar.hs
View File

@ -63,7 +63,7 @@ parseTest =
xio :: XOpts -> IO ()
xio o = case o of
XDeps -> hRunXIO False stderr printDeps
XTest -> hRunXIO False stderr $ withDBus_ evalConfig
XTest -> hRunXIO False stderr $ withDBus_ Nothing Nothing evalConfig
XRun -> runXIO "xmobar.log" run
run :: XIO ()
@ -75,9 +75,9 @@ run = do
-- linebuffering it usually only prints the first few characters (even then
-- it only prints 10-20% of the time)
liftIO $ hSetBuffering stderr LineBuffering
withDBus_ $ \db -> do
c <- evalConfig db
liftIO $ xmobar c
-- TODO do these dbus things really need to remain connected?
c <- withDBus Nothing Nothing evalConfig
liftIO $ xmobar c
evalConfig :: DBusState -> XIO Config
evalConfig db = do
@ -88,7 +88,7 @@ evalConfig db = do
return $ config bf ifs ios cs d
printDeps :: XIO ()
printDeps = withDBus_ $ \db ->
printDeps = withDBus_ Nothing Nothing $ \db ->
mapM_ logInfo $
fmap showFulfillment $
sort $
@ -218,7 +218,7 @@ getWireless =
xpfWireless
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
getEthernet :: Maybe SysClient -> BarFeature
getEthernet :: Maybe NamedSysConnection -> BarFeature
getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
where
root useIcon tree' =
@ -234,12 +234,12 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree
io $
fmap (Msg LevelError) <$> hasBattery
getVPN :: Maybe SysClient -> BarFeature
getVPN :: Maybe NamedSysConnection -> BarFeature
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ devDep)
where
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
getBt :: Maybe SysClient -> BarFeature
getBt :: Maybe NamedSysConnection -> BarFeature
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
getAlsa :: BarFeature
@ -250,7 +250,7 @@ getAlsa =
where
root useIcon = IORoot_ (alsaCmd useIcon)
getBl :: Maybe SesClient -> BarFeature
getBl :: Maybe NamedSesConnection -> BarFeature
getBl =
xmobarDBus
"Intel backlight indicator"
@ -258,7 +258,7 @@ getBl =
intelBacklightSignalDep
blCmd
getCk :: Maybe SesClient -> BarFeature
getCk :: Maybe NamedSesConnection -> BarFeature
getCk =
xmobarDBus
"Clevo keyboard indicator"
@ -266,7 +266,7 @@ getCk =
clevoKeyboardSignalDep
ckCmd
getSs :: Maybe SesClient -> BarFeature
getSs :: Maybe NamedSesConnection -> BarFeature
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
getLock :: Always CmdSpec
@ -283,7 +283,7 @@ xmobarDBus
-> XPQuery
-> DBusDependency_ c
-> (Fontifier -> CmdSpec)
-> Maybe c
-> Maybe (NamedConnection c)
-> BarFeature
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
where

10
bin/xmonad.hs
View File

@ -166,9 +166,9 @@ getCreateDirectories = do
data FeatureSet = FeatureSet
{ fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
, fsDBusExporters :: [Maybe SesClient -> Sometimes (XIO (), XIO ())]
, fsDBusExporters :: [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
, fsPowerMon :: SometimesIO
, fsRemovableMon :: Maybe SysClient -> SometimesIO
, fsRemovableMon :: Maybe NamedSysConnection -> SometimesIO
, fsDaemons :: [Sometimes (XIO (Process () () ()))]
, fsACPIHandler :: Always (String -> X ())
, fsTabbedTheme :: Always Theme
@ -183,7 +183,7 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
niceTheme = IORoot XT.tabbedTheme $ fontTree XT.defFontFamily defFontPkgs
fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont
features :: Maybe SysClient -> FeatureSet
features :: Maybe NamedSysConnection -> FeatureSet
features cl =
FeatureSet
{ fsKeys = externalBindings
@ -251,7 +251,7 @@ stopChildDaemons = mapM_ stop
liftIO $ killNoWait p
printDeps :: XIO ()
printDeps = withDBus_ $ \db -> do
printDeps = withDBus_ Nothing Nothing $ \db -> do
runIO <- askRunInIO
let mockCleanup = runCleanup runIO mockClean db
let bfs =
@ -292,7 +292,7 @@ runCleanup runIO ts db = liftIO $ runIO $ do
mapM_ stopXmobar $ clXmobar ts
stopChildDaemons $ clChildren ts
sequence_ $ clDBusUnexporters ts
disconnectDBusX db
disconnectDBus db
-- | Kill a process (group) after xmonad has already started
-- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad

154
lib/Data/Internal/DBus.hs
View File

@ -5,9 +5,13 @@ module Data.Internal.DBus
( SafeClient (..)
, SysClient (..)
, SesClient (..)
, NamedConnection (..)
, NamedSesConnection
, NamedSysConnection
, DBusEnv (..)
, DIO
, HasClient (..)
, releaseBusName
, withDIO
, addMatchCallback
, addMatchCallbackSignal
@ -55,54 +59,129 @@ import qualified RIO.Text as T
--------------------------------------------------------------------------------
-- Type-safe client
-- data NamedConnection c = NamedConnection
-- { ncClient :: Client
-- , ncName :: Maybe BusName
-- , ncType :: c
-- }
data NamedConnection c = NamedConnection
{ ncClient :: !Client
, ncHumanName :: !(Maybe BusName)
--, ncUniqueName :: !BusName
, ncType :: !c
}
type NamedSesConnection = NamedConnection SesClient
type NamedSysConnection = NamedConnection SysClient
class SafeClient c where
toClient :: c -> Client
getDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> m (Maybe c)
=> Maybe BusName
-> m (Maybe (NamedConnection c))
disconnectDBusClient :: MonadUnliftIO m => c -> m ()
disconnectDBusClient = liftIO . disconnect . toClient
disconnectDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> NamedConnection c
-> m ()
disconnectDBusClient c = do
releaseBusName c
liftIO $ disconnect $ ncClient c
withDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> m a)
=> Maybe BusName
-> (NamedConnection c -> m a)
-> m (Maybe a)
withDBusClient f =
bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
withDBusClient n f =
bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $ mapM f
withDBusClient_
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> m ())
=> Maybe BusName
-> (NamedConnection c -> m ())
-> m ()
withDBusClient_ = void . withDBusClient
withDBusClient_ n = void . withDBusClient n
fromDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> a)
=> Maybe BusName
-> (NamedConnection c -> a)
-> m (Maybe a)
fromDBusClient f = withDBusClient (return . f)
fromDBusClient n f = withDBusClient n (return . f)
newtype SysClient = SysClient Client
data SysClient = SysClient
instance SafeClient SysClient where
toClient (SysClient cl) = cl
getDBusClient = connectToDBusWithName True SysClient
getDBusClient = fmap SysClient <$> getDBusClient' True
newtype SesClient = SesClient Client
data SesClient = SesClient
instance SafeClient SesClient where
toClient (SesClient cl) = cl
-- TODO wet
getDBusClient = connectToDBusWithName False SesClient
getDBusClient = fmap SesClient <$> getDBusClient' False
connectToDBusWithName
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Bool
-> c
-> Maybe BusName
-> m (Maybe (NamedConnection c))
connectToDBusWithName sys t n = do
clRes <- getDBusClient' sys
case clRes of
Nothing -> do
logError "could not get client"
return Nothing
Just cl -> do
--helloRes <- liftIO $ callHello cl
--case helloRes of
-- Nothing -> do
-- logError "count not get unique name"
-- return Nothing
-- Just unique -> do
n' <- maybe (return Nothing) (`requestBusName` cl) n
return $
Just $
NamedConnection
{ ncClient = cl
, ncHumanName = n'
-- , ncUniqueName = unique
, ncType = t
}
releaseBusName
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> NamedConnection c
-> m ()
releaseBusName NamedConnection {ncClient, ncHumanName} = do
-- TODO this might error?
case ncHumanName of
Just n -> do
liftIO $ void $ releaseName ncClient n
logInfo $ "released bus name: " <> displayBusName n
Nothing -> return ()
requestBusName
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> BusName
-> Client
-> m (Maybe BusName)
requestBusName n cl = do
res <- try $ liftIO $ requestName cl n []
case res of
Left e -> do
logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
return Nothing
Right r -> do
let msg
| r == NamePrimaryOwner = "registering name"
| r == NameAlreadyOwner = "this process already owns name"
| r == NameInQueue
|| r == NameExists =
"another process owns name"
-- this should never happen
| otherwise = "unknown error when requesting name"
logInfo $ msg <> ": " <> displayBusName n
case r of
NamePrimaryOwner -> return $ Just n
_ -> return Nothing
getDBusClient'
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
@ -116,7 +195,16 @@ getDBusClient' sys = do
return Nothing
Right c -> return $ Just c
data DBusEnv env c = DBusEnv {dClient :: !c, dEnv :: !env}
--callHello :: Client -> IO (Maybe BusName)
--callHello cl = do
-- reply <- call_ cl $ methodCallBus dbusName dbusPath dbusInterface "Hello"
-- case methodReturnBody reply of
-- [name] | Just nameStr <- fromVariant name -> do
-- busName <- parseBusName nameStr
-- return $ Just busName
-- _ -> return Nothing
--
data DBusEnv env c = DBusEnv {dClient :: !(NamedConnection c), dEnv :: !env}
type DIO env c = RIO (DBusEnv env c)
@ -128,7 +216,7 @@ instance HasLogFunc (DBusEnv SimpleApp c) where
withDIO
:: (MonadUnliftIO m, MonadReader env m)
=> c
=> NamedConnection c
-> DIO env c a
-> m a
withDIO cl x = do
@ -136,7 +224,7 @@ withDIO cl x = do
runRIO (DBusEnv cl env) x
class HasClient env where
clientL :: SafeClient c => Lens' (env c) c
clientL :: SafeClient c => Lens' (env c) (NamedConnection c)
--------------------------------------------------------------------------------
-- Methods
@ -148,7 +236,7 @@ callMethod'
=> MethodCall
-> m MethodBody
callMethod' mc = do
cl <- toClient <$> view clientL
cl <- ncClient <$> view clientL
liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
callMethod
@ -220,7 +308,7 @@ addMatchCallbackSignal
-> (Signal -> m ())
-> m SignalHandler
addMatchCallbackSignal rule cb = do
cl <- toClient <$> view clientL
cl <- ncClient <$> view clientL
withRunInIO $ \run -> addMatch cl rule $ run . cb
addMatchCallback
@ -301,7 +389,7 @@ callPropertyGet
-> MemberName
-> m [Variant]
callPropertyGet bus path iface property = do
cl <- toClient <$> view clientL
cl <- ncClient <$> view clientL
res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
case res of
Left err -> do
@ -453,14 +541,14 @@ addInterfaceRemovedListener bus =
-- Interface export/unexport
exportPair
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> ObjectPath
-> (Client -> m Interface)
-> c
-> NamedConnection c
-> (m (), m ())
exportPair path toIface cl = (up, down)
where
cl_ = toClient cl
cl_ = ncClient cl
up = do
logInfo $ "adding interface: " <> path_
i <- toIface cl_

24
lib/Data/Internal/XIO.hs
View File

@ -288,8 +288,18 @@ type SubfeatureRoot a = Subfeature (Root a)
data Root a
= forall p. IORoot (p -> a) (IOTree p)
| IORoot_ a IOTree_
| 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)
| forall c p.
SafeClient c =>
DBusRoot
(p -> NamedConnection c -> a)
(DBusTree c p)
(Maybe (NamedConnection c))
| forall c.
SafeClient c =>
DBusRoot_
(NamedConnection c -> a)
(DBusTree_ c)
(Maybe (NamedConnection c))
instance Functor Root where
fmap f (IORoot a t) = IORoot (f . a) t
@ -876,10 +886,10 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect"
testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> XIO MResult_
testDBusDep_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO MResult_
testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d
testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> XIO Result_
testDBusDepNoCache_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO Result_
testDBusDepNoCache_ cl (Bus _ bus) = do
ret <- withDIO cl $ callMethod queryBus queryPath queryIface queryMem
return $ case ret of
@ -1010,11 +1020,11 @@ sometimesExeArgs fn n ful sys path args =
sometimesDBus
:: SafeClient c
=> Maybe c
=> Maybe (NamedConnection c)
-> T.Text
-> T.Text
-> Tree_ (DBusDependency_ c)
-> (c -> a)
-> (NamedConnection c -> a)
-> Sometimes a
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
@ -1028,7 +1038,7 @@ sometimesEndpoint
-> ObjectPath
-> InterfaceName
-> MemberName
-> Maybe c
-> Maybe (NamedConnection c)
-> Sometimes (m ())
sometimesEndpoint fn name ful busname path iface mem cl =
sometimesDBus cl fn name deps cmd

4
lib/XMonad/Internal/Command/DMenu.hs
View File

@ -146,7 +146,7 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
runWinMenu :: MonadUnliftIO m => Sometimes (m ())
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
runNetMenu :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
runNetMenu :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
runNetMenu cl =
Sometimes
"network control menu"
@ -171,7 +171,7 @@ runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
--------------------------------------------------------------------------------
-- Password manager
runBwMenu :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runBwMenu :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
where
cmd _ =

22
lib/XMonad/Internal/Command/Desktop.hs
View File

@ -246,7 +246,7 @@ runNotificationCmd
:: MonadUnliftIO m
=> T.Text
-> T.Text
-> Maybe SesClient
-> Maybe NamedSesConnection
-> Sometimes (m ())
runNotificationCmd n arg cl =
sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
@ -258,18 +258,18 @@ runNotificationCmd n arg cl =
Method_ $
memberName_ "NotificationAction"
runNotificationClose :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runNotificationClose :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runNotificationClose = runNotificationCmd "close notification" "close"
runNotificationCloseAll :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runNotificationCloseAll :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runNotificationCloseAll =
runNotificationCmd "close all notifications" "close-all"
runNotificationHistory :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runNotificationHistory :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runNotificationHistory =
runNotificationCmd "see notification history" "history-pop"
runNotificationContext :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runNotificationContext :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runNotificationContext =
runNotificationCmd "open notification context" "context"
@ -277,7 +277,7 @@ runNotificationContext =
-- System commands
-- this is required for some vpn's to work properly with network-manager
runNetAppDaemon :: Maybe SysClient -> Sometimes (XIO (P.Process () () ()))
runNetAppDaemon :: Maybe NamedSysConnection -> Sometimes (XIO (P.Process () () ()))
runNetAppDaemon cl =
Sometimes
"network applet"
@ -288,7 +288,7 @@ runNetAppDaemon cl =
app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
runToggleBluetooth :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
runToggleBluetooth :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
runToggleBluetooth cl =
Sometimes
"bluetooth toggle"
@ -366,7 +366,7 @@ runFlameshot
:: MonadUnliftIO m
=> T.Text
-> T.Text
-> Maybe SesClient
-> Maybe NamedSesConnection
-> Sometimes (m ())
runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
where
@ -378,15 +378,15 @@ runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
-- TODO this will steal focus from the current window (and puts it
-- in the root window?) ...need to fix
runAreaCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runAreaCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runAreaCapture = runFlameshot "screen area capture" "gui"
-- myWindowCap = "screencap -w" --external script
runDesktopCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runDesktopCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runDesktopCapture = runFlameshot "fullscreen capture" "full"
runScreenCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runScreenCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runScreenCapture = runFlameshot "screen capture" "screen"
runCaptureBrowser :: MonadUnliftIO m => Sometimes (m ())

4
lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs
View File

@ -117,7 +117,7 @@ clevoKeyboardSignalDep =
exportClevoKeyboard
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe SesClient
=> Maybe NamedSesConnection
-> Sometimes (m (), m ())
exportClevoKeyboard =
brightnessExporter
@ -128,7 +128,7 @@ exportClevoKeyboard =
clevoKeyboardControls
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
=> Maybe SesClient
=> Maybe NamedSesConnection
-> BrightnessControls m
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig

10
lib/XMonad/Internal/DBus/Brightness/Common.hs
View File

@ -53,7 +53,7 @@ brightnessControls
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
=> XPQuery
-> BrightnessConfig m a b
-> Maybe SesClient
-> Maybe NamedSesConnection
-> BrightnessControls m
brightnessControls q bc cl =
BrightnessControls
@ -78,7 +78,7 @@ callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
either (const Nothing) bodyGetBrightness
<$> callMethod xmonadSesBusName p i memGet
signalDep :: BrightnessConfig m a b -> DBusDependency_ SesClient
signalDep :: BrightnessConfig m a b -> DBusDependency_ c
signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
Endpoint [] xmonadSesBusName p i $ Signal_ memCur
@ -112,7 +112,7 @@ brightnessExporter
-> [Fulfillment]
-> [IODependency_]
-> BrightnessConfig m a b
-> Maybe SesClient
-> Maybe NamedSesConnection
-> Sometimes (m (), m ())
brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
@ -123,7 +123,7 @@ brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
exportBrightnessControlsInner
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
=> BrightnessConfig m a b
-> SesClient
-> NamedSesConnection
-> (m (), m ())
exportBrightnessControlsInner bc = cmd
where
@ -172,7 +172,7 @@ emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
callBacklight
:: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
=> XPQuery
-> Maybe SesClient
-> Maybe NamedSesConnection
-> BrightnessConfig m a b
-> T.Text
-> MemberName

4
lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs
View File

@ -103,7 +103,7 @@ intelBacklightSignalDep =
exportIntelBacklight
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe SesClient
=> Maybe NamedSesConnection
-> Sometimes (m (), m ())
exportIntelBacklight =
brightnessExporter
@ -114,7 +114,7 @@ exportIntelBacklight =
intelBacklightControls
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
=> Maybe SesClient
=> Maybe NamedSesConnection
-> BrightnessControls m
intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig

4
lib/XMonad/Internal/DBus/Common.hs
View File

@ -14,10 +14,10 @@ where
import DBus
xmonadSesBusName :: BusName
xmonadSesBusName = busName_ "org.xmonad.Session"
xmonadSesBusName = busName_ "org.xmonad.session"
xmonadSysBusName :: BusName
xmonadSysBusName = busName_ "org.xmonad.System"
xmonadSysBusName = busName_ "org.xmonad.system"
btBus :: BusName
btBus = busName_ "org.bluez"

136
lib/XMonad/Internal/DBus/Control.hs
View File

@ -11,7 +11,7 @@ module XMonad.Internal.DBus.Control
, withDBus_
, connectDBus
, disconnectDBus
, disconnectDBusX
-- , disconnectDBusX
, getDBusClient
, withDBusClient
, withDBusClient_
@ -22,7 +22,6 @@ where
import DBus
import DBus.Client
import qualified Data.ByteString.Char8 as BC
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
@ -33,8 +32,8 @@ import XMonad.Internal.DBus.Screensaver
-- | Current connections to the DBus (session and system buses)
data DBusState = DBusState
{ dbSesClient :: Maybe SesClient
, dbSysClient :: Maybe SysClient
{ dbSesClient :: Maybe NamedSesConnection
, dbSysClient :: Maybe NamedSysConnection
}
withDBusX_
@ -46,50 +45,47 @@ withDBusX_ = void . withDBusX
withDBusX
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a)
-> m (Maybe a)
withDBusX f = withDBus $ \db -> do
case (dbSesClient db, dbSysClient db) of
(Just ses, Just sys) -> do
res <-
bracket_
( do
requestBusName xmonadSesBusName ses
requestBusName xmonadSysBusName sys
)
( do
releaseBusName xmonadSesBusName ses
releaseBusName xmonadSysBusName sys
)
$ f db
return $ Just res
_ -> return Nothing
-> m a
withDBusX = withDBus (Just xmonadSesBusName) (Just xmonadSysBusName)
withDBus_
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a)
=> Maybe BusName
-> Maybe BusName
-> (DBusState -> m a)
-> m ()
withDBus_ = void . withDBus
withDBus_ sesname sysname = void . withDBus sesname sysname
withDBus
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a)
=> Maybe BusName
-> Maybe BusName
-> (DBusState -> m a)
-> m a
withDBus = bracket connectDBus disconnectDBus
withDBus sesname sysname = bracket (connectDBus sesname sysname) disconnectDBus
-- | Connect to the DBus
connectDBus
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> m DBusState
connectDBus = do
ses <- getDBusClient
sys <- getDBusClient
=> Maybe BusName
-> Maybe BusName
-> m DBusState
connectDBus sesname sysname = do
ses <- getDBusClient sesname
sys <- getDBusClient sysname
return DBusState {dbSesClient = ses, dbSysClient = sys}
-- | Disconnect from the DBus
disconnectDBus :: MonadUnliftIO m => DBusState -> m ()
disconnectDBus
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> DBusState
-> m ()
disconnectDBus db = disc dbSesClient >> disc dbSysClient
where
disc :: (MonadUnliftIO m, SafeClient c) => (DBusState -> Maybe c) -> m ()
disc
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
=> (DBusState -> Maybe (NamedConnection c))
-> m ()
disc f = maybe (return ()) disconnectDBusClient $ f db
-- -- | Connect to the DBus and request the XMonad name
@ -101,15 +97,15 @@ disconnectDBus db = disc dbSesClient >> disc dbSysClient
-- requestXMonadName2 db
-- return db
-- | Disconnect from DBus and release the XMonad name
disconnectDBusX
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> DBusState
-> m ()
disconnectDBusX db = do
forM_ (dbSesClient db) $ releaseBusName xmonadSesBusName
forM_ (dbSysClient db) $ releaseBusName xmonadSysBusName
disconnectDBus db
-- -- | Disconnect from DBus and release the XMonad name
-- disconnectDBusX
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-- => DBusState
-- -> m ()
-- disconnectDBusX db = do
-- forM_ (dbSesClient db) releaseBusName
-- forM_ (dbSysClient db) releaseBusName
-- disconnectDBus db
-- requestXMonadName2
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
@ -121,7 +117,7 @@ disconnectDBusX db = do
withDBusInterfaces
:: DBusState
-> [Maybe SesClient -> Sometimes (XIO (), XIO ())]
-> [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
-> ([XIO ()] -> XIO a)
-> XIO a
withDBusInterfaces db interfaces = bracket up sequence
@ -134,7 +130,7 @@ withDBusInterfaces db interfaces = bracket up sequence
-- | All exporter features to be assigned to the DBus
dbusExporters
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> [Maybe SesClient -> Sometimes (m (), m ())]
=> [Maybe NamedSesConnection -> Sometimes (m (), m ())]
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
-- releaseXMonadName
@ -146,35 +142,35 @@ dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
-- liftIO $ void $ releaseName (toClient cl) xmonadBusName
-- logInfo "released xmonad name"
releaseBusName
:: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> BusName
-> c
-> m ()
releaseBusName n cl = do
-- TODO this might error?
liftIO $ void $ releaseName (toClient cl) n
logInfo $ "released bus name: " <> displayBusName n
-- releaseBusName
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-- => BusName
-- -> c
-- -> m ()
-- releaseBusName n cl = do
-- -- TODO this might error?
-- liftIO $ void $ releaseName (toClient cl) n
-- logInfo $ "released bus name: " <> displayBusName n
requestBusName
:: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> BusName
-> c
-> m ()
requestBusName n cl = do
res <- try $ liftIO $ requestName (toClient cl) n []
case res of
Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
Right r -> do
let msg
| r == NamePrimaryOwner = "registering name"
| r == NameAlreadyOwner = "this process already owns name"
| r == NameInQueue
|| r == NameExists =
"another process owns name"
-- this should never happen
| otherwise = "unknown error when requesting name"
logInfo $ msg <> ": " <> displayBusName n
-- requestBusName
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-- => BusName
-- -> c
-- -> m ()
-- requestBusName n cl = do
-- res <- try $ liftIO $ requestName (toClient cl) n []
-- case res of
-- Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
-- Right r -> do
-- let msg
-- | r == NamePrimaryOwner = "registering name"
-- | r == NameAlreadyOwner = "this process already owns name"
-- | r == NameInQueue
-- || r == NameExists =
-- "another process owns name"
-- -- this should never happen
-- | otherwise = "unknown error when requesting name"
-- logInfo $ msg <> ": " <> displayBusName n
-- requestXMonadName
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)

4
lib/XMonad/Internal/DBus/Removable.hs
View File

@ -83,7 +83,7 @@ listenDevices
, MonadReader env m
, MonadUnliftIO m
)
=> SysClient
=> NamedSysConnection
-> m ()
listenDevices cl = do
addMatch' memAdded driveInsertedSound addedHasDrive
@ -98,7 +98,7 @@ runRemovableMon
, MonadReader env m
, MonadUnliftIO m
)
=> Maybe SysClient
=> Maybe NamedSysConnection
-> Sometimes (m ())
runRemovableMon cl =
sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices

4
lib/XMonad/Internal/DBus/Screensaver.hs
View File

@ -93,7 +93,7 @@ bodyGetCurrentState _ = Nothing
exportScreensaver
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe SesClient
=> Maybe NamedSesConnection
-> Sometimes (m (), m ())
exportScreensaver ses =
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
@ -124,7 +124,7 @@ exportScreensaver ses =
callToggle
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
=> Maybe SesClient
=> Maybe NamedSesConnection
-> Sometimes (m ())
callToggle =
sometimesEndpoint

4
lib/Xmobar/Plugins/ActiveConnection.hs
View File

@ -39,7 +39,7 @@ connAlias = T.intercalate "_" . NE.toList
instance Exec ActiveConnection where
alias (ActiveConnection (contypes, _, _)) = T.unpack $ connAlias contypes
start (ActiveConnection (contypes, text, colors)) cb =
withDBusClientConnection cb (Just "ethernet.log") $ \c -> do
withDBusClientConnection cb Nothing (Just "ethernet.log") $ \c -> do
let dpy cb' = displayMaybe cb' formatter . Just =<< readState
i <- withDIO c $ initialState contypes
s <- newMVar i
@ -60,7 +60,7 @@ instance Exec ActiveConnection where
-- TODO can I recycle the client?
void $
addMatchCallbackSignal rule $ \sig ->
withDBusClientConnection cb (Just "ethernet-cb.log") $ \c' ->
withDBusClientConnection cb Nothing (Just "ethernet-cb.log") $ \c' ->
mapEnv c' $
testActiveType contypes sig

8
lib/Xmobar/Plugins/BacklightCommon.hs
View File

@ -4,6 +4,7 @@
-- to signals spawned by commands
module Xmobar.Plugins.BacklightCommon (startBacklight) where
import DBus
import Data.Internal.DBus
import RIO
import qualified RIO.Text as T
@ -11,14 +12,15 @@ import Xmobar.Plugins.Common
startBacklight
:: (MonadUnliftIO m, RealFrac a)
=> Maybe FilePath
=> Maybe BusName
-> Maybe FilePath
-> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ())
-> DIO SimpleApp SesClient (Maybe a)
-> T.Text
-> Callback
-> m ()
startBacklight name matchSignal callGetBrightness icon cb = do
withDBusClientConnection cb name $ \c -> withDIO c $ do
startBacklight n name matchSignal callGetBrightness icon cb = do
withDBusClientConnection cb n name $ \c -> withDIO c $ do
matchSignal dpy
dpy =<< callGetBrightness
where

12
lib/Xmobar/Plugins/Bluetooth.hs
View File

@ -54,13 +54,17 @@ data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
instance Exec Bluetooth where
alias (Bluetooth _ _) = T.unpack btAlias
start (Bluetooth icons colors) cb =
withDBusClientConnection cb (Just "bluetooth.log") $ startAdapter icons colors cb
withDBusClientConnection
cb
(Just "org.xmonad.bluetooth")
(Just "bluetooth.log")
$ startAdapter icons colors cb
startAdapter
:: Icons
-> Colors
-> Callback
-> SysClient
-> NamedSysConnection
-> RIO SimpleApp ()
startAdapter is cs cb cl = do
state <- newMVar emptyState
@ -201,7 +205,7 @@ startAdaptorListener adaptor = do
<> displayObjectPath adaptor
where
callback sig =
withNestedDBusClientConnection Nothing $
withNestedDBusClientConnection Nothing Nothing $
withSignalMatch procMatch $
matchPropertyChanged adaptorInterface adaptorPowered sig
procMatch = beforeDisplay . putPowered
@ -249,7 +253,7 @@ startConnectedListener adaptor = do
where
adaptor_ = displayWrapQuote $ displayObjectPath adaptor
callback sig =
withNestedDBusClientConnection Nothing $ do
withNestedDBusClientConnection Nothing Nothing $ do
let devpath = signalPath sig
when (adaptorHasDevice adaptor devpath) $
withSignalMatch (update devpath) $

7
lib/Xmobar/Plugins/ClevoKeyboard.hs
View File

@ -24,4 +24,9 @@ ckAlias = "clevokeyboard"
instance Exec ClevoKeyboard where
alias (ClevoKeyboard _) = T.unpack ckAlias
start (ClevoKeyboard icon) =
startBacklight (Just "clevo_kbd.log") matchSignalCK callGetBrightnessCK icon
startBacklight
(Just "org.xmobar.clevo")
(Just "clevo_kbd.log")
matchSignalCK
callGetBrightnessCK
icon

16
lib/Xmobar/Plugins/Common.hs
View File

@ -26,7 +26,7 @@ import qualified RIO.Text as T
import XMonad.Hooks.DynamicLog (xmobarColor)
data PluginEnv s c = PluginEnv
{ plugClient :: !c
{ plugClient :: !(NamedConnection c)
, plugState :: !(MVar s)
, plugDisplay :: !(Callback -> PluginIO s c ())
, plugCallback :: !Callback
@ -99,17 +99,18 @@ displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
withDBusClientConnection
:: (MonadUnliftIO m, SafeClient c)
=> Callback
-> Maybe BusName
-> Maybe FilePath
-> (c -> RIO SimpleApp ())
-> (NamedConnection c -> RIO SimpleApp ())
-> m ()
withDBusClientConnection cb logfile f =
withDBusClientConnection cb n logfile f =
maybe (run stderr) (`withLogFile` run) logfile
where
run h = do
logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False
withLogFunc logOpts $ \lf -> do
env <- mkSimpleApp lf Nothing
runRIO env $ displayMaybe' cb f =<< getDBusClient
runRIO env $ displayMaybe' cb f =<< getDBusClient n
-- | Run a plugin action with a new DBus client and logfile path.
-- This is necessary for DBus callbacks which run in separate threads, which
@ -117,11 +118,12 @@ withDBusClientConnection cb logfile f =
-- DBus connection and closed its logfile.
withNestedDBusClientConnection
:: (MonadUnliftIO m, SafeClient c, MonadReader (PluginEnv s c) m)
=> Maybe FilePath
=> Maybe BusName
-> Maybe FilePath
-> PluginIO s c ()
-> m ()
withNestedDBusClientConnection logfile f = do
withNestedDBusClientConnection n logfile f = do
dpy <- asks plugDisplay
s <- asks plugState
cb <- asks plugCallback
withDBusClientConnection cb logfile $ \c -> mapRIO (PluginEnv c s dpy cb) f
withDBusClientConnection cb n logfile $ \c -> mapRIO (PluginEnv c s dpy cb) f

7
lib/Xmobar/Plugins/IntelBacklight.hs
View File

@ -24,4 +24,9 @@ blAlias = "intelbacklight"
instance Exec IntelBacklight where
alias (IntelBacklight _) = T.unpack blAlias
start (IntelBacklight icon) =
startBacklight (Just "intel_backlight.log") matchSignalIB callGetBrightnessIB icon
startBacklight
(Just "org.xmobar.intelbacklight")
(Just "intel_backlight.log")
matchSignalIB
callGetBrightnessIB
icon

10
lib/Xmobar/Plugins/Screensaver.hs
View File

@ -25,8 +25,12 @@ ssAlias = "screensaver"
instance Exec Screensaver where
alias (Screensaver _) = T.unpack ssAlias
start (Screensaver (text, colors)) cb =
withDBusClientConnection cb (Just "screensaver.log") $ \cl -> withDIO cl $ do
matchSignal dpy
dpy =<< callQuery
withDBusClientConnection
cb
(Just "org.xmobar.screensaver")
(Just "screensaver.log")
$ \cl -> withDIO cl $ do
matchSignal dpy
dpy =<< callQuery
where
dpy = displayMaybe cb $ return . (\s -> colorText colors s text)