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

400 lines
12 KiB
Haskell

--------------------------------------------------------------------------------
-- 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 = "urxvt"
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 "rxvt-unicode"
, Package Official "urxvt-perls"
]
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" "urxvt" 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 = "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 SesClient
-> 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 SesClient -> Sometimes (m ())
runNotificationClose = runNotificationCmd "close notification" "close"
runNotificationCloseAll :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runNotificationCloseAll =
runNotificationCmd "close all notifications" "close-all"
runNotificationHistory :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runNotificationHistory =
runNotificationCmd "see notification history" "history-pop"
runNotificationContext :: MonadUnliftIO m => Maybe SesClient -> 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 SysClient -> 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 SysClient -> 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 SesClient
-> 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 SesClient -> Sometimes (m ())
runAreaCapture = runFlameshot "screen area capture" "gui"
-- myWindowCap = "screencap -w" --external script
runDesktopCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runDesktopCapture = runFlameshot "fullscreen capture" "full"
runScreenCapture :: MonadUnliftIO m => Maybe SesClient -> 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]