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

--------------------------------------------------------------------------------
-- General commands

module XMonad.Internal.Command.Desktop
  ( myTerm
  , playSound
  -- commands
  , runTerm
  , runTMux
  , runCalc
  , runBrowser
  , runEditor
  , runFileManager
  , runTogglePlay
  , runPrevTrack
  , runNextTrack
  , runStopPlay
  , runVolumeDown
  , runVolumeUp
  , runVolumeMute
  , runToggleBluetooth
  , runToggleEthernet
  , runRestart
  , runRecompile
  , runAreaCapture
  , runScreenCapture
  , runDesktopCapture
  , runCaptureBrowser
  , runNotificationClose
  , runNotificationCloseAll
  , runNotificationHistory
  , runNotificationContext
  -- daemons
  , runNetAppDaemon
  -- packages
  , networkManagerPkgs
  )
where

import DBus
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import RIO.Directory
import RIO.FilePath
import qualified RIO.Process as P
import qualified RIO.Text as T
import System.Posix.User
import UnliftIO.Environment
import XMonad.Actions.Volume
import XMonad.Core hiding (spawn)
import XMonad.Internal.DBus.Common
import XMonad.Internal.Notify
import XMonad.Internal.Shell as S
import XMonad.Operations

--------------------------------------------------------------------------------
-- My Executables

myTerm :: FilePath
myTerm = "alacritty"

myCalc :: FilePath
myCalc = "bc"

myBrowser :: FilePath
myBrowser = "brave"

myEditor :: FilePath
myEditor = "emacsclient"

myEditorServer :: FilePath
myEditorServer = "emacs"

myMultimediaCtl :: FilePath
myMultimediaCtl = "playerctl"

myBluetooth :: FilePath
myBluetooth = "bluetoothctl"

myCapture :: FilePath
myCapture = "flameshot"

myImageBrowser :: FilePath
myImageBrowser = "feh"

myNotificationCtrl :: FilePath
myNotificationCtrl = "dunstctl"

--------------------------------------------------------------------------------
-- Packages

myTermPkgs :: [Fulfillment]
myTermPkgs =
  [ Package Official "alacritty"
  ]

myEditorPkgs :: [Fulfillment]
myEditorPkgs = [Package Official "emacs-nativecomp"]

notifyPkgs :: [Fulfillment]
notifyPkgs = [Package Official "dunst"]

bluetoothPkgs :: [Fulfillment]
bluetoothPkgs = [Package Official "bluez-utils"]

networkManagerPkgs :: [Fulfillment]
networkManagerPkgs = [Package Official "networkmanager"]

--------------------------------------------------------------------------------
-- Misc constants

volumeChangeSound :: FilePath
volumeChangeSound = "smb_fireball.wav"

--------------------------------------------------------------------------------
-- Some nice apps

runTerm :: MonadUnliftIO m => Sometimes (m ())
runTerm = sometimesExe "terminal" "alacritty" myTermPkgs True myTerm

runTMux :: MonadUnliftIO m => Sometimes (m ())
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
  where
    deps =
      listToAnds (socketExists "tmux" [] socketName) $
        fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
    act =
      S.spawn $
        fmtCmd "tmux" ["has-session"]
          #!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
          #!|| fmtNotifyCmd defNoteError {body = Just $ Text msg}
    c = "exec tmux attach-session -d"
    msg = "could not connect to tmux session"
    socketName = do
      u <- liftIO getEffectiveUserID
      t <- getTemporaryDirectory
      return $ t </> "tmux-" ++ show u </> "default"

runCalc :: MonadUnliftIO m => Sometimes (m ())
runCalc = sometimesIO_ "calculator" "bc" deps act
  where
    deps = toAnd_ (sysExe myTermPkgs myTerm) (sysExe [Package Official "bc"] myCalc)
    act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"]

runBrowser :: MonadUnliftIO m => Sometimes (m ())
runBrowser =
  sometimesExe
    "web browser"
    "brave"
    [Package AUR "brave-bin"]
    False
    myBrowser

runEditor :: MonadUnliftIO m => Sometimes (m ())
runEditor = sometimesIO_ "text editor" "emacs" tree cmd
  where
    cmd =
      spawnCmd
        myEditor
        ["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
    -- NOTE 1: we could test if the emacs socket exists, but it won't come up
    -- before xmonad starts, so just check to see if the process has started
    tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] $ T.pack myEditorServer

runFileManager :: MonadUnliftIO m => Sometimes (m ())
runFileManager =
  sometimesExe
    "file browser"
    "pcmanfm"
    [Package Official "pcmanfm"]
    True
    "pcmanfm"

--------------------------------------------------------------------------------
-- Multimedia Commands

runMultimediaIfInstalled
  :: MonadUnliftIO m
  => T.Text
  -> T.Text
  -> Sometimes (m ())
runMultimediaIfInstalled n cmd =
  sometimesExeArgs
    (T.append n " multimedia control")
    "playerctl"
    [Package Official "playerctl"]
    True
    myMultimediaCtl
    [cmd]

runTogglePlay :: MonadUnliftIO m => Sometimes (m ())
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"

runPrevTrack :: MonadUnliftIO m => Sometimes (m ())
runPrevTrack = runMultimediaIfInstalled "previous track" "previous"

runNextTrack :: MonadUnliftIO m => Sometimes (m ())
runNextTrack = runMultimediaIfInstalled "next track" "next"

runStopPlay :: MonadUnliftIO m => Sometimes (m ())
runStopPlay = runMultimediaIfInstalled "stop playback" "stop"

--------------------------------------------------------------------------------
-- Volume Commands

soundDir :: FilePath
soundDir = "assets" </> "sound"

