REF clean up dbus init process

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

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

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