ndwarshuis
/
xmonad-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

REF overload internal dbus functions

This commit is contained in:
Nathan Dwarshuis 2022-07-09 17:44:14 -04:00
parent cfde8865c1
commit dda7a96d4c
22 changed files with 172 additions and 201 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
bin/xmobar.hs
View File

@ -11,6 +11,8 @@ module Main (main) where
-- * Theme integration with xmonad (shared module imported below)
-- * A custom Locks plugin from my own forked repo
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.List
import Data.Maybe
@ -38,7 +40,6 @@ import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Control
import XMonad.Internal.DBus.Screensaver (ssSignalDep)
import XMonad.Internal.Dependency
import XMonad.Internal.Process
( proc'
, readCreateProcessWithExitCode'

3
bin/xmonad.hs
View File

@ -10,6 +10,8 @@ import Control.Concurrent
import Control.Concurrent.Lifted (fork)
import Control.Monad
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.List
( intercalate
, isPrefixOf
@ -53,7 +55,6 @@ import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Control
import XMonad.Internal.DBus.Removable
import XMonad.Internal.DBus.Screensaver
import XMonad.Internal.Dependency
import XMonad.Internal.Process
import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as T

144
lib/DBus/Internal.hs → lib/Data/Internal/DBus.hs
View File

@ -1,12 +1,11 @@
--------------------------------------------------------------------------------
-- | Common internal DBus functions
module DBus.Internal
( addMatchCallback
-- , getDBusClient
-- , fromDBusClient
-- , withDBusClient
-- , withDBusClient_
module Data.Internal.DBus
( SafeClient(..)
, SysClient(..)
, SesClient(..)
, addMatchCallback
, matchProperty
, matchPropertyFull
, matchPropertyChanged
@ -28,26 +27,70 @@ module DBus.Internal
, bodyToMaybe
) where
-- import Control.Exception
import Control.Exception
import Control.Monad
import Data.Bifunctor
import qualified Data.Map.Strict as M
import qualified Data.Map.Strict as M
import Data.Maybe
import DBus
import DBus.Client
--------------------------------------------------------------------------------
-- | Type-safe client
class SafeClient c where
toClient :: c -> Client
getDBusClient :: IO (Maybe c)
withDBusClient :: (c -> IO a) -> IO (Maybe a)
withDBusClient f = do
client <- getDBusClient
forM client $ \c -> do
r <- f c
disconnect (toClient c)
return r
withDBusClient_ :: (c -> IO ()) -> IO ()
withDBusClient_ = void . withDBusClient
fromDBusClient :: (c -> a) -> IO (Maybe a)
fromDBusClient f = withDBusClient (return . f)
newtype SysClient = SysClient Client
instance SafeClient SysClient where
toClient (SysClient cl) = cl
getDBusClient = fmap SysClient <$> getDBusClient' True
newtype SesClient = SesClient Client
instance SafeClient SesClient where
toClient (SesClient cl) = cl
getDBusClient = fmap SesClient <$> getDBusClient' False
getDBusClient' :: Bool -> IO (Maybe Client)
getDBusClient' sys = do
res <- try $ if sys then connectSystem else connectSession
case res of
Left e -> putStrLn (clientErrorMessage e) >> return Nothing
Right c -> return $ Just c
--------------------------------------------------------------------------------
-- | Methods
type MethodBody = Either String [Variant]
callMethod' :: Client -> MethodCall -> IO MethodBody
callMethod' cl = fmap (bimap methodErrorMessage methodReturnBody) . call cl
callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
callMethod' cl = fmap (bimap methodErrorMessage methodReturnBody)
. call (toClient cl)
callMethod :: Client -> BusName -> ObjectPath -> InterfaceName -> MemberName
-> IO MethodBody
callMethod :: SafeClient c => c -> BusName -> ObjectPath -> InterfaceName
-> MemberName -> IO MethodBody
callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
@ -60,8 +103,8 @@ methodCallBus b p i m = (methodCall p i m)
dbusInterface :: InterfaceName
dbusInterface = interfaceName_ "org.freedesktop.DBus"
callGetNameOwner :: Client -> BusName -> IO (Maybe BusName)
callGetNameOwner client name = bodyToMaybe <$> callMethod' client mc
callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName)
callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
where
mc = (methodCallBus dbusName dbusPath dbusInterface mem)
{ methodCallBody = [toVariant name] }
@ -81,8 +124,9 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
type SignalCallback = [Variant] -> IO ()
addMatchCallback :: MatchRule -> SignalCallback -> Client -> IO SignalHandler
addMatchCallback rule cb client = addMatch client rule $ cb . signalBody
addMatchCallback :: SafeClient c => MatchRule -> SignalCallback -> c
-> IO SignalHandler
addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody
matchSignal :: Maybe BusName -> Maybe ObjectPath -> Maybe InterfaceName
-> Maybe MemberName -> MatchRule
@ -93,8 +137,8 @@ matchSignal b p i m = matchAny
, matchMember = m
}
matchSignalFull :: Client -> BusName -> Maybe ObjectPath -> Maybe InterfaceName
-> Maybe MemberName -> IO (Maybe MatchRule)
matchSignalFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
-> Maybe InterfaceName -> Maybe MemberName -> IO (Maybe MatchRule)
matchSignalFull client b p i m =
fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
@ -107,18 +151,19 @@ propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
propertySignal :: MemberName
propertySignal = memberName_ "PropertiesChanged"
callPropertyGet :: BusName -> ObjectPath -> InterfaceName -> MemberName -> Client
-> IO [Variant]
callPropertyGet bus path iface property client = fmap (either (const []) (:[]))
$ getProperty client $ methodCallBus bus path iface property
callPropertyGet :: SafeClient c => BusName -> ObjectPath -> InterfaceName
-> MemberName -> c -> IO [Variant]
callPropertyGet bus path iface property cl = fmap (either (const []) (:[]))
$ getProperty (toClient cl) $ methodCallBus bus path iface property
matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
matchProperty b p =
matchSignal b p (Just propertyInterface) (Just propertySignal)
matchPropertyFull :: Client -> BusName -> Maybe ObjectPath -> IO (Maybe MatchRule)
matchPropertyFull client b p =
matchSignalFull client b p (Just propertyInterface) (Just propertySignal)
matchPropertyFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
-> IO (Maybe MatchRule)
matchPropertyFull cl b p =
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
@ -141,30 +186,6 @@ matchPropertyChanged iface property [i, body, _] =
toMap v = fromVariant v :: Maybe (M.Map String Variant)
matchPropertyChanged _ _ _ = Failure
--------------------------------------------------------------------------------
-- | Client requests
-- getDBusClient :: Bool -> IO (Maybe Client)
-- getDBusClient sys = do
-- res <- try $ if sys then connectSystem else connectSession
-- case res of
-- Left e -> putStrLn (clientErrorMessage e) >> return Nothing
-- Right c -> return $ Just c
-- withDBusClient :: Bool -> (c -> IO a) -> IO (Maybe a)
-- withDBusClient sys f = do
-- client <- getDBusClient sys
-- forM client $ \c -> do
-- r <- f c
-- disconnect c
-- return r
-- withDBusClient_ :: Bool -> (Client -> IO ()) -> IO ()
-- withDBusClient_ sys = void . withDBusClient sys
-- fromDBusClient :: Bool -> (Client -> a) -> IO (Maybe a)
-- fromDBusClient sys f = withDBusClient sys (return . f)
--------------------------------------------------------------------------------
-- | Object Manager
@ -182,23 +203,24 @@ omInterfacesAdded = memberName_ "InterfacesAdded"
omInterfacesRemoved :: MemberName
omInterfacesRemoved = memberName_ "InterfacesRemoved"
callGetManagedObjects :: Client -> BusName -> ObjectPath -> IO ObjectTree
callGetManagedObjects client bus path =
callGetManagedObjects :: SafeClient c => c -> BusName -> ObjectPath
-> IO ObjectTree
callGetManagedObjects cl bus path =
either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
<$> callMethod client bus path omInterface getManagedObjects
<$> callMethod cl bus path omInterface getManagedObjects
addInterfaceChangedListener :: BusName -> MemberName -> ObjectPath
-> SignalCallback -> Client -> IO (Maybe SignalHandler)
addInterfaceChangedListener bus prop path sc client = do
rule <- matchSignalFull client bus (Just path) (Just omInterface) (Just prop)
forM rule $ \r -> addMatchCallback r sc client
addInterfaceChangedListener :: SafeClient c => BusName -> MemberName
-> ObjectPath -> SignalCallback -> c -> IO (Maybe SignalHandler)
addInterfaceChangedListener bus prop path sc cl = do
rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
forM rule $ \r -> addMatchCallback r sc cl
addInterfaceAddedListener :: BusName -> ObjectPath -> SignalCallback -> Client
-> IO (Maybe SignalHandler)
addInterfaceAddedListener :: SafeClient c => BusName -> ObjectPath
-> SignalCallback -> c -> IO (Maybe SignalHandler)
addInterfaceAddedListener bus =
addInterfaceChangedListener bus omInterfacesAdded
addInterfaceRemovedListener :: BusName -> ObjectPath -> SignalCallback -> Client
-> IO (Maybe SignalHandler)
addInterfaceRemovedListener :: SafeClient c => BusName -> ObjectPath
-> SignalCallback -> c -> IO (Maybe SignalHandler)
addInterfaceRemovedListener bus =
addInterfaceChangedListener bus omInterfacesRemoved

75
lib/XMonad/Internal/Dependency.hs → lib/Data/Internal/Dependency.hs
View File

@ -8,7 +8,7 @@
--------------------------------------------------------------------------------
-- | Functions for handling dependencies
module XMonad.Internal.Dependency
module Data.Internal.Dependency
-- feature types
( Feature
, Always(..)
@ -41,8 +41,6 @@ module XMonad.Internal.Dependency
, DBusTree
, DBusTree_
, SafeClient(..)
, SysClient(..)
, SesClient(..)
, IODependency(..)
, IODependency_(..)
, SystemDependency(..)
@ -112,7 +110,6 @@ module XMonad.Internal.Dependency
, shellTest
) where
import Control.Exception hiding (bracket)
import Control.Monad.IO.Class
import Control.Monad.Identity
import Control.Monad.Reader
@ -124,6 +121,7 @@ import Data.Bifunctor
import Data.Either
import qualified Data.HashMap.Strict as H
import Data.Hashable
import Data.Internal.DBus
import Data.List
import Data.Maybe
import Data.Yaml
@ -132,8 +130,6 @@ import GHC.Generics (Generic)
import GHC.IO.Exception (ioe_description)
import DBus hiding (typeOf)
import DBus.Client
import DBus.Internal
import qualified DBus.Introspection as I
import System.Directory
@ -300,47 +296,6 @@ data Root a = forall p. IORoot (p -> a) (IOTree p)
| forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
| forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c)
class SafeClient c where
toClient :: c -> Client
getDBusClient :: IO (Maybe c)
withDBusClient :: (c -> IO a) -> IO (Maybe a)
withDBusClient f = do
client <- getDBusClient
forM client $ \c -> do
r <- f c
disconnect (toClient c)
return r
withDBusClient_ :: (c -> IO ()) -> IO ()
withDBusClient_ = void . withDBusClient
fromDBusClient :: (c -> a) -> IO (Maybe a)
fromDBusClient f = withDBusClient (return . f)
newtype SysClient = SysClient Client
instance SafeClient SysClient where
toClient (SysClient cl) = cl
getDBusClient = fmap SysClient <$> getDBusClient' True
newtype SesClient = SesClient Client
instance SafeClient SesClient where
toClient (SesClient cl) = cl
getDBusClient = fmap SesClient <$> getDBusClient' False
getDBusClient' :: Bool -> IO (Maybe Client)
getDBusClient' sys = do
res <- try $ if sys then connectSystem else connectSession
case res of
Left e -> putStrLn (clientErrorMessage e) >> return Nothing
Right c -> return $ Just c
-- | The dependency tree with rule to merge results when needed
data Tree d d_ p =
forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y)
@ -937,7 +892,7 @@ testDBusDependency_ = testDBusDependency'_
testDBusDependency'_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_
testDBusDependency'_ cl (Bus _ bus) = io $ do
ret <- callMethod (toClient cl) queryBus queryPath queryIface queryMem
ret <- callMethod cl queryBus queryPath queryIface queryMem
return $ case ret of
Left e -> Left [Msg Error e]
Right b -> let ns = bodyGetNames b in
@ -955,7 +910,7 @@ testDBusDependency'_ cl (Bus _ bus) = io $ do
bodyGetNames _ = []
testDBusDependency'_ cl (Endpoint _ busname objpath iface mem) = io $ do
ret <- callMethod (toClient cl) busname objpath introspectInterface introspectMethod
ret <- callMethod cl busname objpath introspectInterface introspectMethod
return $ case ret of
Left e -> Left [Msg Error e]
Right body -> procBody body
@ -1055,7 +1010,7 @@ sometimesEndpoint fn name ful busname path iface mem cl =
sometimesDBus cl fn name deps cmd
where
deps = Only_ $ Endpoint ful busname path iface $ Method_ mem
cmd c = io $ void $ callMethod (toClient c) busname path iface mem
cmd c = io $ void $ callMethod c busname path iface mem
--------------------------------------------------------------------------------
-- | Dependency Tree Constructors
@ -1395,23 +1350,3 @@ bracket s = "[" ++ s ++ "]"
curly :: String -> String
curly s = "{" ++ s ++ "}"
--------------------------------------------------------------------------------
-- | Other random formatting
-- failedMsgsIO :: Bool -> String -> [SubfeatureFail] -> FIO [Msg]
-- failedMsgsIO err fn = io . failedMsgs err fn
-- failedMsgs :: Bool -> String -> [SubfeatureFail] -> IO [Msg]
-- failedMsgs err fn = fmap concat . mapM (failedMsg err fn)
-- failedMsg :: Bool -> String -> SubfeatureFail -> IO [Msg]
-- failedMsg err fn Subfeature { sfData = d, sfName = n } = do
-- mapM (fmtMsg err fn n) $ case d of (PostMissing e) -> [e]; (PostFail es) -> es
-- fmtMsg :: Bool -> String -> String -> Msg -> IO Msg
-- fmtMsg err fn n msg = do
-- let e = if err then "ERROR" else "WARNING"
-- p <- getProgName
-- return $ unwords [bracket p, bracket e, bracket fn, bracket n, msg]

