150 lines
4.4 KiB
Haskell
150 lines
4.4 KiB
Haskell
--------------------------------------------------------------------------------
|
|
-- Device plugin
|
|
--
|
|
-- Display different text depending on whether or not the interface has
|
|
-- connectivity
|
|
|
|
module Xmobar.Plugins.Device
|
|
( Device (..)
|
|
, devDep
|
|
)
|
|
where
|
|
|
|
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 (NE.NonEmpty T.Text, T.Text, Colors) deriving (Read, Show)
|
|
|
|
nmPath :: ObjectPath
|
|
nmPath = objectPath_ "/org/freedesktop/NetworkManager"
|
|
|
|
nmInterface :: InterfaceName
|
|
nmInterface = interfaceName_ "org.freedesktop.NetworkManager"
|
|
|
|
nmActiveInterface :: InterfaceName
|
|
nmActiveInterface =
|
|
interfaceName_ "org.freedesktop.NetworkManager.Connection.Active"
|
|
|
|
stateChanged :: MemberName
|
|
stateChanged = "StateChanged"
|
|
|
|
getByIP :: MemberName
|
|
getByIP = memberName_ "GetDeviceByIpIface"
|
|
|
|
devDep :: DBusDependency_ SysClient
|
|
devDep =
|
|
Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
|
|
Method_ getByIP
|
|
|
|
-- -- 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
|
|
path = signalPath sig
|
|
|
|
initialState
|
|
:: ( SafeClient c
|
|
, MonadUnliftIO m
|
|
, MonadReader (env c) m
|
|
, HasClient env
|
|
, HasLogFunc (env c)
|
|
)
|
|
=> 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
|
|
|
|
readState :: EthIO [T.Text]
|
|
readState = M.elems <$> (readMVar =<< asks ethState)
|
|
|
|
instance Exec Device where
|
|
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
|
|
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 -> void $ addMatchCallbackSignal rule (testActiveType contypes)
|
|
Nothing -> logError "could not start listener"
|