rofi-extras/app/rofi-evpn.hs

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

module Main (main) where

import           Control.Monad

import           Data.List          (isPrefixOf)
import           Data.List.Split
import           Data.Maybe

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"