WIP add backlight to dbus

This commit is contained in:
Nathan Dwarshuis 2020-03-20 00:51:36 -04:00
parent 778dc38538
commit 673a7f5f07
6 changed files with 212 additions and 10 deletions

View File

@ -1,3 +1,4 @@
-- import Xmobar.Backlight
import Xmobar.Screensaver import Xmobar.Screensaver
import qualified Theme as T import qualified Theme as T
@ -25,6 +26,7 @@ myTemplate = formatTemplate left right
, "%alsa:default:Master%" , "%alsa:default:Master%"
, "%battery%" , "%battery%"
, "%bright%" , "%bright%"
-- , "%betterbacklight%"
, "%screensaver%" , "%screensaver%"
, "%locks%" , "%locks%"
, "%date%" , "%date%"
@ -52,8 +54,8 @@ blockFont = T.fmtFontXFT T.font
} }
config :: String -> Config config :: String -> Config
config confDir = defaultConfig { config confDir = defaultConfig
font = barFont { font = barFont
, additionalFonts = [ iconFont, blockFont ] , additionalFonts = [ iconFont, blockFont ]
, textOffset = 16 , textOffset = 16
, textOffsets = [ 16, 17 ] , textOffsets = [ 16, 17 ]
@ -103,6 +105,8 @@ config confDir = defaultConfig {
, "-D", "intel_backlight" , "-D", "intel_backlight"
] 10 ] 10
-- , Run $ Backlight ("", "")
, Run $ Wireless "wlp0s20f3" , Run $ Wireless "wlp0s20f3"
[ "-t", "<qualityipat><essid>" [ "-t", "<qualityipat><essid>"
, "--" , "--"

View File

@ -7,6 +7,10 @@ import ACPI
import SendXMsg import SendXMsg
import Notify import Notify
import Shell import Shell
import DBus.Client (Client)
import DBus.Common
import DBus.Backlight
import qualified Theme as T import qualified Theme as T
@ -75,11 +79,12 @@ import XMonad.Util.Run
import qualified XMonad.StackSet as W import qualified XMonad.StackSet as W
main = do main = do
dbClient <- startXMonadService
(barPID, h) <- spawnPipe' "xmobar" (barPID, h) <- spawnPipe' "xmobar"
pwrPID <- spawnPID "powermon" pwrPID <- spawnPID "powermon"
launch launch
$ ewmh $ ewmh
$ addDescrKeys' ((myModMask, xK_F1), showKeybindings) (myKeys [pwrPID, barPID]) $ addDescrKeys' ((myModMask, xK_F1), showKeybindings) (myKeys [pwrPID, barPID] dbClient)
$ def { terminal = myTerm $ def { terminal = myTerm
, modMask = myModMask , modMask = myModMask
, layoutHook = myLayouts , layoutHook = myLayouts
@ -436,8 +441,10 @@ runVBox = spawnCmdOwnWS "vbox-start win8raw" [] myVMWorkspace
runGimp :: X () runGimp :: X ()
runGimp = spawnCmdOwnWS "gimp" [] myGimpWorkspace runGimp = spawnCmdOwnWS "gimp" [] myGimpWorkspace
runCleanup :: [ProcessID] -> X () runCleanup :: [ProcessID] -> Client -> X ()
runCleanup ps = io $ mapM_ killPID ps runCleanup ps client = io $ do
mapM_ killPID ps
stopXMonadService client
killPID :: ProcessID -> IO () killPID :: ProcessID -> IO ()
killPID pID = do killPID pID = do
@ -509,10 +516,10 @@ runDecBacklight :: X ()
runDecBacklight = spawnCmd "adj_backlight" ["down"] runDecBacklight = spawnCmd "adj_backlight" ["down"]
runMinBacklight :: X () runMinBacklight :: X ()
runMinBacklight = spawnCmd "adj_backlight" ["min"] runMinBacklight = io callMinBrightness
runMaxBacklight :: X () runMaxBacklight :: X ()
runMaxBacklight = spawnCmd "adj_backlight" ["max"] runMaxBacklight = io callMaxBrightness
showWorkspace tag = windows $ W.view tag showWorkspace tag = windows $ W.view tag
@ -557,8 +564,8 @@ mkNamedSubmap c sectionName bindings =
-- NOTE: the following bindings are used by dunst: -- NOTE: the following bindings are used by dunst:
-- "M-~", "M-<esc>", "M-S-<esc>", "M-S-." -- "M-~", "M-<esc>", "M-S-<esc>", "M-S-."
myKeys :: [ProcessID] -> XConfig Layout -> [((KeyMask, KeySym), NamedAction)] myKeys :: [ProcessID] -> Client -> XConfig Layout -> [((KeyMask, KeySym), NamedAction)]
myKeys hs c = myKeys hs client c =
mkNamedSubmap c "Window Layouts" mkNamedSubmap c "Window Layouts"
[ ("M-j", addName "focus down" $ windows W.focusDown) [ ("M-j", addName "focus down" $ windows W.focusDown)
, ("M-k", addName "focus up" $ windows W.focusUp) , ("M-k", addName "focus up" $ windows W.focusUp)
@ -640,7 +647,7 @@ myKeys hs c =
, ("M-M1-.", addName "backlight max" runMaxBacklight) , ("M-M1-.", addName "backlight max" runMaxBacklight)
, ("M-M1-=", addName "enable screensaver" enableDPMS) , ("M-M1-=", addName "enable screensaver" enableDPMS)
, ("M-M1--", addName "disable screensaver" disableDPMS) , ("M-M1--", addName "disable screensaver" disableDPMS)
, ("M-<F2>", addName "restart xmonad" $ runCleanup hs >> runRestart) , ("M-<F2>", addName "restart xmonad" $ runCleanup hs client >> runRestart)
, ("M-S-<F2>", addName "recompile xmonad" runRecompile) , ("M-S-<F2>", addName "recompile xmonad" runRecompile)
, ("M-<End>", addName "power menu" myPowerPrompt) , ("M-<End>", addName "power menu" myPowerPrompt)
, ("M-<Home>", addName "quit xmonad" myQuitPrompt) , ("M-<Home>", addName "quit xmonad" myQuitPrompt)

111
lib/DBus/Backlight.hs Normal file
View File

@ -0,0 +1,111 @@
{-# LANGUAGE OverloadedStrings #-}
module DBus.Backlight where
-- import Control.Monad
import Data.Char
import Data.Int (Int32)
-- use strict IO here, the data in these files is literally 1-10 bytes
import Data.Text (pack, unpack)
import Data.Text.IO as T (readFile, writeFile)
import DBus
import DBus.Client
brightnessDir :: FilePath
brightnessDir = "/sys/class/backlight/intel_backlight/"
maxFile :: String
maxFile = brightnessDir ++ "max_brightness"
curFile :: String
curFile = brightnessDir ++ "brightness"
steps :: Int
steps = 15
readFileInt :: FilePath -> IO Int
readFileInt file = do
contents <- T.readFile file
return $ read $ takeWhile isDigit $ unpack contents
getMaxValue :: IO Int
getMaxValue = readFileInt maxFile
getCurValue :: IO Int
getCurValue = readFileInt curFile
getStepSize :: IO Int
getStepSize = getMaxValue >>= (\x -> return $ x `div` steps)
setCurValue :: Int -> IO ()
setCurValue = T.writeFile curFile . pack . show
truncateValue :: Int -> Int -> Int
truncateValue maxval = min maxval . max 1
changeBrightness :: Int -> Int -> IO ()
changeBrightness maxval delta = getCurValue
>>= setCurValue . truncateValue maxval . (+ delta)
setBrightness :: Int -> IO ()
setBrightness = setCurValue
exportBrightness :: Client -> IO ()
exportBrightness client = do
maxval <- getMaxValue
stepsize <- getStepSize
export client "/brightness" defaultInterface
{ interfaceName = "org.xmonad.Brightness"
, interfaceMethods =
[ autoMethod "MaxBrightness" (setBrightness maxval)
, autoMethod "MinBrightness" (setBrightness 1)
, autoMethod "IncBrightness" (changeBrightness maxval stepsize)
, autoMethod "DecBrightness" (changeBrightness maxval (-stepsize))
]
}
brPath :: ObjectPath
brPath = "/brightness"
brInterface :: InterfaceName
brInterface = "org.xmonad.Brightness"
brSignal :: Signal
brSignal = (signal brPath brInterface "CurrentBrightness")
-- { signalDestination = Just "org.xmonad" }
brMatcher :: MatchRule
brMatcher = matchAny
{
-- matchSender = Just "org.xmonad"
-- , matchDestination = Just "org.xmonad"
-- matchPath = Just brPath
-- , matchInterface = Just brInterface
matchMember = Just "CurrentBrightness"
}
callMaxBrightness :: IO ()
callMaxBrightness = do
client <- connectSession
_ <- call client (methodCall "/brightness" "org.xmonad.Brightness" "MaxBrightness")
{ methodCallDestination = Just "org.xmonad" }
emit client =<< wrapSig <$> getCurValue
-- print reply
where
wrapSig i = brSignal
{ signalBody = [toVariant (fromIntegral i :: Int32)] }
callMinBrightness :: IO ()
callMinBrightness = do
client <- connectSession
_ <- call client (methodCall "/brightness" "org.xmonad.Brightness" "MinBrightness")
{ methodCallDestination = Just "org.xmonad" }
emit client =<< wrapSig <$> getCurValue
-- print reply
where
wrapSig i = brSignal
{ signalBody = [toVariant (fromIntegral i :: Int32)] }

39
lib/DBus/Common.hs Normal file
View File

@ -0,0 +1,39 @@
{-# LANGUAGE OverloadedStrings #-}
module DBus.Common where
-- import Control.Concurrent
-- import Control.Monad
import DBus.Backlight
-- import DBus
import DBus.Client
onFoo :: IO String
onFoo = return "testicle"
startXMonadService :: IO Client
startXMonadService = do
client <- connectSession
requestResult <- requestName client "org.xmonad" []
-- TODO if the client is not released on shutdown the owner will be
-- different
if requestResult /= NamePrimaryOwner then
putStrLn "Another service owns \"org.xmonad\""
else do
putStrLn "Started xmonad dbus client"
exportBrightness client
export client "/test" defaultInterface
{ interfaceName = "test.iface"
, interfaceMethods = [ autoMethod "foo" onFoo ]
}
return client
stopXMonadService :: Client -> IO ()
stopXMonadService client = do
reply <- releaseName client "org.xmonad"
disconnect client
print reply
return ()

34
lib/Xmobar/Backlight.hs Normal file
View File

@ -0,0 +1,34 @@
module Xmobar.Backlight where
import Control.Monad
import Control.Concurrent
import Data.Int (Int32)
import DBus
import DBus.Client
import DBus.Backlight
import Xmobar
data Backlight = Backlight (String, String)
deriving (Read, Show)
instance Exec Backlight where
alias (Backlight _) = "betterbacklight"
start (Backlight _) cb = do
-- print "connecting"
client <- connectSession
_ <- addMatch client brMatcher $ \sig -> do
cb $ formatSignal sig
-- print sig
forever (threadDelay 5000)
formatSignal :: Signal -> String
formatSignal sig = -- show $ (map fromVariant $ signalBody sig :: [Maybe Int32])
case signalBody sig of
[] -> "N/A"
(x:_) -> case (fromVariant x :: Maybe Int32) of
Just i -> show i
Nothing -> "n/a"

View File

@ -10,13 +10,18 @@ library
, Theme , Theme
, Notify , Notify
, Shell , Shell
, DBus.Common
, DBus.Backlight
, Xmobar.Screensaver , Xmobar.Screensaver
, Xmobar.Backlight
build-depends: base build-depends: base
, X11 >= 1.9.1 , X11 >= 1.9.1
, colour >= 2.3.5 , colour >= 2.3.5
, xmonad >= 0.13 , xmonad >= 0.13
, xmonad-contrib >= 0.13 , xmonad-contrib >= 0.13
, fdo-notify , fdo-notify
, dbus >= 1.2.7
, text >= 1.2.3.1
, xmobar , xmobar
ghc-options: -Wall -Werror -fno-warn-missing-signatures ghc-options: -Wall -Werror -fno-warn-missing-signatures
default-language: Haskell2010 default-language: Haskell2010
@ -32,6 +37,7 @@ executable xmonad
, process >= 1.6.5.0 , process >= 1.6.5.0
, directory >= 1.3.3.0 , directory >= 1.3.3.0
, containers >= 0.6.0.1 , containers >= 0.6.0.1
, dbus >= 1.2.7
, my-xmonad , 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
@ -40,6 +46,7 @@ executable xmobar
main-is: bin/xmobar.hs main-is: bin/xmobar.hs
build-depends: base build-depends: base
, xmonad >= 0.13 , xmonad >= 0.13
, dbus >= 1.2.7
, xmobar , xmobar
, my-xmonad , my-xmonad
default-language: Haskell2010 default-language: Haskell2010