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

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