4
lib/XMonad/Internal/Command/DMenu.hs
View File

@ -17,6 +17,9 @@ module XMonad.Internal.Command.DMenu
import Control.Monad.Reader
import Data.Internal.DBus
import Data.Internal.Dependency
import DBus
import Graphics.X11.Types
@ -30,7 +33,6 @@ import System.IO
import XMonad.Core hiding (spawn)
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import XMonad.Internal.Dependency
import XMonad.Internal.Notify
import XMonad.Internal.Process
import XMonad.Internal.Shell

4
lib/XMonad/Internal/Command/Desktop.hs
View File

@ -42,6 +42,9 @@ module XMonad.Internal.Command.Desktop
import Control.Monad (void)
import Control.Monad.IO.Class
import Data.Internal.DBus
import Data.Internal.Dependency
import DBus
import System.Directory
@ -53,7 +56,6 @@ import XMonad (asks)
import XMonad.Actions.Volume
import XMonad.Core hiding (spawn)
import XMonad.Internal.DBus.Common
import XMonad.Internal.Dependency
import XMonad.Internal.Notify
import XMonad.Internal.Process
import XMonad.Internal.Shell

3
lib/XMonad/Internal/Command/Power.hs
View File

@ -27,6 +27,8 @@ module XMonad.Internal.Command.Power
import Control.Arrow (first)
import Data.Internal.Dependency
import Data.Either
import qualified Data.Map as M
@ -39,7 +41,6 @@ import System.IO.Error
import System.Process (ProcessHandle)
import XMonad.Core
import XMonad.Internal.Dependency
import XMonad.Internal.Process (spawnPipeArgs)
import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as T

2
lib/XMonad/Internal/Concurrent/ACPIEvent.hs
View File

@ -15,6 +15,7 @@ import Control.Monad
import Data.ByteString hiding (readFile)
import Data.ByteString.Char8 as C hiding (readFile)
import Data.Connection
import Data.Internal.Dependency
import Text.Read (readMaybe)
@ -24,7 +25,6 @@ import System.IO.Streams.UnixSocket
import XMonad.Core
import XMonad.Internal.Command.Power
import XMonad.Internal.Concurrent.ClientMessage
import XMonad.Internal.Dependency
import XMonad.Internal.Shell
import XMonad.Internal.Theme (FontBuilder)

3
lib/XMonad/Internal/Concurrent/VirtualBox.hs
View File

@ -8,11 +8,12 @@ module XMonad.Internal.Concurrent.VirtualBox
import Control.Exception
import Data.Internal.Dependency
import Text.XML.Light
import System.Directory
import XMonad.Internal.Dependency
import XMonad.Internal.Shell
vmExists :: String -> IO (Maybe Msg)

7
lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs
View File

@ -13,13 +13,14 @@ module XMonad.Internal.DBus.Brightness.ClevoKeyboard
import Control.Monad (when)
import Data.Int (Int32)
import Data.Internal.DBus
import Data.Internal.Dependency
import DBus
import System.FilePath.Posix
import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.Dependency
import XMonad.Internal.IO
--------------------------------------------------------------------------------
@ -123,7 +124,7 @@ clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
callGetBrightnessCK :: SesClient -> IO (Maybe Brightness)
callGetBrightnessCK = callGetBrightness clevoKeyboardConfig . toClient
callGetBrightnessCK = callGetBrightness clevoKeyboardConfig
matchSignalCK :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
matchSignalCK cb = matchSignal clevoKeyboardConfig cb . toClient
matchSignalCK = matchSignal clevoKeyboardConfig

