From cc5670f2f14a6eee9c43e38585a1298dc49a756a Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Fri, 27 Oct 2023 23:12:22 -0400 Subject: [PATCH] ENH use names for dbus connections --- bin/xmobar.hs | 24 +-- bin/xmonad.hs | 10 +- lib/Data/Internal/DBus.hs | 154 ++++++++++++++---- lib/Data/Internal/XIO.hs | 24 ++- lib/XMonad/Internal/Command/DMenu.hs | 4 +- lib/XMonad/Internal/Command/Desktop.hs | 22 +-- .../Internal/DBus/Brightness/ClevoKeyboard.hs | 4 +- lib/XMonad/Internal/DBus/Brightness/Common.hs | 10 +- .../DBus/Brightness/IntelBacklight.hs | 4 +- lib/XMonad/Internal/DBus/Common.hs | 4 +- lib/XMonad/Internal/DBus/Control.hs | 136 ++++++++-------- lib/XMonad/Internal/DBus/Removable.hs | 4 +- lib/XMonad/Internal/DBus/Screensaver.hs | 4 +- lib/Xmobar/Plugins/ActiveConnection.hs | 4 +- lib/Xmobar/Plugins/BacklightCommon.hs | 8 +- lib/Xmobar/Plugins/Bluetooth.hs | 12 +- lib/Xmobar/Plugins/ClevoKeyboard.hs | 7 +- lib/Xmobar/Plugins/Common.hs | 16 +- lib/Xmobar/Plugins/IntelBacklight.hs | 7 +- lib/Xmobar/Plugins/Screensaver.hs | 10 +- 20 files changed, 292 insertions(+), 176 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 843c5f5..4ac7837 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -63,7 +63,7 @@ parseTest = xio :: XOpts -> IO () xio o = case o of XDeps -> hRunXIO False stderr printDeps - XTest -> hRunXIO False stderr $ withDBus_ evalConfig + XTest -> hRunXIO False stderr $ withDBus_ Nothing Nothing evalConfig XRun -> runXIO "xmobar.log" run run :: XIO () @@ -75,9 +75,9 @@ run = do -- linebuffering it usually only prints the first few characters (even then -- it only prints 10-20% of the time) liftIO $ hSetBuffering stderr LineBuffering - withDBus_ $ \db -> do - c <- evalConfig db - liftIO $ xmobar c + -- TODO do these dbus things really need to remain connected? + c <- withDBus Nothing Nothing evalConfig + liftIO $ xmobar c evalConfig :: DBusState -> XIO Config evalConfig db = do @@ -88,7 +88,7 @@ evalConfig db = do return $ config bf ifs ios cs d printDeps :: XIO () -printDeps = withDBus_ $ \db -> +printDeps = withDBus_ Nothing Nothing $ \db -> mapM_ logInfo $ fmap showFulfillment $ sort $ @@ -218,7 +218,7 @@ getWireless = xpfWireless [Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"] -getEthernet :: Maybe SysClient -> BarFeature +getEthernet :: Maybe NamedSysConnection -> BarFeature getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep) where root useIcon tree' = @@ -234,12 +234,12 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree io $ fmap (Msg LevelError) <$> hasBattery -getVPN :: Maybe SysClient -> BarFeature +getVPN :: Maybe NamedSysConnection -> BarFeature getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ devDep) where root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl -getBt :: Maybe SysClient -> BarFeature +getBt :: Maybe NamedSysConnection -> BarFeature getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd getAlsa :: BarFeature @@ -250,7 +250,7 @@ getAlsa = where root useIcon = IORoot_ (alsaCmd useIcon) -getBl :: Maybe SesClient -> BarFeature +getBl :: Maybe NamedSesConnection -> BarFeature getBl = xmobarDBus "Intel backlight indicator" @@ -258,7 +258,7 @@ getBl = intelBacklightSignalDep blCmd -getCk :: Maybe SesClient -> BarFeature +getCk :: Maybe NamedSesConnection -> BarFeature getCk = xmobarDBus "Clevo keyboard indicator" @@ -266,7 +266,7 @@ getCk = clevoKeyboardSignalDep ckCmd -getSs :: Maybe SesClient -> BarFeature +getSs :: Maybe NamedSesConnection -> BarFeature getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd getLock :: Always CmdSpec @@ -283,7 +283,7 @@ xmobarDBus -> XPQuery -> DBusDependency_ c -> (Fontifier -> CmdSpec) - -> Maybe c + -> Maybe (NamedConnection c) -> BarFeature xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep) where diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 5945454..b5679c4 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -166,9 +166,9 @@ getCreateDirectories = do data FeatureSet = FeatureSet { fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX] - , fsDBusExporters :: [Maybe SesClient -> Sometimes (XIO (), XIO ())] + , fsDBusExporters :: [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())] , fsPowerMon :: SometimesIO - , fsRemovableMon :: Maybe SysClient -> SometimesIO + , fsRemovableMon :: Maybe NamedSysConnection -> SometimesIO , fsDaemons :: [Sometimes (XIO (Process () () ()))] , fsACPIHandler :: Always (String -> X ()) , fsTabbedTheme :: Always Theme @@ -183,7 +183,7 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback niceTheme = IORoot XT.tabbedTheme $ fontTree XT.defFontFamily defFontPkgs fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont -features :: Maybe SysClient -> FeatureSet +features :: Maybe NamedSysConnection -> FeatureSet features cl = FeatureSet { fsKeys = externalBindings @@ -251,7 +251,7 @@ stopChildDaemons = mapM_ stop liftIO $ killNoWait p printDeps :: XIO () -printDeps = withDBus_ $ \db -> do +printDeps = withDBus_ Nothing Nothing $ \db -> do runIO <- askRunInIO let mockCleanup = runCleanup runIO mockClean db let bfs = @@ -292,7 +292,7 @@ runCleanup runIO ts db = liftIO $ runIO $ do mapM_ stopXmobar $ clXmobar ts stopChildDaemons $ clChildren ts sequence_ $ clDBusUnexporters ts - disconnectDBusX db + disconnectDBus db -- | Kill a process (group) after xmonad has already started -- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad diff --git a/lib/Data/Internal/DBus.hs b/lib/Data/Internal/DBus.hs index c5a0f2d..7989b9c 100644 --- a/lib/Data/Internal/DBus.hs +++ b/lib/Data/Internal/DBus.hs @@ -5,9 +5,13 @@ module Data.Internal.DBus ( SafeClient (..) , SysClient (..) , SesClient (..) + , NamedConnection (..) + , NamedSesConnection + , NamedSysConnection , DBusEnv (..) , DIO , HasClient (..) + , releaseBusName , withDIO , addMatchCallback , addMatchCallbackSignal @@ -55,54 +59,129 @@ import qualified RIO.Text as T -------------------------------------------------------------------------------- -- Type-safe client --- data NamedConnection c = NamedConnection --- { ncClient :: Client --- , ncName :: Maybe BusName --- , ncType :: c --- } +data NamedConnection c = NamedConnection + { ncClient :: !Client + , ncHumanName :: !(Maybe BusName) + --, ncUniqueName :: !BusName + , ncType :: !c + } + +type NamedSesConnection = NamedConnection SesClient + +type NamedSysConnection = NamedConnection SysClient class SafeClient c where - toClient :: c -> Client - getDBusClient :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => m (Maybe c) + => Maybe BusName + -> m (Maybe (NamedConnection c)) - disconnectDBusClient :: MonadUnliftIO m => c -> m () - disconnectDBusClient = liftIO . disconnect . toClient + disconnectDBusClient + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => NamedConnection c + -> m () + disconnectDBusClient c = do + releaseBusName c + liftIO $ disconnect $ ncClient c withDBusClient :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => (c -> m a) + => Maybe BusName + -> (NamedConnection c -> m a) -> m (Maybe a) - withDBusClient f = - bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f + withDBusClient n f = + bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $ mapM f withDBusClient_ :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => (c -> m ()) + => Maybe BusName + -> (NamedConnection c -> m ()) -> m () - withDBusClient_ = void . withDBusClient + withDBusClient_ n = void . withDBusClient n fromDBusClient :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => (c -> a) + => Maybe BusName + -> (NamedConnection c -> a) -> m (Maybe a) - fromDBusClient f = withDBusClient (return . f) + fromDBusClient n f = withDBusClient n (return . f) -newtype SysClient = SysClient Client +data SysClient = SysClient instance SafeClient SysClient where - toClient (SysClient cl) = cl + getDBusClient = connectToDBusWithName True SysClient - getDBusClient = fmap SysClient <$> getDBusClient' True - -newtype SesClient = SesClient Client +data SesClient = SesClient instance SafeClient SesClient where - toClient (SesClient cl) = cl + -- TODO wet + getDBusClient = connectToDBusWithName False SesClient - getDBusClient = fmap SesClient <$> getDBusClient' False +connectToDBusWithName + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => Bool + -> c + -> Maybe BusName + -> m (Maybe (NamedConnection c)) +connectToDBusWithName sys t n = do + clRes <- getDBusClient' sys + case clRes of + Nothing -> do + logError "could not get client" + return Nothing + Just cl -> do + --helloRes <- liftIO $ callHello cl + --case helloRes of + -- Nothing -> do + -- logError "count not get unique name" + -- return Nothing + -- Just unique -> do + n' <- maybe (return Nothing) (`requestBusName` cl) n + return $ + Just $ + NamedConnection + { ncClient = cl + , ncHumanName = n' + -- , ncUniqueName = unique + , ncType = t + } + +releaseBusName + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => NamedConnection c + -> m () +releaseBusName NamedConnection {ncClient, ncHumanName} = do + -- TODO this might error? + case ncHumanName of + Just n -> do + liftIO $ void $ releaseName ncClient n + logInfo $ "released bus name: " <> displayBusName n + Nothing -> return () + +requestBusName + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => BusName + -> Client + -> m (Maybe BusName) +requestBusName n cl = do + res <- try $ liftIO $ requestName cl n [] + case res of + Left e -> do + logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e + return Nothing + Right r -> do + let msg + | r == NamePrimaryOwner = "registering name" + | r == NameAlreadyOwner = "this process already owns name" + | r == NameInQueue + || r == NameExists = + "another process owns name" + -- this should never happen + | otherwise = "unknown error when requesting name" + logInfo $ msg <> ": " <> displayBusName n + case r of + NamePrimaryOwner -> return $ Just n + _ -> return Nothing getDBusClient' :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) @@ -116,7 +195,16 @@ getDBusClient' sys = do return Nothing Right c -> return $ Just c -data DBusEnv env c = DBusEnv {dClient :: !c, dEnv :: !env} +--callHello :: Client -> IO (Maybe BusName) +--callHello cl = do +-- reply <- call_ cl $ methodCallBus dbusName dbusPath dbusInterface "Hello" +-- case methodReturnBody reply of +-- [name] | Just nameStr <- fromVariant name -> do +-- busName <- parseBusName nameStr +-- return $ Just busName +-- _ -> return Nothing +-- +data DBusEnv env c = DBusEnv {dClient :: !(NamedConnection c), dEnv :: !env} type DIO env c = RIO (DBusEnv env c) @@ -128,7 +216,7 @@ instance HasLogFunc (DBusEnv SimpleApp c) where withDIO :: (MonadUnliftIO m, MonadReader env m) - => c + => NamedConnection c -> DIO env c a -> m a withDIO cl x = do @@ -136,7 +224,7 @@ withDIO cl x = do runRIO (DBusEnv cl env) x class HasClient env where - clientL :: SafeClient c => Lens' (env c) c + clientL :: SafeClient c => Lens' (env c) (NamedConnection c) -------------------------------------------------------------------------------- -- Methods @@ -148,7 +236,7 @@ callMethod' => MethodCall -> m MethodBody callMethod' mc = do - cl <- toClient <$> view clientL + cl <- ncClient <$> view clientL liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc callMethod @@ -220,7 +308,7 @@ addMatchCallbackSignal -> (Signal -> m ()) -> m SignalHandler addMatchCallbackSignal rule cb = do - cl <- toClient <$> view clientL + cl <- ncClient <$> view clientL withRunInIO $ \run -> addMatch cl rule $ run . cb addMatchCallback @@ -301,7 +389,7 @@ callPropertyGet -> MemberName -> m [Variant] callPropertyGet bus path iface property = do - cl <- toClient <$> view clientL + cl <- ncClient <$> view clientL res <- liftIO $ getProperty cl $ methodCallBus bus path iface property case res of Left err -> do @@ -453,14 +541,14 @@ addInterfaceRemovedListener bus = -- Interface export/unexport exportPair - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c) + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) => ObjectPath -> (Client -> m Interface) - -> c + -> NamedConnection c -> (m (), m ()) exportPair path toIface cl = (up, down) where - cl_ = toClient cl + cl_ = ncClient cl up = do logInfo $ "adding interface: " <> path_ i <- toIface cl_ diff --git a/lib/Data/Internal/XIO.hs b/lib/Data/Internal/XIO.hs index 808f664..3df040b 100644 --- a/lib/Data/Internal/XIO.hs +++ b/lib/Data/Internal/XIO.hs @@ -288,8 +288,18 @@ type SubfeatureRoot a = Subfeature (Root a) data Root a = forall p. IORoot (p -> a) (IOTree p) | IORoot_ a IOTree_ - | forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c) - | forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c) + | forall c p. + SafeClient c => + DBusRoot + (p -> NamedConnection c -> a) + (DBusTree c p) + (Maybe (NamedConnection c)) + | forall c. + SafeClient c => + DBusRoot_ + (NamedConnection c -> a) + (DBusTree_ c) + (Maybe (NamedConnection c)) instance Functor Root where fmap f (IORoot a t) = IORoot (f . a) t @@ -876,10 +886,10 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" introspectMethod :: MemberName introspectMethod = memberName_ "Introspect" -testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> XIO MResult_ +testDBusDep_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO MResult_ testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d -testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> XIO Result_ +testDBusDepNoCache_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO Result_ testDBusDepNoCache_ cl (Bus _ bus) = do ret <- withDIO cl $ callMethod queryBus queryPath queryIface queryMem return $ case ret of @@ -1010,11 +1020,11 @@ sometimesExeArgs fn n ful sys path args = sometimesDBus :: SafeClient c - => Maybe c + => Maybe (NamedConnection c) -> T.Text -> T.Text -> Tree_ (DBusDependency_ c) - -> (c -> a) + -> (NamedConnection c -> a) -> Sometimes a sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c @@ -1028,7 +1038,7 @@ sometimesEndpoint -> ObjectPath -> InterfaceName -> MemberName - -> Maybe c + -> Maybe (NamedConnection c) -> Sometimes (m ()) sometimesEndpoint fn name ful busname path iface mem cl = sometimesDBus cl fn name deps cmd diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index a0a7b4a..3661a73 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -146,7 +146,7 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"] runWinMenu :: MonadUnliftIO m => Sometimes (m ()) runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"] -runNetMenu :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ()) +runNetMenu :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ()) runNetMenu cl = Sometimes "network control menu" @@ -171,7 +171,7 @@ runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd -------------------------------------------------------------------------------- -- Password manager -runBwMenu :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ()) +runBwMenu :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ()) runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd where cmd _ = diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index 37834b9..8dd6676 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -246,7 +246,7 @@ runNotificationCmd :: MonadUnliftIO m => T.Text -> T.Text - -> Maybe SesClient + -> Maybe NamedSesConnection -> Sometimes (m ()) runNotificationCmd n arg cl = sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd @@ -258,18 +258,18 @@ runNotificationCmd n arg cl = Method_ $ memberName_ "NotificationAction" -runNotificationClose :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ()) +runNotificationClose :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ()) runNotificationClose = runNotificationCmd "close notification" "close" -runNotificationCloseAll :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ()) +runNotificationCloseAll :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ()) runNotificationCloseAll = runNotificationCmd "close all notifications" "close-all" -runNotificationHistory :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ()) +runNotificationHistory :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ()) runNotificationHistory = runNotificationCmd "see notification history" "history-pop" -runNotificationContext :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ()) +runNotificationContext :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ()) runNotificationContext = runNotificationCmd "open notification context" "context" @@ -277,7 +277,7 @@ runNotificationContext = -- System commands -- this is required for some vpn's to work properly with network-manager -runNetAppDaemon :: Maybe SysClient -> Sometimes (XIO (P.Process () () ())) +runNetAppDaemon :: Maybe NamedSysConnection -> Sometimes (XIO (P.Process () () ())) runNetAppDaemon cl = Sometimes "network applet" @@ -288,7 +288,7 @@ runNetAppDaemon cl = app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet" cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True) -runToggleBluetooth :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ()) +runToggleBluetooth :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ()) runToggleBluetooth cl = Sometimes "bluetooth toggle" @@ -366,7 +366,7 @@ runFlameshot :: MonadUnliftIO m => T.Text -> T.Text - -> Maybe SesClient + -> Maybe NamedSesConnection -> Sometimes (m ()) runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd where @@ -378,15 +378,15 @@ runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd -- TODO this will steal focus from the current window (and puts it -- in the root window?) ...need to fix -runAreaCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ()) +runAreaCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ()) runAreaCapture = runFlameshot "screen area capture" "gui" -- myWindowCap = "screencap -w" --external script -runDesktopCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ()) +runDesktopCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ()) runDesktopCapture = runFlameshot "fullscreen capture" "full" -runScreenCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ()) +runScreenCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ()) runScreenCapture = runFlameshot "screen capture" "screen" runCaptureBrowser :: MonadUnliftIO m => Sometimes (m ()) diff --git a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs index 6d558a8..070e553 100644 --- a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs +++ b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs @@ -117,7 +117,7 @@ clevoKeyboardSignalDep = exportClevoKeyboard :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => Maybe SesClient + => Maybe NamedSesConnection -> Sometimes (m (), m ()) exportClevoKeyboard = brightnessExporter @@ -128,7 +128,7 @@ exportClevoKeyboard = clevoKeyboardControls :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m) - => Maybe SesClient + => Maybe NamedSesConnection -> BrightnessControls m clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 68aab36..9942a33 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -53,7 +53,7 @@ brightnessControls :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m) => XPQuery -> BrightnessConfig m a b - -> Maybe SesClient + -> Maybe NamedSesConnection -> BrightnessControls m brightnessControls q bc cl = BrightnessControls @@ -78,7 +78,7 @@ callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} = either (const Nothing) bodyGetBrightness <$> callMethod xmonadSesBusName p i memGet -signalDep :: BrightnessConfig m a b -> DBusDependency_ SesClient +signalDep :: BrightnessConfig m a b -> DBusDependency_ c signalDep BrightnessConfig {bcPath = p, bcInterface = i} = Endpoint [] xmonadSesBusName p i $ Signal_ memCur @@ -112,7 +112,7 @@ brightnessExporter -> [Fulfillment] -> [IODependency_] -> BrightnessConfig m a b - -> Maybe SesClient + -> Maybe NamedSesConnection -> Sometimes (m (), m ()) brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl = Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"] @@ -123,7 +123,7 @@ brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl = exportBrightnessControlsInner :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b) => BrightnessConfig m a b - -> SesClient + -> NamedSesConnection -> (m (), m ()) exportBrightnessControlsInner bc = cmd where @@ -172,7 +172,7 @@ emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur = callBacklight :: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m) => XPQuery - -> Maybe SesClient + -> Maybe NamedSesConnection -> BrightnessConfig m a b -> T.Text -> MemberName diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index 6b7c92b..80e7c88 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs @@ -103,7 +103,7 @@ intelBacklightSignalDep = exportIntelBacklight :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => Maybe SesClient + => Maybe NamedSesConnection -> Sometimes (m (), m ()) exportIntelBacklight = brightnessExporter @@ -114,7 +114,7 @@ exportIntelBacklight = intelBacklightControls :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m) - => Maybe SesClient + => Maybe NamedSesConnection -> BrightnessControls m intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig diff --git a/lib/XMonad/Internal/DBus/Common.hs b/lib/XMonad/Internal/DBus/Common.hs index 1b7d8e0..d7e4aa5 100644 --- a/lib/XMonad/Internal/DBus/Common.hs +++ b/lib/XMonad/Internal/DBus/Common.hs @@ -14,10 +14,10 @@ where import DBus xmonadSesBusName :: BusName -xmonadSesBusName = busName_ "org.xmonad.Session" +xmonadSesBusName = busName_ "org.xmonad.session" xmonadSysBusName :: BusName -xmonadSysBusName = busName_ "org.xmonad.System" +xmonadSysBusName = busName_ "org.xmonad.system" btBus :: BusName btBus = busName_ "org.bluez" diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index 6e43ff0..363357c 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -11,7 +11,7 @@ module XMonad.Internal.DBus.Control , withDBus_ , connectDBus , disconnectDBus - , disconnectDBusX + -- , disconnectDBusX , getDBusClient , withDBusClient , withDBusClient_ @@ -22,7 +22,6 @@ where import DBus import DBus.Client -import qualified Data.ByteString.Char8 as BC import Data.Internal.DBus import Data.Internal.XIO import RIO @@ -33,8 +32,8 @@ import XMonad.Internal.DBus.Screensaver -- | Current connections to the DBus (session and system buses) data DBusState = DBusState - { dbSesClient :: Maybe SesClient - , dbSysClient :: Maybe SysClient + { dbSesClient :: Maybe NamedSesConnection + , dbSysClient :: Maybe NamedSysConnection } withDBusX_ @@ -46,50 +45,47 @@ withDBusX_ = void . withDBusX withDBusX :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) => (DBusState -> m a) - -> m (Maybe a) -withDBusX f = withDBus $ \db -> do - case (dbSesClient db, dbSysClient db) of - (Just ses, Just sys) -> do - res <- - bracket_ - ( do - requestBusName xmonadSesBusName ses - requestBusName xmonadSysBusName sys - ) - ( do - releaseBusName xmonadSesBusName ses - releaseBusName xmonadSysBusName sys - ) - $ f db - return $ Just res - _ -> return Nothing + -> m a +withDBusX = withDBus (Just xmonadSesBusName) (Just xmonadSysBusName) withDBus_ :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => (DBusState -> m a) + => Maybe BusName + -> Maybe BusName + -> (DBusState -> m a) -> m () -withDBus_ = void . withDBus +withDBus_ sesname sysname = void . withDBus sesname sysname withDBus :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => (DBusState -> m a) + => Maybe BusName + -> Maybe BusName + -> (DBusState -> m a) -> m a -withDBus = bracket connectDBus disconnectDBus +withDBus sesname sysname = bracket (connectDBus sesname sysname) disconnectDBus -- | Connect to the DBus connectDBus :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => m DBusState -connectDBus = do - ses <- getDBusClient - sys <- getDBusClient + => Maybe BusName + -> Maybe BusName + -> m DBusState +connectDBus sesname sysname = do + ses <- getDBusClient sesname + sys <- getDBusClient sysname return DBusState {dbSesClient = ses, dbSysClient = sys} -- | Disconnect from the DBus -disconnectDBus :: MonadUnliftIO m => DBusState -> m () +disconnectDBus + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => DBusState + -> m () disconnectDBus db = disc dbSesClient >> disc dbSysClient where - disc :: (MonadUnliftIO m, SafeClient c) => (DBusState -> Maybe c) -> m () + disc + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c) + => (DBusState -> Maybe (NamedConnection c)) + -> m () disc f = maybe (return ()) disconnectDBusClient $ f db -- -- | Connect to the DBus and request the XMonad name @@ -101,15 +97,15 @@ disconnectDBus db = disc dbSesClient >> disc dbSysClient -- requestXMonadName2 db -- return db --- | Disconnect from DBus and release the XMonad name -disconnectDBusX - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => DBusState - -> m () -disconnectDBusX db = do - forM_ (dbSesClient db) $ releaseBusName xmonadSesBusName - forM_ (dbSysClient db) $ releaseBusName xmonadSysBusName - disconnectDBus db +-- -- | Disconnect from DBus and release the XMonad name +-- disconnectDBusX +-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) +-- => DBusState +-- -> m () +-- disconnectDBusX db = do +-- forM_ (dbSesClient db) releaseBusName +-- forM_ (dbSysClient db) releaseBusName +-- disconnectDBus db -- requestXMonadName2 -- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) @@ -121,7 +117,7 @@ disconnectDBusX db = do withDBusInterfaces :: DBusState - -> [Maybe SesClient -> Sometimes (XIO (), XIO ())] + -> [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())] -> ([XIO ()] -> XIO a) -> XIO a withDBusInterfaces db interfaces = bracket up sequence @@ -134,7 +130,7 @@ withDBusInterfaces db interfaces = bracket up sequence -- | All exporter features to be assigned to the DBus dbusExporters :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => [Maybe SesClient -> Sometimes (m (), m ())] + => [Maybe NamedSesConnection -> Sometimes (m (), m ())] dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard] -- releaseXMonadName @@ -146,35 +142,35 @@ dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard] -- liftIO $ void $ releaseName (toClient cl) xmonadBusName -- logInfo "released xmonad name" -releaseBusName - :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => BusName - -> c - -> m () -releaseBusName n cl = do - -- TODO this might error? - liftIO $ void $ releaseName (toClient cl) n - logInfo $ "released bus name: " <> displayBusName n +-- releaseBusName +-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m) +-- => BusName +-- -> c +-- -> m () +-- releaseBusName n cl = do +-- -- TODO this might error? +-- liftIO $ void $ releaseName (toClient cl) n +-- logInfo $ "released bus name: " <> displayBusName n -requestBusName - :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => BusName - -> c - -> m () -requestBusName n cl = do - res <- try $ liftIO $ requestName (toClient cl) n [] - case res of - Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e - Right r -> do - let msg - | r == NamePrimaryOwner = "registering name" - | r == NameAlreadyOwner = "this process already owns name" - | r == NameInQueue - || r == NameExists = - "another process owns name" - -- this should never happen - | otherwise = "unknown error when requesting name" - logInfo $ msg <> ": " <> displayBusName n +-- requestBusName +-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m) +-- => BusName +-- -> c +-- -> m () +-- requestBusName n cl = do +-- res <- try $ liftIO $ requestName (toClient cl) n [] +-- case res of +-- Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e +-- Right r -> do +-- let msg +-- | r == NamePrimaryOwner = "registering name" +-- | r == NameAlreadyOwner = "this process already owns name" +-- | r == NameInQueue +-- || r == NameExists = +-- "another process owns name" +-- -- this should never happen +-- | otherwise = "unknown error when requesting name" +-- logInfo $ msg <> ": " <> displayBusName n -- requestXMonadName -- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m) diff --git a/lib/XMonad/Internal/DBus/Removable.hs b/lib/XMonad/Internal/DBus/Removable.hs index 631fbb7..e3be100 100644 --- a/lib/XMonad/Internal/DBus/Removable.hs +++ b/lib/XMonad/Internal/DBus/Removable.hs @@ -83,7 +83,7 @@ listenDevices , MonadReader env m , MonadUnliftIO m ) - => SysClient + => NamedSysConnection -> m () listenDevices cl = do addMatch' memAdded driveInsertedSound addedHasDrive @@ -98,7 +98,7 @@ runRemovableMon , MonadReader env m , MonadUnliftIO m ) - => Maybe SysClient + => Maybe NamedSysConnection -> Sometimes (m ()) runRemovableMon cl = sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index f01c4ef..34c8541 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -93,7 +93,7 @@ bodyGetCurrentState _ = Nothing exportScreensaver :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => Maybe SesClient + => Maybe NamedSesConnection -> Sometimes (m (), m ()) exportScreensaver ses = sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd @@ -124,7 +124,7 @@ exportScreensaver ses = callToggle :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m) - => Maybe SesClient + => Maybe NamedSesConnection -> Sometimes (m ()) callToggle = sometimesEndpoint diff --git a/lib/Xmobar/Plugins/ActiveConnection.hs b/lib/Xmobar/Plugins/ActiveConnection.hs index 3a09dcc..654f245 100644 --- a/lib/Xmobar/Plugins/ActiveConnection.hs +++ b/lib/Xmobar/Plugins/ActiveConnection.hs @@ -39,7 +39,7 @@ connAlias = T.intercalate "_" . NE.toList instance Exec ActiveConnection where alias (ActiveConnection (contypes, _, _)) = T.unpack $ connAlias contypes start (ActiveConnection (contypes, text, colors)) cb = - withDBusClientConnection cb (Just "ethernet.log") $ \c -> do + withDBusClientConnection cb Nothing (Just "ethernet.log") $ \c -> do let dpy cb' = displayMaybe cb' formatter . Just =<< readState i <- withDIO c $ initialState contypes s <- newMVar i @@ -60,7 +60,7 @@ instance Exec ActiveConnection where -- TODO can I recycle the client? void $ addMatchCallbackSignal rule $ \sig -> - withDBusClientConnection cb (Just "ethernet-cb.log") $ \c' -> + withDBusClientConnection cb Nothing (Just "ethernet-cb.log") $ \c' -> mapEnv c' $ testActiveType contypes sig diff --git a/lib/Xmobar/Plugins/BacklightCommon.hs b/lib/Xmobar/Plugins/BacklightCommon.hs index f703e37..85fc18d 100644 --- a/lib/Xmobar/Plugins/BacklightCommon.hs +++ b/lib/Xmobar/Plugins/BacklightCommon.hs @@ -4,6 +4,7 @@ -- to signals spawned by commands module Xmobar.Plugins.BacklightCommon (startBacklight) where +import DBus import Data.Internal.DBus import RIO import qualified RIO.Text as T @@ -11,14 +12,15 @@ import Xmobar.Plugins.Common startBacklight :: (MonadUnliftIO m, RealFrac a) - => Maybe FilePath + => Maybe BusName + -> Maybe FilePath -> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient (Maybe a) -> T.Text -> Callback -> m () -startBacklight name matchSignal callGetBrightness icon cb = do - withDBusClientConnection cb name $ \c -> withDIO c $ do +startBacklight n name matchSignal callGetBrightness icon cb = do + withDBusClientConnection cb n name $ \c -> withDIO c $ do matchSignal dpy dpy =<< callGetBrightness where diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index 1516f8d..c94eaae 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -54,13 +54,17 @@ data Bluetooth = Bluetooth Icons Colors deriving (Read, Show) instance Exec Bluetooth where alias (Bluetooth _ _) = T.unpack btAlias start (Bluetooth icons colors) cb = - withDBusClientConnection cb (Just "bluetooth.log") $ startAdapter icons colors cb + withDBusClientConnection + cb + (Just "org.xmonad.bluetooth") + (Just "bluetooth.log") + $ startAdapter icons colors cb startAdapter :: Icons -> Colors -> Callback - -> SysClient + -> NamedSysConnection -> RIO SimpleApp () startAdapter is cs cb cl = do state <- newMVar emptyState @@ -201,7 +205,7 @@ startAdaptorListener adaptor = do <> displayObjectPath adaptor where callback sig = - withNestedDBusClientConnection Nothing $ + withNestedDBusClientConnection Nothing Nothing $ withSignalMatch procMatch $ matchPropertyChanged adaptorInterface adaptorPowered sig procMatch = beforeDisplay . putPowered @@ -249,7 +253,7 @@ startConnectedListener adaptor = do where adaptor_ = displayWrapQuote $ displayObjectPath adaptor callback sig = - withNestedDBusClientConnection Nothing $ do + withNestedDBusClientConnection Nothing Nothing $ do let devpath = signalPath sig when (adaptorHasDevice adaptor devpath) $ withSignalMatch (update devpath) $ diff --git a/lib/Xmobar/Plugins/ClevoKeyboard.hs b/lib/Xmobar/Plugins/ClevoKeyboard.hs index f62b922..23706d5 100644 --- a/lib/Xmobar/Plugins/ClevoKeyboard.hs +++ b/lib/Xmobar/Plugins/ClevoKeyboard.hs @@ -24,4 +24,9 @@ ckAlias = "clevokeyboard" instance Exec ClevoKeyboard where alias (ClevoKeyboard _) = T.unpack ckAlias start (ClevoKeyboard icon) = - startBacklight (Just "clevo_kbd.log") matchSignalCK callGetBrightnessCK icon + startBacklight + (Just "org.xmobar.clevo") + (Just "clevo_kbd.log") + matchSignalCK + callGetBrightnessCK + icon diff --git a/lib/Xmobar/Plugins/Common.hs b/lib/Xmobar/Plugins/Common.hs index 9771cec..bd36224 100644 --- a/lib/Xmobar/Plugins/Common.hs +++ b/lib/Xmobar/Plugins/Common.hs @@ -26,7 +26,7 @@ import qualified RIO.Text as T import XMonad.Hooks.DynamicLog (xmobarColor) data PluginEnv s c = PluginEnv - { plugClient :: !c + { plugClient :: !(NamedConnection c) , plugState :: !(MVar s) , plugDisplay :: !(Callback -> PluginIO s c ()) , plugCallback :: !Callback @@ -99,17 +99,18 @@ displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na) withDBusClientConnection :: (MonadUnliftIO m, SafeClient c) => Callback + -> Maybe BusName -> Maybe FilePath - -> (c -> RIO SimpleApp ()) + -> (NamedConnection c -> RIO SimpleApp ()) -> m () -withDBusClientConnection cb logfile f = +withDBusClientConnection cb n logfile f = maybe (run stderr) (`withLogFile` run) logfile where run h = do logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False withLogFunc logOpts $ \lf -> do env <- mkSimpleApp lf Nothing - runRIO env $ displayMaybe' cb f =<< getDBusClient + runRIO env $ displayMaybe' cb f =<< getDBusClient n -- | Run a plugin action with a new DBus client and logfile path. -- This is necessary for DBus callbacks which run in separate threads, which @@ -117,11 +118,12 @@ withDBusClientConnection cb logfile f = -- DBus connection and closed its logfile. withNestedDBusClientConnection :: (MonadUnliftIO m, SafeClient c, MonadReader (PluginEnv s c) m) - => Maybe FilePath + => Maybe BusName + -> Maybe FilePath -> PluginIO s c () -> m () -withNestedDBusClientConnection logfile f = do +withNestedDBusClientConnection n logfile f = do dpy <- asks plugDisplay s <- asks plugState cb <- asks plugCallback - withDBusClientConnection cb logfile $ \c -> mapRIO (PluginEnv c s dpy cb) f + withDBusClientConnection cb n logfile $ \c -> mapRIO (PluginEnv c s dpy cb) f diff --git a/lib/Xmobar/Plugins/IntelBacklight.hs b/lib/Xmobar/Plugins/IntelBacklight.hs index e5c5bc9..65193a9 100644 --- a/lib/Xmobar/Plugins/IntelBacklight.hs +++ b/lib/Xmobar/Plugins/IntelBacklight.hs @@ -24,4 +24,9 @@ blAlias = "intelbacklight" instance Exec IntelBacklight where alias (IntelBacklight _) = T.unpack blAlias start (IntelBacklight icon) = - startBacklight (Just "intel_backlight.log") matchSignalIB callGetBrightnessIB icon + startBacklight + (Just "org.xmobar.intelbacklight") + (Just "intel_backlight.log") + matchSignalIB + callGetBrightnessIB + icon diff --git a/lib/Xmobar/Plugins/Screensaver.hs b/lib/Xmobar/Plugins/Screensaver.hs index 01a6a81..96a523d 100644 --- a/lib/Xmobar/Plugins/Screensaver.hs +++ b/lib/Xmobar/Plugins/Screensaver.hs @@ -25,8 +25,12 @@ ssAlias = "screensaver" instance Exec Screensaver where alias (Screensaver _) = T.unpack ssAlias start (Screensaver (text, colors)) cb = - withDBusClientConnection cb (Just "screensaver.log") $ \cl -> withDIO cl $ do - matchSignal dpy - dpy =<< callQuery + withDBusClientConnection + cb + (Just "org.xmobar.screensaver") + (Just "screensaver.log") + $ \cl -> withDIO cl $ do + matchSignal dpy + dpy =<< callQuery where dpy = displayMaybe cb $ return . (\s -> colorText colors s text)