From c96bcc0bfa1640714fa9d5e05cc09b941d33985c Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Fri, 20 Mar 2020 23:47:02 -0400 Subject: [PATCH] ENH make signal happen when method is called --- lib/DBus/IntelBacklight.hs | 116 ++++++++++++++++--------------------- lib/DBus/Internal.hs | 24 ++------ lib/DBus/Screensaver.hs | 85 +++++++++++++++------------ 3 files changed, 101 insertions(+), 124 deletions(-) diff --git a/lib/DBus/IntelBacklight.hs b/lib/DBus/IntelBacklight.hs index c9bfd1e..3da5845 100644 --- a/lib/DBus/IntelBacklight.hs +++ b/lib/DBus/IntelBacklight.hs @@ -13,7 +13,7 @@ module DBus.IntelBacklight , matchSignal ) where -import Control.Monad (forM_) +import Control.Monad (void) import Data.Char @@ -25,6 +25,7 @@ import Data.Text.IO as T (readFile, writeFile) import DBus import DBus.Client +import DBus.Internal -------------------------------------------------------------------------------- -- | Low level sysfs functions @@ -69,6 +70,7 @@ getRawBrightness = readFileInt curFile setRawBrightness :: RawBrightness -> IO () setRawBrightness = T.writeFile curFile . pack . show +-- TODO this has rounding errors that make the steps uneven rawToNorm :: RawBrightness -> RawBrightness -> Brightness rawToNorm maxRaw curRaw = fromIntegral $ (curRaw - 1) * maxNorm `div` (maxRaw - 1) @@ -105,69 +107,48 @@ setBrightness maxRaw newNorm = do -- integer and emit a signal with the same brightness value. Additionally, there -- is one method to get the current brightness. -brPath :: ObjectPath -brPath = "/intelbacklight" +path :: ObjectPath +path = "/intelbacklight" -brInterface :: InterfaceName -brInterface = "org.xmonad.Brightness" +interface :: InterfaceName +interface = "org.xmonad.Brightness" -brCurrentBrightness :: MemberName -brCurrentBrightness = "CurrentBrightness" +memCurrentBrightness :: MemberName +memCurrentBrightness = "CurrentBrightness" -brGetBrightness :: MemberName -brGetBrightness = "GetBrightness" +memGetBrightness :: MemberName +memGetBrightness = "GetBrightness" -brMaxBrightness :: MemberName -brMaxBrightness = "MaxBrightness" +memMaxBrightness :: MemberName +memMaxBrightness = "MaxBrightness" -brMinBrightness :: MemberName -brMinBrightness = "MinBrightness" +memMinnBrightness :: MemberName +memMinnBrightness = "MinBrightness" -brIncBrightness :: MemberName -brIncBrightness = "IncBrightness" +memIncBrightness :: MemberName +memIncBrightness = "IncBrightness" -brDecBrightness :: MemberName -brDecBrightness = "DecBrightness" +memDecBrightness :: MemberName +memDecBrightness = "DecBrightness" brSignal :: Signal -brSignal = signal brPath brInterface brCurrentBrightness +brSignal = signal path interface memCurrentBrightness -- { signalDestination = Just "org.xmonad" } brMatcher :: MatchRule brMatcher = matchAny - { matchPath = Just brPath - , matchInterface = Just brInterface - , matchMember = Just brCurrentBrightness + { matchPath = Just path + , matchInterface = Just interface + , matchMember = Just memCurrentBrightness } -callBacklight :: Client -> MemberName -> IO (Maybe [Variant]) -callBacklight client method = do - -- TODO this will throw a clienterror if it cannot connect at all - reply <- call client (methodCall brPath brInterface method) - { methodCallDestination = Just "org.xmonad" } - return $ case reply of - Left _ -> Nothing - Right ret -> Just $ methodReturnBody ret -callBacklight' :: MemberName -> IO (Maybe Brightness) -callBacklight' method = do - client <- connectSession - body <- callBacklight client method - -- TODO this is a bit convoluted...I return the body in the reply of - -- the method call and feed that to the signal and then return the - -- body (the latter is not really necessary since the only things - -- that read the backlight status either use the signal or call - -- GetBrightness directly - forM_ body $ emitBrightness client - return $ body >>= signalBrightness +callBacklight :: MemberName -> IO () +callBacklight method = void $ callMethod $ methodCall path interface method -emitBrightness :: Client -> [Variant] -> IO () -emitBrightness client body = - emit client $ brSignal { signalBody = body } - -signalBrightness :: [Variant] -> Maybe Brightness -signalBrightness [b] = fromVariant b :: Maybe Brightness -signalBrightness _ = Nothing +bodyGetBrightness :: [Variant] -> Maybe Brightness +bodyGetBrightness [b] = fromVariant b :: Maybe Brightness +bodyGetBrightness _ = Nothing -- | Exported haskell API @@ -175,36 +156,39 @@ exportIntelBacklight :: Client -> IO () exportIntelBacklight client = do maxval <- getMaxRawBrightness -- assume the max value will never change let stepsize = maxBrightness `div` steps - export client brPath defaultInterface - { interfaceName = brInterface + let emit' = emitBrightness client + export client path defaultInterface + { interfaceName = interface , interfaceMethods = - [ autoMethod brMaxBrightness (setBrightness maxval maxBrightness) - , autoMethod brMinBrightness (setBrightness maxval 0) - , autoMethod brIncBrightness (changeBrightness maxval stepsize) - , autoMethod brDecBrightness (changeBrightness maxval (-stepsize)) - , autoMethod brGetBrightness (getBrightness maxval) + [ autoMethod memMaxBrightness $ emit' =<< setBrightness maxval maxBrightness + , autoMethod memMinnBrightness $ emit' =<< setBrightness maxval 0 + , autoMethod memIncBrightness $ emit' =<< changeBrightness maxval stepsize + , autoMethod memDecBrightness $ emit' =<< changeBrightness maxval (-stepsize) + , autoMethod memGetBrightness $ getBrightness maxval ] } -callMaxBrightness :: IO (Maybe Brightness) -callMaxBrightness = callBacklight' brMaxBrightness +emitBrightness :: Client -> Brightness -> IO () +emitBrightness client cur = emit client $ brSignal { signalBody = [toVariant cur] } -callMinBrightness :: IO (Maybe Brightness) -callMinBrightness = callBacklight' brMinBrightness +callMaxBrightness :: IO () +callMaxBrightness = callBacklight memMaxBrightness -callIncBrightness :: IO (Maybe Brightness) -callIncBrightness = callBacklight' brIncBrightness +callMinBrightness :: IO () +callMinBrightness = callBacklight memMinnBrightness -callDecBrightness :: IO (Maybe Brightness) -callDecBrightness = callBacklight' brDecBrightness +callIncBrightness :: IO () +callIncBrightness = callBacklight memIncBrightness + +callDecBrightness :: IO () +callDecBrightness = callBacklight memDecBrightness callGetBrightness :: IO (Maybe Brightness) callGetBrightness = do - client <- connectSession - body <- callBacklight client brGetBrightness - return $ body >>= signalBrightness + reply <- callMethod $ methodCall path interface memGetBrightness + return $ reply >>= bodyGetBrightness matchSignal :: (Maybe Brightness -> IO ()) -> IO SignalHandler matchSignal cb = do client <- connectSession - addMatch client brMatcher $ cb . signalBrightness . signalBody + addMatch client brMatcher $ cb . bodyGetBrightness . signalBody diff --git a/lib/DBus/Internal.hs b/lib/DBus/Internal.hs index 6a52106..ab0e965 100644 --- a/lib/DBus/Internal.hs +++ b/lib/DBus/Internal.hs @@ -2,35 +2,19 @@ module DBus.Internal where -import Control.Monad (forM_) - import DBus import DBus.Client -callMethod' :: Client -> MethodCall -> IO (Maybe [Variant]) -callMethod' client mc = do +-- TODO not all methods warrent that we wait for a reply? +callMethod :: MethodCall -> IO (Maybe [Variant]) +callMethod mc = do + client <- connectSession -- TODO handle clienterrors here reply <- call client mc { methodCallDestination = Just "org.xmonad" } return $ case reply of Left _ -> Nothing Right ret -> Just $ methodReturnBody ret -callMethod :: MethodCall -> ([Variant] -> Maybe a) -> IO (Maybe a) -callMethod mc procBody = do - client <- connectSession - body <- callMethod' client mc - return $ body >>= procBody - -callMethodEmit :: MethodCall - -> ([Variant] -> Maybe a) - -> ([Variant] -> Signal) - -> IO (Maybe a) -callMethodEmit mc procBody bodyToSignal = do - client <- connectSession - body <- callMethod' client mc - forM_ body $ emit client . bodyToSignal - return $ body >>= procBody - addMatchCallback :: MatchRule -> ([Variant] -> IO ()) -> IO SignalHandler addMatchCallback rule cb = do client <- connectSession diff --git a/lib/DBus/Screensaver.hs b/lib/DBus/Screensaver.hs index bef8afd..6c63ebb 100644 --- a/lib/DBus/Screensaver.hs +++ b/lib/DBus/Screensaver.hs @@ -3,7 +3,14 @@ -------------------------------------------------------------------------------- -- | DBus module for X11 screensave/DPMS control -module DBus.Screensaver where +module DBus.Screensaver + ( exportScreensaver + , callToggle + , callQuery + , matchSignal + ) where + +import Control.Monad (void) import DBus import DBus.Client @@ -46,59 +53,61 @@ query = do -------------------------------------------------------------------------------- -- | DBus Interface -- --- Define two methods to enable/disable the screensaver. These methods will --- emit signals with the state when called. Define another method to get the --- current state. +-- Define a methods to toggle the screensaver. This methods will emit signal +-- with the new state when called. Define another method to get the current +-- state. -ssPath :: ObjectPath -ssPath = "/screensaver" +path :: ObjectPath +path = "/screensaver" -ssInterface :: InterfaceName -ssInterface = "org.xmonad.Screensaver" +interface :: InterfaceName +interface = "org.xmonad.Screensaver" -ssState :: MemberName -ssState = "State" +memState :: MemberName +memState = "State" -ssToggle :: MemberName -ssToggle = "Toggle" +memToggle :: MemberName +memToggle = "Toggle" -ssQuery :: MemberName -ssQuery = "Query" +memQuery :: MemberName +memQuery = "Query" -ssSignal :: Signal -ssSignal = signal ssPath ssInterface ssState +sigCurrentState :: Signal +sigCurrentState = signal path interface memState -ssMatcher :: MatchRule -ssMatcher = matchAny - { matchPath = Just ssPath - , matchInterface = Just ssInterface - , matchMember = Just ssState +ruleCurrentState :: MatchRule +ruleCurrentState = matchAny + { matchPath = Just path + , matchInterface = Just interface + , matchMember = Just memState } +emitState :: Client -> SSState -> IO () +emitState client sss = emit client $ sigCurrentState { signalBody = [toVariant sss] } + +bodyGetCurrentState :: [Variant] -> Maybe SSState +bodyGetCurrentState [b] = fromVariant b :: Maybe SSState +bodyGetCurrentState _ = Nothing + +-- | Exported haskell API + exportScreensaver :: Client -> IO () exportScreensaver client = - export client ssPath defaultInterface - { interfaceName = ssInterface + export client path defaultInterface + { interfaceName = interface , interfaceMethods = - [ autoMethod ssToggle toggle - , autoMethod ssQuery query + [ autoMethod memToggle $ emitState client =<< toggle + , autoMethod memQuery query ] } -callToggle :: IO (Maybe SSState) -callToggle = callMethodEmit mc bodyState sig - where - mc = methodCall ssPath ssInterface ssToggle - sig b = ssSignal { signalBody = b } - -bodyState :: [Variant] -> Maybe SSState -bodyState [b] = fromVariant b :: Maybe SSState -bodyState _ = Nothing +callToggle :: IO () +callToggle = void $ callMethod $ methodCall path interface memToggle callQuery :: IO (Maybe SSState) -callQuery = callMethod mc bodyState - where - mc = methodCall ssPath ssInterface ssQuery +callQuery = do + reply <- callMethod $ methodCall path interface memQuery + return $ reply >>= bodyGetCurrentState matchSignal :: (Maybe SSState -> IO ()) -> IO SignalHandler -matchSignal cb = addMatchCallback ssMatcher $ cb . bodyState +matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState