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
  , runStartISyncTimer
  , runStartISyncService
  , runNotificationClose
  , runNotificationCloseAll
  , runNotificationHistory
  , runNotificationContext

  -- daemons
  , runNetAppDaemon
  ) where

import           Control.Monad               (void)
import           Control.Monad.IO.Class

import           DBus
import           DBus.Client

import           System.Directory
import           System.Environment
import           System.FilePath
import           System.Posix.User

import           XMonad                      (asks)
import           XMonad.Actions.Volume
import           XMonad.Core                 hiding (spawn)
import           XMonad.Internal.DBus.Common
import           XMonad.Internal.Dependency
import           XMonad.Internal.Notify
import           XMonad.Internal.Process
import           XMonad.Internal.Shell
import           XMonad.Operations

--------------------------------------------------------------------------------
-- | My Executables

myTerm :: String
myTerm = "urxvt"

myBrowser :: String
myBrowser = "brave-accel"

myEditor :: String
myEditor = "emacsclient"

myEditorServer :: String
myEditorServer = "emacs"

myMultimediaCtl :: String
myMultimediaCtl = "playerctl"

myBluetooth :: String
myBluetooth = "bluetoothctl"

myCapture :: String
myCapture = "flameshot"

myImageBrowser :: String
myImageBrowser = "feh"

myNotificationCtrl :: String
myNotificationCtrl = "dunstctl"

--------------------------------------------------------------------------------
-- | Misc constants

volumeChangeSound :: FilePath
volumeChangeSound = "smb_fireball.wav"

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

runTerm :: SometimesX
runTerm = sometimesExe "terminal" "urxvt" True myTerm

runTMux :: SometimesX
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
  where
    deps = listToAnds (socketExists "tmux" socketName)
      $ fmap sysExe [myTerm, "tmux", "bash"]
    act = spawn
      $ "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 <- getEffectiveUserID
      t <- getTemporaryDirectory
      return $ t </> "tmux-" ++ show u </> "default"

runCalc :: SometimesX
runCalc = sometimesIO_ "calculator" "R" deps act
  where
    deps = toAnd_ (sysExe myTerm) (sysExe "R")
    act = spawnCmd myTerm ["-e", "R"]

runBrowser :: SometimesX
runBrowser = sometimesExe "web browser" "brave" False myBrowser

runEditor :: SometimesX
runEditor = sometimesIO_ "text editor" "emacs" tree cmd
  where
    cmd = spawnCmd myEditor
      ["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
    -- NOTE 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 myEditor) $ process myEditorServer

runFileManager :: SometimesX
runFileManager = sometimesExe "file browser" "pcmanfm" True "pcmanfm"

--------------------------------------------------------------------------------
-- | Multimedia Commands

runMultimediaIfInstalled :: String -> String -> SometimesX
runMultimediaIfInstalled n cmd = sometimesExeArgs (n ++ " multimedia control")
  "playerctl" True myMultimediaCtl [cmd]

runTogglePlay :: SometimesX
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"

runPrevTrack :: SometimesX
runPrevTrack = runMultimediaIfInstalled "previous track" "previous"

runNextTrack :: SometimesX
runNextTrack = runMultimediaIfInstalled "next track" "next"

runStopPlay :: SometimesX
runStopPlay = runMultimediaIfInstalled "stop playback" "stop"

--------------------------------------------------------------------------------
-- | Volume Commands

soundDir :: FilePath
soundDir = "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" [p]

featureSound :: String -> FilePath -> X () -> X () -> SometimesX
featureSound n file pre post =
  sometimesIO_ ("volume " ++ n ++ " control") "paplay" (Only_ $ sysExe "paplay")
  $ pre >> playSound file >> post

runVolumeDown :: SometimesX
runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2)

runVolumeUp :: SometimesX
runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2)

runVolumeMute :: SometimesX
runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()

--------------------------------------------------------------------------------
-- | Notification control

