ENH make dmenu deps more stringent

This commit is contained in:
Nathan Dwarshuis 2022-07-08 00:21:05 -04:00
parent a7e7eee2a8
commit cdba344695
5 changed files with 92 additions and 61 deletions

View File

@ -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 "<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

View File

@ -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}'"

View File

@ -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 =

View File

@ -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"

View File

@ -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