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

View File

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

View File

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

View File

@ -5,9 +5,13 @@ module Data.Internal.DBus
( SafeClient (..) ( SafeClient (..)
, SysClient (..) , SysClient (..)
, SesClient (..) , SesClient (..)
, NamedConnection (..)
, NamedSesConnection
, NamedSysConnection
, DBusEnv (..) , DBusEnv (..)
, DIO , DIO
, HasClient (..) , HasClient (..)
, releaseBusName
, withDIO , withDIO
, addMatchCallback , addMatchCallback
, addMatchCallbackSignal , addMatchCallbackSignal
@ -55,54 +59,129 @@ import qualified RIO.Text as T
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Type-safe client -- Type-safe client
-- data NamedConnection c = NamedConnection data NamedConnection c = NamedConnection
-- { ncClient :: Client { ncClient :: !Client
-- , ncName :: Maybe BusName , ncHumanName :: !(Maybe BusName)
-- , ncType :: c --, ncUniqueName :: !BusName
-- } , ncType :: !c
}
type NamedSesConnection = NamedConnection SesClient
type NamedSysConnection = NamedConnection SysClient
class SafeClient c where class SafeClient c where
toClient :: c -> Client
getDBusClient getDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> m (Maybe c) => Maybe BusName
-> m (Maybe (NamedConnection c))
disconnectDBusClient :: MonadUnliftIO m => c -> m () disconnectDBusClient
disconnectDBusClient = liftIO . disconnect . toClient :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> NamedConnection c
-> m ()
disconnectDBusClient c = do
releaseBusName c
liftIO $ disconnect $ ncClient c
withDBusClient withDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> m a) => Maybe BusName
-> (NamedConnection c -> m a)
-> m (Maybe a) -> m (Maybe a)
withDBusClient f = withDBusClient n f =
bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $ mapM f
withDBusClient_ withDBusClient_
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> m ()) => Maybe BusName
-> (NamedConnection c -> m ())
-> m () -> m ()
withDBusClient_ = void . withDBusClient withDBusClient_ n = void . withDBusClient n
fromDBusClient fromDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> a) => Maybe BusName
-> (NamedConnection c -> a)
-> m (Maybe 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 instance SafeClient SysClient where
toClient (SysClient cl) = cl getDBusClient = connectToDBusWithName True SysClient
getDBusClient = fmap SysClient <$> getDBusClient' True data SesClient = SesClient
newtype SesClient = SesClient Client
instance SafeClient SesClient where 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' getDBusClient'
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
@ -116,7 +195,16 @@ getDBusClient' sys = do
return Nothing return Nothing
Right c -> return $ Just c 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) type DIO env c = RIO (DBusEnv env c)
@ -128,7 +216,7 @@ instance HasLogFunc (DBusEnv SimpleApp c) where
withDIO withDIO
:: (MonadUnliftIO m, MonadReader env m) :: (MonadUnliftIO m, MonadReader env m)
=> c => NamedConnection c
-> DIO env c a -> DIO env c a
-> m a -> m a
withDIO cl x = do withDIO cl x = do
@ -136,7 +224,7 @@ withDIO cl x = do
runRIO (DBusEnv cl env) x runRIO (DBusEnv cl env) x
class HasClient env where class HasClient env where
clientL :: SafeClient c => Lens' (env c) c clientL :: SafeClient c => Lens' (env c) (NamedConnection c)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Methods -- Methods
@ -148,7 +236,7 @@ callMethod'
=> MethodCall => MethodCall
-> m MethodBody -> m MethodBody
callMethod' mc = do callMethod' mc = do
cl <- toClient <$> view clientL cl <- ncClient <$> view clientL
liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
callMethod callMethod
@ -220,7 +308,7 @@ addMatchCallbackSignal
-> (Signal -> m ()) -> (Signal -> m ())
-> m SignalHandler -> m SignalHandler
addMatchCallbackSignal rule cb = do addMatchCallbackSignal rule cb = do
cl <- toClient <$> view clientL cl <- ncClient <$> view clientL
withRunInIO $ \run -> addMatch cl rule $ run . cb withRunInIO $ \run -> addMatch cl rule $ run . cb
addMatchCallback addMatchCallback
@ -301,7 +389,7 @@ callPropertyGet
-> MemberName -> MemberName
-> m [Variant] -> m [Variant]
callPropertyGet bus path iface property = do callPropertyGet bus path iface property = do
cl <- toClient <$> view clientL cl <- ncClient <$> view clientL
res <- liftIO $ getProperty cl $ methodCallBus bus path iface property res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
case res of case res of
Left err -> do Left err -> do
@ -453,14 +541,14 @@ addInterfaceRemovedListener bus =
-- Interface export/unexport -- Interface export/unexport
exportPair exportPair
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> ObjectPath => ObjectPath
-> (Client -> m Interface) -> (Client -> m Interface)
-> c -> NamedConnection c
-> (m (), m ()) -> (m (), m ())
exportPair path toIface cl = (up, down) exportPair path toIface cl = (up, down)
where where
cl_ = toClient cl cl_ = ncClient cl
up = do up = do
logInfo $ "adding interface: " <> path_ logInfo $ "adding interface: " <> path_
i <- toIface cl_ i <- toIface cl_

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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