xmonad-config/lib/XMonad/Internal/Command/DMenu.hs

248 lines
6.8 KiB
Haskell

--------------------------------------------------------------------------------
-- Dmenu (Rofi) Commands
module XMonad.Internal.Command.DMenu
( runCmdMenu
, runAppMenu
, runClipMenu
, runWinMenu
, runNetMenu
, runDevMenu
, runBwMenu
, runVPNMenu
, runBTMenu
, runShowKeys
, runAutorandrMenu
)
where
import DBus
import qualified Data.ByteString.Char8 as BC
import Data.Internal.DBus
import Data.Internal.XIO
import Graphics.X11.Types
import RIO
import qualified RIO.ByteString as B
import RIO.Directory
( XdgDirectory (..)
, getXdgDirectory
)
import qualified RIO.Text as T
-- import System.IO
import XMonad.Core hiding (spawn)
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import XMonad.Internal.Notify
import XMonad.Internal.Shell
import XMonad.Util.NamedActions
--------------------------------------------------------------------------------
-- DMenu executables
myDmenuCmd :: FilePath
myDmenuCmd = "rofi"
myDmenuDevices :: FilePath
myDmenuDevices = "rofi-dev"
myDmenuPasswords :: FilePath
myDmenuPasswords = "rofi-bw"
myDmenuBluetooth :: FilePath
myDmenuBluetooth = "rofi-bt"
myDmenuVPN :: FilePath
myDmenuVPN = "rofi-evpn"
myDmenuMonitors :: FilePath
myDmenuMonitors = "rofi-autorandr"
myDmenuNetworks :: FilePath
myDmenuNetworks = "networkmanager_dmenu"
myClipboardManager :: FilePath
myClipboardManager = "greenclip"
--------------------------------------------------------------------------------
-- Packages
dmenuPkgs :: [Fulfillment]
dmenuPkgs = [Package Official "rofi"]
clipboardPkgs :: [Fulfillment]
clipboardPkgs = [Package AUR "rofi-greenclip"]
--------------------------------------------------------------------------------
-- Other internal functions
spawnDmenuCmd :: MonadUnliftIO m => T.Text -> [T.Text] -> Sometimes (m ())
spawnDmenuCmd n =
sometimesExeArgs n "rofi preset" dmenuPkgs True myDmenuCmd
themeArgs :: T.Text -> [T.Text]
themeArgs hexColor =
[ "-theme-str"
, T.concat ["'#element.selected.normal { background-color: ", hexColor, "; }'"]
]
myDmenuMatchingArgs :: [T.Text]
myDmenuMatchingArgs = ["-i"] -- case insensitivity
dmenuTree :: IOTree_ -> IOTree_
dmenuTree = And_ $ Only_ dmenuDep
dmenuDep :: IODependency_
dmenuDep = sysExe dmenuPkgs myDmenuCmd
--------------------------------------------------------------------------------
-- Exported Commands
-- TODO test that veracrypt and friends are installed
runDevMenu :: MonadUnliftIO m => Sometimes (m ())
runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
where
t = dmenuTree $ Only_ (localExe [] myDmenuDevices)
x = do
c <- io $ getXdgDirectory XdgConfig "rofi/devices.dhall"
spawnCmd myDmenuDevices $
["-c", T.pack c]
++ "--"
: themeArgs "#999933"
++ myDmenuMatchingArgs
-- TODO test that bluetooth interface exists
runBTMenu :: MonadUnliftIO m => Sometimes (m ())
runBTMenu =
Sometimes
"bluetooth selector"
xpfBluetooth
[Subfeature (IORoot_ cmd tree) "rofi bluetooth"]
where
cmd = spawnCmd myDmenuBluetooth $ "-c" : themeArgs "#0044bb"
tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth
runVPNMenu :: MonadUnliftIO m => Sometimes (m ())
runVPNMenu =
Sometimes
"VPN selector"
xpfVPN
[Subfeature (IORoot_ cmd tree) "rofi VPN"]
where
cmd =
spawnCmd myDmenuVPN $
["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
tree =
dmenuTree $
toAnd_ (localExe [] myDmenuVPN) $
socketExists "expressVPN" [] $
return "/var/lib/expressvpn/expressvpnd.socket"
runCmdMenu :: MonadUnliftIO m => Sometimes (m ())
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
runAppMenu :: MonadUnliftIO m => Sometimes (m ())
runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
runWinMenu :: MonadUnliftIO m => Sometimes (m ())
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
runNetMenu :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
runNetMenu cl =
Sometimes
"network control menu"
enabled
[Subfeature root "network control menu"]
where
enabled f = xpfEthernet f || xpfWireless f || xpfVPN f
root = DBusRoot_ cmd tree cl
cmd _ = spawnCmd myDmenuNetworks $ themeArgs "#ff3333"
tree =
And_ (Only_ $ Bus networkManagerPkgs networkManagerBus) $
toAnd_ (DBusIO dmenuDep) $
DBusIO $
sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
runAutorandrMenu :: MonadUnliftIO m => Sometimes (m ())
runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
where
cmd = spawnCmd myDmenuMonitors $ themeArgs "#ff0066"
tree = dmenuTree $ Only_ $ localExe [] myDmenuMonitors
--------------------------------------------------------------------------------
-- Password manager
runBwMenu :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
where
cmd _ =
spawnCmd myDmenuPasswords $
["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
tree =
And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden") $
toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords)
--------------------------------------------------------------------------------
-- Clipboard
runClipMenu :: MonadUnliftIO m => Sometimes (m ())
runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
where
act = spawnCmd myDmenuCmd args
tree =
listToAnds
dmenuDep
[ sysExe clipboardPkgs myClipboardManager
, process [] $ T.pack myClipboardManager
]
args =
[ "-modi"
, "\"clipboard:greenclip print\""
, "-show"
, "clipboard"
, "-run-command"
, "'{cmd}'"
]
++ themeArgs "#00c44e"
--------------------------------------------------------------------------------
-- Shortcut menu
runShowKeys
:: (MonadReader env m, MonadUnliftIO m)
=> Always ([((KeyMask, KeySym), NamedAction)] -> m ())
runShowKeys =
Always "keyboard menu" $
Option showKeysDMenu $
Always_ $
FallbackAlone fallback
where
-- TODO this should technically depend on dunst
fallback =
const $
spawnNotify $
defNoteError {body = Just $ Text "could not display keymap"}
showKeysDMenu
:: (MonadReader env m, MonadUnliftIO m)
=> SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> m ())
showKeysDMenu =
Subfeature
{ sfName = "keyboard shortcut menu"
, sfData = IORoot_ showKeys $ Only_ dmenuDep
}
showKeys
:: (MonadReader env m, MonadUnliftIO m)
=> [((KeyMask, KeySym), NamedAction)]
-> m ()
showKeys kbs = do
h <- spawnPipe cmd
B.hPut h $ BC.unlines $ BC.pack <$> showKm kbs
hClose h
where
cmd =
fmtCmd myDmenuCmd $
["-dmenu", "-p", "commands"]
++ themeArgs "#7f66ff"
++ myDmenuMatchingArgs