12
lib/XMonad/Internal/DBus/Brightness/Common.hs
View File

@ -14,15 +14,15 @@ module XMonad.Internal.DBus.Brightness.Common
import Control.Monad (void)
import Data.Int (Int32)
import Data.Internal.DBus
import Data.Internal.Dependency
import DBus
import DBus.Client
import DBus.Internal
import qualified DBus.Introspection as I
import XMonad.Core (io)
import XMonad.Internal.DBus.Common
import XMonad.Internal.Dependency
--------------------------------------------------------------------------------
-- | External API
@ -64,7 +64,8 @@ brightnessControls q bc cl =
where
cb = callBacklight q cl bc
callGetBrightness :: Num c => BrightnessConfig a b -> Client -> IO (Maybe c)
callGetBrightness :: (SafeClient c, Num n) => BrightnessConfig a b -> c
-> IO (Maybe n)
callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client =
either (const Nothing) bodyGetBrightness
<$> callMethod client xmonadBusName p i memGet
@ -73,7 +74,8 @@ signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient
signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
Endpoint [] xmonadBusName p i $ Signal_ memCur
matchSignal :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> Client -> IO ()
matchSignal :: (SafeClient c, Num n) => BrightnessConfig a b
-> (Maybe n-> IO ()) -> c -> IO ()
matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
void . addMatchCallback brMatcher (cb . bodyGetBrightness)
where
@ -139,7 +141,7 @@ callBacklight q cl BrightnessConfig { bcPath = p
Sometimes (unwords [n, controlName]) q [Subfeature root "method call"]
where
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
cmd c = io $ void $ callMethod (toClient c) xmonadBusName p i m
cmd c = io $ void $ callMethod c xmonadBusName p i m
bodyGetBrightness :: Num a => [Variant] -> Maybe a
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)

