ENH make dmenu deps more stringent
This commit is contained in:
parent
a7e7eee2a8
commit
cdba344695
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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}'"
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue