From dda7a96d4c06c7314b0983e442fd91604781e4c9 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sat, 9 Jul 2022 17:44:14 -0400 Subject: [PATCH] REF overload internal dbus functions --- bin/xmobar.hs | 3 +- bin/xmonad.hs | 3 +- .../Internal.hs => Data/Internal/DBus.hs} | 144 ++++++++++-------- lib/{XMonad => Data}/Internal/Dependency.hs | 75 +-------- lib/XMonad/Internal/Command/DMenu.hs | 4 +- lib/XMonad/Internal/Command/Desktop.hs | 4 +- lib/XMonad/Internal/Command/Power.hs | 3 +- lib/XMonad/Internal/Concurrent/ACPIEvent.hs | 2 +- lib/XMonad/Internal/Concurrent/VirtualBox.hs | 3 +- .../Internal/DBus/Brightness/ClevoKeyboard.hs | 7 +- lib/XMonad/Internal/DBus/Brightness/Common.hs | 12 +- .../DBus/Brightness/IntelBacklight.hs | 7 +- lib/XMonad/Internal/DBus/Control.hs | 4 +- lib/XMonad/Internal/DBus/Removable.hs | 5 +- lib/XMonad/Internal/DBus/Screensaver.hs | 13 +- lib/Xmobar/Plugins/BacklightCommon.hs | 3 +- lib/Xmobar/Plugins/Bluetooth.hs | 28 ++-- lib/Xmobar/Plugins/Common.hs | 11 +- lib/Xmobar/Plugins/Device.hs | 21 ++- lib/Xmobar/Plugins/Screensaver.hs | 7 +- lib/Xmobar/Plugins/VPN.hs | 10 +- my-xmonad.cabal | 4 +- 22 files changed, 172 insertions(+), 201 deletions(-) rename lib/{DBus/Internal.hs => Data/Internal/DBus.hs} (58%) rename lib/{XMonad => Data}/Internal/Dependency.hs (95%) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 878823b..9f76230 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -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' diff --git a/bin/xmonad.hs b/bin/xmonad.hs index f5cd0c5..7d31a1f 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -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 diff --git a/lib/DBus/Internal.hs b/lib/Data/Internal/DBus.hs similarity index 58% rename from lib/DBus/Internal.hs rename to lib/Data/Internal/DBus.hs index 6bb7895..3d83a67 100644 --- a/lib/DBus/Internal.hs +++ b/lib/Data/Internal/DBus.hs @@ -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 diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/Data/Internal/Dependency.hs similarity index 95% rename from lib/XMonad/Internal/Dependency.hs rename to lib/Data/Internal/Dependency.hs index 61e18d9..797f9dd 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/Data/Internal/Dependency.hs @@ -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] - diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index f02dd7a..b3ff9d6 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -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 diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index d3e83e2..d3e474e 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -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 diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index 3949e51..b25223a 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -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 diff --git a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs index 9b9b9b8..4e12f36 100644 --- a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs +++ b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs @@ -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) diff --git a/lib/XMonad/Internal/Concurrent/VirtualBox.hs b/lib/XMonad/Internal/Concurrent/VirtualBox.hs index 0c3f6de..ceefbb2 100644 --- a/lib/XMonad/Internal/Concurrent/VirtualBox.hs +++ b/lib/XMonad/Internal/Concurrent/VirtualBox.hs @@ -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) diff --git a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs index 680b3f9..46717c1 100644 --- a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs +++ b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 9bc0354..91c9593 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -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) diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index f2f33cc..e7db071 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index 5ce7dc7..80bd414 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Removable.hs b/lib/XMonad/Internal/DBus/Removable.hs index c00bbb7..bf78ea3 100644 --- a/lib/XMonad/Internal/DBus/Removable.hs +++ b/lib/XMonad/Internal/DBus/Removable.hs @@ -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" diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 69fe3f9..d77bab4 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -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 diff --git a/lib/Xmobar/Plugins/BacklightCommon.hs b/lib/Xmobar/Plugins/BacklightCommon.hs index 9dbef05..71a9991 100644 --- a/lib/Xmobar/Plugins/BacklightCommon.hs +++ b/lib/Xmobar/Plugins/BacklightCommon.hs @@ -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 ()) diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index f2b8c30..8f073f1 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -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 diff --git a/lib/Xmobar/Plugins/Common.hs b/lib/Xmobar/Plugins/Common.hs index bc08ea6..8aa99e9 100644 --- a/lib/Xmobar/Plugins/Common.hs +++ b/lib/Xmobar/Plugins/Common.hs @@ -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 diff --git a/lib/Xmobar/Plugins/Device.hs b/lib/Xmobar/Plugins/Device.hs index ce82abf..284c09a 100644 --- a/lib/Xmobar/Plugins/Device.hs +++ b/lib/Xmobar/Plugins/Device.hs @@ -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) diff --git a/lib/Xmobar/Plugins/Screensaver.hs b/lib/Xmobar/Plugins/Screensaver.hs index 804e57d..454a1db 100644 --- a/lib/Xmobar/Plugins/Screensaver.hs +++ b/lib/Xmobar/Plugins/Screensaver.hs @@ -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) diff --git a/lib/Xmobar/Plugins/VPN.hs b/lib/Xmobar/Plugins/VPN.hs index 51525ff..46f2cbf 100644 --- a/lib/Xmobar/Plugins/VPN.hs +++ b/lib/Xmobar/Plugins/VPN.hs @@ -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 diff --git a/my-xmonad.cabal b/my-xmonad.cabal index 10d9230..fad387b 100644 --- a/my-xmonad.cabal +++ b/my-xmonad.cabal @@ -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