7
lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs
View File

@ -11,13 +11,14 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
) where
import Data.Int (Int32)
import Data.Internal.DBus
import Data.Internal.Dependency
import DBus
import System.FilePath.Posix
import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.Dependency
import XMonad.Internal.IO
--------------------------------------------------------------------------------
@ -105,7 +106,7 @@ intelBacklightControls :: Maybe SesClient -> BrightnessControls
intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
callGetBrightnessIB :: SesClient -> IO (Maybe Brightness)
callGetBrightnessIB = callGetBrightness intelBacklightConfig . toClient
callGetBrightnessIB = callGetBrightness intelBacklightConfig
matchSignalIB :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
matchSignalIB cb = matchSignal intelBacklightConfig cb . toClient
matchSignalIB = matchSignal intelBacklightConfig

4
lib/XMonad/Internal/DBus/Control.hs
View File

@ -19,6 +19,9 @@ module XMonad.Internal.DBus.Control
import Control.Monad
import Data.Internal.DBus
import Data.Internal.Dependency
import DBus
import DBus.Client
@ -26,7 +29,6 @@ import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common
import XMonad.Internal.DBus.Screensaver
import XMonad.Internal.Dependency
-- | Current connections to the DBus (session and system buses)
data DBusState = DBusState

5
lib/XMonad/Internal/DBus/Removable.hs
View File

