400 lines
12 KiB
Haskell
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]
|