ENH make dmenu deps more stringent

bin/xmonad.hs

@@ -107,8 +107,8 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
     niceTheme = IORoot T.tabbedTheme $ fontTree T.defFontFamily
     fallback = Always_ $ FallbackAlone $ T.tabbedTheme T.fallbackFont
 
-features :: FeatureSet
+features :: Maybe Client -> FeatureSet
-features = FeatureSet
+features cl = FeatureSet
   { fsKeys = externalBindings
   , fsDBusExporters = dbusExporters
   , fsPowerMon = runPowermon
@@ -117,22 +117,23 @@ features = FeatureSet
   , fsDynWorkspaces = allDWs'
   , fsTabbedTheme = tabbedFeature
   , fsShowKeys = runShowKeys
-  , fsDaemons = [runNetAppDaemon, runAutolock]
+  , fsDaemons = [runNetAppDaemon cl, runAutolock]
   }
 
-evalConf db = do
+evalConf db@DBusState { dbSysClient = cl } = do
   -- start DBus interfaces first since many features after this test these
   -- interfaces as dependencies
-  startDBusInterfaces
+  let fs = features cl
-  (xmobarHandle, ts) <- startChildDaemons
+  startDBusInterfaces fs
-  startRemovableMon
+  (xmobarHandle, ts) <- startChildDaemons fs
-  startPowerMon
+  startRemovableMon fs
-  dws <- startDynWorkspaces
+  startPowerMon fs
-  tt <- evalAlways $ fsTabbedTheme features
+  dws <- startDynWorkspaces fs
+  tt <- evalAlways $ fsTabbedTheme fs
   -- fb <- evalAlways $ fsFontBuilder features
-  kbs <- filterExternal <$> evalExternal (fsKeys features ts db)
+  kbs <- filterExternal <$> evalExternal (fsKeys fs ts db)
-  sk <- evalAlways $ fsShowKeys features
+  sk <- evalAlways $ fsShowKeys fs
-  ha <- evalAlways $ fsACPIHandler features
+  ha <- evalAlways $ fsACPIHandler fs
   return $ ewmh
     $ addKeymap dws sk kbs
     $ docks
@@ -151,17 +152,17 @@ evalConf db = do
           }
   where
     forkIO_ = void . forkIO
-    startDBusInterfaces = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)
+    startDBusInterfaces fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)
-      $ fsDBusExporters features
+      $ fsDBusExporters fs
-    startChildDaemons = do
+    startChildDaemons fs = do
       (h, p) <- io $ spawnPipe "xmobar"
-      ps <- catMaybes <$> mapM executeSometimes (fsDaemons features)
+      ps <- catMaybes <$> mapM executeSometimes (fsDaemons fs)
       return (h, ThreadState (p:ps) [h])
-    startRemovableMon = void $ executeSometimes $ fsRemovableMon features
+    startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs
                         $ dbSysClient db
-    startPowerMon = void $ fork $ void $ executeSometimes $ fsPowerMon features
+    startPowerMon fs = void $ fork $ void $ executeSometimes $ fsPowerMon fs
-    startDynWorkspaces = do
+    startDynWorkspaces fs = do
-      dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces features)
+      dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
       io $ forkIO_ $ runWorkspaceMon dws
       return dws
 