@ -8,14 +8,15 @@ module XMonad.Internal.DBus.Removable (runRemovableMon) where
import Control.Monad
import Data.Map.Lazy (Map, member)
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.Map.Strict (Map, member)
import DBus
import DBus.Client
import XMonad.Core (io)
import XMonad.Internal.Command.Desktop
import XMonad.Internal.Dependency
bus :: BusName
bus = busName_ "org.freedesktop.UDisks2"

13
lib/XMonad/Internal/DBus/Screensaver.hs
View File

@ -11,16 +11,17 @@ module XMonad.Internal.DBus.Screensaver
import Control.Monad (void)
import Data.Internal.DBus
import Data.Internal.Dependency
import DBus
import DBus.Client
import DBus.Internal
import qualified DBus.Introspection as I
import Graphics.X11.XScreenSaver
import Graphics.X11.Xlib.Display
import XMonad.Internal.DBus.Common
import XMonad.Internal.Dependency
import XMonad.Internal.Process
--------------------------------------------------------------------------------
@ -124,14 +125,14 @@ callToggle :: Maybe SesClient -> SometimesIO
callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" []
xmonadBusName ssPath interface memToggle
callQuery :: Client -> IO (Maybe SSState)
callQuery client = do
reply <- callMethod client xmonadBusName ssPath interface memQuery
callQuery :: SesClient -> IO (Maybe SSState)
callQuery ses = do
reply <- callMethod ses xmonadBusName ssPath interface memQuery
return $ either (const Nothing) bodyGetCurrentState reply
matchSignal :: (Maybe SSState -> IO ()) -> SesClient -> IO ()
matchSignal cb ses = void $ addMatchCallback ruleCurrentState
(cb . bodyGetCurrentState) $ toClient ses
(cb . bodyGetCurrentState) ses
ssSignalDep :: DBusDependency_ SesClient
ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState

3
lib/Xmobar/Plugins/BacklightCommon.hs
View File

@ -6,7 +6,8 @@
module Xmobar.Plugins.BacklightCommon (startBacklight) where
import XMonad.Internal.Dependency
import Data.Internal.DBus
import Xmobar.Plugins.Common
startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ())

28
lib/Xmobar/Plugins/Bluetooth.hs
View File

@ -39,6 +39,8 @@ module Xmobar.Plugins.Bluetooth
import Control.Concurrent.MVar
import Control.Monad
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.List
import Data.List.Split
import qualified Data.Map as M
@ -46,10 +48,8 @@ import Data.Maybe
import DBus
import DBus.Client
import DBus.Internal
import XMonad.Internal.DBus.Common
import XMonad.Internal.Dependency
import Xmobar
import Xmobar.Plugins.Common
@ -158,13 +158,13 @@ splitPath :: ObjectPath -> [String]
splitPath = splitOn "/" . dropWhile (=='/') . formatObjectPath
getBtObjectTree :: SysClient -> IO ObjectTree
getBtObjectTree sys = callGetManagedObjects (toClient sys) btBus btOMPath
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
btOMPath :: ObjectPath
btOMPath = objectPath_ "/"
addBtOMListener :: SignalCallback -> SysClient -> IO ()
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc . toClient
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
addDeviceAddedListener state display adapter client =
@ -195,19 +195,19 @@ initAdapter state adapter client = do
putPowered state $ fromSingletonVariant reply
matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
matchBTProperty client p = matchPropertyFull (toClient client) btBus (Just p)
matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
-> IO (Maybe SignalHandler)
addAdaptorListener state display adaptor sys = do
rule <- matchBTProperty sys adaptor
forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) (toClient sys)
forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys
where
procMatch = withSignalMatch $ \b -> putPowered state b >> display
callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
callGetPowered adapter sys =
callPropertyGet btBus adapter adapterInterface (memberName_ adaptorPowered) $ toClient sys
callGetPowered adapter = callPropertyGet btBus adapter adapterInterface
$ memberName_ adaptorPowered
matchPowered :: [Variant] -> SignalMatch Bool
matchPowered = matchPropertyChanged adapterInterface adaptorPowered
@ -234,8 +234,8 @@ addAndInitDevice state display device client = do
forM_ sh $ \s -> initDevice state s device client
initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
initDevice state sh device client = do
reply <- callGetConnected device (toClient client)
initDevice state sh device sys = do
reply <- callGetConnected device sys
void $ insertDevice state device $
BTDevice { btDevConnected = fromVariant =<< listToMaybe reply
, btDevSigHandler = sh
@ -243,16 +243,16 @@ initDevice state sh device client = do
addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
-> IO (Maybe SignalHandler)
addDeviceListener state display device client = do
rule <- matchBTProperty client device
forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) (toClient client)
addDeviceListener state display device sys = do
rule <- matchBTProperty sys device
forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
where
procMatch = withSignalMatch $ \c -> updateDevice state device c >> display
matchConnected :: [Variant] -> SignalMatch Bool
matchConnected = matchPropertyChanged devInterface devConnected
callGetConnected :: ObjectPath -> Client -> IO [Variant]
callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
callGetConnected p = callPropertyGet btBus p devInterface $ memberName_ devConnected
insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool

11
lib/Xmobar/Plugins/Common.hs
View File

@ -1,4 +1,3 @@
module Xmobar.Plugins.Common
( colorText
, startListener
@ -16,12 +15,12 @@ module Xmobar.Plugins.Common
import Control.Monad
import Data.Internal.DBus
import DBus
import DBus.Client
import DBus.Internal
import XMonad.Hooks.DynamicLog (xmobarColor)
import XMonad.Internal.Dependency
import XMonad.Hooks.DynamicLog (xmobarColor)
type Callback = String -> IO ()
@ -31,9 +30,9 @@ data Colors = Colors
}
deriving (Eq, Show, Read)
startListener :: IsVariant a => MatchRule -> (Client -> IO [Variant])
startListener :: (SafeClient c, IsVariant a) => MatchRule -> (c -> IO [Variant])
-> ([Variant] -> SignalMatch a) -> (a -> IO String) -> Callback
-> Client -> IO ()
-> c -> IO ()
startListener rule getProp fromSignal toColor cb client = do
reply <- getProp client
displayMaybe cb toColor $ fromSingletonVariant reply

21
lib/Xmobar/Plugins/Device.hs
View File

