REF move dependency interface to own module/pull common code from intelbacklight

This commit is contained in:
Nathan Dwarshuis 2021-11-07 13:35:08 -05:00
parent 53279475f4
commit 76c0eb3386
16 changed files with 498 additions and 380 deletions

View File

@ -21,7 +21,9 @@ import System.Directory
import System.Exit import System.Exit
import System.IO import System.IO
import System.IO.Error import System.IO.Error
import System.Process (readProcessWithExitCode) import System.Process
( readProcessWithExitCode
)
import Xmobar.Plugins.Bluetooth import Xmobar.Plugins.Bluetooth
import Xmobar.Plugins.ClevoKeyboard import Xmobar.Plugins.ClevoKeyboard
@ -30,15 +32,18 @@ import Xmobar.Plugins.IntelBacklight
import Xmobar.Plugins.Screensaver import Xmobar.Plugins.Screensaver
import Xmobar.Plugins.VPN import Xmobar.Plugins.VPN
import XMonad (getXMonadDir) import XMonad (getXMonadDir)
import XMonad.Hooks.DynamicLog (wrap, xmobarColor) import XMonad.Hooks.DynamicLog
import XMonad.Internal.Command.Power (hasBattery) ( wrap
import XMonad.Internal.DBus.Common (xmonadBus) , xmobarColor
import XMonad.Internal.DBus.Control (pathExists) )
import XMonad.Internal.DBus.IntelBacklight (blPath) import XMonad.Internal.Command.Power (hasBattery)
import XMonad.Internal.DBus.Screensaver (ssPath) import XMonad.Internal.DBus.Brightness.IntelBacklight (blPath)
import XMonad.Internal.Shell (fmtCmd) import XMonad.Internal.DBus.Common (xmonadBus)
import qualified XMonad.Internal.Theme as T 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 import Xmobar
main :: IO () main :: IO ()

View File

