REF move dependency interface to own module/pull common code from intelbacklight
This commit is contained in:
parent
53279475f4
commit
76c0eb3386
|
|
@ -21,7 +21,9 @@ import System.Directory
|
|||
import System.Exit
|
||||
import System.IO
|
||||
import System.IO.Error
|
||||
import System.Process (readProcessWithExitCode)
|
||||
import System.Process
|
||||
( readProcessWithExitCode
|
||||
)
|
||||
|
||||
import Xmobar.Plugins.Bluetooth
|
||||
import Xmobar.Plugins.ClevoKeyboard
|
||||
|
|
@ -30,15 +32,18 @@ import Xmobar.Plugins.IntelBacklight
|
|||
import Xmobar.Plugins.Screensaver
|
||||
import Xmobar.Plugins.VPN
|
||||
|
||||
import XMonad (getXMonadDir)
|
||||
import XMonad.Hooks.DynamicLog (wrap, xmobarColor)
|
||||
import XMonad.Internal.Command.Power (hasBattery)
|
||||
import XMonad.Internal.DBus.Common (xmonadBus)
|
||||
import XMonad.Internal.DBus.Control (pathExists)
|
||||
import XMonad.Internal.DBus.IntelBacklight (blPath)
|
||||
import XMonad.Internal.DBus.Screensaver (ssPath)
|
||||
import XMonad.Internal.Shell (fmtCmd)
|
||||
import qualified XMonad.Internal.Theme as T
|
||||
import XMonad (getXMonadDir)
|
||||
import XMonad.Hooks.DynamicLog
|
||||
( wrap
|
||||
, xmobarColor
|
||||
)
|
||||
import XMonad.Internal.Command.Power (hasBattery)
|
||||
import XMonad.Internal.DBus.Brightness.IntelBacklight (blPath)
|
||||
import XMonad.Internal.DBus.Common (xmonadBus)
|
||||
import XMonad.Internal.DBus.Control (pathExists)
|
||||
import XMonad.Internal.DBus.Screensaver (ssPath)
|
||||
import XMonad.Internal.Shell (fmtCmd)
|
||||
import qualified XMonad.Internal.Theme as T
|
||||
import Xmobar
|
||||
|
||||
main :: IO ()
|
||||
|
|
|
|||
|
|
@ -44,9 +44,10 @@ import XMonad.Internal.Concurrent.ACPIEvent
|
|||
import XMonad.Internal.Concurrent.ClientMessage
|
||||
import XMonad.Internal.Concurrent.DynamicWorkspaces
|
||||
import XMonad.Internal.Concurrent.Removable
|
||||
import XMonad.Internal.DBus.Brightness.Common
|
||||
import XMonad.Internal.DBus.Control
|
||||
import XMonad.Internal.DBus.IntelBacklight
|
||||
import XMonad.Internal.DBus.Screensaver
|
||||
import XMonad.Internal.Dependency
|
||||
import XMonad.Internal.Process
|
||||
import XMonad.Internal.Shell
|
||||
import qualified XMonad.Internal.Theme as T
|
||||
|
|
@ -66,7 +67,11 @@ import XMonad.Util.WorkspaceCompare
|
|||
|
||||
main :: IO ()
|
||||
main = do
|
||||
(cl, bc, sc) <- startXMonadService
|
||||
DBusXMonad
|
||||
{ dxClient = cl
|
||||
, dxIntelBacklightCtrl = bc
|
||||
, dxScreensaverCtrl = sc
|
||||
} <- startXMonadService
|
||||
(h, p) <- spawnPipe "xmobar"
|
||||
_ <- forkIO runPowermon
|
||||
_ <- forkIO runRemovableMon
|
||||
|
|
@ -485,7 +490,7 @@ filterExternal kgs = let kgs' = fmap go kgs in (fst <$> kgs', concatMap snd kgs'
|
|||
Ignore -> (Nothing, [])
|
||||
flagMissing s = "[!!!]" ++ s
|
||||
|
||||
externalBindings :: Maybe BacklightControls
|
||||
externalBindings :: Maybe BrightnessControls
|
||||
-> MaybeExe SSControls
|
||||
-> ThreadState
|
||||
-> [KeyGroup (IO MaybeX)]
|
||||
|
|
@ -534,10 +539,10 @@ externalBindings bc sc ts =
|
|||
]
|
||||
|
||||
, KeyGroup "System"
|
||||
[ KeyBinding "M-." "backlight up" $ runMaybe bc backlightUp
|
||||
, KeyBinding "M-," "backlight down" $ runMaybe bc backlightDown
|
||||
, KeyBinding "M-M1-," "backlight min" $ runMaybe bc backlightMin
|
||||
, KeyBinding "M-M1-." "backlight max" $ runMaybe bc backlightMax
|
||||
[ KeyBinding "M-." "backlight up" $ runMaybe bc bctlInc
|
||||
, KeyBinding "M-," "backlight down" $ runMaybe bc bctlDec
|
||||
, KeyBinding "M-M1-," "backlight min" $ runMaybe bc bctlMin
|
||||
, KeyBinding "M-M1-." "backlight max" $ runMaybe bc bctlMax
|
||||
, KeyBinding "M-<End>" "power menu" $ noCheck runPowerPrompt
|
||||
, KeyBinding "M-<Home>" "quit xmonad" $ noCheck runQuitPrompt
|
||||
, KeyBinding "M-<Delete>" "lock screen" runScreenLock
|
||||
|
|
|
|||
|
|
@ -17,13 +17,13 @@ import Control.Monad.Reader
|
|||
|
||||
import Graphics.X11.Types
|
||||
|
||||
import System.Directory (XdgDirectory (..), getXdgDirectory)
|
||||
import System.Directory (XdgDirectory (..), getXdgDirectory)
|
||||
import System.IO
|
||||
|
||||
import XMonad.Core hiding (spawn)
|
||||
import XMonad.Core hiding (spawn)
|
||||
import XMonad.Internal.Dependency
|
||||
import XMonad.Internal.Notify
|
||||
import XMonad.Internal.Process
|
||||
import XMonad.Internal.Shell
|
||||
import XMonad.Util.NamedActions
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -45,9 +45,9 @@ import System.FilePath
|
|||
import XMonad.Actions.Volume
|
||||
import XMonad.Core hiding (spawn)
|
||||
import XMonad.Internal.DBus.Screensaver
|
||||
import XMonad.Internal.Dependency
|
||||
import XMonad.Internal.Notify
|
||||
import XMonad.Internal.Process
|
||||
import XMonad.Internal.Shell
|
||||
import XMonad.Operations
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -28,8 +28,8 @@ import System.IO.Error
|
|||
import System.Process
|
||||
|
||||
import XMonad.Core
|
||||
import XMonad.Internal.Dependency
|
||||
import XMonad.Internal.Process (readCreateProcessWithExitCode')
|
||||
import XMonad.Internal.Shell
|
||||
import qualified XMonad.Internal.Theme as T
|
||||
import XMonad.Prompt
|
||||
import XMonad.Prompt.ConfirmPrompt
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ import System.IO.Streams.UnixSocket
|
|||
import XMonad.Core
|
||||
import XMonad.Internal.Command.Power
|
||||
import XMonad.Internal.Concurrent.ClientMessage
|
||||
import XMonad.Internal.Shell
|
||||
import XMonad.Internal.Dependency
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Data structure to hold the ACPI events I care about
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ import DBus
|
|||
import DBus.Client
|
||||
|
||||
import XMonad.Internal.DBus.Control (pathExists)
|
||||
import XMonad.Internal.Shell
|
||||
import XMonad.Internal.Dependency
|
||||
|
||||
bus :: BusName
|
||||
bus = busName_ "org.freedesktop.UDisks2"
|
||||
|
|
|
|||
|
|
@ -0,0 +1,128 @@
|
|||
--------------------------------------------------------------------------------
|
||||
-- | DBus module for DBus brightness controls
|
||||
|
||||
module XMonad.Internal.DBus.Brightness.Common
|
||||
( BrightnessConfig(..)
|
||||
, BrightnessControls(..)
|
||||
, exportBrightnessControls
|
||||
, callGetBrightness
|
||||
, matchSignal
|
||||
) where
|
||||
|
||||
import Control.Monad (void)
|
||||
|
||||
import Data.Int (Int32)
|
||||
|
||||
import DBus
|
||||
import DBus.Client
|
||||
|
||||
import XMonad.Internal.DBus.Common
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | External API
|
||||
--
|
||||
-- Define four methods to increase, decrease, maximize, or minimize the
|
||||
-- brightness. These methods will all return the current brightness as a 32-bit
|
||||
-- integer and emit a signal with the same brightness value. Additionally, there
|
||||
-- is one method to get the current brightness.
|
||||
|
||||
data BrightnessConfig a b = BrightnessConfig
|
||||
{ bcMin :: a -> IO b
|
||||
, bcMax :: a -> IO b
|
||||
, bcDec :: a -> IO b
|
||||
, bcInc :: a -> IO b
|
||||
, bcGet :: a -> IO b
|
||||
, bcGetMax :: IO a
|
||||
, bcPath :: ObjectPath
|
||||
, bcInterface :: InterfaceName
|
||||
}
|
||||
|
||||
data BrightnessControls = BrightnessControls
|
||||
{ bctlMax :: IO ()
|
||||
, bctlMin :: IO ()
|
||||
, bctlInc :: IO ()
|
||||
, bctlDec :: IO ()
|
||||
}
|
||||
|
||||
exportBrightnessControls :: RealFrac b => BrightnessConfig a b -> Client
|
||||
-> IO BrightnessControls
|
||||
exportBrightnessControls bc client = do
|
||||
exportBrightnessControls' bc client
|
||||
return $ BrightnessControls
|
||||
{ bctlMax = callBacklight' memMax
|
||||
, bctlMin = callBacklight' memMin
|
||||
, bctlInc = callBacklight' memInc
|
||||
, bctlDec = callBacklight' memDec
|
||||
}
|
||||
where
|
||||
callBacklight' = callBacklight bc
|
||||
|
||||
callGetBrightness :: Num c => BrightnessConfig a b -> IO (Maybe c)
|
||||
callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } = do
|
||||
reply <- callMethod $ methodCall p i memGet
|
||||
return $ reply >>= bodyGetBrightness
|
||||
|
||||
matchSignal :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> IO SignalHandler
|
||||
matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do
|
||||
client <- connectSession
|
||||
addMatch client brMatcher $ cb . bodyGetBrightness . signalBody
|
||||
where
|
||||
brMatcher = matchAny
|
||||
{ matchPath = Just p
|
||||
, matchInterface = Just i
|
||||
, matchMember = Just memCur
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Internal DBus Crap
|
||||
|
||||
exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
|
||||
exportBrightnessControls' bc client = do
|
||||
maxval <- bcGetMax bc -- assume the max value will never change
|
||||
let autoMethod' m f = autoMethod m $ emitBrightness bc client =<< f bc maxval
|
||||
let funget = bcGet bc
|
||||
export client (bcPath bc) defaultInterface
|
||||
{ interfaceName = bcInterface bc
|
||||
, interfaceMethods =
|
||||
[ autoMethod' memMax bcMax
|
||||
, autoMethod' memMin bcMin
|
||||
, autoMethod' memInc bcInc
|
||||
, autoMethod' memDec bcDec
|
||||
, autoMethod memGet (round <$> funget maxval :: IO Int32)
|
||||
]
|
||||
}
|
||||
|
||||
emitBrightness :: RealFrac b => BrightnessConfig a b -> Client -> b -> IO ()
|
||||
emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
|
||||
emit client $ sig { signalBody = [toVariant (round cur :: Int32)] }
|
||||
where
|
||||
sig = signal p i memCur
|
||||
|
||||
callBacklight :: BrightnessConfig a b -> MemberName -> IO ()
|
||||
callBacklight BrightnessConfig { bcPath = p, bcInterface = i } mem =
|
||||
void $ callMethod $ methodCall p i mem
|
||||
|
||||
bodyGetBrightness :: Num a => [Variant] -> Maybe a
|
||||
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
|
||||
bodyGetBrightness _ = Nothing
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | DBus Members
|
||||
|
||||
memCur :: MemberName
|
||||
memCur = memberName_ "CurrentBrightness"
|
||||
|
||||
memGet :: MemberName
|
||||
memGet = memberName_ "GetBrightness"
|
||||
|
||||
memMax :: MemberName
|
||||
memMax = memberName_ "MaxBrightness"
|
||||
|
||||
memMin :: MemberName
|
||||
memMin = memberName_ "MinBrightness"
|
||||
|
||||
memInc :: MemberName
|
||||
memInc = memberName_ "IncBrightness"
|
||||
|
||||
memDec :: MemberName
|
||||
memDec = memberName_ "DecBrightness"
|
||||
|
|
@ -0,0 +1,126 @@
|
|||
--------------------------------------------------------------------------------
|
||||
-- | DBus module for Intel Backlight control
|
||||
|
||||
module XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||
( callGetBrightnessIB
|
||||
, matchSignalIB
|
||||
, exportIntelBacklight
|
||||
, hasBacklight
|
||||
, blPath
|
||||
) where
|
||||
|
||||
import Data.Either
|
||||
import Data.Int (Int32)
|
||||
|
||||
import DBus
|
||||
import DBus.Client
|
||||
|
||||
import System.FilePath.Posix
|
||||
|
||||
import XMonad.Internal.DBus.Brightness.Common
|
||||
import XMonad.Internal.IO
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Low level sysfs functions
|
||||
--
|
||||
type Brightness = Float
|
||||
|
||||
type RawBrightness = Int32
|
||||
|
||||
steps :: Int
|
||||
steps = 16
|
||||
|
||||
backlightDir :: FilePath
|
||||
backlightDir = "/sys/class/backlight/intel_backlight/"
|
||||
|
||||
maxFile :: FilePath
|
||||
maxFile = backlightDir </> "max_brightness"
|
||||
|
||||
curFile :: FilePath
|
||||
curFile = backlightDir </> "brightness"
|
||||
|
||||
getMaxRawBrightness :: IO RawBrightness
|
||||
getMaxRawBrightness = readInt maxFile
|
||||
|
||||
getBrightness :: RawBrightness -> IO Brightness
|
||||
getBrightness upper = readPercent upper curFile
|
||||
|
||||
minBrightness :: RawBrightness -> IO Brightness
|
||||
minBrightness upper = writePercentMin upper curFile
|
||||
|
||||
maxBrightness :: RawBrightness -> IO Brightness
|
||||
maxBrightness upper = writePercentMax upper curFile
|
||||
|
||||
incBrightness :: RawBrightness -> IO Brightness
|
||||
incBrightness = incPercent steps curFile
|
||||
|
||||
decBrightness :: RawBrightness -> IO Brightness
|
||||
decBrightness = decPercent steps curFile
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Access checks
|
||||
|
||||
-- | determine if backlight is accessible/present
|
||||
-- Right True -> backlight accessible and present
|
||||
-- Right False -> backlight not present
|
||||
-- Left x -> backlight present but could not access (x explaining why)
|
||||
hasBacklight' :: IO (Either String Bool)
|
||||
hasBacklight' = do
|
||||
mx <- isReadable maxFile
|
||||
cx <- isWritable curFile
|
||||
return $ case (mx, cx) of
|
||||
(NotFoundError, NotFoundError) -> Right False
|
||||
(PermResult True, PermResult True) -> Right True
|
||||
(PermResult _, PermResult _) -> Left "Insufficient permissions for backlight files"
|
||||
_ -> Left "Could not determine permissions for backlight files"
|
||||
|
||||
msg :: Either String Bool -> IO ()
|
||||
msg (Right True) = return ()
|
||||
msg (Right False) = putStrLn "No backlight detected. Controls disabled"
|
||||
msg (Left m) = putStrLn $ "WARNING: " ++ m
|
||||
|
||||
hasBacklightMsg :: IO Bool
|
||||
hasBacklightMsg = do
|
||||
b <- hasBacklight'
|
||||
msg b
|
||||
return $ fromRight False b
|
||||
|
||||
hasBacklight :: IO Bool
|
||||
hasBacklight = fromRight False <$> hasBacklight'
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | DBus interface
|
||||
|
||||
blPath :: ObjectPath
|
||||
blPath = objectPath_ "/intelbacklight"
|
||||
|
||||
interface :: InterfaceName
|
||||
interface = interfaceName_ "org.xmonad.Brightness"
|
||||
|
||||
intelBacklightConfig :: BrightnessConfig RawBrightness Brightness
|
||||
intelBacklightConfig = BrightnessConfig
|
||||
{ bcMin = minBrightness
|
||||
, bcMax = maxBrightness
|
||||
, bcInc = incBrightness
|
||||
, bcDec = decBrightness
|
||||
, bcGet = getBrightness
|
||||
, bcGetMax = getMaxRawBrightness
|
||||
, bcPath = blPath
|
||||
, bcInterface = interface
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Exported haskell API
|
||||
|
||||
exportIntelBacklight :: Client -> IO (Maybe BrightnessControls)
|
||||
exportIntelBacklight client = do
|
||||
b <- hasBacklightMsg
|
||||
if b
|
||||
then Just <$> exportBrightnessControls intelBacklightConfig client
|
||||
else return Nothing
|
||||
|
||||
callGetBrightnessIB :: IO (Maybe Brightness)
|
||||
callGetBrightnessIB = callGetBrightness intelBacklightConfig
|
||||
|
||||
matchSignalIB :: (Maybe Brightness -> IO ()) -> IO SignalHandler
|
||||
matchSignalIB = matchSignal intelBacklightConfig
|
||||
|
|
@ -9,6 +9,7 @@ module XMonad.Internal.DBus.Control
|
|||
, stopXMonadService
|
||||
, pathExists
|
||||
, xmonadBus
|
||||
, DBusXMonad(..)
|
||||
) where
|
||||
|
||||
import Data.Either
|
||||
|
|
@ -16,10 +17,11 @@ import Data.Either
|
|||
import DBus
|
||||
import DBus.Client
|
||||
|
||||
import XMonad.Internal.DBus.Brightness.Common
|
||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||
import XMonad.Internal.DBus.Common
|
||||
import XMonad.Internal.DBus.IntelBacklight
|
||||
import XMonad.Internal.DBus.Screensaver
|
||||
import XMonad.Internal.Shell
|
||||
import XMonad.Internal.Dependency
|
||||
|
||||
introspectInterface :: InterfaceName
|
||||
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
|
||||
|
|
@ -27,20 +29,33 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
|
|||
introspectMethod :: MemberName
|
||||
introspectMethod = memberName_ "Introspect"
|
||||
|
||||
startXMonadService :: IO (Client, Maybe BacklightControls, MaybeExe SSControls)
|
||||
data DBusXMonad = DBusXMonad
|
||||
{ dxClient :: Client
|
||||
, dxIntelBacklightCtrl :: Maybe BrightnessControls
|
||||
, dxClevoBacklightCtrl :: Maybe BrightnessControls
|
||||
, dxScreensaverCtrl :: MaybeExe SSControls
|
||||
}
|
||||
|
||||
startXMonadService :: IO DBusXMonad
|
||||
startXMonadService = do
|
||||
client <- connectSession
|
||||
requestResult <- requestName client xmonadBus []
|
||||
-- TODO if the client is not released on shutdown the owner will be
|
||||
-- different
|
||||
if requestResult /= NamePrimaryOwner then do
|
||||
(i, c, s) <- if requestResult /= NamePrimaryOwner then do
|
||||
putStrLn "Another service owns \"org.xmonad\""
|
||||
return (client, Nothing, Ignore)
|
||||
else do
|
||||
return (Nothing, Nothing, Ignore)
|
||||
else do
|
||||
putStrLn "Started xmonad dbus client"
|
||||
bc <- exportIntelBacklight client
|
||||
sc <- exportScreensaver client
|
||||
return (client, bc, sc)
|
||||
return (bc, Nothing, sc)
|
||||
return $ DBusXMonad
|
||||
{ dxClient = client
|
||||
, dxIntelBacklightCtrl = i
|
||||
, dxClevoBacklightCtrl = c
|
||||
, dxScreensaverCtrl = s
|
||||
}
|
||||
|
||||
stopXMonadService :: Client -> IO ()
|
||||
stopXMonadService client = do
|
||||
|
|
|
|||
|
|
@ -1,205 +0,0 @@
|
|||
--------------------------------------------------------------------------------
|
||||
-- | DBus module for Intel Backlight control
|
||||
|
||||
module XMonad.Internal.DBus.IntelBacklight
|
||||
( callGetBrightness
|
||||
, exportIntelBacklight
|
||||
, matchSignal
|
||||
, hasBacklight
|
||||
, blPath
|
||||
, BacklightControls(..)
|
||||
) where
|
||||
|
||||
import Control.Monad (void)
|
||||
|
||||
import Data.Either
|
||||
import Data.Int (Int32)
|
||||
|
||||
import DBus
|
||||
import DBus.Client
|
||||
|
||||
import System.FilePath.Posix
|
||||
|
||||
import XMonad.Internal.DBus.Common
|
||||
import XMonad.Internal.IO
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Low level sysfs functions
|
||||
--
|
||||
type Brightness = Float
|
||||
|
||||
type RawBrightness = Int32
|
||||
|
||||
steps :: Int
|
||||
steps = 16
|
||||
|
||||
backlightDir :: FilePath
|
||||
backlightDir = "/sys/class/backlight/intel_backlight/"
|
||||
|
||||
maxFile :: FilePath
|
||||
maxFile = backlightDir </> "max_brightness"
|
||||
|
||||
curFile :: FilePath
|
||||
curFile = backlightDir </> "brightness"
|
||||
|
||||
getMaxRawBrightness :: IO RawBrightness
|
||||
getMaxRawBrightness = readInt maxFile
|
||||
|
||||
getBrightness :: RawBrightness -> IO Brightness
|
||||
getBrightness upper = readPercent upper curFile
|
||||
|
||||
minBrightness :: RawBrightness -> IO Brightness
|
||||
minBrightness upper = writePercentMin upper curFile
|
||||
|
||||
maxBrightness :: RawBrightness -> IO Brightness
|
||||
maxBrightness upper = writePercentMax upper curFile
|
||||
|
||||
incBrightness :: RawBrightness -> IO Brightness
|
||||
incBrightness = incPercent steps curFile
|
||||
|
||||
decBrightness :: RawBrightness -> IO Brightness
|
||||
decBrightness = decPercent steps curFile
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Access checks
|
||||
|
||||
-- | determine if backlight is accessible/present
|
||||
-- Right True -> backlight accessible and present
|
||||
-- Right False -> backlight not present
|
||||
-- Left x -> backlight present but could not access (x explaining why)
|
||||
hasBacklight' :: IO (Either String Bool)
|
||||
hasBacklight' = do
|
||||
mx <- isReadable maxFile
|
||||
cx <- isWritable curFile
|
||||
return $ case (mx, cx) of
|
||||
(NotFoundError, NotFoundError) -> Right False
|
||||
(PermResult True, PermResult True) -> Right True
|
||||
(PermResult _, PermResult _) -> Left "Insufficient permissions for backlight files"
|
||||
_ -> Left "Could not determine permissions for backlight files"
|
||||
|
||||
msg :: Either String Bool -> IO ()
|
||||
msg (Right True) = return ()
|
||||
msg (Right False) = putStrLn "No backlight detected. Controls disabled"
|
||||
msg (Left m) = putStrLn $ "WARNING: " ++ m
|
||||
|
||||
hasBacklightMsg :: IO Bool
|
||||
hasBacklightMsg = do
|
||||
b <- hasBacklight'
|
||||
msg b
|
||||
return $ fromRight False b
|
||||
|
||||
hasBacklight :: IO Bool
|
||||
hasBacklight = fromRight False <$> hasBacklight'
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | DBus interface
|
||||
--
|
||||
-- Define four methods to increase, decrease, maximize, or minimize the
|
||||
-- brightness. These methods will all return the current brightness as a 32-bit
|
||||
-- integer and emit a signal with the same brightness value. Additionally, there
|
||||
-- is one method to get the current brightness.
|
||||
|
||||
blPath :: ObjectPath
|
||||
blPath = objectPath_ "/intelbacklight"
|
||||
|
||||
interface :: InterfaceName
|
||||
interface = interfaceName_ "org.xmonad.Brightness"
|
||||
|
||||
memCurrentBrightness :: MemberName
|
||||
memCurrentBrightness = memberName_ "CurrentBrightness"
|
||||
|
||||
memGetBrightness :: MemberName
|
||||
memGetBrightness = memberName_ "GetBrightness"
|
||||
|
||||
memMaxBrightness :: MemberName
|
||||
memMaxBrightness = memberName_ "MaxBrightness"
|
||||
|
||||
memMinBrightness :: MemberName
|
||||
memMinBrightness = memberName_ "MinBrightness"
|
||||
|
||||
memIncBrightness :: MemberName
|
||||
memIncBrightness = memberName_ "IncBrightness"
|
||||
|
||||
memDecBrightness :: MemberName
|
||||
memDecBrightness = memberName_ "DecBrightness"
|
||||
|
||||
brSignal :: Signal
|
||||
brSignal = signal blPath interface memCurrentBrightness
|
||||
-- { signalDestination = Just "org.xmonad" }
|
||||
|
||||
brMatcher :: MatchRule
|
||||
brMatcher = matchAny
|
||||
{ matchPath = Just blPath
|
||||
, matchInterface = Just interface
|
||||
, matchMember = Just memCurrentBrightness
|
||||
}
|
||||
|
||||
callBacklight :: MemberName -> IO ()
|
||||
callBacklight method = void $ callMethod $ methodCall blPath interface method
|
||||
|
||||
bodyGetBrightness :: [Variant] -> Maybe Brightness
|
||||
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
|
||||
bodyGetBrightness _ = Nothing
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Exported haskell API
|
||||
|
||||
data BacklightControls = BacklightControls
|
||||
{ backlightMax :: IO ()
|
||||
, backlightMin :: IO ()
|
||||
, backlightUp :: IO ()
|
||||
, backlightDown :: IO ()
|
||||
}
|
||||
|
||||
exportIntelBacklight :: Client -> IO (Maybe BacklightControls)
|
||||
exportIntelBacklight client = do
|
||||
b <- hasBacklightMsg
|
||||
if b then exportIntelBacklight' client >> return (Just bc) else return Nothing
|
||||
where
|
||||
bc = BacklightControls
|
||||
{ backlightMax = callMaxBrightness
|
||||
, backlightMin = callMinBrightness
|
||||
, backlightUp = callIncBrightness
|
||||
, backlightDown = callDecBrightness
|
||||
}
|
||||
|
||||
exportIntelBacklight' :: Client -> IO ()
|
||||
exportIntelBacklight' client = do
|
||||
maxval <- getMaxRawBrightness -- assume the max value will never change
|
||||
let emit' f = emitBrightness client =<< f maxval
|
||||
export client blPath defaultInterface
|
||||
{ interfaceName = interface
|
||||
, interfaceMethods =
|
||||
[ autoMethod memMaxBrightness $ emit' maxBrightness
|
||||
, autoMethod memMinBrightness $ emit' minBrightness
|
||||
, autoMethod memIncBrightness $ emit' incBrightness
|
||||
, autoMethod memDecBrightness $ emit' decBrightness
|
||||
, autoMethod memGetBrightness (round <$> getBrightness maxval :: IO Int32)
|
||||
]
|
||||
}
|
||||
|
||||
emitBrightness :: Client -> Brightness -> IO ()
|
||||
emitBrightness client cur = emit client
|
||||
$ brSignal { signalBody = [toVariant (round cur :: Int32)] }
|
||||
|
||||
callMaxBrightness :: IO ()
|
||||
callMaxBrightness = callBacklight memMaxBrightness
|
||||
|
||||
callMinBrightness :: IO ()
|
||||
callMinBrightness = callBacklight memMinBrightness
|
||||
|
||||
callIncBrightness :: IO ()
|
||||
callIncBrightness = callBacklight memIncBrightness
|
||||
|
||||
callDecBrightness :: IO ()
|
||||
callDecBrightness = callBacklight memDecBrightness
|
||||
|
||||
callGetBrightness :: IO (Maybe Brightness)
|
||||
callGetBrightness = do
|
||||
reply <- callMethod $ methodCall blPath interface memGetBrightness
|
||||
return $ reply >>= bodyGetBrightness
|
||||
|
||||
matchSignal :: (Maybe Brightness -> IO ()) -> IO SignalHandler
|
||||
matchSignal cb = do
|
||||
client <- connectSession
|
||||
addMatch client brMatcher $ cb . bodyGetBrightness . signalBody
|
||||
|
|
@ -19,8 +19,8 @@ import Graphics.X11.XScreenSaver
|
|||
import Graphics.X11.Xlib.Display
|
||||
|
||||
import XMonad.Internal.DBus.Common
|
||||
import XMonad.Internal.Dependency
|
||||
import XMonad.Internal.Process
|
||||
import XMonad.Internal.Shell
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Low-level functions
|
||||
|
|
|
|||
|
|
@ -0,0 +1,177 @@
|
|||
--------------------------------------------------------------------------------
|
||||
-- | Functions for handling dependencies
|
||||
|
||||
module XMonad.Internal.Dependency
|
||||
( MaybeExe(..)
|
||||
, UnitType(..)
|
||||
, Dependency(..)
|
||||
, MaybeX
|
||||
, exe
|
||||
, systemUnit
|
||||
, userUnit
|
||||
, runIfInstalled
|
||||
, depInstalled
|
||||
, warnMissing
|
||||
, whenInstalled
|
||||
, ifInstalled
|
||||
, spawnIfInstalled
|
||||
, spawnCmdIfInstalled
|
||||
, noCheck
|
||||
, fmtCmd
|
||||
, spawnCmd
|
||||
, doubleQuote
|
||||
, singleQuote
|
||||
, (#!&&)
|
||||
, (#!||)
|
||||
, (#!|)
|
||||
, (#!>>)
|
||||
, playSound
|
||||
, spawnSound
|
||||
) where
|
||||
|
||||
import Control.Monad (filterM)
|
||||
import Control.Monad.IO.Class
|
||||
|
||||
import Data.Maybe (isJust)
|
||||
|
||||
-- import System.Directory (findExecutable, readable, writable)
|
||||
import System.Directory (findExecutable)
|
||||
import System.Exit
|
||||
import System.FilePath
|
||||
|
||||
import XMonad.Core (X, getXMonadDir)
|
||||
-- import XMonad.Internal.IO
|
||||
import XMonad.Internal.Process
|
||||
import XMonad.Internal.Shell
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Gracefully handling missing binaries
|
||||
|
||||
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
|
||||
|
||||
data DependencyType = Executable
|
||||
-- | AccessiblePath FilePath Bool Bool
|
||||
| Systemd UnitType deriving (Eq, Show)
|
||||
|
||||
data Dependency = Dependency
|
||||
{ depRequired :: Bool
|
||||
, depName :: String
|
||||
, depType :: DependencyType
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
exe :: String -> Dependency
|
||||
exe n = Dependency
|
||||
{ depRequired = True
|
||||
, depName = n
|
||||
, depType = Executable
|
||||
}
|
||||
|
||||
unit :: UnitType -> String -> Dependency
|
||||
unit t n = Dependency
|
||||
{ depRequired = True
|
||||
, depName = n
|
||||
, depType = Systemd t
|
||||
}
|
||||
|
||||
systemUnit :: String -> Dependency
|
||||
systemUnit = unit SystemUnit
|
||||
|
||||
userUnit :: String -> Dependency
|
||||
userUnit = unit UserUnit
|
||||
|
||||
data MaybeExe a = Installed a [Dependency] | Missing [Dependency] | Ignore
|
||||
|
||||
instance Functor MaybeExe where
|
||||
fmap f (Installed x ds) = Installed (f x) ds
|
||||
fmap _ (Missing x) = Missing x
|
||||
fmap _ Ignore = Ignore
|
||||
|
||||
type MaybeX = MaybeExe (X ())
|
||||
|
||||
warnMissing :: Dependency -> IO ()
|
||||
warnMissing Dependency {depRequired = r, depName = n, depType = t } =
|
||||
putStrLn $ "WARNING: " ++ r' ++ " " ++ fmtType t ++ " not found: " ++ n
|
||||
where
|
||||
fmtType Executable = "executable"
|
||||
-- fmtType (AccessiblePath _ _ _) = undefined
|
||||
fmtType (Systemd UserUnit) = "systemd user unit"
|
||||
fmtType (Systemd SystemUnit) = "systemd system unit"
|
||||
r' = if r then "required" else "optional"
|
||||
|
||||
exeInstalled :: String -> IO Bool
|
||||
exeInstalled x = isJust <$> findExecutable x
|
||||
|
||||
unitInstalled :: String -> UnitType -> IO Bool
|
||||
unitInstalled x u = do
|
||||
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
|
||||
return $ case rc of
|
||||
ExitSuccess -> True
|
||||
_ -> False
|
||||
where
|
||||
cmd = fmtCmd "systemctl" $ ["--user" | u == UserUnit] ++ ["status", x]
|
||||
|
||||
-- pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String)
|
||||
-- pathAccessible p testread testwrite = do
|
||||
-- res <- getPermissionsSafe p
|
||||
-- let msg = permMsg res
|
||||
-- return $ fmap (\m -> m ++ ": " ++ p) msg
|
||||
-- where
|
||||
-- testPerm False _ _ = Nothing
|
||||
-- testPerm True f r = Just $ f r
|
||||
-- permMsg NotFoundError = Just "file not found"
|
||||
-- permMsg PermError = Just "could not get permissions"
|
||||
-- permMsg (PermResult r) =
|
||||
-- case (testPerm testread readable r, testPerm testwrite writable r) of
|
||||
-- (Just False, Just False) -> Just "file not readable or writable"
|
||||
-- (Just False, _) -> Just "file not readable"
|
||||
-- (_, Just False) -> Just "file not writable"
|
||||
-- _ -> Nothing
|
||||
|
||||
depInstalled :: Dependency -> IO Bool
|
||||
depInstalled Dependency { depName = n, depType = t } =
|
||||
case t of
|
||||
Executable -> exeInstalled n
|
||||
-- (AccessiblePath p r w) -> pathAccessible p r w
|
||||
Systemd u -> unitInstalled n u
|
||||
|
||||
filterMissing :: [Dependency] -> IO [Dependency]
|
||||
filterMissing = filterM (fmap not . depInstalled)
|
||||
|
||||
runIfInstalled :: MonadIO m => [Dependency] -> m () -> IO (MaybeExe (m ()))
|
||||
runIfInstalled ds x = do
|
||||
missing <- filterMissing ds
|
||||
return $ if not $ any depRequired missing
|
||||
then Installed x $ filter (not . depRequired) missing
|
||||
else Missing missing
|
||||
|
||||
spawnIfInstalled :: MonadIO m => String -> IO (MaybeExe (m ()))
|
||||
spawnIfInstalled n = runIfInstalled [exe n] $ spawn n
|
||||
|
||||
spawnCmdIfInstalled :: MonadIO m => String -> [String] -> IO (MaybeExe (m ()))
|
||||
spawnCmdIfInstalled n args = runIfInstalled [exe n] $ spawnCmd n args
|
||||
|
||||
whenInstalled :: Monad m => MaybeExe (m ()) -> m ()
|
||||
whenInstalled = flip ifInstalled skip
|
||||
|
||||
ifInstalled :: MaybeExe a -> a -> a
|
||||
ifInstalled (Installed x _) _ = x
|
||||
ifInstalled _ alt = alt
|
||||
|
||||
noCheck :: Monad m => a () -> m (MaybeExe (a ()))
|
||||
noCheck = return . flip Installed []
|
||||
|
||||
-- not sure what to do with these
|
||||
|
||||
soundDir :: FilePath
|
||||
soundDir = "sound"
|
||||
|
||||
spawnSound :: MonadIO m => FilePath -> m () -> m () -> IO (MaybeExe (m ()))
|
||||
spawnSound file pre post = runIfInstalled [exe "paplay"]
|
||||
$ pre >> playSound file >> post
|
||||
|
||||
playSound :: MonadIO m => FilePath -> m ()
|
||||
playSound file = do
|
||||
path <- (</> soundDir </> file) <$> getXMonadDir
|
||||
-- paplay seems to have less latency than aplay
|
||||
spawnCmd "paplay" [path]
|
||||
|
|
@ -2,25 +2,8 @@
|
|||
-- | Functions for formatting and spawning shell commands
|
||||
|
||||
module XMonad.Internal.Shell
|
||||
( MaybeExe(..)
|
||||
, UnitType(..)
|
||||
, Dependency(..)
|
||||
, MaybeX
|
||||
, exe
|
||||
, systemUnit
|
||||
, userUnit
|
||||
, runIfInstalled
|
||||
, depInstalled
|
||||
, warnMissing
|
||||
, whenInstalled
|
||||
, ifInstalled
|
||||
, spawnIfInstalled
|
||||
, spawnCmdIfInstalled
|
||||
, noCheck
|
||||
, fmtCmd
|
||||
( fmtCmd
|
||||
, spawnCmd
|
||||
, spawnSound
|
||||
, playSound
|
||||
, doubleQuote
|
||||
, singleQuote
|
||||
, skip
|
||||
|
|
@ -30,137 +13,16 @@ module XMonad.Internal.Shell
|
|||
, (#!>>)
|
||||
) where
|
||||
|
||||
import Control.Monad (filterM)
|
||||
import Control.Monad.IO.Class
|
||||
|
||||
import Data.Maybe (isJust)
|
||||
|
||||
import System.Directory (findExecutable)
|
||||
import System.Exit
|
||||
import System.FilePath.Posix
|
||||
|
||||
import XMonad.Core (X, getXMonadDir)
|
||||
import XMonad.Internal.Process
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Gracefully handling missing binaries
|
||||
|
||||
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
|
||||
|
||||
data DependencyType = Executable | Systemd UnitType deriving (Eq, Show)
|
||||
|
||||
data Dependency = Dependency
|
||||
{ depRequired :: Bool
|
||||
, depName :: String
|
||||
, depType :: DependencyType
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
exe :: String -> Dependency
|
||||
exe n = Dependency
|
||||
{ depRequired = True
|
||||
, depName = n
|
||||
, depType = Executable }
|
||||
|
||||
unit :: UnitType -> String -> Dependency
|
||||
unit t n = Dependency
|
||||
{ depRequired = True
|
||||
, depName = n
|
||||
, depType = Systemd t }
|
||||
|
||||
systemUnit :: String -> Dependency
|
||||
systemUnit = unit SystemUnit
|
||||
|
||||
userUnit :: String -> Dependency
|
||||
userUnit = unit UserUnit
|
||||
|
||||
data MaybeExe a = Installed a [Dependency] | Missing [Dependency] | Ignore
|
||||
|
||||
instance Functor MaybeExe where
|
||||
fmap f (Installed x ds) = Installed (f x) ds
|
||||
fmap _ (Missing x) = Missing x
|
||||
fmap _ Ignore = Ignore
|
||||
|
||||
type MaybeX = MaybeExe (X ())
|
||||
|
||||
warnMissing :: Dependency -> IO ()
|
||||
warnMissing Dependency {depRequired = r, depName = n, depType = t } =
|
||||
putStrLn $ "WARNING: " ++ r' ++ " " ++ fmtType t ++ " not found: " ++ n
|
||||
where
|
||||
fmtType Executable = "executable"
|
||||
fmtType (Systemd u) =
|
||||
"systemd " ++ (if u == UserUnit then "user" else "system") ++ " unit"
|
||||
r' = if r then "required" else "optional"
|
||||
|
||||
exeInstalled :: String -> IO Bool
|
||||
exeInstalled x = isJust <$> findExecutable x
|
||||
|
||||
unitInstalled :: String -> UnitType -> IO Bool
|
||||
unitInstalled x u = do
|
||||
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
|
||||
return $ case rc of
|
||||
ExitSuccess -> True
|
||||
_ -> False
|
||||
where
|
||||
cmd = fmtCmd "systemctl" $ ["--user" | u == UserUnit] ++ ["status", x]
|
||||
|
||||
depInstalled :: Dependency -> IO Bool
|
||||
depInstalled Dependency { depName = n, depType = t } =
|
||||
case t of
|
||||
Executable -> exeInstalled n
|
||||
Systemd u -> unitInstalled n u
|
||||
|
||||
filterMissing :: [Dependency] -> IO [Dependency]
|
||||
filterMissing = filterM (fmap not . depInstalled)
|
||||
|
||||
runIfInstalled :: MonadIO m => [Dependency] -> m () -> IO (MaybeExe (m ()))
|
||||
runIfInstalled ds x = do
|
||||
missing <- filterMissing ds
|
||||
return $ if not $ any depRequired missing
|
||||
then Installed x $ filter (not . depRequired) missing
|
||||
else Missing missing
|
||||
|
||||
spawnIfInstalled :: MonadIO m => String -> IO (MaybeExe (m ()))
|
||||
spawnIfInstalled n = runIfInstalled [exe n] $ spawn n
|
||||
|
||||
spawnCmdIfInstalled :: MonadIO m => String -> [String] -> IO (MaybeExe (m ()))
|
||||
spawnCmdIfInstalled n args = runIfInstalled [exe n] $ spawnCmd n args
|
||||
|
||||
whenInstalled :: Monad m => MaybeExe (m ()) -> m ()
|
||||
whenInstalled = flip ifInstalled skip
|
||||
|
||||
ifInstalled :: MaybeExe a -> a -> a
|
||||
ifInstalled (Installed x _) _ = x
|
||||
ifInstalled _ alt = alt
|
||||
|
||||
skip :: Monad m => m ()
|
||||
skip = return ()
|
||||
|
||||
noCheck :: Monad m => a () -> m (MaybeExe (a ()))
|
||||
noCheck = return . flip Installed []
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Opening subshell
|
||||
|
||||
spawnCmd :: MonadIO m => String -> [String] -> m ()
|
||||
spawnCmd cmd args = spawn $ fmtCmd cmd args
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Playing sound
|
||||
|
||||
soundDir :: FilePath
|
||||
soundDir = "sound"
|
||||
|
||||
spawnSound :: MonadIO m => FilePath -> m () -> m () -> IO (MaybeExe (m ()))
|
||||
spawnSound file pre post = runIfInstalled [exe "paplay"]
|
||||
$ pre >> playSound file >> post
|
||||
|
||||
playSound :: MonadIO m => FilePath -> m ()
|
||||
playSound file = do
|
||||
path <- (</> soundDir </> file) <$> getXMonadDir
|
||||
-- paplay seems to have less latency than aplay
|
||||
spawnCmd "paplay" [path]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Formatting commands
|
||||
|
||||
|
|
@ -192,3 +54,6 @@ doubleQuote s = "\"" ++ s ++ "\""
|
|||
|
||||
singleQuote :: String -> String
|
||||
singleQuote s = "'" ++ s ++ "'"
|
||||
|
||||
skip :: Monad m => m ()
|
||||
skip = return ()
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ import Control.Monad
|
|||
|
||||
import Xmobar
|
||||
|
||||
import XMonad.Internal.DBus.IntelBacklight
|
||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||
|
||||
newtype IntelBacklight = IntelBacklight String deriving (Read, Show)
|
||||
|
||||
|
|
@ -26,8 +26,8 @@ blAlias = "intelbacklight"
|
|||
instance Exec IntelBacklight where
|
||||
alias (IntelBacklight _) = blAlias
|
||||
start (IntelBacklight icon) cb = do
|
||||
_ <- matchSignal $ cb . formatBrightness
|
||||
cb . formatBrightness =<< callGetBrightness
|
||||
_ <- matchSignalIB $ cb . formatBrightness
|
||||
cb . formatBrightness =<< callGetBrightnessIB
|
||||
forever (threadDelay 5000000)
|
||||
where
|
||||
formatBrightness = \case
|
||||
|
|
|
|||
|
|
@ -12,12 +12,14 @@ library
|
|||
, XMonad.Internal.Theme
|
||||
, XMonad.Internal.Notify
|
||||
, XMonad.Internal.Shell
|
||||
, XMonad.Internal.Dependency
|
||||
, XMonad.Internal.IO
|
||||
, XMonad.Internal.Command.Desktop
|
||||
, XMonad.Internal.Command.DMenu
|
||||
, XMonad.Internal.Command.Power
|
||||
, XMonad.Internal.DBus.Common
|
||||
, XMonad.Internal.DBus.IntelBacklight
|
||||
, XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||
, XMonad.Internal.DBus.Brightness.Common
|
||||
, XMonad.Internal.DBus.Control
|
||||
, XMonad.Internal.DBus.Screensaver
|
||||
, XMonad.Internal.Process
|
||||
|
|
|
|||
Loading…
Reference in New Issue