From cdba3446952e984f814a61fe2730e81f2b413366 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Fri, 8 Jul 2022 00:21:05 -0400 Subject: [PATCH] ENH make dmenu deps more stringent --- bin/xmonad.hs | 47 +++++++++++++------------- lib/XMonad/Internal/Command/DMenu.hs | 44 +++++++++++++++--------- lib/XMonad/Internal/Command/Desktop.hs | 26 ++++---------- lib/XMonad/Internal/DBus/Common.hs | 4 +++ lib/XMonad/Internal/Dependency.hs | 32 ++++++++++++++++-- 5 files changed, 92 insertions(+), 61 deletions(-) diff --git a/bin/xmonad.hs b/bin/xmonad.hs index a7bd590..19b3047 100644 --- a/bin/xmonad.hs +++ b/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 = FeatureSet +features :: Maybe Client -> 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 - (xmobarHandle, ts) <- startChildDaemons - startRemovableMon - startPowerMon - dws <- startDynWorkspaces - tt <- evalAlways $ fsTabbedTheme features + let fs = features cl + startDBusInterfaces fs + (xmobarHandle, ts) <- startChildDaemons fs + startRemovableMon fs + startPowerMon fs + dws <- startDynWorkspaces fs + tt <- evalAlways $ fsTabbedTheme fs -- fb <- evalAlways $ fsFontBuilder features - kbs <- filterExternal <$> evalExternal (fsKeys features ts db) - sk <- evalAlways $ fsShowKeys features - ha <- evalAlways $ fsACPIHandler features + kbs <- filterExternal <$> evalExternal (fsKeys fs ts db) + sk <- evalAlways $ fsShowKeys fs + 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) - $ fsDBusExporters features - startChildDaemons = do + startDBusInterfaces fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db) + $ fsDBusExporters fs + 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 - startDynWorkspaces = do - dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces features) + startPowerMon fs = void $ fork $ void $ executeSometimes $ fsPowerMon fs + startDynWorkspaces fs = do + dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs) io $ forkIO_ $ runWorkspaceMon dws return dws @@ -617,10 +618,10 @@ externalBindings ts db = [ KeyGroup "Launchers" [ KeyBinding "" "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 diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index 4a954c6..0560e08 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/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" - (Only_ $ localExe myDmenuVPN) $ spawnCmd myDmenuVPN +runVPNMenu = sometimesIO_ "VPN selector" "rofi VPN" tree $ 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 :: SometimesX -runNetMenu = sometimesExeArgs "network control menu" "rofi NetworkManager" - True myDmenuNetworks $ themeArgs "#ff3333" +runNetMenu :: Maybe Client -> SometimesX +runNetMenu cl = + sometimesDBus cl "network control menu" "rofi NetworkManager" tree cmd + 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 = sometimesIO_ "password manager" "rofi bitwarden" - -- TODO test that this program is actually running (query the DBus?) - (Only_ $ localExe myDmenuPasswords) $ spawnCmd myDmenuPasswords - $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs +runBwMenu :: Maybe Client -> SometimesX +runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd + where + cmd _ = spawnCmd myDmenuPasswords + $ ["-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}'" diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index f8d5b5a..b9d4fe6 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/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 :: Sometimes (IO ProcessHandle) -runNetAppDaemon = sometimesIO_ "network applet" "NM-applet" tree cmd +runNetAppDaemon :: Maybe Client -> Sometimes (IO ProcessHandle) +runNetAppDaemon cl = sometimesDBus cl "network applet" "NM-applet" tree cmd where - tree = Only_ $ localExe "nm-applet" - cmd = snd <$> spawnPipe "nm-applet" + tree = toAnd_ (DBusIO $ localExe "nm-applet") $ Bus networkManagerBus + cmd _ = snd <$> spawnPipe "nm-applet" runToggleBluetooth :: Maybe Client -> SometimesX runToggleBluetooth cl = diff --git a/lib/XMonad/Internal/DBus/Common.hs b/lib/XMonad/Internal/DBus/Common.hs index 3a1e838..4fb4b0a 100644 --- a/lib/XMonad/Internal/DBus/Common.hs +++ b/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" + diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index fb7c8f3..5fdd66b 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/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