xmonad-config/lib/Xmobar/Plugins/ActiveConnection.hs

--------------------------------------------------------------------------------
-- NetworkManager Connection plugin
--
-- Show active connections of varying types.
--
-- This plugin exclusively monitors the */ActiveConnection/* paths in the
-- NetworkManager DBus path for state changes. It does not pin these to any
-- particular interface but instead looks at all connections equally and filters
-- based on their Type (ethernet, wifi, VPN, etc). For many use cases this will
-- track well enough with either one or a collection of similar interfaces (ie
-- all ethernet or all wifi).

module Xmobar.Plugins.ActiveConnection
  ( ActiveConnection (..)
  , devDep
  , connAlias
  )
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 ActiveConnection
  = ActiveConnection (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)

connAlias :: NE.NonEmpty T.Text -> T.Text
connAlias = T.intercalate "_" . NE.toList

instance Exec ActiveConnection where
  alias (ActiveConnection (contypes, _, _)) = T.unpack $ connAlias contypes
  start (ActiveConnection (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
      let mapEnv c' = mapRIO (EthEnv c' s dpy)
      mapEnv c $ addListener mapEnv >> dpy
    where
      formatter names = return $ case names of
        [] -> colorText colors False text
        xs -> T.unwords [T.intercalate "|" xs, colorText colors True text]
      addListener mapEnv = do
        res <- matchSignalFull ethBus Nothing (Just nmActiveInterface) (Just stateChanged)
        case res of
          Nothing -> logError "could not start listener"
          Just rule ->
            void $
              addMatchCallbackSignal rule $ \sig ->
                withDBusClientConnection cb (Just "ethernet-cb.log") $ \c' ->
                  mapEnv c' $
                    testActiveType contypes sig