rofi-extras/app/rofi-evpn.hs

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

module Main (main) where

import RIO
import qualified RIO.Text as T
import Rofi.Command
import System.Process
import UnliftIO.Environment

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

runPrompt :: [String] -> RIO SimpleApp ()
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
      runRofi (RofiVPNConf $ fmap T.pack args) $
        emptyMenu
          { groups =
              [ untitledGroup $ toRofiActions $ maybeToList d
              , untitledGroup $ toRofiActions cs
              ]
          , prompt = Just "Select Action"
          }

newtype RofiVPNConf = RofiVPNConf [T.Text]

instance HasRofiConf RofiVPNConf where
  defArgs (RofiVPNConf as) = as

type VPNAction = RofiAction RofiVPNConf

type VPNServer = (T.Text, T.Text)

data VPNStatus = VPNStatus (Maybe T.Text) [VPNServer] deriving (Show)

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

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

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

getAvailableServers :: MonadIO m => m [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 . T.split (== '\t')) $
          takeWhile (/= "") $
            drop 1
            -- super lame way of matching lines that start with "-----"
            $
              dropWhile (not . T.isPrefixOf "-----") $
                T.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 :: MonadIO m => m Bool
daemonIsRunning = isJust <$> readCmdSuccess "pgrep" [eVPND] ""

getDisconnectAction :: T.Text -> VPNAction
getDisconnectAction server =
  (T.append "Disconnect from " server, io $ void $ disconnect server)

getConnectAction :: Maybe T.Text -> 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 -> T.Text
formatServerLine (sid, sname) = T.concat [pad sid, " | ", sname]
  where
    pad s = T.append s $ T.replicate (10 - T.length s) " "

eVPN :: T.Text
eVPN = "expressvpn"

eVPND :: T.Text
eVPND = "expressvpnd"

connect :: MonadIO m => VPNServer -> m ()
connect (sid, sname) = do
  res <- readCmdSuccess' eVPN ["connect", sid]
  notifyIf
    res
    (T.append "connected to " sname)
    (T.append "failed to connect to " sname)

disconnect :: MonadIO m => T.Text -> m Bool
disconnect server = do
  res <- readCmdSuccess' eVPN ["disconnect"]
  notifyIf
    res
    (T.append "disconnected from " server)
    (T.append "failed to disconnect from " server)
  return res

readCmdSuccess' :: MonadIO m => T.Text -> [T.Text] -> m 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 :: MonadIO m => Bool -> T.Text -> T.Text -> m ()
notifyIf True s _ = notify IconInfo s
notifyIf False _ s = notify IconError s

notify :: MonadIO m => NotifyIcon -> T.Text -> m ()
notify icon body = liftIO $ void $ spawnProcess "notify-send" $ args ++ [T.unpack body]
  where
    args = ["-i", show icon, summary]
    summary = "ExpressVPN"