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)

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 cb' = displayMaybe cb' formatter . Just =<< readState
      i <- withDIO c $ initialState contypes
      s <- newMVar i
      let mapEnv c' = mapRIO (PluginEnv c' s dpy cb)
      mapEnv c $ addListener mapEnv >> pluginDisplay
    where
      formatter names = return $ case names of
        [] -> colorText colors False text
        xs -> T.unwords [colorText colors True text, T.intercalate "|" xs]
      addListener mapEnv = do
        res <- matchSignalFull nmBus Nothing (Just nmActiveInterface) (Just stateChanged)
        case res of
          Nothing -> logError "could not start listener"
          Just rule ->
            -- Start a new connection and RIO process since the parent thread
            -- will have died before these callbacks fire, therefore the logging
            -- file descriptor will be closed. This makes a new one
            -- TODO can I recycle the client?
            void $
              addMatchCallbackSignal rule $ \sig ->
                withDBusClientConnection cb (Just "ethernet-cb.log") $ \c' ->
                  mapEnv c' $
                    testActiveType contypes sig

nmBus :: BusName
nmBus = "org.freedesktop.NetworkManager"

nmPath :: ObjectPath
nmPath = "/org/freedesktop/NetworkManager"

nmInterface :: InterfaceName
nmInterface = "org.freedesktop.NetworkManager"

nmObjectTreePath :: ObjectPath
nmObjectTreePath = "/org/freedesktop"

nmActiveInterface :: InterfaceName
nmActiveInterface = "org.freedesktop.NetworkManager.Connection.Active"

stateChanged :: MemberName
stateChanged = "StateChanged"

-- semi-random method to test to ensure that NetworkManager is up and on DBus
devDep :: DBusDependency_ SysClient
devDep =
  Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
    Method_ "GetDeviceByIpIface"

type EthIO = PluginIO EthState SysClient

type EthState = M.Map ObjectPath T.Text

getConnectionProp :: MemberName -> ObjectPath -> EthIO [Variant]
getConnectionProp prop path = callPropertyGet nmBus 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
  logMaybe "type" getId typeRes
  where
    path' = displayBytesUtf8 $ T.encodeUtf8 $ T.pack $ formatObjectPath path
    logMaybe what = maybe (logError ("could not get " <> what <> " for " <> path'))
    getId contype = do
      when (contype `elem` contypes) $ do
        idRes <- getConnectionId path
        logMaybe "ID" insertId idRes
    insertId i = do
      s <- asks plugState
      modifyMVar_ s $ return . M.insert path i

updateDisconnected :: ObjectPath -> EthIO ()
updateDisconnected path = do
  s <- asks plugState
  modifyMVar_ s $ return . M.delete path

testActiveType :: NE.NonEmpty T.Text -> Signal -> EthIO ()
testActiveType contypes sig = do
  case signalBody sig of
    [state, _] -> case fromVariant state of
      Just (2 :: Word32) -> updateConnected contypes path >> pluginDisplay
      Just 4 -> updateDisconnected path >> pluginDisplay
      _ -> 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 nmBus nmObjectTreePath
  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 plugState)