@ -44,9 +44,10 @@ import XMonad.Internal.Concurrent.ACPIEvent
import XMonad.Internal.Concurrent.ClientMessage import XMonad.Internal.Concurrent.ClientMessage
import XMonad.Internal.Concurrent.DynamicWorkspaces import XMonad.Internal.Concurrent.DynamicWorkspaces
import XMonad.Internal.Concurrent.Removable import XMonad.Internal.Concurrent.Removable
import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.DBus.Control import XMonad.Internal.DBus.Control
import XMonad.Internal.DBus.IntelBacklight
import XMonad.Internal.DBus.Screensaver import XMonad.Internal.DBus.Screensaver
import XMonad.Internal.Dependency
import XMonad.Internal.Process import XMonad.Internal.Process
import XMonad.Internal.Shell import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as T import qualified XMonad.Internal.Theme as T
@ -66,7 +67,11 @@ import XMonad.Util.WorkspaceCompare
main :: IO () main :: IO ()
main = do main = do
(cl, bc, sc) <- startXMonadService DBusXMonad
{ dxClient = cl
, dxIntelBacklightCtrl = bc
, dxScreensaverCtrl = sc
} <- startXMonadService
(h, p) <- spawnPipe "xmobar" (h, p) <- spawnPipe "xmobar"
_ <- forkIO runPowermon _ <- forkIO runPowermon
_ <- forkIO runRemovableMon _ <- forkIO runRemovableMon
@ -485,7 +490,7 @@ filterExternal kgs = let kgs' = fmap go kgs in (fst <$> kgs', concatMap snd kgs'
Ignore -> (Nothing, []) Ignore -> (Nothing, [])
flagMissing s = "[!!!]" ++ s flagMissing s = "[!!!]" ++ s
externalBindings :: Maybe BacklightControls externalBindings :: Maybe BrightnessControls
-> MaybeExe SSControls -> MaybeExe SSControls
-> ThreadState -> ThreadState
-> [KeyGroup (IO MaybeX)] -> [KeyGroup (IO MaybeX)]
@ -534,10 +539,10 @@ externalBindings bc sc ts =
] ]
, KeyGroup "System" , KeyGroup "System"
[ KeyBinding "M-." "backlight up" $ runMaybe bc backlightUp [ KeyBinding "M-." "backlight up" $ runMaybe bc bctlInc
, KeyBinding "M-," "backlight down" $ runMaybe bc backlightDown , KeyBinding "M-," "backlight down" $ runMaybe bc bctlDec
, KeyBinding "M-M1-," "backlight min" $ runMaybe bc backlightMin , KeyBinding "M-M1-," "backlight min" $ runMaybe bc bctlMin
, KeyBinding "M-M1-." "backlight max" $ runMaybe bc backlightMax , KeyBinding "M-M1-." "backlight max" $ runMaybe bc bctlMax
, KeyBinding "M-<End>" "power menu" $ noCheck runPowerPrompt , KeyBinding "M-<End>" "power menu" $ noCheck runPowerPrompt
, KeyBinding "M-<Home>" "quit xmonad" $ noCheck runQuitPrompt , KeyBinding "M-<Home>" "quit xmonad" $ noCheck runQuitPrompt
, KeyBinding "M-<Delete>" "lock screen" runScreenLock , KeyBinding "M-<Delete>" "lock screen" runScreenLock

View File

@ -17,13 +17,13 @@ import Control.Monad.Reader
import Graphics.X11.Types import Graphics.X11.Types
import System.Directory (XdgDirectory (..), getXdgDirectory) import System.Directory (XdgDirectory (..), getXdgDirectory)
import System.IO import System.IO
import XMonad.Core hiding (spawn) import XMonad.Core hiding (spawn)
import XMonad.Internal.Dependency
import XMonad.Internal.Notify import XMonad.Internal.Notify
import XMonad.Internal.Process import XMonad.Internal.Process
import XMonad.Internal.Shell
import XMonad.Util.NamedActions import XMonad.Util.NamedActions
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View File

@ -45,9 +45,9 @@ import System.FilePath
import XMonad.Actions.Volume import XMonad.Actions.Volume
import XMonad.Core hiding (spawn) import XMonad.Core hiding (spawn)
import XMonad.Internal.DBus.Screensaver import XMonad.Internal.DBus.Screensaver
import XMonad.Internal.Dependency
import XMonad.Internal.Notify import XMonad.Internal.Notify
import XMonad.Internal.Process import XMonad.Internal.Process
import XMonad.Internal.Shell
import XMonad.Operations import XMonad.Operations
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View File

@ -28,8 +28,8 @@ import System.IO.Error
import System.Process import System.Process
import XMonad.Core import XMonad.Core
import XMonad.Internal.Dependency
import XMonad.Internal.Process (readCreateProcessWithExitCode') import XMonad.Internal.Process (readCreateProcessWithExitCode')
import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as T import qualified XMonad.Internal.Theme as T
import XMonad.Prompt import XMonad.Prompt
import XMonad.Prompt.ConfirmPrompt import XMonad.Prompt.ConfirmPrompt

View File

@ -25,7 +25,7 @@ import System.IO.Streams.UnixSocket
import XMonad.Core import XMonad.Core
import XMonad.Internal.Command.Power import XMonad.Internal.Command.Power
import XMonad.Internal.Concurrent.ClientMessage import XMonad.Internal.Concurrent.ClientMessage
import XMonad.Internal.Shell import XMonad.Internal.Dependency
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Data structure to hold the ACPI events I care about -- | Data structure to hold the ACPI events I care about

View File

@ -15,7 +15,7 @@ import DBus
import DBus.Client import DBus.Client
import XMonad.Internal.DBus.Control (pathExists) import XMonad.Internal.DBus.Control (pathExists)
import XMonad.Internal.Shell import XMonad.Internal.Dependency
bus :: BusName bus :: BusName
bus = busName_ "org.freedesktop.UDisks2" bus = busName_ "org.freedesktop.UDisks2"

View File

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

View File

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

View File

@ -9,6 +9,7 @@ module XMonad.Internal.DBus.Control
, stopXMonadService , stopXMonadService
, pathExists , pathExists
, xmonadBus , xmonadBus
, DBusXMonad(..)
) where ) where
import Data.Either import Data.Either
@ -16,10 +17,11 @@ import Data.Either
import DBus import DBus
import DBus.Client import DBus.Client
import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
import XMonad.Internal.DBus.IntelBacklight
import XMonad.Internal.DBus.Screensaver import XMonad.Internal.DBus.Screensaver
import XMonad.Internal.Shell import XMonad.Internal.Dependency
introspectInterface :: InterfaceName introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
@ -27,20 +29,33 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect" 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 startXMonadService = do
client <- connectSession client <- connectSession
requestResult <- requestName client xmonadBus [] requestResult <- requestName client xmonadBus []
-- TODO if the client is not released on shutdown the owner will be -- TODO if the client is not released on shutdown the owner will be
-- different -- different
if requestResult /= NamePrimaryOwner then do (i, c, s) <- if requestResult /= NamePrimaryOwner then do
putStrLn "Another service owns \"org.xmonad\"" putStrLn "Another service owns \"org.xmonad\""
return (client, Nothing, Ignore) return (Nothing, Nothing, Ignore)
else do else do
putStrLn "Started xmonad dbus client" putStrLn "Started xmonad dbus client"
bc <- exportIntelBacklight client bc <- exportIntelBacklight client
sc <- exportScreensaver 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 -> IO ()
stopXMonadService client = do stopXMonadService client = do