@ -11,15 +11,14 @@ module Xmobar.Plugins.Device
import Control.Monad
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.Word
import DBus
import DBus.Client
import DBus.Internal
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import XMonad.Internal.Dependency
import Xmobar
import Xmobar.Plugins.Common
@ -45,13 +44,13 @@ devDep = Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface
$ Method_ getByIP
getDevice :: SysClient -> String -> IO (Maybe ObjectPath)
getDevice cl iface = bodyToMaybe <$> callMethod' (toClient cl) mc
getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
where
mc = (methodCallBus networkManagerBus nmPath nmInterface getByIP)
{ methodCallBody = [toVariant iface]
}
getDeviceConnected :: ObjectPath -> Client -> IO [Variant]
getDeviceConnected :: ObjectPath -> SysClient -> IO [Variant]
getDeviceConnected path = callPropertyGet networkManagerBus path nmDeviceInterface
$ memberName_ devSignal
@ -61,13 +60,13 @@ matchStatus = matchPropertyChanged nmDeviceInterface devSignal
instance Exec Device where
alias (Device (iface, _, _)) = iface
start (Device (iface, text, colors)) cb = do
withDBusClientConnection cb $ \client -> do
path <- getDevice client iface
displayMaybe' cb (listener client) path
withDBusClientConnection cb $ \sys -> do
path <- getDevice sys iface
displayMaybe' cb (listener sys) path
where
listener client path = do
rule <- matchPropertyFull (toClient client) networkManagerBus (Just path)
listener sys path = do
rule <- matchPropertyFull sys networkManagerBus (Just path)
-- TODO warn the user here rather than silently drop the listener
forM_ rule $ \r ->
startListener r (getDeviceConnected path) matchStatus chooseColor' cb (toClient client)
startListener r (getDeviceConnected path) matchStatus chooseColor' cb sys
chooseColor' = return . (\s -> colorText colors s text) . (> 1)

7
lib/Xmobar/Plugins/Screensaver.hs
View File

@ -12,7 +12,6 @@ module Xmobar.Plugins.Screensaver
import Xmobar
import XMonad.Internal.DBus.Screensaver
import XMonad.Internal.Dependency
import Xmobar.Plugins.Common
newtype Screensaver = Screensaver (String, Colors) deriving (Read, Show)
@ -23,9 +22,9 @@ ssAlias = "screensaver"
instance Exec Screensaver where
alias (Screensaver _) = ssAlias
start (Screensaver (text, colors)) cb = do
withDBusClientConnection cb $ \c -> do
matchSignal display c
display =<< callQuery (toClient c)
withDBusClientConnection cb $ \sys -> do
matchSignal display sys
display =<< callQuery sys
where
display = displayMaybe cb $ return . (\s -> colorText colors s text)

10
lib/Xmobar/Plugins/VPN.hs
View File

@ -14,16 +14,16 @@ module Xmobar.Plugins.VPN
import Control.Concurrent.MVar
import Control.Monad
import Data.Internal.DBus
import Data.Internal.Dependency
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Set as S
import DBus
import DBus.Internal
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import XMonad.Internal.Dependency
import Xmobar
import Xmobar.Plugins.Common
@ -70,16 +70,16 @@ updateState f state op = modifyMVar_ state $ return . f op
--
getVPNObjectTree :: SysClient -> IO ObjectTree
getVPNObjectTree client = callGetManagedObjects (toClient client) vpnBus vpnPath
getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
findTunnels :: ObjectTree -> VPNState
findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
vpnAddedListener :: SignalCallback -> SysClient -> IO ()
vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb . toClient
vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb
vpnRemovedListener :: SignalCallback -> SysClient -> IO ()
vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb . toClient
vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
addedCallback :: MutableVPNState -> IO () -> SignalCallback
addedCallback state display [device, added] = update >> display

4
my-xmonad.cabal
View File

@ -12,7 +12,6 @@ library
, XMonad.Internal.Theme
, XMonad.Internal.Notify
, XMonad.Internal.Shell
, XMonad.Internal.Dependency
, XMonad.Internal.IO
, XMonad.Internal.Command.Desktop
, XMonad.Internal.Command.DMenu
@ -33,7 +32,8 @@ library
, Xmobar.Plugins.IntelBacklight
, Xmobar.Plugins.Screensaver
, Xmobar.Plugins.VPN
, DBus.Internal
, Data.Internal.Dependency
, Data.Internal.DBus
build-depends: X11 >= 1.9.1
, base
, bytestring >= 0.10.8.2