@@ -617,10 +618,10 @@ externalBindings ts db =
   [ KeyGroup "Launchers"
     [ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
     , KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu
-    , KeyBinding "M-a" "launch network selector" $ Left runNetMenu
+    , KeyBinding "M-a" "launch network selector" $ Left $ runNetMenu sys
     , KeyBinding "M-w" "launch window selector" $ Left runWinMenu
     , KeyBinding "M-u" "launch device selector" $ Left runDevMenu
-    , KeyBinding "M-b" "launch bitwarden selector" $ Left runBwMenu
+    , KeyBinding "M-b" "launch bitwarden selector" $ Left $ runBwMenu ses
     , KeyBinding "M-v" "launch ExpressVPN selector" $ Left runVPNMenu
     , KeyBinding "M-e" "launch bluetooth selector" $ Left runBTMenu
     , KeyBinding "M-C-e" "launch editor" $ Left runEditor

lib/XMonad/Internal/Command/DMenu.hs

@@ -17,12 +17,19 @@ module XMonad.Internal.Command.DMenu
 
 import           Control.Monad.Reader
 
+import           DBus
+import           DBus.Client
+
 import           Graphics.X11.Types
 
-import           System.Directory           (XdgDirectory (..), getXdgDirectory)
+import           System.Directory
+    ( XdgDirectory (..)
+    , getXdgDirectory
+    )
 import           System.IO
 
-import           XMonad.Core                hiding (spawn)
+import           XMonad.Core                 hiding (spawn)
+import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.Dependency
 import           XMonad.Internal.Notify
 import           XMonad.Internal.Process
@@ -91,11 +98,12 @@ runBTMenu :: SometimesX
 runBTMenu = sometimesExeArgs "bluetooth selector" "rofi bluetooth" False
   myDmenuBluetooth $ "-c":themeArgs "#0044bb"
 
--- TODO test that expressVPN is actually running (/var/lib/expressvpn/expressvpnd.socket)
 runVPNMenu :: SometimesX
-runVPNMenu = sometimesIO_ "VPN selector" "rofi VPN"
+runVPNMenu = sometimesIO_ "VPN selector" "rofi VPN" tree $ spawnCmd myDmenuVPN
-  (Only_ $ localExe myDmenuVPN) $ spawnCmd myDmenuVPN
   $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
+  where
+    tree = toAnd_ (localExe myDmenuVPN) $ socketExists "expressVPN"
+      $ return "/var/lib/expressvpn/expressvpnd.socket"
 
 runCmdMenu :: SometimesX
 runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
@@ -106,10 +114,12 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
 runWinMenu :: SometimesX
 runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
 
--- TODO test that networkManager is actually running (systemd service)
+runNetMenu :: Maybe Client -> SometimesX
-runNetMenu :: SometimesX
+runNetMenu cl =
-runNetMenu = sometimesExeArgs "network control menu" "rofi NetworkManager"
+  sometimesDBus cl "network control menu" "rofi NetworkManager" tree cmd
-  True myDmenuNetworks $ themeArgs "#ff3333"
+  where
+    cmd _ = spawnCmd myDmenuNetworks $ themeArgs "#ff3333"
+    tree = toAnd_ (DBusIO $ localExe myDmenuNetworks) $ Bus networkManagerBus
 
 runAutorandrMenu :: SometimesX
 runAutorandrMenu = sometimesExeArgs "autorandr menu" "rofi autorandr"
@@ -118,21 +128,23 @@ runAutorandrMenu = sometimesExeArgs "autorandr menu" "rofi autorandr"
 --------------------------------------------------------------------------------
 -- | Password manager
 
-runBwMenu :: SometimesX
+runBwMenu :: Maybe Client -> SometimesX
-runBwMenu = sometimesIO_ "password manager" "rofi bitwarden"
+runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
-  -- TODO test that this program is actually running (query the DBus?)
+  where
-  (Only_ $ localExe myDmenuPasswords) $ spawnCmd myDmenuPasswords
+    cmd _ = spawnCmd myDmenuPasswords
-  $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
+      $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
+    tree = toAnd_ (DBusIO $ localExe myDmenuPasswords)
+      $ Bus $ busName_ "org.rofi.bitwarden"
 
 --------------------------------------------------------------------------------
 -- | Clipboard
 
--- TODO test that greenclip daemon is actually running (get process id?)
 runClipMenu :: SometimesX
 runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
   where
     act = spawnCmd myDmenuCmd args
-    tree = toAnd_ (sysExe myDmenuCmd) $ sysExe myClipboardManager
+    tree = listToAnds (processExists myClipboardManager)
+      $ sysExe <$> [myDmenuCmd, myClipboardManager]
     args = [ "-modi", "\"clipboard:greenclip print\""
            , "-show", "clipboard"
            , "-run-command", "'{cmd}'"

lib/XMonad/Internal/Command/Desktop.hs

@@ -47,7 +47,6 @@ import           DBus.Client
 import           System.Directory
 import           System.Environment
 import           System.FilePath
-import           System.Posix.Files
 import           System.Posix.User
 
 import           XMonad                      (asks)
@@ -102,7 +101,7 @@ runTerm = sometimesExe "terminal" "urxvt" True myTerm
 runTMux :: SometimesX
 runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
   where
-    deps = listToAnds (socketExists socketName)
+    deps = listToAnds (socketExists "tmux" socketName)
       $ fmap sysExe [myTerm, "tmux", "bash"]
     act = spawn
       $ "tmux has-session"
@@ -115,18 +114,6 @@ runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
       t <- getTemporaryDirectory
       return $ t </> "tmux-" ++ show u </> "default"
 
-socketExists :: IO FilePath -> IODependency_
-socketExists getPath = IOTest_ "find tmux socket current user" $ do
-  p <- getPath
-  e <- fileExist p
-  s <- isSocket <$> getFileStatus p
-  return $ case (e, s) of
-    (True, True) -> Nothing
-    (False, _)   -> toErr $ "could not find socket at " ++ p
-    (_, False)   -> toErr $ p ++ " is not a socket"
-  where
-    toErr = Just . Msg Error
-
 runCalc :: SometimesX
 runCalc = sometimesIO_ "calculator" "R" deps act
   where
@@ -141,7 +128,7 @@ runEditor = sometimesIO_ "text editor" "emacs" tree cmd
   where
     cmd = spawnCmd myEditor
       ["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
-    tree = toAnd_ (sysExe myEditor) (socketExists socketName)
+    tree = toAnd_ (sysExe myEditor) (socketExists "emacs" socketName)
     socketName = (</> "emacs" </> "server") <$> getEnv "XDG_RUNTIME_DIR"
 
 runFileManager :: SometimesX
@@ -224,12 +211,11 @@ runNotificationContext =
 -- | System commands
 
 -- this is required for some vpn's to work properly with network-manager
--- TODO test that network manager is up
+runNetAppDaemon :: Maybe Client -> Sometimes (IO ProcessHandle)
-runNetAppDaemon :: Sometimes (IO ProcessHandle)
+runNetAppDaemon cl = sometimesDBus cl "network applet" "NM-applet" tree cmd
-runNetAppDaemon = sometimesIO_ "network applet" "NM-applet" tree cmd
   where
-    tree = Only_ $ localExe "nm-applet"
+    tree = toAnd_ (DBusIO $ localExe "nm-applet") $ Bus networkManagerBus
-    cmd = snd <$> spawnPipe "nm-applet"
+    cmd _ = snd <$> spawnPipe "nm-applet"
 
 runToggleBluetooth :: Maybe Client -> SometimesX
 runToggleBluetooth cl =

lib/XMonad/Internal/DBus/Common.hs

@@ -6,6 +6,7 @@ module XMonad.Internal.DBus.Common
   , btBus
   , notifyBus
   , notifyPath
+  , networkManagerBus
   ) where
 
 import           DBus
@@ -22,3 +23,6 @@ notifyBus = busName_ "org.freedesktop.Notifications"
 notifyPath :: ObjectPath
 notifyPath = objectPath_ "/org/freedesktop/Notifications"
 
+networkManagerBus :: BusName
+networkManagerBus = busName_ "org.freedesktop.NetworkManager"
+

lib/XMonad/Internal/Dependency.hs

@@ -67,6 +67,8 @@ module XMonad.Internal.Dependency
   , fontSometimes
   , readEthernet
   , readWireless
+  , socketExists
+  , processExists
 
   -- lifting
   , ioSometimes
@@ -685,7 +687,7 @@ unitType SystemUnit = "system"
 unitType UserUnit   = "user"
 
 --------------------------------------------------------------------------------
--- | IO testers
+-- | Font testers
 --
 -- Make a special case for these since we end up testing the font alot, and it
 -- would be nice if I can cache them.
@@ -733,7 +735,7 @@ testFont' fam = maybe pass (Left . (:[])) <$> shellTest cmd msg
     pass = Right $ PostPass (buildFont $ Just fam) []
 
 --------------------------------------------------------------------------------
--- | network dependencies
+-- | Network Testers
 --
 -- ASSUME that the system uses systemd in which case ethernet interfaces always
 -- start with "en" and wireless interfaces always start with "wl"
@@ -769,6 +771,32 @@ readInterface n f = IORead n go
           return $ Right $ PostPass x
             $ fmap (Msg Warn . ("ignoring extra interface: " ++)) xs
 
+--------------------------------------------------------------------------------
+-- | Misc testers
+
+socketExists :: String -> IO FilePath -> IODependency_
+socketExists n = IOTest_ ("test if " ++ n ++ " socket exists") . socketExists'
+
+socketExists' :: IO FilePath -> IO (Maybe Msg)
+socketExists' getPath = do
+  p <- getPath
+  e <- fileExist p
+  s <- isSocket <$> getFileStatus p
+  return $ case (e, s) of
+    (True, True) -> Nothing
+    (False, _)   -> toErr $ "could not find socket at " ++ p
+    (_, False)   -> toErr $ p ++ " is not a socket"
+  where
+    toErr = Just . Msg Error
+
+processExists :: String -> IODependency_
+processExists n = IOTest_ ("determine if process " ++ n ++ " is running")
+  $ processExists' n
+
+processExists' :: String -> IO (Maybe Msg)
+processExists' n = shellTest (fmtCmd "pidof" [n])
+  $ "Process " ++ singleQuote n ++ " not found"
+
 --------------------------------------------------------------------------------
 -- | DBus Dependency Testing