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

{-# LANGUAGE FlexibleInstances #-}
{-# 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 "VPN" $ \c -> do
      let dpy = displayMaybe cb iconFormatter . Just =<< readState
      s <- newMVar S.empty
      mapRIO (VEnv c s dpy) $ do
        initState
        vpnAddedListener addedCallback
        vpnRemovedListener removedCallback
        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.

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

instance HasLogFunc (VEnv SysClient) 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 = S.Set ObjectPath

type MutableVPNState = MVar VPNState

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

readState :: VIO Bool
readState = fmap (not . null) . readMVar =<< asks vState

updateState :: (ObjectPath -> VPNState -> VPNState) -> ObjectPath -> VIO ()
updateState f op = do
  s <- asks vState
  modifyMVar_ s $ return . f 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 = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)

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 $
    updateDevice S.insert device $
      M.keys $
        fromMaybe M.empty added'
  where
    added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
addedCallback _ = return ()

removedCallback :: SignalCallback VIO
removedCallback [device, interfaces] =
  beforeDisplay $
    updateDevice S.delete device $
      fromMaybe [] $
        fromVariant interfaces
removedCallback _ = return ()

updateDevice
  :: (ObjectPath -> VPNState -> VPNState)
  -> Variant
  -> [T.Text]
  -> VIO ()
updateDevice f device interfaces =
  when (vpnDeviceTun `elem` interfaces) $
    forM_ d $
      updateState f
  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