REF clean up dbus init process
This commit is contained in:
parent
a468785742
commit
b28279794c
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ()
|
||||||
|
|
Loading…
Reference in New Issue