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

{-# LANGUAGE OverloadedStrings #-}

--------------------------------------------------------------------------------
-- 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.Set as S
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 $ \c -> do
      state <- initState c
      let dpy = displayMaybe cb iconFormatter . Just =<< readState state
      let signalCallback' f = f state dpy
      vpnAddedListener (signalCallback' addedCallback) c
      vpnRemovedListener (signalCallback' removedCallback) c
      dpy
    where
      iconFormatter b = return $ colorText colors b 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.

type VPNState = S.Set ObjectPath

type MutableVPNState = MVar VPNState

initState :: MonadUnliftIO m => SysClient -> m MutableVPNState
initState client = do
  ot <- getVPNObjectTree client
  newMVar $ findTunnels ot

readState :: MonadUnliftIO m => MutableVPNState -> m Bool
readState = fmap (not . null) . readMVar

updateState
  :: MonadUnliftIO m
  => (ObjectPath -> VPNState -> VPNState)
  -> MutableVPNState
  -> ObjectPath
  -> m ()
updateState f state op = modifyMVar_ state $ return . f op

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

getVPNObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree
getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath

findTunnels :: ObjectTree -> VPNState
findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)

vpnAddedListener
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => SignalCallback m
  -> SysClient
  -> m ()
vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb

vpnRemovedListener
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => SignalCallback m
  -> SysClient
  -> m ()
vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb

addedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
addedCallback state dpy [device, added] = update >> dpy
  where
    added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
    is = M.keys $ fromMaybe M.empty added'
    update = updateDevice S.insert state device is
addedCallback _ _ _ = return ()

removedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
removedCallback state dpy [device, interfaces] = update >> dpy
  where
    is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
    update = updateDevice S.delete state device is
removedCallback _ _ _ = return ()

updateDevice
  :: MonadUnliftIO m
  => (ObjectPath -> VPNState -> VPNState)
  -> MutableVPNState
  -> Variant
  -> [T.Text]
  -> m ()
updateDevice f state device interfaces =
  when (vpnDeviceTun `elem` interfaces) $
    forM_ d $
      updateState f state
  where
    d = fromVariant device :: Maybe ObjectPath

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

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

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

vpnDeviceTun :: T.Text
vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"

vpnAlias :: T.Text
vpnAlias = "vpn"

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