ADD acpi integration

bin/powermon.hs

@@ -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

bin/xit-event.hs

@@ -9,11 +9,7 @@
 -- differentiate this event and the tag is meant to be a signal to be
 -- read by xmonad.
 
-import Graphics.X11.Types
-import Graphics.X11.Xlib.Atom
-import Graphics.X11.Xlib.Display
-import Graphics.X11.Xlib.Event
-import Graphics.X11.Xlib.Extras
+import SendXMsg
 
 import System.Environment
 import System.Exit
@@ -22,31 +18,5 @@ main :: IO ()
 main = getArgs >>= parse
 
 parse :: [String] -> IO ()
-parse [magic, tag] = send magic tag >> exitSuccess
+parse [magic, tag] = sendXMsg magic tag >> exitSuccess
 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

lib/.gitignore

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

lib/ACPI.hs

@@ -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")

lib/SendXMsg.hs

@@ -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

my-xmonad.cabal

@@ -2,23 +2,41 @@ name:                my-xmonad
 version:             0.1.0.0
 build-type:          Simple
 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
-  main-is:             ../xmonad.hs
-  other-modules:
-  build-depends:       base
-                     , xmonad >= 0.13
-                     , xmonad-contrib >= 0.13
-                     , xmonad-extras >= 0.15.2
-                     , X11 >= 1.9.1
-  hs-source-dirs:      lib
-  default-language:    Haskell2010
-  ghc-options:         -Wall -Werror -fno-warn-missing-signatures -threaded
+    main-is: ../xmonad.hs
+    build-depends: base
+                 , xmonad >= 0.13
+                 , xmonad-contrib >= 0.13
+                 , xmonad-extras >= 0.15.2
+                 , X11 >= 1.9.1
+                 , my-xmonad
+    hs-source-dirs: bin
+    default-language: Haskell2010
+    ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded
 
 executable xit-event
-  main-is:             bin/xit-event.hs
-  other-modules:
-  build-depends:       base
-                     , X11 >= 1.9.1
-  default-language:    Haskell2010
-  ghc-options:         -Wall -Werror -fno-warn-missing-signatures -threaded
+    main-is: bin/xit-event.hs
+    build-depends: base
+                 , X11 >= 1.9.1
+                 , my-xmonad
+    default-language: Haskell2010
+    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

xmonad.hs

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