Compare commits
11 Commits
adf0257533
...
71c875702f
Author | SHA1 | Date |
---|---|---|
Nathan Dwarshuis | 71c875702f | |
Nathan Dwarshuis | 98358983de | |
Nathan Dwarshuis | b9a10df606 | |
Nathan Dwarshuis | e508f29bd8 | |
Nathan Dwarshuis | c36a63e251 | |
Nathan Dwarshuis | f39762e1e8 | |
Nathan Dwarshuis | c394a65523 | |
Nathan Dwarshuis | 6738f8a4c7 | |
Nathan Dwarshuis | cc0465194a | |
Nathan Dwarshuis | 4aae54b90e | |
Nathan Dwarshuis | 993b9e731a |
|
@ -28,13 +28,13 @@ module Data.Internal.DBus
|
|||
)
|
||||
where
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import DBus
|
||||
import DBus.Client
|
||||
import Data.Bifunctor
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
@ -43,23 +43,23 @@ import qualified RIO.Text as T
|
|||
class SafeClient c where
|
||||
toClient :: c -> Client
|
||||
|
||||
getDBusClient :: IO (Maybe c)
|
||||
getDBusClient :: MonadUnliftIO m => m (Maybe c)
|
||||
|
||||
disconnectDBusClient :: c -> IO ()
|
||||
disconnectDBusClient = disconnect . toClient
|
||||
disconnectDBusClient :: MonadUnliftIO m => c -> m ()
|
||||
disconnectDBusClient = liftIO . disconnect . toClient
|
||||
|
||||
withDBusClient :: (c -> IO a) -> IO (Maybe a)
|
||||
withDBusClient :: MonadUnliftIO m => (c -> m a) -> m (Maybe a)
|
||||
withDBusClient f = do
|
||||
client <- getDBusClient
|
||||
forM client $ \c -> do
|
||||
r <- f c
|
||||
disconnect (toClient c)
|
||||
liftIO $ disconnect (toClient c)
|
||||
return r
|
||||
|
||||
withDBusClient_ :: (c -> IO ()) -> IO ()
|
||||
withDBusClient_ :: MonadUnliftIO m => (c -> m ()) -> m ()
|
||||
withDBusClient_ = void . withDBusClient
|
||||
|
||||
fromDBusClient :: (c -> a) -> IO (Maybe a)
|
||||
fromDBusClient :: MonadUnliftIO m => (c -> a) -> m (Maybe a)
|
||||
fromDBusClient f = withDBusClient (return . f)
|
||||
|
||||
newtype SysClient = SysClient Client
|
||||
|
@ -76,11 +76,11 @@ instance SafeClient SesClient where
|
|||
|
||||
getDBusClient = fmap SesClient <$> getDBusClient' False
|
||||
|
||||
getDBusClient' :: Bool -> IO (Maybe Client)
|
||||
getDBusClient' :: MonadUnliftIO m => Bool -> m (Maybe Client)
|
||||
getDBusClient' sys = do
|
||||
res <- try $ if sys then connectSystem else connectSession
|
||||
res <- try $ liftIO $ if sys then connectSystem else connectSession
|
||||
case res of
|
||||
Left e -> putStrLn (clientErrorMessage e) >> return Nothing
|
||||
Left e -> liftIO $ putStrLn (clientErrorMessage e) >> return Nothing
|
||||
Right c -> return $ Just c
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
@ -88,19 +88,20 @@ getDBusClient' sys = do
|
|||
|
||||
type MethodBody = Either T.Text [Variant]
|
||||
|
||||
callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
|
||||
callMethod' :: (MonadUnliftIO m, SafeClient c) => c -> MethodCall -> m MethodBody
|
||||
callMethod' cl =
|
||||
fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
|
||||
liftIO
|
||||
. fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
|
||||
. call (toClient cl)
|
||||
|
||||
callMethod
|
||||
:: SafeClient c
|
||||
:: (MonadUnliftIO m, SafeClient c)
|
||||
=> c
|
||||
-> BusName
|
||||
-> ObjectPath
|
||||
-> InterfaceName
|
||||
-> MemberName
|
||||
-> IO MethodBody
|
||||
-> m MethodBody
|
||||
callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
|
||||
|
||||
methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
|
||||
|
@ -115,7 +116,7 @@ methodCallBus b p i m =
|
|||
dbusInterface :: InterfaceName
|
||||
dbusInterface = interfaceName_ "org.freedesktop.DBus"
|
||||
|
||||
callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName)
|
||||
callGetNameOwner :: (MonadUnliftIO m, SafeClient c) => c -> BusName -> m (Maybe BusName)
|
||||
callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
|
||||
where
|
||||
mc =
|
||||
|
@ -136,15 +137,16 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
|
|||
--------------------------------------------------------------------------------
|
||||
-- Signals
|
||||
|
||||
type SignalCallback = [Variant] -> IO ()
|
||||
type SignalCallback m = [Variant] -> m ()
|
||||
|
||||
addMatchCallback
|
||||
:: SafeClient c
|
||||
:: (MonadUnliftIO m, SafeClient c)
|
||||
=> MatchRule
|
||||
-> SignalCallback
|
||||
-> SignalCallback m
|
||||
-> c
|
||||
-> IO SignalHandler
|
||||
addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody
|
||||
-> m SignalHandler
|
||||
addMatchCallback rule cb cl = withRunInIO $ \run -> do
|
||||
addMatch (toClient cl) rule $ run . cb . signalBody
|
||||
|
||||
matchSignal
|
||||
:: Maybe BusName
|
||||
|
@ -161,13 +163,13 @@ matchSignal b p i m =
|
|||
}
|
||||
|
||||
matchSignalFull
|
||||
:: SafeClient c
|
||||
:: (MonadUnliftIO m, SafeClient c)
|
||||
=> c
|
||||
-> BusName
|
||||
-> Maybe ObjectPath
|
||||
-> Maybe InterfaceName
|
||||
-> Maybe MemberName
|
||||
-> IO (Maybe MatchRule)
|
||||
-> m (Maybe MatchRule)
|
||||
matchSignalFull client b p i m =
|
||||
fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
|
||||
|
||||
|
@ -181,34 +183,35 @@ propertySignal :: MemberName
|
|||
propertySignal = memberName_ "PropertiesChanged"
|
||||
|
||||
callPropertyGet
|
||||
:: SafeClient c
|
||||
:: (MonadUnliftIO m, SafeClient c)
|
||||
=> BusName
|
||||
-> ObjectPath
|
||||
-> InterfaceName
|
||||
-> MemberName
|
||||
-> c
|
||||
-> IO [Variant]
|
||||
-> m [Variant]
|
||||
callPropertyGet bus path iface property cl =
|
||||
fmap (either (const []) (: [])) $
|
||||
getProperty (toClient cl) $
|
||||
methodCallBus bus path iface property
|
||||
liftIO $
|
||||
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
|
||||
:: SafeClient c
|
||||
:: (MonadUnliftIO m, SafeClient c)
|
||||
=> c
|
||||
-> BusName
|
||||
-> Maybe ObjectPath
|
||||
-> IO (Maybe MatchRule)
|
||||
-> m (Maybe MatchRule)
|
||||
matchPropertyFull cl b p =
|
||||
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
|
||||
|
||||
data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
|
||||
|
||||
withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO ()
|
||||
withSignalMatch :: MonadUnliftIO m => (Maybe a -> m ()) -> SignalMatch a -> m ()
|
||||
withSignalMatch f (Match x) = f (Just x)
|
||||
withSignalMatch f Failure = f Nothing
|
||||
withSignalMatch _ NoMatch = return ()
|
||||
|
@ -250,43 +253,43 @@ omInterfacesRemoved :: MemberName
|
|||
omInterfacesRemoved = memberName_ "InterfacesRemoved"
|
||||
|
||||
callGetManagedObjects
|
||||
:: SafeClient c
|
||||
:: (MonadUnliftIO m, SafeClient c)
|
||||
=> c
|
||||
-> BusName
|
||||
-> ObjectPath
|
||||
-> IO ObjectTree
|
||||
-> m ObjectTree
|
||||
callGetManagedObjects cl bus path =
|
||||
either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
|
||||
<$> callMethod cl bus path omInterface getManagedObjects
|
||||
|
||||
addInterfaceChangedListener
|
||||
:: SafeClient c
|
||||
:: (MonadUnliftIO m, SafeClient c)
|
||||
=> BusName
|
||||
-> MemberName
|
||||
-> ObjectPath
|
||||
-> SignalCallback
|
||||
-> SignalCallback m
|
||||
-> c
|
||||
-> IO (Maybe SignalHandler)
|
||||
-> m (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
|
||||
:: SafeClient c
|
||||
:: (MonadUnliftIO m, SafeClient c)
|
||||
=> BusName
|
||||
-> ObjectPath
|
||||
-> SignalCallback
|
||||
-> SignalCallback m
|
||||
-> c
|
||||
-> IO (Maybe SignalHandler)
|
||||
-> m (Maybe SignalHandler)
|
||||
addInterfaceAddedListener bus =
|
||||
addInterfaceChangedListener bus omInterfacesAdded
|
||||
|
||||
addInterfaceRemovedListener
|
||||
:: SafeClient c
|
||||
:: (MonadUnliftIO m, SafeClient c)
|
||||
=> BusName
|
||||
-> ObjectPath
|
||||
-> SignalCallback
|
||||
-> SignalCallback m
|
||||
-> c
|
||||
-> IO (Maybe SignalHandler)
|
||||
-> m (Maybe SignalHandler)
|
||||
addInterfaceRemovedListener bus =
|
||||
addInterfaceChangedListener bus omInterfacesRemoved
|
||||
|
|
|
@ -13,11 +13,10 @@ module XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
|||
)
|
||||
where
|
||||
|
||||
import Control.Monad (when)
|
||||
import DBus
|
||||
import Data.Int (Int32)
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
import RIO
|
||||
import RIO.FilePath
|
||||
import XMonad.Internal.DBus.Brightness.Common
|
||||
import XMonad.Internal.IO
|
||||
|
@ -127,8 +126,12 @@ exportClevoKeyboard =
|
|||
clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
|
||||
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
|
||||
|
||||
callGetBrightnessCK :: SesClient -> IO (Maybe Brightness)
|
||||
callGetBrightnessCK :: MonadUnliftIO m => SesClient -> m (Maybe Brightness)
|
||||
callGetBrightnessCK = callGetBrightness clevoKeyboardConfig
|
||||
|
||||
matchSignalCK :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
|
||||
matchSignalCK
|
||||
:: MonadUnliftIO m
|
||||
=> (Maybe Brightness -> m ())
|
||||
-> SesClient
|
||||
-> m ()
|
||||
matchSignalCK = matchSignal clevoKeyboardConfig
|
||||
|
|
|
@ -14,13 +14,12 @@ module XMonad.Internal.DBus.Brightness.Common
|
|||
)
|
||||
where
|
||||
|
||||
import Control.Monad (void)
|
||||
import DBus
|
||||
import DBus.Client
|
||||
import qualified DBus.Introspection as I
|
||||
import Data.Int (Int32)
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
import XMonad.Core (io)
|
||||
import XMonad.Internal.DBus.Common
|
||||
|
@ -69,10 +68,10 @@ brightnessControls q bc cl =
|
|||
cb = callBacklight q cl bc
|
||||
|
||||
callGetBrightness
|
||||
:: (SafeClient c, Num n)
|
||||
:: (MonadUnliftIO m, SafeClient c, Num n)
|
||||
=> BrightnessConfig a b
|
||||
-> c
|
||||
-> IO (Maybe n)
|
||||
-> m (Maybe n)
|
||||
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client =
|
||||
either (const Nothing) bodyGetBrightness
|
||||
<$> callMethod client xmonadBusName p i memGet
|
||||
|
@ -82,11 +81,11 @@ signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
|
|||
Endpoint [] xmonadBusName p i $ Signal_ memCur
|
||||
|
||||
matchSignal
|
||||
:: (SafeClient c, Num n)
|
||||
:: (MonadUnliftIO m, SafeClient c, Num n)
|
||||
=> BrightnessConfig a b
|
||||
-> (Maybe n -> IO ())
|
||||
-> (Maybe n -> m ())
|
||||
-> c
|
||||
-> IO ()
|
||||
-> m ()
|
||||
matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
|
||||
void . addMatchCallback brMatcher (cb . bodyGetBrightness)
|
||||
where
|
||||
|
@ -115,7 +114,11 @@ brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
|
|||
root = DBusRoot_ (exportBrightnessControls' bc) tree cl
|
||||
tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
|
||||
|
||||
exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> SesClient -> FIO ()
|
||||
exportBrightnessControls'
|
||||
:: (MonadUnliftIO m, RealFrac b)
|
||||
=> BrightnessConfig a b
|
||||
-> SesClient
|
||||
-> m ()
|
||||
exportBrightnessControls' bc cl = io $ do
|
||||
let ses = toClient cl
|
||||
maxval <- bcGetMax bc -- assume the max value will never change
|
||||
|
@ -148,9 +151,14 @@ exportBrightnessControls' bc cl = io $ do
|
|||
]
|
||||
}
|
||||
|
||||
emitBrightness :: RealFrac b => BrightnessConfig a b -> Client -> b -> IO ()
|
||||
emitBrightness
|
||||
:: (MonadUnliftIO m, RealFrac b)
|
||||
=> BrightnessConfig a b
|
||||
-> Client
|
||||
-> b
|
||||
-> m ()
|
||||
emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
|
||||
emit client $ sig {signalBody = [toVariant (round cur :: Int32)]}
|
||||
liftIO $ emit client $ sig {signalBody = [toVariant (round cur :: Int32)]}
|
||||
where
|
||||
sig = signal p i memCur
|
||||
|
||||
|
|
|
@ -14,9 +14,9 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
|
|||
where
|
||||
|
||||
import DBus
|
||||
import Data.Int (Int32)
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
import RIO
|
||||
import RIO.FilePath
|
||||
import XMonad.Internal.DBus.Brightness.Common
|
||||
import XMonad.Internal.IO
|
||||
|
@ -110,8 +110,12 @@ exportIntelBacklight =
|
|||
intelBacklightControls :: Maybe SesClient -> BrightnessControls
|
||||
intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
|
||||
|
||||
callGetBrightnessIB :: SesClient -> IO (Maybe Brightness)
|
||||
callGetBrightnessIB :: MonadUnliftIO m => SesClient -> m (Maybe Brightness)
|
||||
callGetBrightnessIB = callGetBrightness intelBacklightConfig
|
||||
|
||||
matchSignalIB :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
|
||||
matchSignalIB
|
||||
:: MonadUnliftIO m
|
||||
=> (Maybe Brightness -> m ())
|
||||
-> SesClient
|
||||
-> m ()
|
||||
matchSignalIB = matchSignal intelBacklightConfig
|
||||
|
|
|
@ -18,11 +18,11 @@ module XMonad.Internal.DBus.Control
|
|||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import DBus
|
||||
import DBus.Client
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
import RIO
|
||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||
import XMonad.Internal.DBus.Common
|
||||
|
@ -35,27 +35,27 @@ data DBusState = DBusState
|
|||
}
|
||||
|
||||
-- | Connect to the DBus
|
||||
connectDBus :: IO DBusState
|
||||
connectDBus :: MonadUnliftIO m => m DBusState
|
||||
connectDBus = do
|
||||
ses <- getDBusClient
|
||||
sys <- getDBusClient
|
||||
return DBusState {dbSesClient = ses, dbSysClient = sys}
|
||||
|
||||
-- | Disconnect from the DBus
|
||||
disconnectDBus :: DBusState -> IO ()
|
||||
disconnectDBus :: MonadUnliftIO m => DBusState -> m ()
|
||||
disconnectDBus db = disc dbSesClient >> disc dbSysClient
|
||||
where
|
||||
disc f = maybe (return ()) disconnectDBusClient $ f db
|
||||
|
||||
-- | Connect to the DBus and request the XMonad name
|
||||
connectDBusX :: IO DBusState
|
||||
connectDBusX :: MonadUnliftIO m => m DBusState
|
||||
connectDBusX = do
|
||||
db <- connectDBus
|
||||
forM_ (dbSesClient db) requestXMonadName
|
||||
return db
|
||||
|
||||
-- | Disconnect from DBus and release the XMonad name
|
||||
disconnectDBusX :: DBusState -> IO ()
|
||||
disconnectDBusX :: MonadUnliftIO m => DBusState -> m ()
|
||||
disconnectDBusX db = do
|
||||
forM_ (dbSesClient db) releaseXMonadName
|
||||
disconnectDBus db
|
||||
|
@ -64,12 +64,12 @@ disconnectDBusX db = do
|
|||
dbusExporters :: [Maybe SesClient -> SometimesIO]
|
||||
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
|
||||
|
||||
releaseXMonadName :: SesClient -> IO ()
|
||||
releaseXMonadName ses = void $ releaseName (toClient ses) xmonadBusName
|
||||
releaseXMonadName :: MonadUnliftIO m => SesClient -> m ()
|
||||
releaseXMonadName ses = liftIO $ void $ releaseName (toClient ses) xmonadBusName
|
||||
|
||||
requestXMonadName :: SesClient -> IO ()
|
||||
requestXMonadName :: MonadUnliftIO m => SesClient -> m ()
|
||||
requestXMonadName ses = do
|
||||
res <- requestName (toClient ses) xmonadBusName []
|
||||
res <- liftIO $ requestName (toClient ses) xmonadBusName []
|
||||
-- TODO if the client is not released on shutdown the owner will be different
|
||||
let msg
|
||||
| res == NamePrimaryOwner = Nothing
|
||||
|
@ -78,6 +78,6 @@ requestXMonadName ses = do
|
|||
|| res == NameExists =
|
||||
Just $ "another process owns " ++ xn
|
||||
| otherwise = Just $ "unknown error when requesting " ++ xn
|
||||
forM_ msg putStrLn
|
||||
liftIO $ forM_ msg putStrLn
|
||||
where
|
||||
xn = "'" ++ formatBusName xmonadBusName ++ "'"
|
||||
|
|
|
@ -7,20 +7,21 @@
|
|||
module Xmobar.Plugins.BacklightCommon (startBacklight) where
|
||||
|
||||
import Data.Internal.DBus
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
import Xmobar.Plugins.Common
|
||||
|
||||
startBacklight
|
||||
:: RealFrac a
|
||||
=> ((Maybe a -> IO ()) -> SesClient -> IO ())
|
||||
-> (SesClient -> IO (Maybe a))
|
||||
:: (MonadUnliftIO m, RealFrac a)
|
||||
=> ((Maybe a -> m ()) -> SesClient -> m ())
|
||||
-> (SesClient -> m (Maybe a))
|
||||
-> T.Text
|
||||
-> Callback
|
||||
-> IO ()
|
||||
-> m ()
|
||||
startBacklight matchSignal callGetBrightness icon cb = do
|
||||
withDBusClientConnection cb $ \c -> do
|
||||
matchSignal display c
|
||||
display =<< callGetBrightness c
|
||||
matchSignal dpy c
|
||||
dpy =<< callGetBrightness c
|
||||
where
|
||||
formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
|
||||
display = displayMaybe cb formatBrightness
|
||||
dpy = displayMaybe cb formatBrightness
|
||||
|
|
|
@ -39,7 +39,6 @@ module Xmobar.Plugins.Bluetooth
|
|||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad
|
||||
import DBus
|
||||
import DBus.Client
|
||||
|
@ -49,6 +48,7 @@ import Data.List
|
|||
import Data.List.Split
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
import XMonad.Internal.DBus.Common
|
||||
import Xmobar
|
||||
|
@ -69,23 +69,29 @@ instance Exec Bluetooth where
|
|||
start (Bluetooth icons colors) cb =
|
||||
withDBusClientConnection cb $ startAdapter icons colors cb
|
||||
|
||||
startAdapter :: Icons -> Colors -> Callback -> SysClient -> IO ()
|
||||
startAdapter
|
||||
:: MonadUnliftIO m
|
||||
=> Icons
|
||||
-> Colors
|
||||
-> Callback
|
||||
-> SysClient
|
||||
-> m ()
|
||||
startAdapter is cs cb cl = do
|
||||
ot <- getBtObjectTree cl
|
||||
state <- newMVar emptyState
|
||||
let display = displayIcon cb (iconFormatter is cs) state
|
||||
let dpy = displayIcon cb (iconFormatter is cs) state
|
||||
forM_ (findAdapter ot) $ \adapter -> do
|
||||
-- set up adapter
|
||||
initAdapter state adapter cl
|
||||
-- TODO this step could fail; at least warn the user...
|
||||
void $ addAdaptorListener state display adapter cl
|
||||
void $ addAdaptorListener state dpy adapter cl
|
||||
-- set up devices on the adapter (and listeners for adding/removing devices)
|
||||
let devices = findDevices adapter ot
|
||||
addDeviceAddedListener state display adapter cl
|
||||
addDeviceRemovedListener state display adapter cl
|
||||
forM_ devices $ \d -> addAndInitDevice state display d cl
|
||||
addDeviceAddedListener state dpy adapter cl
|
||||
addDeviceRemovedListener state dpy adapter cl
|
||||
forM_ devices $ \d -> addAndInitDevice state dpy d cl
|
||||
-- after setting things up, show the icon based on the initialized state
|
||||
display
|
||||
dpy
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Icon Display
|
||||
|
@ -97,9 +103,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)
|
|||
|
||||
type Icons = (T.Text, T.Text)
|
||||
|
||||
displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO ()
|
||||
displayIcon :: MonadUnliftIO m => Callback -> IconFormatter -> MutableBtState -> m ()
|
||||
displayIcon callback formatter =
|
||||
callback . T.unpack . uncurry formatter <=< readState
|
||||
liftIO . callback . T.unpack . uncurry formatter <=< readState
|
||||
|
||||
-- TODO maybe I want this to fail when any of the device statuses are Nothing
|
||||
iconFormatter :: Icons -> Colors -> IconFormatter
|
||||
|
@ -137,7 +143,7 @@ emptyState =
|
|||
, btPowered = Nothing
|
||||
}
|
||||
|
||||
readState :: MutableBtState -> IO (Maybe Bool, Bool)
|
||||
readState :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool, Bool)
|
||||
readState state = do
|
||||
p <- readPowered state
|
||||
c <- readDevices state
|
||||
|
@ -160,59 +166,81 @@ adaptorHasDevice adaptor device = case splitPath device of
|
|||
splitPath :: ObjectPath -> [T.Text]
|
||||
splitPath = fmap T.pack . splitOn "/" . dropWhile (== '/') . formatObjectPath
|
||||
|
||||
getBtObjectTree :: SysClient -> IO ObjectTree
|
||||
getBtObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree
|
||||
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
|
||||
|
||||
btOMPath :: ObjectPath
|
||||
btOMPath = objectPath_ "/"
|
||||
|
||||
addBtOMListener :: SignalCallback -> SysClient -> IO ()
|
||||
addBtOMListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
|
||||
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
|
||||
|
||||
addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
|
||||
addDeviceAddedListener state display adapter client =
|
||||
addDeviceAddedListener
|
||||
:: MonadUnliftIO m
|
||||
=> MutableBtState
|
||||
-> m ()
|
||||
-> ObjectPath
|
||||
-> SysClient
|
||||
-> m ()
|
||||
addDeviceAddedListener state dpy adapter client =
|
||||
addBtOMListener addDevice client
|
||||
where
|
||||
addDevice = pathCallback adapter display $ \d ->
|
||||
addAndInitDevice state display d client
|
||||
addDevice = pathCallback adapter dpy $ \d ->
|
||||
addAndInitDevice state dpy d client
|
||||
|
||||
addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
|
||||
addDeviceRemovedListener state display adapter sys =
|
||||
addDeviceRemovedListener
|
||||
:: (MonadUnliftIO m)
|
||||
=> MutableBtState
|
||||
-> m ()
|
||||
-> ObjectPath
|
||||
-> SysClient
|
||||
-> m ()
|
||||
addDeviceRemovedListener state dpy adapter sys =
|
||||
addBtOMListener remDevice sys
|
||||
where
|
||||
remDevice = pathCallback adapter display $ \d -> do
|
||||
remDevice = pathCallback adapter dpy $ \d -> do
|
||||
old <- removeDevice state d
|
||||
forM_ old $ removeMatch (toClient sys) . btDevSigHandler
|
||||
forM_ old $ liftIO . removeMatch (toClient sys) . btDevSigHandler
|
||||
|
||||
pathCallback :: ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback
|
||||
pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
|
||||
when (adaptorHasDevice adapter d) $ f d >> display
|
||||
pathCallback :: MonadUnliftIO m => ObjectPath -> m () -> (ObjectPath -> m ()) -> SignalCallback m
|
||||
pathCallback adapter dpy f [device, _] = forM_ (fromVariant device) $ \d ->
|
||||
when (adaptorHasDevice adapter d) $ f d >> dpy
|
||||
pathCallback _ _ _ _ = return ()
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Adapter
|
||||
|
||||
initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
|
||||
initAdapter
|
||||
:: (MonadUnliftIO m)
|
||||
=> MutableBtState
|
||||
-> ObjectPath
|
||||
-> SysClient
|
||||
-> m ()
|
||||
initAdapter state adapter client = do
|
||||
reply <- callGetPowered adapter client
|
||||
putPowered state $ fromSingletonVariant reply
|
||||
|
||||
matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
|
||||
matchBTProperty
|
||||
:: (MonadUnliftIO m)
|
||||
=> SysClient
|
||||
-> ObjectPath
|
||||
-> m (Maybe MatchRule)
|
||||
matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
|
||||
|
||||
addAdaptorListener
|
||||
:: MutableBtState
|
||||
-> IO ()
|
||||
:: MonadUnliftIO m
|
||||
=> MutableBtState
|
||||
-> m ()
|
||||
-> ObjectPath
|
||||
-> SysClient
|
||||
-> IO (Maybe SignalHandler)
|
||||
addAdaptorListener state display adaptor sys = do
|
||||
-> m (Maybe SignalHandler)
|
||||
addAdaptorListener state dpy adaptor sys = do
|
||||
rule <- matchBTProperty sys adaptor
|
||||
forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys
|
||||
where
|
||||
procMatch = withSignalMatch $ \b -> putPowered state b >> display
|
||||
procMatch = withSignalMatch $ \b -> putPowered state b >> dpy
|
||||
|
||||
callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
|
||||
callGetPowered :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
|
||||
callGetPowered adapter =
|
||||
callPropertyGet btBus adapter adapterInterface $
|
||||
memberName_ $
|
||||
|
@ -221,10 +249,10 @@ callGetPowered adapter =
|
|||
matchPowered :: [Variant] -> SignalMatch Bool
|
||||
matchPowered = matchPropertyChanged adapterInterface adaptorPowered
|
||||
|
||||
putPowered :: MutableBtState -> Maybe Bool -> IO ()
|
||||
putPowered :: MonadUnliftIO m => MutableBtState -> Maybe Bool -> m ()
|
||||
putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds})
|
||||
|
||||
readPowered :: MutableBtState -> IO (Maybe Bool)
|
||||
readPowered :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool)
|
||||
readPowered = fmap btPowered . readMVar
|
||||
|
||||
adapterInterface :: InterfaceName
|
||||
|
@ -236,13 +264,25 @@ adaptorPowered = "Powered"
|
|||
--------------------------------------------------------------------------------
|
||||
-- Devices
|
||||
|
||||
addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
|
||||
addAndInitDevice state display device client = do
|
||||
sh <- addDeviceListener state display device client
|
||||
addAndInitDevice
|
||||
:: MonadUnliftIO m
|
||||
=> MutableBtState
|
||||
-> m ()
|
||||
-> ObjectPath
|
||||
-> SysClient
|
||||
-> m ()
|
||||
addAndInitDevice state dpy device client = do
|
||||
sh <- addDeviceListener state dpy device client
|
||||
-- TODO add some intelligent error messages here
|
||||
forM_ sh $ \s -> initDevice state s device client
|
||||
|
||||
initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
|
||||
initDevice
|
||||
:: MonadUnliftIO m
|
||||
=> MutableBtState
|
||||
-> SignalHandler
|
||||
-> ObjectPath
|
||||
-> SysClient
|
||||
-> m ()
|
||||
initDevice state sh device sys = do
|
||||
reply <- callGetConnected device sys
|
||||
void $
|
||||
|
@ -253,31 +293,42 @@ initDevice state sh device sys = do
|
|||
}
|
||||
|
||||
addDeviceListener
|
||||
:: MutableBtState
|
||||
-> IO ()
|
||||
:: MonadUnliftIO m
|
||||
=> MutableBtState
|
||||
-> m ()
|
||||
-> ObjectPath
|
||||
-> SysClient
|
||||
-> IO (Maybe SignalHandler)
|
||||
addDeviceListener state display device sys = do
|
||||
-> m (Maybe SignalHandler)
|
||||
addDeviceListener state dpy device sys = do
|
||||
rule <- matchBTProperty sys device
|
||||
forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
|
||||
where
|
||||
procMatch = withSignalMatch $ \c -> updateDevice state device c >> display
|
||||
procMatch = withSignalMatch $ \c -> updateDevice state device c >> dpy
|
||||
|
||||
matchConnected :: [Variant] -> SignalMatch Bool
|
||||
matchConnected = matchPropertyChanged devInterface devConnected
|
||||
|
||||
callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
|
||||
callGetConnected :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
|
||||
callGetConnected p =
|
||||
callPropertyGet btBus p devInterface $
|
||||
memberName_ (T.unpack devConnected)
|
||||
|
||||
insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
|
||||
insertDevice
|
||||
:: MonadUnliftIO m
|
||||
=> MutableBtState
|
||||
-> ObjectPath
|
||||
-> BTDevice
|
||||
-> m Bool
|
||||
insertDevice m device dev = modifyMVar m $ \s -> do
|
||||
let new = M.insert device dev $ btDevices s
|
||||
return (s {btDevices = new}, anyDevicesConnected new)
|
||||
|
||||
updateDevice :: MutableBtState -> ObjectPath -> Maybe Bool -> IO Bool
|
||||
updateDevice
|
||||
:: MonadUnliftIO m
|
||||
=> MutableBtState
|
||||
-> ObjectPath
|
||||
-> Maybe Bool
|
||||
-> m Bool
|
||||
updateDevice m device status = modifyMVar m $ \s -> do
|
||||
let new = M.update (\d -> Just d {btDevConnected = status}) device $ btDevices s
|
||||
return (s {btDevices = new}, anyDevicesConnected new)
|
||||
|
@ -285,12 +336,16 @@ updateDevice m device status = modifyMVar m $ \s -> do
|
|||
anyDevicesConnected :: ConnectedDevices -> Bool
|
||||
anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
|
||||
|
||||
removeDevice :: MutableBtState -> ObjectPath -> IO (Maybe BTDevice)
|
||||
removeDevice
|
||||
:: MonadUnliftIO m
|
||||
=> MutableBtState
|
||||
-> ObjectPath
|
||||
-> m (Maybe BTDevice)
|
||||
removeDevice m device = modifyMVar m $ \s -> do
|
||||
let devs = btDevices s
|
||||
return (s {btDevices = M.delete device devs}, M.lookup device devs)
|
||||
|
||||
readDevices :: MutableBtState -> IO ConnectedDevices
|
||||
readDevices :: MonadUnliftIO m => MutableBtState -> m ConnectedDevices
|
||||
readDevices = fmap btDevices . readMVar
|
||||
|
||||
devInterface :: InterfaceName
|
||||
|
|
|
@ -15,10 +15,10 @@ module Xmobar.Plugins.Common
|
|||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import DBus
|
||||
import DBus.Client
|
||||
import Data.Internal.DBus
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
import XMonad.Hooks.DynamicLog (xmobarColor)
|
||||
|
||||
|
@ -32,14 +32,14 @@ data Colors = Colors
|
|||
deriving (Eq, Show, Read)
|
||||
|
||||
startListener
|
||||
:: (SafeClient c, IsVariant a)
|
||||
:: (MonadUnliftIO m, SafeClient c, IsVariant a)
|
||||
=> MatchRule
|
||||
-> (c -> IO [Variant])
|
||||
-> (c -> m [Variant])
|
||||
-> ([Variant] -> SignalMatch a)
|
||||
-> (a -> IO T.Text)
|
||||
-> (a -> m T.Text)
|
||||
-> Callback
|
||||
-> c
|
||||
-> IO ()
|
||||
-> m ()
|
||||
startListener rule getProp fromSignal toColor cb client = do
|
||||
reply <- getProp client
|
||||
displayMaybe cb toColor $ fromSingletonVariant reply
|
||||
|
@ -47,7 +47,8 @@ startListener rule getProp fromSignal toColor cb client = do
|
|||
where
|
||||
procMatch = procSignalMatch cb toColor
|
||||
|
||||
procSignalMatch :: Callback -> (a -> IO T.Text) -> SignalMatch a -> IO ()
|
||||
procSignalMatch
|
||||
:: MonadUnliftIO m => Callback -> (a -> m T.Text) -> SignalMatch a -> m ()
|
||||
procSignalMatch cb f = withSignalMatch (displayMaybe cb f)
|
||||
|
||||
colorText :: Colors -> Bool -> T.Text -> T.Text
|
||||
|
@ -60,11 +61,15 @@ xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack
|
|||
na :: T.Text
|
||||
na = "N/A"
|
||||
|
||||
displayMaybe :: Callback -> (a -> IO T.Text) -> Maybe a -> IO ()
|
||||
displayMaybe cb f = (cb . T.unpack) <=< maybe (return na) f
|
||||
displayMaybe :: MonadUnliftIO m => Callback -> (a -> m T.Text) -> Maybe a -> m ()
|
||||
displayMaybe cb f = (liftIO . cb . T.unpack) <=< maybe (return na) f
|
||||
|
||||
displayMaybe' :: Callback -> (a -> IO ()) -> Maybe a -> IO ()
|
||||
displayMaybe' cb = maybe (cb $ T.unpack na)
|
||||
displayMaybe' :: MonadUnliftIO m => Callback -> (a -> m ()) -> Maybe a -> m ()
|
||||
displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
|
||||
|
||||
withDBusClientConnection :: SafeClient c => Callback -> (c -> IO ()) -> IO ()
|
||||
withDBusClientConnection
|
||||
:: (MonadUnliftIO m, SafeClient c)
|
||||
=> Callback
|
||||
-> (c -> m ())
|
||||
-> m ()
|
||||
withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient
|
||||
|
|
|
@ -12,11 +12,11 @@ module Xmobar.Plugins.Device
|
|||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import DBus
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
import Data.Word
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
import XMonad.Internal.Command.Desktop
|
||||
import XMonad.Internal.DBus.Common
|
||||
|
@ -45,7 +45,7 @@ devDep =
|
|||
Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
|
||||
Method_ getByIP
|
||||
|
||||
getDevice :: SysClient -> T.Text -> IO (Maybe ObjectPath)
|
||||
getDevice :: MonadUnliftIO m => SysClient -> T.Text -> m (Maybe ObjectPath)
|
||||
getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
|
||||
where
|
||||
mc =
|
||||
|
@ -53,7 +53,7 @@ getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
|
|||
{ methodCallBody = [toVariant iface]
|
||||
}
|
||||
|
||||
getDeviceConnected :: ObjectPath -> SysClient -> IO [Variant]
|
||||
getDeviceConnected :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
|
||||
getDeviceConnected path =
|
||||
callPropertyGet networkManagerBus path nmDeviceInterface $
|
||||
memberName_ $
|
||||
|
|
|
@ -14,14 +14,13 @@ module Xmobar.Plugins.VPN
|
|||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad
|
||||
import DBus
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as S
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
import XMonad.Internal.Command.Desktop
|
||||
import XMonad.Internal.DBus.Common
|
||||
|
@ -35,11 +34,11 @@ instance Exec VPN where
|
|||
start (VPN (text, colors)) cb =
|
||||
withDBusClientConnection cb $ \c -> do
|
||||
state <- initState c
|
||||
let display = displayMaybe cb iconFormatter . Just =<< readState state
|
||||
let signalCallback' f = f state display
|
||||
let dpy = displayMaybe cb iconFormatter . Just =<< readState state
|
||||
let signalCallback' f = f state dpy
|
||||
vpnAddedListener (signalCallback' addedCallback) c
|
||||
vpnRemovedListener (signalCallback' removedCallback) c
|
||||
display
|
||||
dpy
|
||||
where
|
||||
iconFormatter b = return $ colorText colors b text
|
||||
|
||||
|
@ -54,57 +53,59 @@ type VPNState = S.Set ObjectPath
|
|||
|
||||
type MutableVPNState = MVar VPNState
|
||||
|
||||
initState :: SysClient -> IO MutableVPNState
|
||||
initState :: MonadUnliftIO m => SysClient -> m MutableVPNState
|
||||
initState client = do
|
||||
ot <- getVPNObjectTree client
|
||||
newMVar $ findTunnels ot
|
||||
|
||||
readState :: MutableVPNState -> IO Bool
|
||||
readState :: MonadUnliftIO m => MutableVPNState -> m Bool
|
||||
readState = fmap (not . null) . readMVar
|
||||
|
||||
updateState
|
||||
:: (ObjectPath -> VPNState -> VPNState)
|
||||
:: MonadUnliftIO m
|
||||
=> (ObjectPath -> VPNState -> VPNState)
|
||||
-> MutableVPNState
|
||||
-> ObjectPath
|
||||
-> IO ()
|
||||
-> m ()
|
||||
updateState f state op = modifyMVar_ state $ return . f op
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Tunnel Device Detection
|
||||
|
||||
getVPNObjectTree :: SysClient -> IO ObjectTree
|
||||
getVPNObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree
|
||||
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 :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
|
||||
vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb
|
||||
|
||||
vpnRemovedListener :: SignalCallback -> SysClient -> IO ()
|
||||
vpnRemovedListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
|
||||
vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
|
||||
|
||||
addedCallback :: MutableVPNState -> IO () -> SignalCallback
|
||||
addedCallback state display [device, added] = update >> display
|
||||
addedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
|
||||
addedCallback state dpy [device, added] = update >> dpy
|
||||
where
|
||||
added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
|
||||
is = M.keys $ fromMaybe M.empty added'
|
||||
update = updateDevice S.insert state device is
|
||||
addedCallback _ _ _ = return ()
|
||||
|
||||
removedCallback :: MutableVPNState -> IO () -> SignalCallback
|
||||
removedCallback state display [device, interfaces] = update >> display
|
||||
removedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
|
||||
removedCallback state dpy [device, interfaces] = update >> dpy
|
||||
where
|
||||
is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
|
||||
update = updateDevice S.delete state device is
|
||||
removedCallback _ _ _ = return ()
|
||||
|
||||
updateDevice
|
||||
:: (ObjectPath -> VPNState -> VPNState)
|
||||
:: MonadUnliftIO m
|
||||
=> (ObjectPath -> VPNState -> VPNState)
|
||||
-> MutableVPNState
|
||||
-> Variant
|
||||
-> [T.Text]
|
||||
-> IO ()
|
||||
-> m ()
|
||||
updateDevice f state device interfaces =
|
||||
when (vpnDeviceTun `elem` interfaces) $
|
||||
forM_ d $
|
||||
|
|
Loading…
Reference in New Issue