From b28279794ce0d680d32775fa059c4db300d3fc2c Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sat, 20 Nov 2021 15:20:22 -0500 Subject: [PATCH] REF clean up dbus init process --- bin/xmonad.hs | 36 ++++++------ lib/XMonad/Internal/DBus/Control.hs | 86 ++++++++++++----------------- lib/XMonad/Internal/Dependency.hs | 25 ++++++++- 3 files changed, 77 insertions(+), 70 deletions(-) diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 82a2c74..4352b34 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -7,7 +7,11 @@ module Main (main) where import Control.Concurrent -import Control.Monad (unless) +import Control.Monad + ( forM_ + , unless + , void + ) import Data.List ( isPrefixOf @@ -73,19 +77,17 @@ main :: IO () main = do cl <- startXMonadService (h, p) <- spawnPipe "xmobar" - dbusActions <- mapM evalFeature [exportScreensaver cl, exportIntelBacklight cl] - depActions <- mapM evalFeature [runPowermon, runRemovableMon] - mapM_ whenInstalled dbusActions - mapM_ (mapM_ forkIO) depActions - _ <- forkIO $ runWorkspaceMon allDWs + mapM_ (applyFeature_ forkIO_) [runPowermon, runRemovableMon] + forkIO_ $ runWorkspaceMon allDWs let ts = ThreadState - { client = cl - , childPIDs = [p] - , childHandles = [h] + { tsClient = cl + , tsChildPIDs = [p] + , tsChildHandles = [h] } - lock <- whenInstalled <$> evalFeature runScreenLock + lockRes <- evalFeature runScreenLock + let lock = whenInstalled lockRes ext <- evalExternal $ externalBindings ts lock - warnMissing $ externalToMissing ext ++ fmap (io <$>) (depActions ++ dbusActions) + warnMissing $ externalToMissing ext -- IDK why this is necessary; nothing prior to this line will print if missing hFlush stdout launch @@ -104,21 +106,23 @@ main = do , normalBorderColor = T.bordersColor , focusedBorderColor = T.selectedBordersColor } + where + forkIO_ = void . forkIO -------------------------------------------------------------------------------- -- | Concurrency configuration data ThreadState = ThreadState - { client :: Client - , childPIDs :: [ProcessHandle] - , childHandles :: [Handle] + { tsClient :: Maybe Client + , tsChildPIDs :: [ProcessHandle] + , tsChildHandles :: [Handle] } -- TODO shouldn't this be run by a signal handler? runCleanup :: ThreadState -> X () runCleanup ts = io $ do - mapM_ killHandle $ childPIDs ts - stopXMonadService $ client ts + mapM_ killHandle $ tsChildPIDs ts + forM_ (tsClient ts) stopXMonadService -------------------------------------------------------------------------------- -- | Startuphook configuration diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index 2ad5429..4ac3654 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -9,19 +9,21 @@ module XMonad.Internal.DBus.Control , stopXMonadService , pathExists , xmonadBus - , DBusXMonad(..) ) where +import Control.Exception +import Control.Monad (forM_, void) + import Data.Either import DBus import DBus.Client -import XMonad.Internal.DBus.Brightness.Common --- import XMonad.Internal.DBus.Brightness.IntelBacklight +-- import XMonad.Internal.DBus.Brightness.Common +import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Screensaver --- import XMonad.Internal.Dependency +import XMonad.Internal.Dependency introspectInterface :: InterfaceName introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" @@ -29,60 +31,40 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" introspectMethod :: MemberName introspectMethod = memberName_ "Introspect" -data DBusXMonad = DBusXMonad - { dxClient :: Client - , dxIntelBacklightCtrl :: BrightnessControls - -- , dxClevoBacklightCtrl :: MaybeExe BrightnessControls - , dxScreensaverCtrl :: SSControls - } - --- blankControls :: BrightnessControls --- blankControls = BrightnessControls --- { bctlMax = BlankFeature --- , bctlMin = BlankFeature --- , bctlInc = BlankFeature --- , bctlDec = BlankFeature --- } - --- blankSSToggle :: SSControls --- blankSSToggle = SSControls { ssToggle = BlankFeature } - --- xmonadService :: Feature (IO Client) --- xmonadService = Feature --- { ftrAction = undefined --- , ftr - - -startXMonadService :: IO Client +startXMonadService :: IO (Maybe Client) startXMonadService = do - client <- connectSession - res <- requestName client xmonadBus [] - case res of - NamePrimaryOwner -> return () - _ -> putStrLn $ "error when requesting '" ++ formatBusName xmonadBus ++ "'" - -- TODO if the client is not released on shutdown the owner will be - -- different - -- (i, s) <- if requestResult /= NamePrimaryOwner then do - -- putStrLn "Another service owns \"org.xmonad\"" - -- return (blankControls, blankSSToggle) - -- else do - -- putStrLn "Started xmonad dbus client" - -- bc <- exportIntelBacklight client - -- sc <- exportScreensaver client - -- return (bc, sc) + client <- getDBusClient + forM_ client $ \c -> do + requestXMonadName c + mapM_ (\f -> executeFeature_ $ f c) + [exportScreensaver, exportIntelBacklight] return client - -- return $ DBusXMonad - -- { dxClient = client - -- , dxIntelBacklightCtrl = i - -- -- , dxClevoBacklightCtrl = c - -- , dxScreensaverCtrl = s - -- } stopXMonadService :: Client -> IO () stopXMonadService client = do - _ <- releaseName client xmonadBus + void $ releaseName client xmonadBus disconnect client - return () + +getDBusClient :: IO (Maybe Client) +getDBusClient = do + res <- try connectSession + case res of + Left e -> putStrLn (clientErrorMessage e) >> return Nothing + Right c -> return $ Just c + +requestXMonadName :: Client -> IO () +requestXMonadName client = do + res <- requestName client xmonadBus [] + -- TODO if the client is not released on shutdown the owner will be + -- different + let msg | res == NamePrimaryOwner = Nothing + | res == NameAlreadyOwner = Just $ "this process already owns " ++ xn + | res == NameInQueue + || res == NameExists = Just $ "another process owns " ++ xn + | otherwise = Just $ "unknown error when requesting " ++ xn + forM_ msg putStrLn + where + xn = "'" ++ formatBusName xmonadBus ++ "'" pathExists :: Bool -> BusName -> ObjectPath -> IO Bool pathExists sysbus n p = do diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 8ef6f9e..8937fa4 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -26,6 +26,10 @@ module XMonad.Internal.Dependency , ifInstalled , fmtCmd , spawnCmd + , executeFeature + , executeFeature_ + , applyFeature + , applyFeature_ ) where import Control.Monad.IO.Class @@ -40,7 +44,7 @@ import qualified DBus.Introspection as I import System.Directory (findExecutable, readable, writable) import System.Exit -import XMonad.Core (X) +import XMonad.Core (X, io) import XMonad.Internal.IO import XMonad.Internal.Process import XMonad.Internal.Shell @@ -213,4 +217,21 @@ ifInstalled (Right x) _ = x ifInstalled _ alt = alt warnMissing :: [MaybeExe a] -> IO () -warnMissing xs = mapM_ putStrLn $ fmap ("[WARNING] "++) $ concat $ [ m | (Left m) <- xs ] +warnMissing xs = warnMissing' $ fmap ("[WARNING] "++) $ concat $ [ m | (Left m) <- xs ] + +warnMissing' :: [String] -> IO () +warnMissing' = mapM_ putStrLn + +applyFeature :: MonadIO m => (m a -> m a) -> a -> Feature (IO a) -> m a +applyFeature iof def ftr = do + a <- io $ evalFeature ftr + either (\es -> io $ warnMissing' es >> return def) (iof . io) a + +applyFeature_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m () +applyFeature_ iof = applyFeature iof () + +executeFeature :: MonadIO m => a -> Feature (IO a) -> m a +executeFeature = applyFeature id + +executeFeature_ :: Feature (IO ()) -> IO () +executeFeature_ = executeFeature ()