ENH make signal happen when method is called
This commit is contained in:
parent
6ae7ca5df1
commit
c96bcc0bfa
|
@ -13,7 +13,7 @@ module DBus.IntelBacklight
|
||||||
, matchSignal
|
, matchSignal
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad (forM_)
|
import Control.Monad (void)
|
||||||
|
|
||||||
import Data.Char
|
import Data.Char
|
||||||
|
|
||||||
|
@ -25,6 +25,7 @@ import Data.Text.IO as T (readFile, writeFile)
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
import DBus.Internal
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Low level sysfs functions
|
-- | Low level sysfs functions
|
||||||
|
@ -69,6 +70,7 @@ getRawBrightness = readFileInt curFile
|
||||||
setRawBrightness :: RawBrightness -> IO ()
|
setRawBrightness :: RawBrightness -> IO ()
|
||||||
setRawBrightness = T.writeFile curFile . pack . show
|
setRawBrightness = T.writeFile curFile . pack . show
|
||||||
|
|
||||||
|
-- TODO this has rounding errors that make the steps uneven
|
||||||
rawToNorm :: RawBrightness -> RawBrightness -> Brightness
|
rawToNorm :: RawBrightness -> RawBrightness -> Brightness
|
||||||
rawToNorm maxRaw curRaw = fromIntegral
|
rawToNorm maxRaw curRaw = fromIntegral
|
||||||
$ (curRaw - 1) * maxNorm `div` (maxRaw - 1)
|
$ (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
|
-- integer and emit a signal with the same brightness value. Additionally, there
|
||||||
-- is one method to get the current brightness.
|
-- is one method to get the current brightness.
|
||||||
|
|
||||||
brPath :: ObjectPath
|
path :: ObjectPath
|
||||||
brPath = "/intelbacklight"
|
path = "/intelbacklight"
|
||||||
|
|
||||||
brInterface :: InterfaceName
|
interface :: InterfaceName
|
||||||
brInterface = "org.xmonad.Brightness"
|
interface = "org.xmonad.Brightness"
|
||||||
|
|
||||||
brCurrentBrightness :: MemberName
|
memCurrentBrightness :: MemberName
|
||||||
brCurrentBrightness = "CurrentBrightness"
|
memCurrentBrightness = "CurrentBrightness"
|
||||||
|
|
||||||
brGetBrightness :: MemberName
|
memGetBrightness :: MemberName
|
||||||
brGetBrightness = "GetBrightness"
|
memGetBrightness = "GetBrightness"
|
||||||
|
|
||||||
brMaxBrightness :: MemberName
|
memMaxBrightness :: MemberName
|
||||||
brMaxBrightness = "MaxBrightness"
|
memMaxBrightness = "MaxBrightness"
|
||||||
|
|
||||||
brMinBrightness :: MemberName
|
memMinnBrightness :: MemberName
|
||||||
brMinBrightness = "MinBrightness"
|
memMinnBrightness = "MinBrightness"
|
||||||
|
|
||||||
brIncBrightness :: MemberName
|
memIncBrightness :: MemberName
|
||||||
brIncBrightness = "IncBrightness"
|
memIncBrightness = "IncBrightness"
|
||||||
|
|
||||||
brDecBrightness :: MemberName
|
memDecBrightness :: MemberName
|
||||||
brDecBrightness = "DecBrightness"
|
memDecBrightness = "DecBrightness"
|
||||||
|
|
||||||
brSignal :: Signal
|
brSignal :: Signal
|
||||||
brSignal = signal brPath brInterface brCurrentBrightness
|
brSignal = signal path interface memCurrentBrightness
|
||||||
-- { signalDestination = Just "org.xmonad" }
|
-- { signalDestination = Just "org.xmonad" }
|
||||||
|
|
||||||
brMatcher :: MatchRule
|
brMatcher :: MatchRule
|
||||||
brMatcher = matchAny
|
brMatcher = matchAny
|
||||||
{ matchPath = Just brPath
|
{ matchPath = Just path
|
||||||
, matchInterface = Just brInterface
|
, matchInterface = Just interface
|
||||||
, matchMember = Just brCurrentBrightness
|
, 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 :: MemberName -> IO ()
|
||||||
callBacklight' method = do
|
callBacklight method = void $ callMethod $ methodCall path interface method
|
||||||
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
|
|
||||||
|
|
||||||
emitBrightness :: Client -> [Variant] -> IO ()
|
bodyGetBrightness :: [Variant] -> Maybe Brightness
|
||||||
emitBrightness client body =
|
bodyGetBrightness [b] = fromVariant b :: Maybe Brightness
|
||||||
emit client $ brSignal { signalBody = body }
|
bodyGetBrightness _ = Nothing
|
||||||
|
|
||||||
signalBrightness :: [Variant] -> Maybe Brightness
|
|
||||||
signalBrightness [b] = fromVariant b :: Maybe Brightness
|
|
||||||
signalBrightness _ = Nothing
|
|
||||||
|
|
||||||
-- | Exported haskell API
|
-- | Exported haskell API
|
||||||
|
|
||||||
|
@ -175,36 +156,39 @@ exportIntelBacklight :: Client -> IO ()
|
||||||
exportIntelBacklight client = do
|
exportIntelBacklight client = do
|
||||||
maxval <- getMaxRawBrightness -- assume the max value will never change
|
maxval <- getMaxRawBrightness -- assume the max value will never change
|
||||||
let stepsize = maxBrightness `div` steps
|
let stepsize = maxBrightness `div` steps
|
||||||
export client brPath defaultInterface
|
let emit' = emitBrightness client
|
||||||
{ interfaceName = brInterface
|
export client path defaultInterface
|
||||||
|
{ interfaceName = interface
|
||||||
, interfaceMethods =
|
, interfaceMethods =
|
||||||
[ autoMethod brMaxBrightness (setBrightness maxval maxBrightness)
|
[ autoMethod memMaxBrightness $ emit' =<< setBrightness maxval maxBrightness
|
||||||
, autoMethod brMinBrightness (setBrightness maxval 0)
|
, autoMethod memMinnBrightness $ emit' =<< setBrightness maxval 0
|
||||||
, autoMethod brIncBrightness (changeBrightness maxval stepsize)
|
, autoMethod memIncBrightness $ emit' =<< changeBrightness maxval stepsize
|
||||||
, autoMethod brDecBrightness (changeBrightness maxval (-stepsize))
|
, autoMethod memDecBrightness $ emit' =<< changeBrightness maxval (-stepsize)
|
||||||
, autoMethod brGetBrightness (getBrightness maxval)
|
, autoMethod memGetBrightness $ getBrightness maxval
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
|
|
||||||
callMaxBrightness :: IO (Maybe Brightness)
|
emitBrightness :: Client -> Brightness -> IO ()
|
||||||
callMaxBrightness = callBacklight' brMaxBrightness
|
emitBrightness client cur = emit client $ brSignal { signalBody = [toVariant cur] }
|
||||||
|
|
||||||
callMinBrightness :: IO (Maybe Brightness)
|
callMaxBrightness :: IO ()
|
||||||
callMinBrightness = callBacklight' brMinBrightness
|
callMaxBrightness = callBacklight memMaxBrightness
|
||||||
|
|
||||||
callIncBrightness :: IO (Maybe Brightness)
|
callMinBrightness :: IO ()
|
||||||
callIncBrightness = callBacklight' brIncBrightness
|
callMinBrightness = callBacklight memMinnBrightness
|
||||||
|
|
||||||
callDecBrightness :: IO (Maybe Brightness)
|
callIncBrightness :: IO ()
|
||||||
callDecBrightness = callBacklight' brDecBrightness
|
callIncBrightness = callBacklight memIncBrightness
|
||||||
|
|
||||||
|
callDecBrightness :: IO ()
|
||||||
|
callDecBrightness = callBacklight memDecBrightness
|
||||||
|
|
||||||
callGetBrightness :: IO (Maybe Brightness)
|
callGetBrightness :: IO (Maybe Brightness)
|
||||||
callGetBrightness = do
|
callGetBrightness = do
|
||||||
client <- connectSession
|
reply <- callMethod $ methodCall path interface memGetBrightness
|
||||||
body <- callBacklight client brGetBrightness
|
return $ reply >>= bodyGetBrightness
|
||||||
return $ body >>= signalBrightness
|
|
||||||
|
|
||||||
matchSignal :: (Maybe Brightness -> IO ()) -> IO SignalHandler
|
matchSignal :: (Maybe Brightness -> IO ()) -> IO SignalHandler
|
||||||
matchSignal cb = do
|
matchSignal cb = do
|
||||||
client <- connectSession
|
client <- connectSession
|
||||||
addMatch client brMatcher $ cb . signalBrightness . signalBody
|
addMatch client brMatcher $ cb . bodyGetBrightness . signalBody
|
||||||
|
|
|
@ -2,35 +2,19 @@
|
||||||
|
|
||||||
module DBus.Internal where
|
module DBus.Internal where
|
||||||
|
|
||||||
import Control.Monad (forM_)
|
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
|
||||||
callMethod' :: Client -> MethodCall -> IO (Maybe [Variant])
|
-- TODO not all methods warrent that we wait for a reply?
|
||||||
callMethod' client mc = do
|
callMethod :: MethodCall -> IO (Maybe [Variant])
|
||||||
|
callMethod mc = do
|
||||||
|
client <- connectSession
|
||||||
-- TODO handle clienterrors here
|
-- TODO handle clienterrors here
|
||||||
reply <- call client mc { methodCallDestination = Just "org.xmonad" }
|
reply <- call client mc { methodCallDestination = Just "org.xmonad" }
|
||||||
return $ case reply of
|
return $ case reply of
|
||||||
Left _ -> Nothing
|
Left _ -> Nothing
|
||||||
Right ret -> Just $ methodReturnBody ret
|
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 :: MatchRule -> ([Variant] -> IO ()) -> IO SignalHandler
|
||||||
addMatchCallback rule cb = do
|
addMatchCallback rule cb = do
|
||||||
client <- connectSession
|
client <- connectSession
|
||||||
|
|
|
@ -3,7 +3,14 @@
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus module for X11 screensave/DPMS control
|
-- | 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
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
@ -46,59 +53,61 @@ query = do
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus Interface
|
-- | DBus Interface
|
||||||
--
|
--
|
||||||
-- Define two methods to enable/disable the screensaver. These methods will
|
-- Define a methods to toggle the screensaver. This methods will emit signal
|
||||||
-- emit signals with the state when called. Define another method to get the
|
-- with the new state when called. Define another method to get the current
|
||||||
-- current state.
|
-- state.
|
||||||
|
|
||||||
ssPath :: ObjectPath
|
path :: ObjectPath
|
||||||
ssPath = "/screensaver"
|
path = "/screensaver"
|
||||||
|
|
||||||
ssInterface :: InterfaceName
|
interface :: InterfaceName
|
||||||
ssInterface = "org.xmonad.Screensaver"
|
interface = "org.xmonad.Screensaver"
|
||||||
|
|
||||||
ssState :: MemberName
|
memState :: MemberName
|
||||||
ssState = "State"
|
memState = "State"
|
||||||
|
|
||||||
ssToggle :: MemberName
|
memToggle :: MemberName
|
||||||
ssToggle = "Toggle"
|
memToggle = "Toggle"
|
||||||
|
|
||||||
ssQuery :: MemberName
|
memQuery :: MemberName
|
||||||
ssQuery = "Query"
|
memQuery = "Query"
|
||||||
|
|
||||||
ssSignal :: Signal
|
sigCurrentState :: Signal
|
||||||
ssSignal = signal ssPath ssInterface ssState
|
sigCurrentState = signal path interface memState
|
||||||
|
|
||||||
ssMatcher :: MatchRule
|
ruleCurrentState :: MatchRule
|
||||||
ssMatcher = matchAny
|
ruleCurrentState = matchAny
|
||||||
{ matchPath = Just ssPath
|
{ matchPath = Just path
|
||||||
, matchInterface = Just ssInterface
|
, matchInterface = Just interface
|
||||||
, matchMember = Just ssState
|
, 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 -> IO ()
|
||||||
exportScreensaver client =
|
exportScreensaver client =
|
||||||
export client ssPath defaultInterface
|
export client path defaultInterface
|
||||||
{ interfaceName = ssInterface
|
{ interfaceName = interface
|
||||||
, interfaceMethods =
|
, interfaceMethods =
|
||||||
[ autoMethod ssToggle toggle
|
[ autoMethod memToggle $ emitState client =<< toggle
|
||||||
, autoMethod ssQuery query
|
, autoMethod memQuery query
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
|
|
||||||
callToggle :: IO (Maybe SSState)
|
callToggle :: IO ()
|
||||||
callToggle = callMethodEmit mc bodyState sig
|
callToggle = void $ callMethod $ methodCall path interface memToggle
|
||||||
where
|
|
||||||
mc = methodCall ssPath ssInterface ssToggle
|
|
||||||
sig b = ssSignal { signalBody = b }
|
|
||||||
|
|
||||||
bodyState :: [Variant] -> Maybe SSState
|
|
||||||
bodyState [b] = fromVariant b :: Maybe SSState
|
|
||||||
bodyState _ = Nothing
|
|
||||||
|
|
||||||
callQuery :: IO (Maybe SSState)
|
callQuery :: IO (Maybe SSState)
|
||||||
callQuery = callMethod mc bodyState
|
callQuery = do
|
||||||
where
|
reply <- callMethod $ methodCall path interface memQuery
|
||||||
mc = methodCall ssPath ssInterface ssQuery
|
return $ reply >>= bodyGetCurrentState
|
||||||
|
|
||||||
matchSignal :: (Maybe SSState -> IO ()) -> IO SignalHandler
|
matchSignal :: (Maybe SSState -> IO ()) -> IO SignalHandler
|
||||||
matchSignal cb = addMatchCallback ssMatcher $ cb . bodyState
|
matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
|
||||||
|
|
Loading…
Reference in New Issue