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

{-# LANGUAGE OverloadedStrings #-}

--------------------------------------------------------------------------------
-- | Dmenu (Rofi) Commands

module XMonad.Internal.Command.DMenu
  ( runCmdMenu
  , runAppMenu
  , runClipMenu
  , runWinMenu
  , runNetMenu
  , runDevMenu
  , runBwMenu
  , runVPNMenu
  , runBTMenu
  , runShowKeys
  , runAutorandrMenu
  ) where

import           Data.Internal.DBus
import           Data.Internal.Dependency

import           DBus

import           Graphics.X11.Types

import           RIO.Directory
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 :: T.Text -> [T.Text] -> SometimesX
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 :: SometimesX
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 :: SometimesX
runBTMenu = Sometimes "bluetooth selector" xpfBluetooth
  [Subfeature (IORoot_ cmd tree) "rofi bluetooth"]
  where
    cmd = spawnCmd myDmenuBluetooth $ "-c":themeArgs "#0044bb"
    tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth

runVPNMenu :: SometimesX
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 :: SometimesX
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]

runAppMenu :: SometimesX
runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]

runWinMenu :: SometimesX
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]

runNetMenu :: Maybe SysClient -> SometimesX
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 :: SometimesX
runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
  where
    cmd = spawnCmd myDmenuMonitors $ themeArgs "#ff0066"
    tree = dmenuTree $ Only_ $ localExe [] myDmenuMonitors

--------------------------------------------------------------------------------
-- | Password manager

runBwMenu :: Maybe SesClient -> SometimesX
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 :: SometimesX
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 :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
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 :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ())
showKeysDMenu = Subfeature
  { sfName = "keyboard shortcut menu"
  , sfData = IORoot_ showKeys $ Only_ dmenuDep
  }

showKeys :: [((KeyMask, KeySym), NamedAction)] -> X ()
showKeys kbs = do
  h <- spawnPipe cmd
  io $ hPutStr h $ unlines $ showKm kbs
  io $ hClose h
  where
    cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
      ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs