diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 96f14fa..1b3b319 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -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 () diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 9663d8b..5886996 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -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-" "power menu" $ noCheck runPowerPrompt , KeyBinding "M-" "quit xmonad" $ noCheck runQuitPrompt , KeyBinding "M-" "lock screen" runScreenLock diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index 6dc1ced..7d352eb 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index 6d89b41..89c632f 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index f9e0e36..2f6e605 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -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 diff --git a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs index d6c5861..ec20567 100644 --- a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs +++ b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs @@ -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 diff --git a/lib/XMonad/Internal/Concurrent/Removable.hs b/lib/XMonad/Internal/Concurrent/Removable.hs index 50adfe6..26bce44 100644 --- a/lib/XMonad/Internal/Concurrent/Removable.hs +++ b/lib/XMonad/Internal/Concurrent/Removable.hs @@ -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" diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs new file mode 100644 index 0000000..9db5951 --- /dev/null +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -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" diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs new file mode 100644 index 0000000..20417a5 --- /dev/null +++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index cb76639..a87a231 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/IntelBacklight.hs b/lib/XMonad/Internal/DBus/IntelBacklight.hs deleted file mode 100644 index db8cced..0000000 --- a/lib/XMonad/Internal/DBus/IntelBacklight.hs +++ /dev/null @@ -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 diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index b6a4a3b..aa0468c 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -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 diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs new file mode 100644 index 0000000..2a23d1b --- /dev/null +++ b/lib/XMonad/Internal/Dependency.hs @@ -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] diff --git a/lib/XMonad/Internal/Shell.hs b/lib/XMonad/Internal/Shell.hs index 7c666bb..4c09b18 100644 --- a/lib/XMonad/Internal/Shell.hs +++ b/lib/XMonad/Internal/Shell.hs @@ -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 () diff --git a/lib/Xmobar/Plugins/IntelBacklight.hs b/lib/Xmobar/Plugins/IntelBacklight.hs index 3176686..aef6dbf 100644 --- a/lib/Xmobar/Plugins/IntelBacklight.hs +++ b/lib/Xmobar/Plugins/IntelBacklight.hs @@ -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 diff --git a/my-xmonad.cabal b/my-xmonad.cabal index 20b10f8..1f07edc 100644 --- a/my-xmonad.cabal +++ b/my-xmonad.cabal @@ -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