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
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

View File

@ -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

View File

@ -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 ()