playSound :: MonadIO m => FilePath -> m ()
playSound file = do
  -- manually look up directories to avoid the X monad
  p <- io $ (</> soundDir </> file) . cfgDir <$> getDirectories
  -- paplay seems to have less latency than aplay
  spawnCmd "paplay" [T.pack p]

featureSound
  :: MonadUnliftIO m
  => T.Text
  -> FilePath
  -> m ()
  -> m ()
  -> Sometimes (m ())
featureSound n file pre post =
  sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree $
    pre >> playSound file >> post
  where
    -- ASSUME pulseaudio pulls in libpulse as a dep; pulseaudio itself is needed
    -- to play sound (duh) but libpulse is the package with the paplay binary
    tree = Only_ $ sysExe [Package Official "pulseaudio"] "paplay"

runVolumeDown :: MonadUnliftIO m => Sometimes (m ())
runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2)

runVolumeUp :: MonadUnliftIO m => Sometimes (m ())
runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2)

runVolumeMute :: MonadUnliftIO m => Sometimes (m ())
runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()

--------------------------------------------------------------------------------
-- Notification control

runNotificationCmd
  :: MonadUnliftIO m
  => T.Text
  -> T.Text
  -> Maybe NamedSesConnection
  -> Sometimes (m ())
runNotificationCmd n arg cl =
  sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
  where
    cmd _ = spawnCmd myNotificationCtrl [arg]
    tree =
      toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl) $
        Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0") $
          Method_ $
            memberName_ "NotificationAction"

runNotificationClose :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runNotificationClose = runNotificationCmd "close notification" "close"

runNotificationCloseAll :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runNotificationCloseAll =
  runNotificationCmd "close all notifications" "close-all"

runNotificationHistory :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runNotificationHistory =
  runNotificationCmd "see notification history" "history-pop"

runNotificationContext :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runNotificationContext =
  runNotificationCmd "open notification context" "context"

--------------------------------------------------------------------------------
-- System commands

-- this is required for some vpn's to work properly with network-manager
runNetAppDaemon :: Maybe NamedSysConnection -> Sometimes (XIO (P.Process () () ()))
runNetAppDaemon cl =
  Sometimes
    "network applet"
    xpfVPN
    [Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
  where
    tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
    app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
    cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)

runToggleBluetooth :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
runToggleBluetooth cl =
  Sometimes
    "bluetooth toggle"
    xpfBluetooth
    [Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
  where
    tree = And_ (Only_ $ DBusIO $ sysExe bluetoothPkgs myBluetooth) (Only_ $ Bus [] btBus)
    cmd _ =
      S.spawn $
        fmtCmd myBluetooth ["show"]
          #!| "grep -q \"Powered: no\""
          #!&& "a=on"
          #!|| "a=off"
          #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
          #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"}

runToggleEthernet :: MonadUnliftIO m => Sometimes (m ())
runToggleEthernet =
  Sometimes
    "ethernet toggle"
    xpfEthernet
    [Subfeature root "nmcli"]
  where
    root =
      IORoot cmd $
        And1 (Only readEthernet) $
          Only_ $
            sysExe networkManagerPkgs "nmcli"
    -- TODO make this less noisy
    cmd iface =
      S.spawn $
        fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface]
          #!| "grep -q disconnected"
          #!&& "a=connect"
          #!|| "a=disconnect"
          #!>> fmtCmd "nmcli" ["device", "$a", iface]
          #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "ethernet \"$a\"ed"}

--------------------------------------------------------------------------------
-- Configuration commands

runRestart :: X ()
runRestart = restart "xmonad" True

-- TODO use rio in here so I don't have to fill my xinit log with stack poop
-- TODO only recompile the VM binary if we have virtualbox enabled
runRecompile :: X ()
runRecompile = do
  -- assume that the conf directory contains a valid stack project
  confDir <- asks (cfgDir . directories)
  spawn $
    fmtCmd "cd" [T.pack confDir]
      #!&& fmtCmd "stack" ["install"]
      #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "compilation succeeded"}
      #!|| fmtNotifyCmd defNoteError {body = Just $ Text "compilation failed"}

--------------------------------------------------------------------------------
-- Screen capture commands

getCaptureDir :: MonadIO m => m FilePath
getCaptureDir = do
  e <- lookupEnv "XDG_DATA_HOME"
  parent <- case e of
    Nothing -> fallback
    Just path
      | isRelative path -> fallback
      | otherwise -> return path
  let fullpath = parent </> "screenshots"
  createDirectoryIfMissing True fullpath
  return fullpath
  where
    fallback = (</> ".local/share") <$> getHomeDirectory

runFlameshot
  :: MonadUnliftIO m
  => T.Text
  -> T.Text
  -> Maybe NamedSesConnection
  -> Sometimes (m ())
runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
  where
    cmd _ = spawnCmd myCapture [mode]
    tree =
      toAnd_ (DBusIO $ sysExe [Package Official "flameshot"] myCapture) $
        Bus [] $
          busName_ "org.flameshot.Flameshot"

-- TODO this will steal focus from the current window (and puts it
-- in the root window?) ...need to fix
runAreaCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runAreaCapture = runFlameshot "screen area capture" "gui"

-- myWindowCap = "screencap -w" --external script

runDesktopCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runDesktopCapture = runFlameshot "fullscreen capture" "full"

runScreenCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
runScreenCapture = runFlameshot "screen capture" "screen"

runCaptureBrowser :: MonadUnliftIO m => Sometimes (m ())
runCaptureBrowser = sometimesIO_
  "screen capture browser"
  "feh"
  (Only_ $ sysExe [Package Official "feh"] myImageBrowser)
  $ do
    dir <- getCaptureDir
    spawnCmd myImageBrowser [T.pack dir]