runNotificationCmd :: String -> FilePath -> Maybe Client -> SometimesX
runNotificationCmd n arg cl =
  sometimesDBus cl (n ++ " control") "dunstctl" tree cmd
  where
    cmd _ = spawnCmd myNotificationCtrl [arg]
    tree = toAnd_ (DBusIO $ sysExe myNotificationCtrl)
      $ Endpoint notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0")
      $ Method_ $ memberName_ "NotificationAction"

runNotificationClose :: Maybe Client -> SometimesX
runNotificationClose = runNotificationCmd "close notification" "close"

runNotificationCloseAll :: Maybe Client -> SometimesX
runNotificationCloseAll =
  runNotificationCmd "close all notifications" "close-all"

runNotificationHistory :: Maybe Client -> SometimesX
runNotificationHistory =
  runNotificationCmd "see notification history" "history-pop"

runNotificationContext :: Maybe Client -> SometimesX
runNotificationContext =
  runNotificationCmd "open notification context" "context"

--------------------------------------------------------------------------------
-- | System commands

-- this is required for some vpn's to work properly with network-manager
runNetAppDaemon :: Maybe Client -> Sometimes (IO ProcessHandle)
runNetAppDaemon cl = Sometimes "network applet" xpfVPN
  [Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
  where
    tree = toAnd_ (DBusIO $ localExe "nm-applet") $ Bus networkManagerBus
    cmd _ = snd <$> spawnPipe "nm-applet"

runToggleBluetooth :: Maybe Client -> SometimesX
runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
  [Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
  where
    tree = And_ (Only_ $ DBusIO $ sysExe myBluetooth) (Only_ $ Bus btBus)
    cmd _ = spawn
      $ 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 :: SometimesX
runToggleEthernet = sometimes1 "ethernet toggle" "nmcli" $ IORoot (spawn . cmd) $
  And1 (Only readEthernet) (Only_ $ sysExe "nmcli")
  where
    -- TODO make this less noisy
    cmd iface =
      "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"  }

runStartISyncTimer :: SometimesX
runStartISyncTimer = sometimesIO_ "isync timer" "mbsync timer"
  (Only_ $ sysdUser "mbsync.timer")
  $ spawn
  $ "systemctl --user start mbsync.timer"
  #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync timer started"  }
  #!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" }

runStartISyncService :: SometimesX
runStartISyncService = sometimesIO_ "isync" "mbsync service"
  (Only_ $ sysdUser "mbsync.service")
  $ spawn
  $ "systemctl --user start mbsync.service"
  #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" }
  #!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync failed" }

--------------------------------------------------------------------------------
-- | Configuration commands

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

runRecompile :: X ()
runRecompile = do
  -- assume that the conf directory contains a valid stack project
  confDir <- asks (cfgDir . directories)
  spawnAt confDir $ fmtCmd "stack" ["install"]
    #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "compilation succeeded" }
    #!|| fmtNotifyCmd defNoteError { body = Just $ Text "compilation failed" }

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

getCaptureDir :: IO 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 :: String -> String -> Maybe Client -> SometimesX
runFlameshot n mode cl = sometimesDBus cl n myCapture tree cmd
  where
    cmd _ = spawnCmd myCapture [mode]
    tree = toAnd_ (DBusIO $ sysExe 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 :: Maybe Client -> SometimesX
runAreaCapture = runFlameshot "screen area capture" "gui"

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

runDesktopCapture :: Maybe Client -> SometimesX
runDesktopCapture = runFlameshot "fullscreen capture" "full"

runScreenCapture :: Maybe Client -> SometimesX
runScreenCapture = runFlameshot "screen capture" "screen"

runCaptureBrowser :: SometimesX
runCaptureBrowser = sometimesIO_ "screen capture browser" "feh"
  (Only_ $ sysExe myImageBrowser) $ do
  dir <- io getCaptureDir
  spawnCmd myImageBrowser [dir]