Merge branch 'fix_dbus'

This commit is contained in:
Nathan Dwarshuis 2023-10-27 23:58:06 -04:00
commit 841bf0b5c8
21 changed files with 351 additions and 181 deletions

View File

@ -11,12 +11,12 @@ module Main (main) where
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.XIO import Data.Internal.XIO
import GHC.Enum (enumFrom)
import Options.Applicative import Options.Applicative
import RIO hiding (hFlush) import RIO hiding (hFlush)
import RIO.List import RIO.List
import qualified RIO.NonEmpty as NE import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Config.Prime (enumFrom)
import XMonad.Core hiding (config) import XMonad.Core hiding (config)
import XMonad.Internal.Command.Power import XMonad.Internal.Command.Power
import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.ClevoKeyboard
@ -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,8 +75,8 @@ 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
@ -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,48 +59,129 @@ import qualified RIO.Text as T
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Type-safe client -- Type-safe client
class SafeClient c where data NamedConnection c = NamedConnection
toClient :: c -> Client { ncClient :: !Client
, ncHumanName :: !(Maybe BusName)
--, ncUniqueName :: !BusName
, ncType :: !c
}
type NamedSesConnection = NamedConnection SesClient
type NamedSysConnection = NamedConnection SysClient
class SafeClient c where
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)
@ -110,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)
@ -122,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
@ -130,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
@ -142,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
@ -214,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
@ -295,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
@ -447,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
@ -76,11 +76,11 @@ callGetBrightness
-> m (Maybe n) -> m (Maybe n)
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} = callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
either (const Nothing) bodyGetBrightness either (const Nothing) bodyGetBrightness
<$> callMethod xmonadBusName 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 [] xmonadBusName p i $ Signal_ memCur Endpoint [] xmonadSesBusName p i $ Signal_ memCur
matchSignal matchSignal
:: ( HasClient env :: ( HasClient env
@ -112,18 +112,18 @@ 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"]
where where
root = DBusRoot_ (exportBrightnessControlsInner bc) tree cl root = DBusRoot_ (exportBrightnessControlsInner bc) tree cl
tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps tree = listToAnds (Bus ful xmonadSesBusName) $ fmap DBusIO deps
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
@ -180,8 +180,8 @@ callBacklight
callBacklight q cl BrightnessConfig {bcPath = p, bcInterface = i, bcName = n} controlName m = callBacklight q cl BrightnessConfig {bcPath = p, bcInterface = i, bcName = n} controlName m =
Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"] Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
where where
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadSesBusName p i $ Method_ m) cl
cmd c = void $ withDIO c $ callMethod xmonadBusName p i m cmd c = void $ withDIO c $ callMethod xmonadSesBusName p i m
bodyGetBrightness :: Num a => [Variant] -> Maybe a bodyGetBrightness :: Num a => [Variant] -> Maybe a
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32) bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)

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

