ADD acpi integration

This commit is contained in:
Nathan Dwarshuis 2020-03-13 20:50:13 -04:00
parent a6c4f84ed4
commit e3d9356b36
7 changed files with 188 additions and 67 deletions

42
bin/powermon.hs Normal file
View File

@ -0,0 +1,42 @@
{-# LANGUAGE OverloadedStrings #-}
import SendXMsg
import ACPI
import Control.Monad
import Data.ByteString
import Data.ByteString.Char8 as C
import Data.Connection
import System.IO.Streams.Internal as S (read)
import System.IO.Streams.UnixSocket
splitLine :: ByteString -> [ByteString]
splitLine = C.words . C.reverse . C.dropWhile (== '\n') . C.reverse
parseLine :: ByteString -> Maybe ACPIEvent
parseLine line =
-- TODO what if we don't have a list this long (we crash)
case (line' !! 1, line' !! 2) of
("PBTN", _) -> Just Power
("PWRF", _) -> Just Power
("SLPB", _) -> Just Sleep
("SBTN", _) -> Just Sleep
("LID", "close") -> Just LidClose
_ -> Nothing
where
line' = splitLine line
sendACPIEvent :: ACPIEvent -> IO ()
sendACPIEvent = sendXMsg acpiMagic . show
main :: IO ()
main = do
-- TODO barf when the socket doesn't exist
Connection { source = s } <- connect "/var/run/acpid.socket"
forever $ readStream s
where
readStream s = do
out <- (>>= parseLine) <$> S.read s
forM_ out sendACPIEvent

View File

@ -9,11 +9,7 @@
-- differentiate this event and the tag is meant to be a signal to be -- differentiate this event and the tag is meant to be a signal to be
-- read by xmonad. -- read by xmonad.
import Graphics.X11.Types import SendXMsg
import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Event
import Graphics.X11.Xlib.Extras
import System.Environment import System.Environment
import System.Exit import System.Exit
@ -22,31 +18,5 @@ main :: IO ()
main = getArgs >>= parse main = getArgs >>= parse
parse :: [String] -> IO () parse :: [String] -> IO ()
parse [magic, tag] = send magic tag >> exitSuccess parse [magic, tag] = sendXMsg magic tag >> exitSuccess
parse _ = exitFailure parse _ = exitFailure
send :: String -> String -> IO ()
send magic tag = do
dpy <- openDisplay ""
root <- rootWindow dpy $ defaultScreen dpy
allocaXEvent $ \e -> do
setEventType e clientMessage
-- NOTE: This function is written such that the penultimate
-- argument represents the first 40 bits of the 160 bit data
-- field, and it also only takes a decimal digit, which means the
-- string to be stored in the data field needs to be converted to
-- its decimal equivalent. The penultimate argument will be used
-- for the magic string and the last will be used for the tag.
setClientMessageEvent e root bITMAP 8 m t
sendEvent dpy root False substructureNotifyMask e
flush dpy
where
m = str2digit magic
t = str2digit tag
str2digit :: (Num a) => String -> a
str2digit = fromIntegral
. sum
. map (\(p, n) -> n * 256 ^ p)
. zip [0 :: Int ..]
. map fromEnum

1
lib/.gitignore vendored
View File

@ -1 +0,0 @@
# This file is included so that a `lib/` directory will be created.

36
lib/ACPI.hs Normal file
View File

@ -0,0 +1,36 @@
module ACPI (ACPIEvent(..), acpiMagic, isDischarging) where
import Control.Exception
import Text.Read
data ACPIEvent = Power | Sleep | LidClose deriving (Eq)
instance Show ACPIEvent where
show Power = "power"
show Sleep = "sleep"
-- show LidOpen = "olid"
show LidClose = "clid"
instance Read ACPIEvent where
readPrec = do
Ident s <- lexP
case s of
-- TODO this isn't DRY
"power" -> return Power
"sleep" -> return Sleep
"clid" -> return LidClose
_ -> pfail
-- TODO use a data type that enforces strings of max length 5
acpiMagic :: String
acpiMagic = "%acpi"
isDischarging :: IO (Maybe Bool)
isDischarging = do
status <- try $ readFile "/sys/class/power_supply/BAT0/status"
:: IO (Either IOException String)
case status of
Left e -> do
print e
return Nothing
Right s -> return $ Just (s == "Discharging")

40
lib/SendXMsg.hs Normal file
View File

@ -0,0 +1,40 @@
module SendXMsg (sendXMsg, splitXMsg) where
import Data.Char
import Graphics.X11.Types
import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Event
import Graphics.X11.Xlib.Extras
sendXMsg :: String -> String -> IO ()
sendXMsg magic tag = do
dpy <- openDisplay ""
root <- rootWindow dpy $ defaultScreen dpy
allocaXEvent $ \e -> do
setEventType e clientMessage
-- NOTE: This function is written such that the penultimate
-- argument represents the first 40 bits of the 160 bit data
-- field, and it also only takes a decimal digit, which means the
-- string to be stored in the data field needs to be converted to
-- its decimal equivalent. The penultimate argument will be used
-- for the magic string and the last will be used for the tag.
setClientMessageEvent e root bITMAP 8 m t
sendEvent dpy root False substructureNotifyMask e
flush dpy
where
m = str2digit magic
t = str2digit tag
splitXMsg :: (Integral a) => [a] -> (String, String)
splitXMsg s = (magic, filter isAlphaNum tag)
where
(magic, tag) = splitAt 5 $ map (chr . fromInteger . toInteger) s
str2digit :: (Num a) => String -> a
str2digit = fromIntegral
. sum
. map (\(p, n) -> n * 256 ^ p)
. zip [0 :: Int ..]
. map fromEnum

View File

@ -2,23 +2,41 @@ name: my-xmonad
version: 0.1.0.0 version: 0.1.0.0
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
library
hs-source-dirs: lib
exposed-modules: SendXMsg
, ACPI
build-depends: base
, X11 >= 1.9.1
ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded
executable xmonad executable xmonad
main-is: ../xmonad.hs main-is: ../xmonad.hs
other-modules: build-depends: base
build-depends: base , xmonad >= 0.13
, xmonad >= 0.13 , xmonad-contrib >= 0.13
, xmonad-contrib >= 0.13 , xmonad-extras >= 0.15.2
, xmonad-extras >= 0.15.2 , X11 >= 1.9.1
, X11 >= 1.9.1 , my-xmonad
hs-source-dirs: lib hs-source-dirs: bin
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded
executable xit-event executable xit-event
main-is: bin/xit-event.hs main-is: bin/xit-event.hs
other-modules: build-depends: base
build-depends: base , X11 >= 1.9.1
, X11 >= 1.9.1 , my-xmonad
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded
executable powermon
main-is: bin/powermon.hs
build-depends: base
, tcp-streams >= 1.0.1.1
, io-streams >= 1.5.1.0
, bytestring >= 0.10.8.2
, my-xmonad
default-language: Haskell2010
ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded

View File

@ -1,11 +1,16 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE LambdaCase #-}
module Main (main) where module Main (main) where
import Control.Monad (when, void) import ACPI
import SendXMsg
import Control.Monad (forM_, void, when)
import System.Exit import System.Exit
import System.IO import System.IO
import Data.Char
import Data.List (sortBy, sortOn) import Data.List (sortBy, sortOn)
import Data.Maybe (fromMaybe, isJust) import Data.Maybe (fromMaybe, isJust)
import Data.Monoid (All(..)) import Data.Monoid (All(..))
@ -14,6 +19,8 @@ import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib.Extras
import Graphics.X11.Types import Graphics.X11.Types
import Text.Read (readMaybe)
import XMonad import XMonad
import XMonad.Actions.CopyWindow import XMonad.Actions.CopyWindow
import XMonad.Actions.CycleWS import XMonad.Actions.CycleWS
@ -50,6 +57,7 @@ import qualified XMonad.StackSet as W
main = do main = do
h <- spawnPipe "xmobar" h <- spawnPipe "xmobar"
-- spawn "powermon"
xmonad xmonad
$ ewmh $ ewmh
$ addDescrKeys' ((myModMask, xK_F1), showKeybindings) myKeys $ addDescrKeys' ((myModMask, xK_F1), showKeybindings) myKeys
@ -192,16 +200,18 @@ myManageHook = composeOne
-- registered here, close the dynamic workspaces that are empty. -- registered here, close the dynamic workspaces that are empty.
myEventHook ClientMessageEvent { ev_message_type = t, ev_data = d } myEventHook ClientMessageEvent { ev_message_type = t, ev_data = d }
| t == bITMAP = do | t == bITMAP = do
let (magic, tag) = splitAt 5 $ map (chr . fromInteger . toInteger) d let (magic, tag) = splitXMsg d
io $ putStrLn magic if | magic == magicString -> removeEmptyWorkspaceByTag' tag
when (magic == magicString) $ do | magic == acpiMagic -> do
let tag' = filter isAlphaNum tag let acpiTag = readMaybe tag :: Maybe ACPIEvent
removeEmptyWorkspaceByTag' tag' io $ print acpiTag
-- let onscreen = (\w -> W.current w : W.visible w) W.workspaces windows forM_ acpiTag $ \case
-- io $ putStrLn (show tag') Power -> myPowerPrompt
-- -- TODO this actually won't remove an empty workspace if Sleep -> confirmPrompt myPromptTheme "suspend?" runSuspend
-- -- there are the same number of active workspaces as screens LidClose -> do
-- removeEmptyWorkspaceByTag tag' status <- io isDischarging
forM_ status $ \s -> runScreenLock >> when s runSuspend
| otherwise -> return ()
return (All True) return (All True)
| otherwise = return (All True) | otherwise = return (All True)
myEventHook _ = return (All True) myEventHook _ = return (All True)
@ -272,6 +282,12 @@ data PowerPrompt = PowerPrompt
instance XPrompt PowerPrompt where instance XPrompt PowerPrompt where
showXPrompt PowerPrompt = "Select Option: " showXPrompt PowerPrompt = "Select Option: "
runScreenLock = spawn myScreenLock
runPowerOff = spawn "systemctl poweroff"
runSuspend = spawn "systemctl suspend"
runHibernate = spawn "systemctl hibernate"
runReboot = spawn "systemctl reboot"
myPowerPrompt = mkXPrompt PowerPrompt conf comps myPowerPrompt = mkXPrompt PowerPrompt conf comps
$ fromMaybe (return ()) $ fromMaybe (return ())
. (`lookup` commands) . (`lookup` commands)
@ -279,10 +295,10 @@ myPowerPrompt = mkXPrompt PowerPrompt conf comps
comps = mkComplFunFromList' (map fst commands) comps = mkComplFunFromList' (map fst commands)
conf = myPromptTheme conf = myPromptTheme
commands = commands =
[ ("poweroff", spawn "systemctl poweroff") [ ("poweroff", runPowerOff)
, ("suspend", spawn myScreenLock >> spawn "systemctl suspend") , ("suspend", runScreenLock >> runSuspend)
, ("hibernate", spawn myScreenLock >> spawn "systemctl hibernate") , ("hibernate", runScreenLock >> runHibernate)
, ("reboot", spawn "systemctl reboot") , ("reboot", runReboot)
] ]
-- osd -- osd
@ -426,8 +442,8 @@ myKeys c =
, ("M-,", addName "backlight down" $ spawn "adj_backlight down") , ("M-,", addName "backlight down" $ spawn "adj_backlight down")
, ("M-M1-,", addName "backlight min" $ spawn "adj_backlight min") , ("M-M1-,", addName "backlight min" $ spawn "adj_backlight min")
, ("M-M1-.", addName "backlight max" $ spawn "adj_backlight max") , ("M-M1-.", addName "backlight max" $ spawn "adj_backlight max")
, ("M-<F2>", addName "restart xmonad" $ spawn "killall xmobar; xmonad --restart") , ("M-<F2>", addName "restart xmonad" $ spawn "killall xmobar; killall powermon; xmonad --restart")
, ("M-S-<F2>", addName "recompile xmonad" $ spawn "killall xmobar; xmonad --recompile && xmonad --restart") , ("M-S-<F2>", addName "recompile xmonad" $ spawn "killall xmobar; killall powermon; xmonad --recompile && xmonad --restart")
, ("M-<End>", addName "power menu" myPowerPrompt) , ("M-<End>", addName "power menu" myPowerPrompt)
, ("M-<Home>", addName "quit xmonad" $ , ("M-<Home>", addName "quit xmonad" $
confirmPrompt myPromptTheme "Quit XMonad?" $ io exitSuccess) confirmPrompt myPromptTheme "Quit XMonad?" $ io exitSuccess)