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

--------------------------------------------------------------------------------
-- VPN plugin
--
-- Use the networkmanager to detect when a VPN interface is added or removed.
-- Specifically, monitor the object tree to detect paths with the interface
-- "org.freedesktop.NetworkManager.Device.Tun".

module Xmobar.Plugins.VPN
  ( VPN (..)
  , vpnAlias
  , vpnDep
  )
where

import DBus
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import qualified RIO.Map as M
import qualified RIO.Text as T
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import Xmobar
import Xmobar.Plugins.Common

newtype VPN = VPN (T.Text, Colors) deriving (Read, Show)

instance Exec VPN where
  alias (VPN _) = T.unpack vpnAlias
  start (VPN (text, colors)) cb =
    withDBusClientConnection cb (Just "vpn.log") $ \c -> do
      let dpy = displayMaybe cb formatter . Just =<< readState
      s <- newEmptyMVar
      mapRIO (VEnv c s dpy) $ do
        initState
        vpnAddedListener addedCallback
        vpnRemovedListener removedCallback
        dpy
    where
      formatter names = return $ case names of
        [] -> colorText colors False text
        xs -> T.unwords [T.intercalate "|" xs, colorText colors True text]

--------------------------------------------------------------------------------
-- VPN State
--
-- Maintain a set of paths which are the currently active VPNs. Most of the time
-- this will be a null or singleton set, but this setup could handle the edge
-- case of multiple VPNs being active at once without puking.

data VEnv c = VEnv
  { vClient :: !c
  , vState :: !(MVar VPNState)
  , vDisplay :: !(VIO ())
  , vEnv :: !SimpleApp
  }

instance HasLogFunc (VEnv c) where
  logFuncL = lens vEnv (\x y -> x {vEnv = y}) . logFuncL

instance HasClient VEnv where
  clientL = lens vClient (\x y -> x {vClient = y})

type VIO = RIO (VEnv SysClient)

type VPNState = M.Map ObjectPath T.Text

initState :: VIO ()
initState = do
  ot <- getVPNObjectTree
  s <- asks vState
  putMVar s $ findTunnels ot

readState :: VIO [T.Text]
readState = M.elems <$> (readMVar =<< asks vState)

insertState :: ObjectPath -> T.Text -> VIO ()
insertState op name = do
  s <- asks vState
  modifyMVar_ s $ return . M.insert op name

deleteState :: ObjectPath -> VIO ()
deleteState op = do
  s <- asks vState
  modifyMVar_ s $ return . M.delete op

beforeDisplay :: VIO () -> VIO ()
beforeDisplay f = f >> join (asks vDisplay)

--------------------------------------------------------------------------------
-- Tunnel Device Detection

getVPNObjectTree
  :: ( SafeClient c
     , HasClient env
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     )
  => m ObjectTree
getVPNObjectTree = callGetManagedObjects vpnBus vpnPath

findTunnels :: ObjectTree -> VPNState
findTunnels = M.mapMaybe lookupVPNInterface

-- | For the interface map underneath a given object path, try to lookup a
-- VPN interface, then lookup the ip link name from the parent interface
lookupVPNInterface :: M.Map InterfaceName (M.Map T.Text Variant) -> Maybe T.Text
lookupVPNInterface m
  | isJust $ M.lookup vpnDeviceTun m =
      fromVariant =<< M.lookup "Interface" =<< M.lookup vpnDeviceParent m
  | otherwise = Nothing

vpnAddedListener
  :: ( SafeClient c
     , HasClient env
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     )
  => SignalCallback m
  -> m ()
vpnAddedListener cb = void $ addInterfaceAddedListener vpnBus vpnPath cb

vpnRemovedListener
  :: ( SafeClient c
     , HasClient env
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     )
  => SignalCallback m
  -> m ()
vpnRemovedListener cb = void $ addInterfaceRemovedListener vpnBus vpnPath cb

addedCallback :: SignalCallback VIO
addedCallback [device, added] =
  beforeDisplay $
    forM_ (fromVariant device) $ \d ->
      forM_ (lookupVPNInterface . M.mapKeys interfaceName_ =<< fromVariant added) $
        insertState d
addedCallback _ = return ()

removedCallback :: SignalCallback VIO
removedCallback [device, _] =
  beforeDisplay $ forM_ (fromVariant device) deleteState
removedCallback _ = return ()

--------------------------------------------------------------------------------
-- DBus Interface

vpnBus :: BusName
vpnBus = busName_ "org.freedesktop.NetworkManager"

vpnPath :: ObjectPath
vpnPath = objectPath_ "/org/freedesktop"

vpnDeviceTun :: InterfaceName
vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"

vpnDeviceParent :: InterfaceName
vpnDeviceParent = "org.freedesktop.NetworkManager.Device"

vpnAlias :: T.Text
vpnAlias = "vpn"

vpnDep :: DBusDependency_ SysClient
vpnDep =
  Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface $
    Method_ getManagedObjects