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

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

--------------------------------------------------------------------------------
-- 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.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)

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

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

nmDeviceInterface :: InterfaceName
nmDeviceInterface = interfaceName_ "org.freedesktop.NetworkManager.Device"

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
  where
    mc =
      (methodCallBus networkManagerBus nmPath nmInterface getByIP)
        { methodCallBody = [toVariant iface]
        }

getDeviceConnected
  :: ( SafeClient c
     , HasClient env
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     )
  => ObjectPath
  -> m [Variant]
getDeviceConnected path =
  callPropertyGet networkManagerBus path nmDeviceInterface $
    memberName_ $
      T.unpack devSignal

matchStatus :: [Variant] -> SignalMatch Word32
matchStatus = matchPropertyChanged nmDeviceInterface devSignal

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
    where
      logName = "device@" <> Utf8Builder (encodeUtf8Builder iface)
      listener path = do
        res <- matchPropertyFull networkManagerBus (Just path)
        case res of
          Just rule -> startListener rule (getDeviceConnected path) matchStatus chooseColor' cb
          Nothing -> logError "could not start listener"
      chooseColor' = return . (\s -> colorText colors s text) . (> 1)