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
|
niceTheme = IORoot T.tabbedTheme $ fontTree T.defFontFamily
|
||||||
fallback = Always_ $ FallbackAlone $ T.tabbedTheme T.fallbackFont
|
fallback = Always_ $ FallbackAlone $ T.tabbedTheme T.fallbackFont
|
||||||
|
|
||||||
features :: FeatureSet
|
features :: Maybe Client -> FeatureSet
|
||||||
features = FeatureSet
|
features cl = FeatureSet
|
||||||
{ fsKeys = externalBindings
|
{ fsKeys = externalBindings
|
||||||
, fsDBusExporters = dbusExporters
|
, fsDBusExporters = dbusExporters
|
||||||
, fsPowerMon = runPowermon
|
, fsPowerMon = runPowermon
|
||||||
|
@ -117,22 +117,23 @@ features = FeatureSet
|
||||||
, fsDynWorkspaces = allDWs'
|
, fsDynWorkspaces = allDWs'
|
||||||
, fsTabbedTheme = tabbedFeature
|
, fsTabbedTheme = tabbedFeature
|
||||||
, fsShowKeys = runShowKeys
|
, 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
|
-- start DBus interfaces first since many features after this test these
|
||||||
-- interfaces as dependencies
|
-- 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
|
-- 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
|
return $ ewmh
|
||||||
$ addKeymap dws sk kbs
|
$ addKeymap dws sk kbs
|
||||||
$ docks
|
$ docks
|
||||||
|
@ -151,17 +152,17 @@ evalConf db = do
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
forkIO_ = void . forkIO
|
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"
|
(h, p) <- io $ spawnPipe "xmobar"
|
||||||
ps <- catMaybes <$> mapM executeSometimes (fsDaemons features)
|
ps <- catMaybes <$> mapM executeSometimes (fsDaemons fs)
|
||||||
return (h, ThreadState (p:ps) [h])
|
return (h, ThreadState (p:ps) [h])
|
||||||
startRemovableMon = void $ executeSometimes $ fsRemovableMon features
|
startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs
|
||||||
$ dbSysClient db
|
$ 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
|
io $ forkIO_ $ runWorkspaceMon dws
|
||||||
return dws
|
return dws
|
||||||
|
|
||||||
|
@ -617,10 +618,10 @@ externalBindings ts db =
|
||||||
[ KeyGroup "Launchers"
|
[ KeyGroup "Launchers"
|
||||||
[ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
|
[ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
|
||||||
, KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu
|
, 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-w" "launch window selector" $ Left runWinMenu
|
||||||
, KeyBinding "M-u" "launch device selector" $ Left runDevMenu
|
, 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-v" "launch ExpressVPN selector" $ Left runVPNMenu
|
||||||
, KeyBinding "M-e" "launch bluetooth selector" $ Left runBTMenu
|
, KeyBinding "M-e" "launch bluetooth selector" $ Left runBTMenu
|
||||||
, KeyBinding "M-C-e" "launch editor" $ Left runEditor
|
, KeyBinding "M-C-e" "launch editor" $ Left runEditor
|
||||||
|
|
|
@ -17,12 +17,19 @@ module XMonad.Internal.Command.DMenu
|
||||||
|
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
|
|
||||||
|
import DBus
|
||||||
|
import DBus.Client
|
||||||
|
|
||||||
import Graphics.X11.Types
|
import Graphics.X11.Types
|
||||||
|
|
||||||
import System.Directory (XdgDirectory (..), getXdgDirectory)
|
import System.Directory
|
||||||
|
( XdgDirectory (..)
|
||||||
|
, getXdgDirectory
|
||||||
|
)
|
||||||
import System.IO
|
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.Dependency
|
||||||
import XMonad.Internal.Notify
|
import XMonad.Internal.Notify
|
||||||
import XMonad.Internal.Process
|
import XMonad.Internal.Process
|
||||||
|
@ -91,11 +98,12 @@ runBTMenu :: SometimesX
|
||||||
runBTMenu = sometimesExeArgs "bluetooth selector" "rofi bluetooth" False
|
runBTMenu = sometimesExeArgs "bluetooth selector" "rofi bluetooth" False
|
||||||
myDmenuBluetooth $ "-c":themeArgs "#0044bb"
|
myDmenuBluetooth $ "-c":themeArgs "#0044bb"
|
||||||
|
|
||||||
-- TODO test that expressVPN is actually running (/var/lib/expressvpn/expressvpnd.socket)
|
|
||||||
runVPNMenu :: SometimesX
|
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
|
$ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
|
||||||
|
where
|
||||||
|
tree = toAnd_ (localExe myDmenuVPN) $ socketExists "expressVPN"
|
||||||
|
$ return "/var/lib/expressvpn/expressvpnd.socket"
|
||||||
|
|
||||||
runCmdMenu :: SometimesX
|
runCmdMenu :: SometimesX
|
||||||
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
|
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
|
||||||
|
@ -106,10 +114,12 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
|
||||||
runWinMenu :: SometimesX
|
runWinMenu :: SometimesX
|
||||||
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
|
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 :: SometimesX
|
||||||
runAutorandrMenu = sometimesExeArgs "autorandr menu" "rofi autorandr"
|
runAutorandrMenu = sometimesExeArgs "autorandr menu" "rofi autorandr"
|
||||||
|
@ -118,21 +128,23 @@ runAutorandrMenu = sometimesExeArgs "autorandr menu" "rofi autorandr"
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Password manager
|
-- | 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
|
-- | Clipboard
|
||||||
|
|
||||||
-- TODO test that greenclip daemon is actually running (get process id?)
|
|
||||||
runClipMenu :: SometimesX
|
runClipMenu :: SometimesX
|
||||||
runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
|
runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
|
||||||
where
|
where
|
||||||
act = spawnCmd myDmenuCmd args
|
act = spawnCmd myDmenuCmd args
|
||||||
tree = toAnd_ (sysExe myDmenuCmd) $ sysExe myClipboardManager
|
tree = listToAnds (processExists myClipboardManager)
|
||||||
|
$ sysExe <$> [myDmenuCmd, myClipboardManager]
|
||||||
args = [ "-modi", "\"clipboard:greenclip print\""
|
args = [ "-modi", "\"clipboard:greenclip print\""
|
||||||
, "-show", "clipboard"
|
, "-show", "clipboard"
|
||||||
, "-run-command", "'{cmd}'"
|
, "-run-command", "'{cmd}'"
|
||||||
|
|
|
@ -47,7 +47,6 @@ import DBus.Client
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.Posix.Files
|
|
||||||
import System.Posix.User
|
import System.Posix.User
|
||||||
|
|
||||||
import XMonad (asks)
|
import XMonad (asks)
|
||||||
|
@ -102,7 +101,7 @@ runTerm = sometimesExe "terminal" "urxvt" True myTerm
|
||||||
runTMux :: SometimesX
|
runTMux :: SometimesX
|
||||||
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
|
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
|
||||||
where
|
where
|
||||||
deps = listToAnds (socketExists socketName)
|
deps = listToAnds (socketExists "tmux" socketName)
|
||||||
$ fmap sysExe [myTerm, "tmux", "bash"]
|
$ fmap sysExe [myTerm, "tmux", "bash"]
|
||||||
act = spawn
|
act = spawn
|
||||||
$ "tmux has-session"
|
$ "tmux has-session"
|
||||||
|
@ -115,18 +114,6 @@ runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
|
||||||
t <- getTemporaryDirectory
|
t <- getTemporaryDirectory
|
||||||
return $ t </> "tmux-" ++ show u </> "default"
|
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 :: SometimesX
|
||||||
runCalc = sometimesIO_ "calculator" "R" deps act
|
runCalc = sometimesIO_ "calculator" "R" deps act
|
||||||
where
|
where
|
||||||
|
@ -141,7 +128,7 @@ runEditor = sometimesIO_ "text editor" "emacs" tree cmd
|
||||||
where
|
where
|
||||||
cmd = spawnCmd myEditor
|
cmd = spawnCmd myEditor
|
||||||
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
|
["-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"
|
socketName = (</> "emacs" </> "server") <$> getEnv "XDG_RUNTIME_DIR"
|
||||||
|
|
||||||
runFileManager :: SometimesX
|
runFileManager :: SometimesX
|
||||||
|
@ -224,12 +211,11 @@ runNotificationContext =
|
||||||
-- | System commands
|
-- | System commands
|
||||||
|
|
||||||
-- this is required for some vpn's to work properly with network-manager
|
-- 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
|
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 :: Maybe Client -> SometimesX
|
||||||
runToggleBluetooth cl =
|
runToggleBluetooth cl =
|
||||||
|
|
|
@ -6,6 +6,7 @@ module XMonad.Internal.DBus.Common
|
||||||
, btBus
|
, btBus
|
||||||
, notifyBus
|
, notifyBus
|
||||||
, notifyPath
|
, notifyPath
|
||||||
|
, networkManagerBus
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
|
@ -22,3 +23,6 @@ notifyBus = busName_ "org.freedesktop.Notifications"
|
||||||
notifyPath :: ObjectPath
|
notifyPath :: ObjectPath
|
||||||
notifyPath = objectPath_ "/org/freedesktop/Notifications"
|
notifyPath = objectPath_ "/org/freedesktop/Notifications"
|
||||||
|
|
||||||
|
networkManagerBus :: BusName
|
||||||
|
networkManagerBus = busName_ "org.freedesktop.NetworkManager"
|
||||||
|
|
||||||
|
|
|
@ -67,6 +67,8 @@ module XMonad.Internal.Dependency
|
||||||
, fontSometimes
|
, fontSometimes
|
||||||
, readEthernet
|
, readEthernet
|
||||||
, readWireless
|
, readWireless
|
||||||
|
, socketExists
|
||||||
|
, processExists
|
||||||
|
|
||||||
-- lifting
|
-- lifting
|
||||||
, ioSometimes
|
, ioSometimes
|
||||||
|
@ -685,7 +687,7 @@ unitType SystemUnit = "system"
|
||||||
unitType UserUnit = "user"
|
unitType UserUnit = "user"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | IO testers
|
-- | Font testers
|
||||||
--
|
--
|
||||||
-- Make a special case for these since we end up testing the font alot, and it
|
-- Make a special case for these since we end up testing the font alot, and it
|
||||||
-- would be nice if I can cache them.
|
-- 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) []
|
pass = Right $ PostPass (buildFont $ Just fam) []
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | network dependencies
|
-- | Network Testers
|
||||||
--
|
--
|
||||||
-- ASSUME that the system uses systemd in which case ethernet interfaces always
|
-- ASSUME that the system uses systemd in which case ethernet interfaces always
|
||||||
-- start with "en" and wireless interfaces always start with "wl"
|
-- start with "en" and wireless interfaces always start with "wl"
|
||||||
|
@ -769,6 +771,32 @@ readInterface n f = IORead n go
|
||||||
return $ Right $ PostPass x
|
return $ Right $ PostPass x
|
||||||
$ fmap (Msg Warn . ("ignoring extra interface: " ++)) xs
|
$ 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
|
-- | DBus Dependency Testing
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue