REF clean up dbus init process

This commit is contained in:
Nathan Dwarshuis 2021-11-20 15:20:22 -05:00
parent a468785742
commit b28279794c
3 changed files with 77 additions and 70 deletions

View File

@ -7,7 +7,11 @@
module Main (main) where module Main (main) where
import Control.Concurrent import Control.Concurrent
import Control.Monad (unless) import Control.Monad
( forM_
, unless
, void
)
import Data.List import Data.List
( isPrefixOf ( isPrefixOf
@ -73,19 +77,17 @@ main :: IO ()
main = do main = do
cl <- startXMonadService cl <- startXMonadService
(h, p) <- spawnPipe "xmobar" (h, p) <- spawnPipe "xmobar"
dbusActions <- mapM evalFeature [exportScreensaver cl, exportIntelBacklight cl] mapM_ (applyFeature_ forkIO_) [runPowermon, runRemovableMon]
depActions <- mapM evalFeature [runPowermon, runRemovableMon] forkIO_ $ runWorkspaceMon allDWs
mapM_ whenInstalled dbusActions
mapM_ (mapM_ forkIO) depActions
_ <- forkIO $ runWorkspaceMon allDWs
let ts = ThreadState let ts = ThreadState
{ client = cl { tsClient = cl
, childPIDs = [p] , tsChildPIDs = [p]
, childHandles = [h] , tsChildHandles = [h]
} }
lock <- whenInstalled <$> evalFeature runScreenLock lockRes <- evalFeature runScreenLock
let lock = whenInstalled lockRes
ext <- evalExternal $ externalBindings ts lock 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 -- IDK why this is necessary; nothing prior to this line will print if missing
hFlush stdout hFlush stdout
launch launch
@ -104,21 +106,23 @@ main = do
, normalBorderColor = T.bordersColor , normalBorderColor = T.bordersColor
, focusedBorderColor = T.selectedBordersColor , focusedBorderColor = T.selectedBordersColor
} }
where
forkIO_ = void . forkIO
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Concurrency configuration -- | Concurrency configuration
data ThreadState = ThreadState data ThreadState = ThreadState
{ client :: Client { tsClient :: Maybe Client
, childPIDs :: [ProcessHandle] , tsChildPIDs :: [ProcessHandle]
, childHandles :: [Handle] , tsChildHandles :: [Handle]
} }
-- TODO shouldn't this be run by a signal handler? -- TODO shouldn't this be run by a signal handler?
runCleanup :: ThreadState -> X () runCleanup :: ThreadState -> X ()
runCleanup ts = io $ do runCleanup ts = io $ do
mapM_ killHandle $ childPIDs ts mapM_ killHandle $ tsChildPIDs ts
stopXMonadService $ client ts forM_ (tsClient ts) stopXMonadService
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Startuphook configuration -- | Startuphook configuration

View File

@ -9,19 +9,21 @@ module XMonad.Internal.DBus.Control
, stopXMonadService , stopXMonadService
, pathExists , pathExists
, xmonadBus , xmonadBus
, DBusXMonad(..)
) where ) where
import Control.Exception
import Control.Monad (forM_, void)
import Data.Either import Data.Either
import DBus import DBus
import DBus.Client import DBus.Client
import XMonad.Internal.DBus.Brightness.Common -- import XMonad.Internal.DBus.Brightness.Common
-- import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
import XMonad.Internal.DBus.Screensaver import XMonad.Internal.DBus.Screensaver
-- import XMonad.Internal.Dependency import XMonad.Internal.Dependency
introspectInterface :: InterfaceName introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
@ -29,60 +31,40 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect" introspectMethod = memberName_ "Introspect"
data DBusXMonad = DBusXMonad startXMonadService :: IO (Maybe Client)
{ 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 = do startXMonadService = do
client <- connectSession client <- getDBusClient
res <- requestName client xmonadBus [] forM_ client $ \c -> do
case res of requestXMonadName c
NamePrimaryOwner -> return () mapM_ (\f -> executeFeature_ $ f c)
_ -> putStrLn $ "error when requesting '" ++ formatBusName xmonadBus ++ "'" [exportScreensaver, exportIntelBacklight]
-- 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)
return client return client
-- return $ DBusXMonad
-- { dxClient = client
-- , dxIntelBacklightCtrl = i
-- -- , dxClevoBacklightCtrl = c
-- , dxScreensaverCtrl = s
-- }
stopXMonadService :: Client -> IO () stopXMonadService :: Client -> IO ()
stopXMonadService client = do stopXMonadService client = do
_ <- releaseName client xmonadBus void $ releaseName client xmonadBus
disconnect client 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 :: Bool -> BusName -> ObjectPath -> IO Bool
pathExists sysbus n p = do pathExists sysbus n p = do

View File

@ -26,6 +26,10 @@ module XMonad.Internal.Dependency
, ifInstalled , ifInstalled
, fmtCmd , fmtCmd
, spawnCmd , spawnCmd
, executeFeature
, executeFeature_
, applyFeature
, applyFeature_
) where ) where
import Control.Monad.IO.Class import Control.Monad.IO.Class
@ -40,7 +44,7 @@ import qualified DBus.Introspection as I
import System.Directory (findExecutable, readable, writable) import System.Directory (findExecutable, readable, writable)
import System.Exit import System.Exit
import XMonad.Core (X) import XMonad.Core (X, io)
import XMonad.Internal.IO import XMonad.Internal.IO
import XMonad.Internal.Process import XMonad.Internal.Process
import XMonad.Internal.Shell import XMonad.Internal.Shell
@ -213,4 +217,21 @@ ifInstalled (Right x) _ = x
ifInstalled _ alt = alt ifInstalled _ alt = alt
warnMissing :: [MaybeExe a] -> IO () 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 ()