ENH show network connection names
This commit is contained in:
parent
0a4edb6bf2
commit
f814ac9217
|
|
@ -14,6 +14,7 @@ import Data.Internal.XIO
|
|||
import Options.Applicative
|
||||
import RIO hiding (hFlush)
|
||||
import RIO.List
|
||||
import qualified RIO.NonEmpty as NE
|
||||
import qualified RIO.Text as T
|
||||
import XMonad.Config.Prime (enumFrom)
|
||||
import XMonad.Core hiding (config)
|
||||
|
|
@ -219,10 +220,10 @@ getWireless =
|
|||
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
|
||||
|
||||
getEthernet :: Maybe SysClient -> BarFeature
|
||||
getEthernet cl = iconDBus "ethernet status indicator" xpfEthernet root tree
|
||||
getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
|
||||
where
|
||||
root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl
|
||||
tree = And1 (Only readEthernet) (Only_ devDep)
|
||||
root useIcon tree' =
|
||||
DBusRoot_ (const $ ethernetCmd useIcon ("vlan" :| ["802-3-ethernet"])) tree' cl
|
||||
|
||||
getBattery :: BarFeature
|
||||
getBattery = iconIO_ "battery level indicator" xpfBattery root tree
|
||||
|
|
@ -297,13 +298,13 @@ iconIO_
|
|||
-> BarFeature
|
||||
iconIO_ = iconSometimes' And_ Only_
|
||||
|
||||
iconDBus
|
||||
:: T.Text
|
||||
-> XPQuery
|
||||
-> (Fontifier -> DBusTree c p -> Root CmdSpec)
|
||||
-> DBusTree c p
|
||||
-> BarFeature
|
||||
iconDBus = iconSometimes' And1 $ Only_ . DBusIO
|
||||
-- iconDBus
|
||||
-- :: T.Text
|
||||
-- -> XPQuery
|
||||
-- -> (Fontifier -> DBusTree c p -> Root CmdSpec)
|
||||
-- -> DBusTree c p
|
||||
-- -> BarFeature
|
||||
-- iconDBus = iconSometimes' And1 $ Only_ . DBusIO
|
||||
|
||||
iconDBus_
|
||||
:: T.Text
|
||||
|
|
@ -368,13 +369,13 @@ wirelessCmd iface =
|
|||
, "<icon=wifi_%%.xpm/>"
|
||||
]
|
||||
|
||||
ethernetCmd :: Fontifier -> T.Text -> CmdSpec
|
||||
ethernetCmd fontify iface =
|
||||
ethernetCmd :: Fontifier -> NE.NonEmpty T.Text -> CmdSpec
|
||||
ethernetCmd fontify contypes =
|
||||
CmdSpec
|
||||
{ csAlias = iface
|
||||
{ csAlias = "connection"
|
||||
, csRunnable =
|
||||
Run $
|
||||
Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
|
||||
Device (contypes, fontify IconMedium "\xf0e8" "ETH", colors)
|
||||
}
|
||||
|
||||
batteryCmd :: Fontifier -> CmdSpec
|
||||
|
|
|
|||
|
|
@ -10,6 +10,8 @@ module Data.Internal.DBus
|
|||
, HasClient (..)
|
||||
, withDIO
|
||||
, addMatchCallback
|
||||
, addMatchCallbackSignal
|
||||
, matchSignalFull
|
||||
, matchProperty
|
||||
, matchPropertyFull
|
||||
, matchPropertyChanged
|
||||
|
|
@ -198,6 +200,19 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
|
|||
|
||||
type SignalCallback m = [Variant] -> m ()
|
||||
|
||||
addMatchCallbackSignal
|
||||
:: ( MonadReader (env c) m
|
||||
, MonadUnliftIO m
|
||||
, SafeClient c
|
||||
, HasClient env
|
||||
)
|
||||
=> MatchRule
|
||||
-> (Signal -> m ())
|
||||
-> m SignalHandler
|
||||
addMatchCallbackSignal rule cb = do
|
||||
cl <- toClient <$> view clientL
|
||||
withRunInIO $ \run -> addMatch cl rule $ run . cb
|
||||
|
||||
addMatchCallback
|
||||
:: ( MonadReader (env c) m
|
||||
, MonadUnliftIO m
|
||||
|
|
@ -207,10 +222,7 @@ addMatchCallback
|
|||
=> MatchRule
|
||||
-> SignalCallback m
|
||||
-> m SignalHandler
|
||||
addMatchCallback rule cb = do
|
||||
cl <- toClient <$> view clientL
|
||||
withRunInIO $ \run -> do
|
||||
addMatch cl rule $ run . cb . signalBody
|
||||
addMatchCallback rule cb = addMatchCallbackSignal rule (cb . signalBody)
|
||||
|
||||
matchSignal
|
||||
:: Maybe BusName
|
||||
|
|
@ -333,7 +345,7 @@ matchPropertyChanged _ _ _ = Failure
|
|||
--------------------------------------------------------------------------------
|
||||
-- Object Manager
|
||||
|
||||
type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
|
||||
type ObjectTree = M.Map ObjectPath (M.Map InterfaceName (M.Map T.Text Variant))
|
||||
|
||||
omInterface :: InterfaceName
|
||||
omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
|
||||
|
|
@ -363,7 +375,11 @@ callGetManagedObjects bus path = do
|
|||
Left err -> do
|
||||
logError $ Utf8Builder $ encodeUtf8Builder err
|
||||
return M.empty
|
||||
Right v -> return $ fromMaybe M.empty $ fromSingletonVariant v
|
||||
Right v ->
|
||||
return $
|
||||
fmap (M.mapKeys interfaceName_) $
|
||||
fromMaybe M.empty $
|
||||
fromSingletonVariant v
|
||||
|
||||
addInterfaceChangedListener
|
||||
:: ( MonadReader (env c) m
|
||||
|
|
|
|||
|
|
@ -14,13 +14,15 @@ import DBus
|
|||
import Data.Internal.DBus
|
||||
import Data.Internal.XIO
|
||||
import RIO
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.NonEmpty as NE
|
||||
import qualified RIO.Text as T
|
||||
import XMonad.Internal.Command.Desktop
|
||||
import XMonad.Internal.DBus.Common
|
||||
import Xmobar
|
||||
import Xmobar.Plugins.Common
|
||||
|
||||
newtype Device = Device (T.Text, T.Text, Colors) deriving (Read, Show)
|
||||
newtype Device = Device (NE.NonEmpty T.Text, T.Text, Colors) deriving (Read, Show)
|
||||
|
||||
nmPath :: ObjectPath
|
||||
nmPath = objectPath_ "/org/freedesktop/NetworkManager"
|
||||
|
|
@ -28,59 +30,120 @@ nmPath = objectPath_ "/org/freedesktop/NetworkManager"
|
|||
nmInterface :: InterfaceName
|
||||
nmInterface = interfaceName_ "org.freedesktop.NetworkManager"
|
||||
|
||||
nmDeviceInterface :: InterfaceName
|
||||
nmDeviceInterface = interfaceName_ "org.freedesktop.NetworkManager.Device"
|
||||
nmActiveInterface :: InterfaceName
|
||||
nmActiveInterface =
|
||||
interfaceName_ "org.freedesktop.NetworkManager.Connection.Active"
|
||||
|
||||
stateChanged :: MemberName
|
||||
stateChanged = "StateChanged"
|
||||
|
||||
getByIP :: MemberName
|
||||
getByIP = memberName_ "GetDeviceByIpIface"
|
||||
|
||||
devSignal :: T.Text
|
||||
devSignal = "Ip4Connectivity"
|
||||
|
||||
devDep :: DBusDependency_ SysClient
|
||||
devDep =
|
||||
Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
|
||||
Method_ getByIP
|
||||
|
||||
getDevice
|
||||
:: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
|
||||
=> T.Text
|
||||
-> m (Maybe ObjectPath)
|
||||
getDevice iface = bodyToMaybe <$> callMethod' mc
|
||||
-- -- TODO not DRY, make a NM specific section somewhere for this call
|
||||
ethBus :: BusName
|
||||
ethBus = busName_ "org.freedesktop.NetworkManager"
|
||||
|
||||
data EthEnv c = EthEnv
|
||||
{ ethClient :: !c
|
||||
, ethState :: !(MVar EthState)
|
||||
, ethDisplay :: !(EthIO ())
|
||||
, ethEnv :: !SimpleApp
|
||||
}
|
||||
|
||||
instance HasLogFunc (EthEnv c) where
|
||||
logFuncL = lens ethEnv (\x y -> x {ethEnv = y}) . logFuncL
|
||||
|
||||
instance HasClient EthEnv where
|
||||
clientL = lens ethClient (\x y -> x {ethClient = y})
|
||||
|
||||
type EthIO = RIO (EthEnv SysClient)
|
||||
|
||||
type EthState = M.Map ObjectPath T.Text
|
||||
|
||||
getConnectionProp :: MemberName -> ObjectPath -> EthIO [Variant]
|
||||
getConnectionProp prop path = callPropertyGet ethBus path nmActiveInterface prop
|
||||
|
||||
getConnectionId :: ObjectPath -> EthIO (Maybe T.Text)
|
||||
getConnectionId = fmap fromSingletonVariant . getConnectionProp "Id"
|
||||
|
||||
getConnectionType :: ObjectPath -> EthIO (Maybe T.Text)
|
||||
getConnectionType = fmap fromSingletonVariant . getConnectionProp "Type"
|
||||
|
||||
updateConnected :: NE.NonEmpty T.Text -> ObjectPath -> EthIO ()
|
||||
updateConnected contypes path = do
|
||||
typeRes <- getConnectionType path
|
||||
case typeRes of
|
||||
Nothing -> logError "could not get type"
|
||||
Just contype -> do
|
||||
when (contype `elem` contypes) $ do
|
||||
idRes <- getConnectionId path
|
||||
case idRes of
|
||||
Nothing -> logError "could not get ID"
|
||||
Just i -> do
|
||||
s <- asks ethState
|
||||
modifyMVar_ s $ return . M.insert path i
|
||||
|
||||
updateDisconnected :: ObjectPath -> EthIO ()
|
||||
updateDisconnected path = do
|
||||
s <- asks ethState
|
||||
modifyMVar_ s $ return . M.delete path
|
||||
|
||||
testActiveType :: NE.NonEmpty T.Text -> Signal -> EthIO ()
|
||||
testActiveType contypes sig = do
|
||||
dpy <- asks ethDisplay
|
||||
case signalBody sig of
|
||||
[state, _] -> case fromVariant state of
|
||||
Just (2 :: Word32) -> updateConnected contypes path >> dpy
|
||||
Just 4 -> updateDisconnected path >> dpy
|
||||
_ -> return ()
|
||||
_ -> return ()
|
||||
where
|
||||
mc =
|
||||
(methodCallBus networkManagerBus nmPath nmInterface getByIP)
|
||||
{ methodCallBody = [toVariant iface]
|
||||
}
|
||||
path = signalPath sig
|
||||
|
||||
getDeviceConnected
|
||||
initialState
|
||||
:: ( SafeClient c
|
||||
, HasClient env
|
||||
, MonadReader (env c) m
|
||||
, HasLogFunc (env c)
|
||||
, MonadUnliftIO m
|
||||
, MonadReader (env c) m
|
||||
, HasClient env
|
||||
, HasLogFunc (env c)
|
||||
)
|
||||
=> ObjectPath
|
||||
-> m [Variant]
|
||||
getDeviceConnected path =
|
||||
callPropertyGet networkManagerBus path nmDeviceInterface $
|
||||
memberName_ $
|
||||
T.unpack devSignal
|
||||
=> NE.NonEmpty T.Text
|
||||
-> m EthState
|
||||
initialState contypes =
|
||||
M.mapMaybe go <$> callGetManagedObjects ethBus "/org/freedesktop"
|
||||
where
|
||||
go = getId <=< M.lookup nmActiveInterface
|
||||
getId m =
|
||||
fromVariant
|
||||
=<< (\t -> if t `elem` contypes then M.lookup "Id" m else Nothing)
|
||||
=<< fromVariant
|
||||
=<< M.lookup "Type" m
|
||||
|
||||
matchStatus :: [Variant] -> SignalMatch Word32
|
||||
matchStatus = matchPropertyChanged nmDeviceInterface devSignal
|
||||
readState :: EthIO [T.Text]
|
||||
readState = M.elems <$> (readMVar =<< asks ethState)
|
||||
|
||||
instance Exec Device where
|
||||
alias (Device (iface, _, _)) = T.unpack iface
|
||||
start (Device (iface, text, colors)) cb =
|
||||
withDBusClientConnection cb logName $ \(sys :: SysClient) -> withDIO sys $ do
|
||||
path <- getDevice iface
|
||||
displayMaybe' cb listener path
|
||||
alias (Device (_, _, _)) = "connection"
|
||||
start (Device (contypes, text, colors)) cb =
|
||||
withDBusClientConnection cb (Just "ethernet.log") $ \c -> do
|
||||
let dpy = displayMaybe cb formatter . Just =<< readState
|
||||
i <- withDIO c $ initialState contypes
|
||||
s <- newMVar i
|
||||
mapRIO (EthEnv c s dpy) $ do
|
||||
addListener
|
||||
dpy
|
||||
where
|
||||
logName = Just $ T.unpack $ T.concat ["device@", iface, ".log"]
|
||||
listener path = do
|
||||
res <- matchPropertyFull networkManagerBus (Just path)
|
||||
formatter names = return $ case names of
|
||||
[] -> colorText colors False text
|
||||
xs -> T.unwords [T.intercalate "|" xs, colorText colors True text]
|
||||
addListener = do
|
||||
res <- matchSignalFull ethBus Nothing (Just nmActiveInterface) (Just stateChanged)
|
||||
case res of
|
||||
Just rule -> startListener rule (getDeviceConnected path) matchStatus chooseColor' cb
|
||||
Just rule -> void $ addMatchCallbackSignal rule (testActiveType contypes)
|
||||
Nothing -> logError "could not start listener"
|
||||
chooseColor' = return . (\s -> colorText colors s text) . (> 1)
|
||||
|
|
|
|||
|
|
@ -105,7 +105,7 @@ findTunnels = M.mapMaybe lookupVPNInterface
|
|||
|
||||
-- | For the interface map underneath a given object path, try to lookup a
|
||||
-- VPN interface, then lookup the ip link name from the parent interface
|
||||
lookupVPNInterface :: M.Map T.Text (M.Map T.Text Variant) -> Maybe T.Text
|
||||
lookupVPNInterface :: M.Map InterfaceName (M.Map T.Text Variant) -> Maybe T.Text
|
||||
lookupVPNInterface m
|
||||
| isJust $ M.lookup vpnDeviceTun m =
|
||||
fromVariant =<< M.lookup "Interface" =<< M.lookup vpnDeviceParent m
|
||||
|
|
@ -137,7 +137,7 @@ addedCallback :: SignalCallback VIO
|
|||
addedCallback [device, added] =
|
||||
beforeDisplay $
|
||||
forM_ (fromVariant device) $ \d ->
|
||||
forM_ (lookupVPNInterface =<< fromVariant added) $
|
||||
forM_ (lookupVPNInterface . M.mapKeys interfaceName_ =<< fromVariant added) $
|
||||
insertState d
|
||||
addedCallback _ = return ()
|
||||
|
||||
|
|
@ -155,10 +155,10 @@ vpnBus = busName_ "org.freedesktop.NetworkManager"
|
|||
vpnPath :: ObjectPath
|
||||
vpnPath = objectPath_ "/org/freedesktop"
|
||||
|
||||
vpnDeviceTun :: T.Text
|
||||
vpnDeviceTun :: InterfaceName
|
||||
vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
|
||||
|
||||
vpnDeviceParent :: T.Text
|
||||
vpnDeviceParent :: InterfaceName
|
||||
vpnDeviceParent = "org.freedesktop.NetworkManager.Device"
|
||||
|
||||
vpnAlias :: T.Text
|
||||
|
|
|
|||
Loading…
Reference in New Issue