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

--------------------------------------------------------------------------------
-- 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"