View File

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

View File

@ -19,8 +19,8 @@ import Graphics.X11.XScreenSaver
import Graphics.X11.Xlib.Display import Graphics.X11.Xlib.Display
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
import XMonad.Internal.Dependency
import XMonad.Internal.Process import XMonad.Internal.Process
import XMonad.Internal.Shell
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Low-level functions -- | Low-level functions

View File

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

View File

@ -2,25 +2,8 @@
-- | Functions for formatting and spawning shell commands -- | Functions for formatting and spawning shell commands
module XMonad.Internal.Shell module XMonad.Internal.Shell
( MaybeExe(..) ( fmtCmd
, UnitType(..)
, Dependency(..)
, MaybeX
, exe
, systemUnit
, userUnit
, runIfInstalled
, depInstalled
, warnMissing
, whenInstalled
, ifInstalled
, spawnIfInstalled
, spawnCmdIfInstalled
, noCheck
, fmtCmd
, spawnCmd , spawnCmd
, spawnSound
, playSound
, doubleQuote , doubleQuote
, singleQuote , singleQuote
, skip , skip
@ -30,137 +13,16 @@ module XMonad.Internal.Shell
, (#!>>) , (#!>>)
) where ) where
import Control.Monad (filterM)
import Control.Monad.IO.Class 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 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 -- | Opening subshell
spawnCmd :: MonadIO m => String -> [String] -> m () spawnCmd :: MonadIO m => String -> [String] -> m ()
spawnCmd cmd args = spawn $ fmtCmd cmd args 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 -- | Formatting commands
@ -192,3 +54,6 @@ doubleQuote s = "\"" ++ s ++ "\""
singleQuote :: String -> String singleQuote :: String -> String
singleQuote s = "'" ++ s ++ "'" singleQuote s = "'" ++ s ++ "'"
skip :: Monad m => m ()
skip = return ()

View File

@ -16,7 +16,7 @@ import Control.Monad
import Xmobar import Xmobar
import XMonad.Internal.DBus.IntelBacklight import XMonad.Internal.DBus.Brightness.IntelBacklight
newtype IntelBacklight = IntelBacklight String deriving (Read, Show) newtype IntelBacklight = IntelBacklight String deriving (Read, Show)
@ -26,8 +26,8 @@ blAlias = "intelbacklight"
instance Exec IntelBacklight where instance Exec IntelBacklight where
alias (IntelBacklight _) = blAlias alias (IntelBacklight _) = blAlias
start (IntelBacklight icon) cb = do start (IntelBacklight icon) cb = do
_ <- matchSignal $ cb . formatBrightness _ <- matchSignalIB $ cb . formatBrightness
cb . formatBrightness =<< callGetBrightness cb . formatBrightness =<< callGetBrightnessIB
forever (threadDelay 5000000) forever (threadDelay 5000000)
where where
formatBrightness = \case formatBrightness = \case

View File

@ -12,12 +12,14 @@ library
, XMonad.Internal.Theme , XMonad.Internal.Theme
, XMonad.Internal.Notify , XMonad.Internal.Notify
, XMonad.Internal.Shell , XMonad.Internal.Shell
, XMonad.Internal.Dependency
, XMonad.Internal.IO , XMonad.Internal.IO
, XMonad.Internal.Command.Desktop , XMonad.Internal.Command.Desktop
, XMonad.Internal.Command.DMenu , XMonad.Internal.Command.DMenu
, XMonad.Internal.Command.Power , XMonad.Internal.Command.Power
, XMonad.Internal.DBus.Common , 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.Control
, XMonad.Internal.DBus.Screensaver , XMonad.Internal.DBus.Screensaver
, XMonad.Internal.Process , XMonad.Internal.Process