rofi-extras/app/rofi-evpn.hs

--------------------------------------------------------------------------------
-- rofi-evpn - a prompt to dicsonnect/connect with express VPN
--

module Main (main) where

import Data.List (isPrefixOf)
import Data.List.Split
import Data.Maybe
import RIO
import Rofi.Command
import System.Environment
import System.Process

main :: IO ()
main = getArgs >>= runPrompt

runPrompt :: [String] -> IO ()
runPrompt args = do
  servers <- getServers
  maybe (return ()) run servers
  where
    run (VPNStatus connected servers) = do
      let d = getDisconnectAction <$> connected
      let cs = fmap (getConnectAction connected) servers
      runRofiIO (RofiVPNConf args) $
        selectAction $
          emptyMenu
            { groups =
                [ untitledGroup $ toRofiActions $ maybeToList d
                , untitledGroup $ toRofiActions cs
                ]
            , prompt = Just "Select Action"
            }

newtype RofiVPNConf = RofiVPNConf [String]

instance RofiConf RofiVPNConf where
  defArgs (RofiVPNConf as) = as

type VPNAction = RofiAction RofiVPNConf

type VPNServer = (String, String)

data VPNStatus = VPNStatus (Maybe String) [VPNServer] deriving (Show)

getServers :: IO (Maybe VPNStatus)
getServers = do
  running <- daemonIsRunning
  if running
    then Just <$> getStatus
    else notify IconError "ExpressVPN daemon not running" >> return Nothing

getStatus :: IO VPNStatus
getStatus = do
  connected <- getConnectedServer
  VPNStatus connected <$> getAvailableServers

getConnectedServer :: IO (Maybe String)
getConnectedServer = (procStatus =<<) <$> readCmdSuccess eVPN ["status"] ""
  where
    procStatus = listToMaybe . mapMaybe procLine . lines
    procLine l = case words l of
      -- the output is green...
      ("\ESC[1;32;49mConnected" : "to" : server) -> Just $ unwords server
      _ -> Nothing

getAvailableServers :: IO [VPNServer]
getAvailableServers = procOut =<< readCmdSuccess eVPN ["ls"] ""
  where
    procOut Nothing = do
      notify IconError "failed to get list of servers"
      return []
    -- ASSUME the output has a useless header that ends in a line that starts
    -- with "-----", after which is the stuff we care about, which is followed
    -- by a blank line, after which there is more stuff I don't care about
    procOut (Just ls) =
      return $
        mapMaybe (matchLine . splitOn "\t") $
          takeWhile (/= "") $
            drop 1
            -- super lame way of matching lines that start with "-----"
            $
              dropWhile (not . isPrefixOf "-----") $
                lines ls
    -- The output of this command is very strange; it is delimited (kinda) by
    -- tabs but some lines are long enough that they don't have a tab. In
    -- whatever case, splitting by tabs leads to variable length lists, and the
    -- id is always at the front and the location is always at the end. These
    -- should handle all cases.
    matchLine [i, _, l] = Just (i, l)
    matchLine [i, _, _, l] = Just (i, l)
    matchLine [i, _, _, _, l] = Just (i, l)
    matchLine _ = Nothing

daemonIsRunning :: IO Bool
daemonIsRunning = isJust <$> readCmdSuccess "pgrep" [eVPND] ""

getDisconnectAction :: String -> VPNAction
getDisconnectAction server =
  ("Disconnect from " ++ server, io $ void $ disconnect server)

getConnectAction :: Maybe String -> VPNServer -> VPNAction
getConnectAction connected server =
  (formatServerLine server, io $ go connected)
  where
    go (Just c) = do
      success <- disconnect c
      when success con
    go _ = con
    con = connect server

formatServerLine :: VPNServer -> String
formatServerLine (sid, sname) = pad sid ++ " | " ++ sname
  where
    pad s = s ++ replicate (10 - length s) ' '

eVPN :: String
eVPN = "expressvpn"

eVPND :: String
eVPND = "expressvpnd"

connect :: VPNServer -> IO ()
connect (sid, sname) = do
  res <- readCmdSuccess' eVPN ["connect", sid]
  notifyIf
    res
    ("connected to " ++ sname)
    ("failed to connect to " ++ sname)

disconnect :: String -> IO Bool
disconnect server = do
  res <- readCmdSuccess' eVPN ["disconnect"]
  notifyIf
    res
    ("disconnected from " ++ server)
    ("failed to disconnect from " ++ server)
  return res

readCmdSuccess' :: String -> [String] -> IO Bool
readCmdSuccess' cmd args = isJust <$> readCmdSuccess cmd args ""

-- TODO not DRY
data NotifyIcon = IconError | IconInfo

instance Show NotifyIcon where
  show IconError = "dialog-error-symbolic"
  show IconInfo = "dialog-information-symbolic"

notifyIf :: Bool -> String -> String -> IO ()
notifyIf True s _ = notify IconInfo s
notifyIf False _ s = notify IconError s

notify :: NotifyIcon -> String -> IO ()
notify icon body = void $ spawnProcess "notify-send" $ args ++ [body]
  where
    args = ["-i", show icon, summary]
    summary = "ExpressVPN"