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