@ -2,7 +2,8 @@
-- High-level interface for managing XMonad's DBus -- High-level interface for managing XMonad's DBus
module XMonad.Internal.DBus.Common module XMonad.Internal.DBus.Common
( xmonadBusName ( xmonadSesBusName
, xmonadSysBusName
, btBus , btBus
, notifyBus , notifyBus
, notifyPath , notifyPath
@ -12,8 +13,11 @@ where
import DBus import DBus
xmonadBusName :: BusName xmonadSesBusName :: BusName
xmonadBusName = busName_ "org.xmonad" xmonadSesBusName = busName_ "org.xmonad.session"
xmonadSysBusName :: BusName
xmonadSysBusName = busName_ "org.xmonad.system"
btBus :: BusName btBus :: BusName
btBus = busName_ "org.bluez" btBus = busName_ "org.bluez"

View File

@ -10,9 +10,8 @@ module XMonad.Internal.DBus.Control
, withDBus , withDBus
, withDBus_ , withDBus_
, connectDBus , connectDBus
, connectDBusX
, disconnectDBus , disconnectDBus
, disconnectDBusX -- , disconnectDBusX
, getDBusClient , getDBusClient
, withDBusClient , withDBusClient
, withDBusClient_ , withDBusClient_
@ -26,7 +25,6 @@ import DBus.Client
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.XIO import Data.Internal.XIO
import RIO import RIO
import qualified RIO.Text as T
import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
@ -34,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_
@ -47,60 +45,79 @@ 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) Nothing
forM (dbSesClient db) $ \ses -> do
bracket_ (requestXMonadName ses) (releaseXMonadName ses) $ f db
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
disconnectDBus db = disc dbSesClient >> disc dbSysClient
where
disc :: (MonadUnliftIO m, SafeClient c) => (DBusState -> Maybe c) -> m ()
disc f = maybe (return ()) disconnectDBusClient $ f db
-- | Connect to the DBus and request the XMonad name
connectDBusX
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> m DBusState
connectDBusX = do
db <- connectDBus
forM_ (dbSesClient db) requestXMonadName
return db
-- | Disconnect from DBus and release the XMonad name
disconnectDBusX
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> DBusState => DBusState
-> m () -> m ()
disconnectDBusX db = do disconnectDBus db = disc dbSesClient >> disc dbSysClient
forM_ (dbSesClient db) releaseXMonadName where
disconnectDBus db 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
-- connectDBusX
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-- => m DBusState
-- connectDBusX = do
-- db <- connectDBus
-- 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
-- forM_ (dbSysClient db) releaseBusName
-- disconnectDBus db
-- requestXMonadName2
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-- => DBusState
-- -> m ()
-- requestXMonadName2 db = do
-- forM_ (dbSesClient db) requestXMonadName
-- forM_ (dbSysClient db) requestXMonadName
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
@ -113,35 +130,59 @@ 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
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) -- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> SesClient -- => c
-> m () -- -> m ()
releaseXMonadName ses = do -- releaseXMonadName cl = do
-- TODO this might error? -- -- TODO this might error?
liftIO $ void $ releaseName (toClient ses) xmonadBusName -- liftIO $ void $ releaseName (toClient cl) xmonadBusName
logInfo "released xmonad name" -- logInfo "released xmonad name"
requestXMonadName -- releaseBusName
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) -- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> SesClient -- => BusName
-> m () -- -> c
requestXMonadName ses = do -- -> m ()
res <- liftIO $ requestName (toClient ses) xmonadBusName [] -- releaseBusName n cl = do
let msg -- -- TODO this might error?
| res == NamePrimaryOwner = "registering name" -- liftIO $ void $ releaseName (toClient cl) n
| res == NameAlreadyOwner = "this process already owns name" -- logInfo $ "released bus name: " <> displayBusName n
| res == NameInQueue
|| res == NameExists = -- requestBusName
"another process owns name" -- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
| otherwise = "unknown error when requesting name" -- => BusName
logInfo $ msg <> ": " <> xn -- -> c
where -- -> m ()
xn = -- requestBusName n cl = do
Utf8Builder $ -- res <- try $ liftIO $ requestName (toClient cl) n []
encodeUtf8Builder $ -- case res of
T.pack $ -- Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
formatBusName xmonadBusName -- 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)
-- => c
-- -> m ()
-- requestXMonadName cl = do
-- res <- liftIO $ requestName (toClient cl) xmonadBusName []
-- let msg
-- | res == NamePrimaryOwner = "registering name"
-- | res == NameAlreadyOwner = "this process already owns name"
-- | res == NameInQueue
-- || res == NameExists =
-- "another process owns name"
-- | otherwise = "unknown error when requesting name"
-- logInfo $ msg <> ": " <> displayBusName xmonadBusName

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
@ -119,19 +119,19 @@ exportScreensaver ses =
} }
] ]
} }
bus = Bus [] xmonadBusName bus = Bus [] xmonadSesBusName
ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
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
"screensaver toggle" "screensaver toggle"
"dbus switch" "dbus switch"
[] []
xmonadBusName xmonadSesBusName
ssPath ssPath
interface interface
memToggle memToggle
@ -140,7 +140,7 @@ callQuery
:: (HasClient env, MonadReader (env SesClient) m, MonadUnliftIO m) :: (HasClient env, MonadReader (env SesClient) m, MonadUnliftIO m)
=> m (Maybe SSState) => m (Maybe SSState)
callQuery = do callQuery = do
reply <- callMethod xmonadBusName ssPath interface memQuery reply <- callMethod xmonadSesBusName ssPath interface memQuery
return $ either (const Nothing) bodyGetCurrentState reply return $ either (const Nothing) bodyGetCurrentState reply
matchSignal matchSignal
@ -157,4 +157,4 @@ matchSignal cb =
(cb . bodyGetCurrentState) (cb . bodyGetCurrentState)
ssSignalDep :: DBusDependency_ SesClient ssSignalDep :: DBusDependency_ SesClient
ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState ssSignalDep = Endpoint [] xmonadSesBusName ssPath interface $ Signal_ memState

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,14 @@ 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 Nothing (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 +202,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 +250,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,20 @@ 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 $
bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $
displayMaybe' cb f
-- | 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 +120,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,7 +25,11 @@ 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
cb
(Just "org.xmobar.screensaver")
(Just "screensaver.log")
$ \cl -> withDIO cl $ do
matchSignal dpy matchSignal dpy
dpy =<< callQuery dpy =<< callQuery
where where

View File

@ -17,8 +17,8 @@
# #
# resolver: ./custom-snapshot.yaml # resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml
#resolver: lts-17.4 resolver: lts-19.33
resolver: nightly-2022-03-03 #resolver: nightly-2022-03-03
# User packages to be built. # User packages to be built.
# Various formats can be used as shown in the example below. # Various formats can be used as shown in the example below.