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

235 lines
6.8 KiB
Haskell
Raw Permalink Normal View History

2020-04-01 20:17:47 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Commands for controlling power
2020-04-01 20:17:47 -04:00
module XMonad.Internal.Command.Power
2022-12-30 14:58:23 -05:00
-- commands
2020-03-28 18:38:38 -04:00
( runHibernate
, runOptimusPrompt
, runPowerOff
, runPowerPrompt
, runReboot
, runScreenLock
, runSuspend
, runSuspendPrompt
, runQuitPrompt
2022-07-03 01:11:32 -04:00
-- daemons
, runAutolock
-- functions
, hasBattery
2022-07-02 17:09:21 -04:00
, suspendPrompt
, quitPrompt
, powerPrompt
, defFontPkgs
, promptFontDep
2022-12-30 14:58:23 -05:00
)
where
2023-01-01 18:33:02 -05:00
import Data.Internal.XIO
2022-12-30 14:58:23 -05:00
import Graphics.X11.Types
import RIO
2022-12-31 19:47:02 -05:00
import RIO.Directory
2022-12-30 14:58:23 -05:00
import RIO.FilePath
2022-12-31 19:16:44 -05:00
import qualified RIO.Map as M
2022-12-30 14:58:23 -05:00
import qualified RIO.Process as P
import qualified RIO.Text as T
import XMonad.Core hiding (spawn)
import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as XT
import XMonad.Prompt
import XMonad.Prompt.ConfirmPrompt
2020-03-28 18:38:38 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Executables
myScreenlock :: FilePath
myScreenlock = "screenlock"
myOptimusManager :: FilePath
myOptimusManager = "optimus-manager"
myPrimeOffload :: FilePath
2022-07-02 17:09:21 -04:00
myPrimeOffload = "prime-offload"
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Packages
optimusPackages :: [Fulfillment]
optimusPackages = [Package AUR "optimus-manager"]
2020-03-28 18:38:38 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Core commands
2020-03-28 18:38:38 -04:00
runScreenLock :: SometimesX
2022-12-30 14:58:23 -05:00
runScreenLock =
sometimesExe
"screen locker"
"i3lock script"
[Package AUR "i3lock-color"]
False
myScreenlock
2020-03-28 18:38:38 -04:00
2023-01-02 19:48:48 -05:00
runPowerOff :: MonadUnliftIO m => m ()
2020-03-28 18:38:38 -04:00
runPowerOff = spawn "systemctl poweroff"
2023-01-02 19:48:48 -05:00
runSuspend :: MonadUnliftIO m => m ()
2020-03-28 18:38:38 -04:00
runSuspend = spawn "systemctl suspend"
2023-01-02 19:48:48 -05:00
runHibernate :: MonadUnliftIO m => m ()
2020-03-28 18:38:38 -04:00
runHibernate = spawn "systemctl hibernate"
2023-01-02 19:48:48 -05:00
runReboot :: MonadUnliftIO m => m ()
2020-03-28 18:38:38 -04:00
runReboot = spawn "systemctl reboot"
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Autolock
2022-07-03 01:11:32 -04:00
2023-01-01 15:00:40 -05:00
runAutolock :: Sometimes (XIO (P.Process () () ()))
2022-07-03 01:11:32 -04:00
runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
where
2022-12-30 14:58:23 -05:00
tree =
And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") $
Only_ $
IOSometimes_ runScreenLock
2023-01-17 22:46:22 -05:00
cmd = P.proc "xss-lock" args (P.startProcess . P.setCreateGroup True)
args = ["--ignore-sleep", "--", "screenlock", "true"]
2022-07-03 01:11:32 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Confirmation prompts
2022-07-02 17:09:21 -04:00
promptFontDep :: IOTree XT.FontBuilder
promptFontDep = fontTreeAlt XT.defFontFamily defFontPkgs
defFontPkgs :: [Fulfillment]
defFontPkgs = [Package Official "ttf-dejavu"]
confirmPrompt' :: T.Text -> X () -> XT.FontBuilder -> X ()
confirmPrompt' s x fb = confirmPrompt (XT.promptTheme fb) (T.unpack s) x
2022-07-02 17:09:21 -04:00
suspendPrompt :: XT.FontBuilder -> X ()
2023-01-02 19:48:48 -05:00
suspendPrompt = confirmPrompt' "suspend?" $ liftIO runSuspend
2022-07-02 17:09:21 -04:00
quitPrompt :: XT.FontBuilder -> X ()
2022-07-02 17:09:21 -04:00
quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
sometimesPrompt :: T.Text -> (XT.FontBuilder -> X ()) -> SometimesX
sometimesPrompt n = sometimesIO n (T.append n " command") promptFontDep
2020-03-28 18:38:38 -04:00
2021-11-20 01:15:04 -05:00
-- TODO doesn't this need to also lock the screen?
2022-07-02 17:09:21 -04:00
runSuspendPrompt :: SometimesX
runSuspendPrompt = sometimesPrompt "suspend prompt" suspendPrompt
2020-03-28 18:38:38 -04:00
2022-07-02 17:09:21 -04:00
runQuitPrompt :: SometimesX
runQuitPrompt = sometimesPrompt "quit prompt" quitPrompt
2020-03-28 18:38:38 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Nvidia Optimus
2020-03-28 18:38:38 -04:00
-- TODO for some reason the screen never wakes up after suspend when
-- the nvidia card is up, so block suspend if nvidia card is running
-- and warn user
2022-12-31 19:16:44 -05:00
isUsingNvidia :: MonadUnliftIO m => m Bool
2020-03-28 18:38:38 -04:00
isUsingNvidia = doesDirectoryExist "/sys/module/nvidia"
2022-12-31 19:16:44 -05:00
hasBattery :: MonadUnliftIO m => m (Maybe T.Text)
hasBattery = do
2022-12-31 19:16:44 -05:00
ps <- fromRight [] <$> tryIO (listDirectory syspath)
ts <- catMaybes <$> mapM readType ps
return $
if any (T.isPrefixOf "Battery") ts
then Nothing
else Just "battery not found"
where
2022-12-31 19:16:44 -05:00
readType p = either (const Nothing) Just <$> tryIO (readFileUtf8 $ syspath </> p </> "type")
syspath = "/sys/class/power_supply"
runOptimusPrompt' :: XT.FontBuilder -> X ()
2022-07-02 17:09:21 -04:00
runOptimusPrompt' fb = do
2020-03-28 18:38:38 -04:00
nvidiaOn <- io isUsingNvidia
switch $ if nvidiaOn then "integrated" else "nvidia"
2020-03-28 18:38:38 -04:00
where
2022-07-02 17:09:21 -04:00
switch mode = confirmPrompt' (prompt mode) (cmd mode) fb
prompt mode = T.concat ["gpu switch to ", mode, "?"]
2022-12-30 14:58:23 -05:00
cmd mode =
spawn $
T.pack myPrimeOffload
#!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"]
#!&& "killall xmonad"
2020-03-28 18:38:38 -04:00
runOptimusPrompt :: SometimesX
2022-12-30 14:58:23 -05:00
runOptimusPrompt =
Sometimes
"graphics switcher"
(\x -> xpfOptimus x && xpfBattery x)
[s]
2022-07-02 17:09:21 -04:00
where
2022-12-30 14:58:23 -05:00
s = Subfeature {sfData = r, sfName = "optimus manager"}
2022-07-02 17:09:21 -04:00
r = IORoot runOptimusPrompt' t
2022-12-30 14:58:23 -05:00
t =
And1 promptFontDep $
listToAnds (socketExists "optimus-manager" [] socketName) $
sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload]
socketName = (</> "optimus-manager") <$> getTemporaryDirectory
2020-03-28 18:38:38 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Universal power prompt
2020-03-28 18:38:38 -04:00
2022-12-30 14:58:23 -05:00
data PowerMaybeAction
= Poweroff
| Shutdown
| Hibernate
| Reboot
deriving (Eq)
2020-03-28 18:38:38 -04:00
2023-02-12 23:08:05 -05:00
fromPMA :: PowerMaybeAction -> Int
fromPMA a = case a of
Poweroff -> 0
Shutdown -> 1
Hibernate -> 2
Reboot -> 3
toPMA :: Int -> Maybe PowerMaybeAction
toPMA x = case x of
0 -> Just Poweroff
1 -> Just Shutdown
2 -> Just Hibernate
3 -> Just Reboot
_ -> Nothing
2020-03-28 18:38:38 -04:00
data PowerPrompt = PowerPrompt
instance XPrompt PowerPrompt where
2022-12-30 14:58:23 -05:00
showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
2020-03-28 18:38:38 -04:00
2022-07-03 18:23:32 -04:00
runPowerPrompt :: SometimesX
runPowerPrompt = Sometimes "power prompt" (const True) [sf]
where
sf = Subfeature withLock "prompt with lock"
2022-07-02 17:09:21 -04:00
withLock = IORoot (uncurry powerPrompt) tree
tree = And12 (,) lockTree promptFontDep
2022-07-03 18:23:32 -04:00
lockTree = Or (Only $ IOSometimes runScreenLock id) (Only $ IOConst skip)
powerPrompt :: X () -> XT.FontBuilder -> X ()
2022-07-02 17:09:21 -04:00
powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
2020-03-28 18:38:38 -04:00
where
2022-03-05 18:18:16 -05:00
comp = mkComplFunFromList theme []
2022-12-30 14:58:23 -05:00
theme = (XT.promptTheme fb) {promptKeymap = keymap}
keymap =
M.fromList $
((controlMask, xK_g), quit)
: map
(first $ (,) 0)
[ (xK_p, sendMaybeAction Poweroff)
, (xK_s, sendMaybeAction Shutdown)
, (xK_h, sendMaybeAction Hibernate)
, (xK_r, sendMaybeAction Reboot)
, (xK_Return, quit)
, (xK_Escape, quit)
]
2023-02-12 23:08:05 -05:00
sendMaybeAction a = setInput (show $ fromPMA a) >> setSuccess True >> setDone True
executeMaybeAction a = case toPMA =<< readMaybe a of
Just Poweroff -> liftIO runPowerOff
Just Shutdown -> lock >> liftIO runSuspend
Just Hibernate -> lock >> liftIO runHibernate
Just Reboot -> liftIO runReboot
-- TODO log an error here since this should never happen
Nothing -> skip