rofi-extras/app/rofi-dev.hs

{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE ViewPatterns   #-}

--------------------------------------------------------------------------------
-- | rofi-dev - a rofi prompt for mountable devices
--
-- Like all "mount helpers" this is basically a wrapper for low-level utilities
-- the mount things from the command line. It also creates/destroys mountpoint
-- paths given a specific location for such mountpoints.

module Main (main) where

import           Bitwarden.Internal

import           Control.Monad
import           Control.Monad.Reader

import           Data.Either
import           Data.List
import           Data.List.Split       (splitOn)
import qualified Data.Map              as M
import qualified Data.Map.Ordered      as O
import           Data.Maybe
import qualified Data.Text as T
import qualified Data.Vector as V
import           Data.Yaml

import           GHC.Generics()

import           Rofi.Command

import           Text.Printf

import           System.Console.GetOpt
import           System.Directory
import           System.Environment
import           System.Exit (ExitCode(..))
import           System.FilePath.Posix
import           System.Posix.User     (getEffectiveUserName)
import           System.Process

import           UnliftIO.Exception

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

parse :: [String] -> IO ()
parse args = case getOpt Permute options args of
  -- (o, n, [])   -> initMountConf n >>= \i -> runMounts $ foldl (flip id) i o
  (o, n, [])   -> runMounts $ foldl (flip id) (defaultOpts n) o
  (_, _, errs) -> ioError $ userError $ concat errs ++ usageInfo h options
  where
    h = "Usage: rofi-dev [OPTIONS] [-- ROFI-OPTIONS]"
    defaultOpts r = Opts
      { optsConfig = Nothing
      , optsAlias = Nothing
      , optsUnmount = False
      , optsRofiArgs = r
      }

options :: [OptDescr (Opts -> Opts)]
options =
  [ Option ['c'] ["config"]
    (ReqArg (\s m -> m { optsConfig = Just s } ) "CONF")
    "The path to the config file"
  , Option ['m'] ["mount"]
    (ReqArg (\s m -> m { optsAlias = Just s } ) "ALIAS")
    "Mount the device specified by ALIAS directly"
  , Option ['u'] ["unmount"] (NoArg (\m -> m { optsUnmount = True } ))
    "Unmount the device specified by ALIAS instead of mounting it."
  ]

data Opts = Opts
  { optsConfig   :: Maybe FilePath
  , optsAlias    :: Maybe String
  , optsUnmount  :: Bool
  , optsRofiArgs :: [String]
  } deriving Show

--------------------------------------------------------------------------------
-- | Static configuration
--
-- This is defined in a YAML file which describes how to mount each device. Here
-- I define a parser for said YAML file

defaultTries :: Integer
defaultTries = 2

(.:&) :: FromJSON a => Object -> T.Text -> Parser (V.Vector a)
(.:&) o t = o .:? t .!= V.empty

data MountConfig = MountConfig
  { _mountMountPoint :: FilePath
  , _mountLabel :: Maybe String
  } deriving Show

instance FromJSON MountConfig where
  parseJSON = withObject "devices" $ \o -> MountConfig
    <$> o .: "mountpoint"
    <*> o .:? "label"

data DependsConfig = DependsConfig
  { _dependsVeracrypt :: V.Vector String
  , _dependsSSHFS :: V.Vector String
  , _dependsCIFS :: V.Vector String
  } deriving Show

instance FromJSON DependsConfig where
  parseJSON = withObject "depends" $ \o -> DependsConfig
    <$> o .:& "veracrypt" 
    <*> o .:& "sshfs"
    <*> o .:& "cifs"

data BitwardenConfig = BitwardenConfig
  { _bitwardenKey :: String
  , _bitwardenTries :: Integer }
  deriving Show

instance FromJSON BitwardenConfig where
  parseJSON = withObject "bitwarden" $ \o -> BitwardenConfig
    <$> o .: "key"
    <*> o .:? "tries" .!= defaultTries

newtype LibSecretConfig = LibSecretConfig
  { _libsecretAttributes :: M.Map String String }
  deriving Show

instance FromJSON LibSecretConfig where
  parseJSON = withObject "libsecret" $ \o -> LibSecretConfig
    <$> o .: "attributes"

newtype PromptConfig = PromptConfig
  { _promptTries :: Integer }
  deriving Show

instance FromJSON PromptConfig where
  parseJSON = withObject "libsecret" $ \o -> PromptConfig
    <$> o .: "tries" .!= defaultTries

data PasswordConfig = PasswordConfig
  { _passwordBitwarden :: Maybe BitwardenConfig
  , _passwordLibSecret :: Maybe LibSecretConfig
  , _passwordPrompt :: Maybe PromptConfig
  }
  deriving Show

instance FromJSON PasswordConfig where
  parseJSON = withObject "password" $ \o -> PasswordConfig
    <$> o .:? "bitwarden"
    <*> o .:? "libsecret"
    <*> o .:? "prompt"
                       
data VeracryptConfig = VeracryptConfig
  { _veracryptMount :: MountConfig
  , _veracryptVolume :: String
  , _veracryptDepends :: Maybe DependsConfig
  , _veracryptPassword :: Maybe PasswordConfig
  } deriving Show

instance FromJSON VeracryptConfig where
  parseJSON = withObject "veracrypt" $ \o -> VeracryptConfig
    <$> o .: "mount"
    <*> o .: "volume"
    <*> o .:? "depends"
    <*> o .:? "password"

data SSHFSConfig = SSHFSConfig
  { _sshfsMount :: MountConfig
  , _sshfsRemote :: String
  , _sshfsDepends :: Maybe DependsConfig
  } deriving Show

instance FromJSON SSHFSConfig where
  parseJSON = withObject "sshfs" $ \o -> SSHFSConfig
    <$> o .: "mount"
    <*> o .: "remote"
    <*> o .:? "depends"

data CIFSConfig = CIFSConfig
  { _cifsMount :: MountConfig
  , _cifsRemote :: String
  , _cifsDepends :: Maybe DependsConfig
  , _cifsPassword :: Maybe PasswordConfig
  } deriving Show

instance FromJSON CIFSConfig where
  parseJSON = withObject "cifs" $ \o -> CIFSConfig
    <$> o .: "mount"
    <*> o .: "remote"
    <*> o .:? "depends"
    <*> o .:? "password"

-- data DeviceConfig = VeracryptConfig
--   { _veracryptMount :: MountConfig
--   , _veracryptVolume :: String
--   , _veracryptDepends :: Maybe DependsConfig
--   , _veracryptPassword :: Maybe PasswordConfig
--   } | SSHFSConfig
--   { _sshfsMount :: MountConfig
--   , _sshfsRemote :: String
--   , _sshfsDepends :: Maybe DependsConfig
--   } | CIFSConfig
--   { _cifsMount :: MountConfig
--   , _cifsRemote :: String
--   , _cifsDepends :: Maybe DependsConfig
--   , _cifsPassword :: Maybe PasswordConfig
--   } deriving Show

-- instance FromJSON DeviceConfig where
--   parseJSON = withObject "devices" $ \o -> do
--     devType <- o .: "type"
--     case devType of
--       "cifs"      -> CIFSConfig
--         <$> o .: "mount"
--         <*> o .: "remote"
--         <*> o .:? "depends"
--         <*> o .:? "password"
--       "sshfs"     -> SSHFSConfig
--         <$> o .: "mount"
--         <*> o .: "remote"
--         <*> o .:? "depends"
--       "veracrypt" -> VeracryptConfig
--         <$> o .: "mount"
--         <*> o .: "volume"
--         <*> o .:? "depends"
--         <*> o .:? "password"
--       _           -> fail "unknown device type"

data DevicesConfig = DevicesConfig
  { _veracryptConfigs :: M.Map String VeracryptConfig
  , _sshfsConfigs :: M.Map String SSHFSConfig
  , _cifsConfigs :: M.Map String CIFSConfig
  } deriving Show

instance FromJSON DevicesConfig where
  parseJSON = withObject "devices" $ \o -> DevicesConfig
    <$> o .: "veracrypt"
    <*> o .: "sshfs"
    <*> o .: "cifs"

data StaticConfig = StaticConfig
  { _staticconfigTmpPath :: Maybe String
  , _staticconfigDevices :: Maybe DevicesConfig
  -- , _staticconfigDevices :: M.Map String DeviceConfig
  } deriving Show

instance FromJSON StaticConfig where
  parseJSON = withObject "devices" $ \o -> StaticConfig
    <$> o .:? "mountdir"
    <*> o .:? "devices"

--------------------------------------------------------------------------------
-- | Static Devices typeclass
--
-- A class to represent devices defined in the static configuration (eg the YAML
-- file). Its methods define the machinery to extract specific devies types
-- from the parse tree.

class Mountable m => StaticDevice m a where
  fromConfig :: DevicesConfig -> (DevicesConfig -> M.Map String a) -> RofiIO MountConf [m]
  fromConfig s f = fromConfig' s (M.elems . f)

  fromConfig' :: DevicesConfig -> (DevicesConfig -> [a]) -> RofiIO MountConf [m]
  fromConfig' s f = do
    v <- asks mountconfVolatilePath
    mapM (configToDev v s) $ f s

  configToDev :: FilePath -> DevicesConfig -> a -> RofiIO MountConf m

--------------------------------------------------------------------------------
-- | Global config used in the reader monad stack
--
-- This is defined by the mount options on the command line, and holds:
-- - a map between mountpoints and a means to get passwords when mounting those
--   mountpoints
-- - a mount directory where mountpoints will be created if needed (defaults
--   to '/tmp/media/USER'
-- - any arguments to be passed to the rofi command

data MountConf = MountConf
    { mountconfVolatilePath :: FilePath
    , mountconfRofiArgs     :: [String]
    , mountconfStaticDevs   :: Maybe DevicesConfig
    }

instance RofiConf MountConf where
  defArgs MountConf { mountconfRofiArgs = a } = a

--------------------------------------------------------------------------------
-- | Password-getting functions

type PasswordGetter = IO (Maybe String)

runSecret :: [(String, String)] -> PasswordGetter
runSecret kvs = readCmdSuccess "secret-tool" ("lookup":kvs') ""
  where
    kvs' = concatMap (\(k, v) -> [k, v]) kvs

runBitwarden :: String -> PasswordGetter
runBitwarden pname = ((password . login) <=< find (\i -> name i == pname))
  <$> getItems

runPromptLoop :: Integer -> PasswordGetter -> PasswordGetter
runPromptLoop n pwd = do
  res <- pwd
  if isNothing res then
    if n <= 0 then return Nothing else runPromptLoop (n-1) pwd
    else return res

configToPwd :: PasswordConfig -> PasswordGetter
configToPwd PasswordConfig{ _passwordBitwarden = b
                          , _passwordLibSecret = s
                          , _passwordPrompt = p
                          } =
    getBW b `runMaybe` getLS s `runMaybe` getPrompt p
  where
    getBW (Just BitwardenConfig{ _bitwardenKey = k, _bitwardenTries = n }) =
      runPromptLoop n $ runBitwarden k
    getBW _ = return Nothing
    getLS (Just LibSecretConfig{ _libsecretAttributes = a }) =
      runSecret $ M.toList a
    getLS _ = return Nothing
    getPrompt (Just PromptConfig{ _promptTries = n }) =
      runPromptLoop n readPassword
    getPrompt _ = return Nothing
    runMaybe x y = do
      res <- x
      if isNothing res then y else return res

--------------------------------------------------------------------------------
-- | Main prompt
--
-- This command will have one Rofi prompt and will display all available
-- mounts grouped by device type (eg removable, sshfs, cifs, etc). I like
-- pretty things, so ensure the entries are aligned properly as well

runMounts :: Opts -> IO ()
runMounts opts = do
  static <- join <$> traverse parseStaticConfig (optsConfig opts)
  defaultTmpPath <- ("/tmp/media" </>) <$> getEffectiveUserName
  let tmpPath = fromMaybe defaultTmpPath (_staticconfigTmpPath =<< static)
  let staticDevs = _staticconfigDevices =<< static
  let mountconf = MountConf
        { mountconfVolatilePath = tmpPath
        , mountconfRofiArgs = optsRofiArgs opts
        , mountconfStaticDevs = staticDevs
        }
  let byAlias = mountByAlias $ optsUnmount opts
  let byPrompt = runPrompt =<< getGroups
  runRofiIO mountconf $ maybe byPrompt byAlias $ optsAlias opts

parseStaticConfig :: FilePath -> IO (Maybe StaticConfig)
parseStaticConfig p = do
  res <- decodeFileEither p
  case res of
    Left e  -> print e >> return Nothing
    Right c -> return $ Just c

runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c ()
runPrompt gs = selectAction $ emptyMenu
               { groups = gs
               , prompt = Just "Select Device"
               }

getGroups :: RofiIO MountConf [RofiGroup MountConf]
getGroups = do
  sysd <- io getSystemdDevices
  (cifsDevs, sshfsDevs, vcDevs) <- getStaticDevices
  sequence
    [ mkGroup2 "SSHFS Devices" (filterSysd SystemdSSHFS sysd) sshfsDevs
    , mkGroup "CIFS Devices" cifsDevs
    , mkGroup2 "Veracrypt Devices" (filterSysd SystemdVeracrypt sysd) vcDevs
    , mkGroup "Removable Devices"  =<< getRemovableDevices
    , mkGroup "MTP Devices" =<< getMTPDevices
    ]
  where
    filterSysd t = filter (\s -> sysdType s == t)

mountByAlias :: Bool -> String -> RofiIO MountConf ()
mountByAlias unmountFlag alias = do
  static <- asks mountconfStaticDevs
  forM_ static $ \static' -> do
    volatilePath <- asks mountconfVolatilePath
    c <- toDev volatilePath static' _cifsConfigs alias
    s <- toDev volatilePath static' _sshfsConfigs alias
    v <- toDev volatilePath static' _veracryptConfigs alias
    mountIfJust (c :: Maybe CIFS)
      $ mountIfJust (s :: Maybe SSHFS)
      $ mountIfJust (v :: Maybe VeraCrypt) (return ())
  where
    toDev v s f = mapM (configToDev v s) . aliasToDevice s f
    mountIfJust a b = if isNothing a then b else forM_ a $ flip mount unmountFlag

aliasToDevice :: DevicesConfig -> (DevicesConfig -> M.Map String a) -> String -> Maybe a
aliasToDevice d f = flip M.lookup (f d)

getStaticDevices :: RofiIO MountConf ([CIFS], [SSHFS], [VeraCrypt])
getStaticDevices = do
  static <- asks mountconfStaticDevs
  maybe (return ( [] :: [CIFS], [] :: [SSHFS], [] :: [VeraCrypt]))
    (\c -> liftM3 (,,)
           (fromConfig c _cifsConfigs)
           (fromConfig c _sshfsConfigs)
           (fromConfig c _veracryptConfigs))
    static

mkGroup :: Mountable d => String -> [d] -> RofiIO MountConf (RofiGroup MountConf)
mkGroup header devs = sortGroup header <$> mapM mkAction devs

mkGroup2 :: (Mountable d, Mountable e) => String
  -> [d] -> [e] -> RofiIO MountConf (RofiGroup MountConf)
mkGroup2 header devs1 devs2 = do
  r1 <- mapM mkAction devs1
  r2 <- mapM mkAction devs2
  return $ sortGroup header (r1 ++ r2)

sortGroup :: String -> [(String, RofiIO MountConf ())] -> RofiGroup MountConf
sortGroup header = titledGroup header . alignEntries . toRofiActions

alignSep :: String
alignSep = " | "

alignSepPre :: String
alignSepPre = "@@@"

alignEntries :: RofiActions c -> RofiActions c
alignEntries = O.fromList . withKeys . O.assocs
  where
    withKeys as = let (ks, vs) = unzip as in zip (align ks) vs
    align = fmap (intercalate alignSep)
      . transpose
      . mapToLast pad
      . transpose
      . fmap (splitOn alignSepPre)
    pad xs = let m = getMax xs in fmap (\x -> take m (x ++ repeat ' ')) xs
    getMax = maximum . fmap length
    mapToLast _ []     = []
    mapToLast _ [x]    = [x]
    mapToLast f (x:xs) = f x : mapToLast f xs

--------------------------------------------------------------------------------
-- | Removable devices
--
-- A device which can be removed (which is all the devices we care about)
-- This can be minimally described by a device DEVICESPEC and LABEL.

data Removable = Removable
    { deviceSpec :: String
    , label      :: String
    }
    deriving (Eq, Show)

instance Mountable Removable where
  mount Removable { deviceSpec = d, label = l } m =
    io $ runMountNotify "udisksctl" [c, "-b", d] l m
    where
      c = if m then "unmount" else "mount"

  allInstalled _ = fmap isJust $ io $ findExecutable "udisksctl"

  isMounted Removable { deviceSpec = d } = elem d <$> io curDeviceSpecs

  fmtEntry Removable { deviceSpec = d, label = l } = l ++ alignSepPre ++ d

-- | Return list of possible rofi actions for removable devices
-- A 'removable device' is defined as a hotplugged device with a filesystem as
-- reported by 'lsblk'. If the LABEL does not exist on the filesystem, the
-- label shown on the prompt will be 'SIZE Volume' where size is the size of
-- the device
getRemovableDevices :: RofiConf c => RofiIO c [Removable]
getRemovableDevices = fromLines toDev . lines
  <$> io (readProcess "lsblk" ["-n", "-r", "-o", columns] "")
  where
    columns = "FSTYPE,HOTPLUG,PATH,LABEL,SIZE"
    -- can't use 'words' here since it will drop spaces in the front
    toDev line = case splitBy ' ' line of
      ("":_)             -> Nothing
      [_, "1", d, "", s] -> mk d $ s ++ " Volume"
      [_, "1", d, l, _]  -> mk d l
      _                  -> Nothing
    mk d l = Just $ Removable { deviceSpec = d, label = l }

--------------------------------------------------------------------------------
-- | CIFS Devices
--
-- This wraps the Removable device (since it is removable) and also adds its
-- own mount options and passwords for authentication.

data CIFS = CIFS Removable FilePath (Maybe PasswordGetter) Dependency

instance Show CIFS where
  show (CIFS r f _ d) = unwords [show r, show f, "<Pwd>", show d]

instance Mountable CIFS where
  mount (CIFS Removable{ label = l } m getPwd deps) False = do
    mountDependencies deps
    bracketOnError_
      (mkDirMaybe m)
      (rmDirMaybe m)
      $ io $ do
      res <- case getPwd of
        Just pwd -> do
          p <- maybe [] (\p -> [("PASSWD", p)]) <$> pwd
          readCmdEither' "mount" [m] "" p
        Nothing -> readCmdEither "mount" [m] ""
      notifyMounted (isRight res) False l

  mount (CIFS Removable{ label = l } m _ _) True = umountNotify l m

  allInstalled _ = io $ isJust <$> findExecutable "mount.cifs"

  isMounted (CIFS _ dir _ _) = io $ isDirMounted dir

  fmtEntry (CIFS r _ _ _) = fmtEntry r

instance StaticDevice CIFS CIFSConfig where
  configToDev v s CIFSConfig { _cifsMount = MountConfig { _mountMountPoint = m }
                             , _cifsRemote = t
                             , _cifsDepends = d
                             , _cifsPassword = p } = do
    let r = Removable { deviceSpec = smartSlashPrefix t, label = takeFileName m }
    d' <- maybe (return initDependencies) (getDependencies s) d
    return $ CIFS r (appendRoot v m) (configToPwd <$> p) d'
    where
      smartSlashPrefix a = if "//" `isPrefixOf` a then a else "//" ++ a

--------------------------------------------------------------------------------
-- | SSHFS Devices
--
-- This wraps the Removable device (since it is removable) and also adds its
-- own mount options. If the path does not point to an aliased entry in the ssh
-- config that specifies the port, hostname, user, and identity file, these
-- need to be passed as mount options.

data SSHFS = SSHFS Removable FilePath Dependency deriving Show

instance Mountable SSHFS where
  mount (SSHFS Removable{ deviceSpec = d, label = l } m deps) False = do
    mountDependencies deps
    bracketOnError_
      (mkDirMaybe m)
      (rmDirMaybe m)
      (io $ runMountNotify "sshfs" [d, m] l False)

  mount (SSHFS Removable{ label = l } m _) True = umountNotify l m

  allInstalled _ = fmap isJust $ io $ findExecutable "sshfs"

  isMounted (SSHFS _ dir _) = io $ isDirMounted dir

  fmtEntry (SSHFS r _ _) = fmtEntry r

instance StaticDevice SSHFS SSHFSConfig where
  configToDev v s SSHFSConfig { _sshfsMount = MountConfig { _mountMountPoint = m }
                              , _sshfsDepends = d
                              , _sshfsRemote = t } = do
    let r = Removable { deviceSpec = t, label = takeFileName m }
    d' <- maybe (return initDependencies) (getDependencies s) d
    return $ SSHFS r (appendRoot v m) d'

--------------------------------------------------------------------------------
-- | VeraCrypt Devices
--

data VeraCrypt = VeraCrypt Removable FilePath (Maybe PasswordGetter) Dependency

instance Show VeraCrypt where
  show (VeraCrypt r f _ d) = unwords [show r, show f, show d]

instance Mountable VeraCrypt where
  mount (VeraCrypt Removable{ deviceSpec = s, label = l } m getPwd deps) False = do
    mountDependencies deps
    bracketOnError_ (mkDirMaybe m) (rmDirMaybe m) mountMaybe
    where
      mountMaybe = io $ maybe (runVeraCryptWith "" []) (runVeraCryptWithPwd =<<) getPwd
      runVeraCryptWithPwd = maybe notifyFail (\p -> runVeraCryptWith p ["--stdin"])
      runVeraCryptWith stdin args = (\res -> notifyMounted (isRight res) False l)
        =<< runVeraCrypt stdin ([s, m] ++ args)
      notifyFail = notify "dialog-error-symbolic" $
        printf "Failed to get volume password for %s" l

  mount (VeraCrypt Removable{ label = l } m _ _) True = io $ do
    res <- runVeraCrypt "" ["-d", m]
    notifyMounted (isRight res) True l

  allInstalled _ = io $ isJust <$> findExecutable "veracrypt"

  isMounted (VeraCrypt _ dir _ _) = io $ isDirMounted dir

  fmtEntry (VeraCrypt r _ _ _) = fmtEntry r

-- NOTE: the user is assumed to have added themselves to the sudoers file so
-- that this command will work
runVeraCrypt :: String -> [String] -> IO (Either (Int, String, String) String)
runVeraCrypt stdin args = do
  readCmdEither "sudo" (defaultArgs ++ args) stdin
  where
    defaultArgs = ["/usr/bin/veracrypt", "--text", "--non-interactive"]

instance StaticDevice VeraCrypt VeracryptConfig where
  configToDev v s VeracryptConfig { _veracryptMount = MountConfig { _mountMountPoint = m }
                                  , _veracryptVolume = t
                                  , _veracryptDepends = d
                                  , _veracryptPassword = p } = do
    let r = Removable { deviceSpec = t, label = takeFileName m }
    d' <- maybe (return initDependencies) (getDependencies s) d
    return $ VeraCrypt r (appendRoot v m) (configToPwd <$> p) d'

--------------------------------------------------------------------------------
-- | Dependencies
--
-- Define a data structure that allows one device to depend on another. Since
-- each device is different and has a different typeclass instance, need to
-- include slots for all possible devices. For now only deal with static
-- devices.

data Dependency = Dependency
  { dependencySSHFS :: [SSHFS]
  , dependencyCIFS :: [CIFS]
  , dependencyVeracrypt :: [VeraCrypt]
  } deriving Show

initDependencies :: Dependency
initDependencies = Dependency [] [] []

getDependencies :: DevicesConfig -> DependsConfig -> RofiIO MountConf Dependency 
getDependencies devConf DependsConfig { _dependsCIFS = c
                                      , _dependsSSHFS = s
                                      , _dependsVeracrypt = v} = do
  c' <- getDepConfigs c _cifsConfigs
  s' <- getDepConfigs s _sshfsConfigs
  v' <- getDepConfigs v _veracryptConfigs
  return Dependency
    { dependencyCIFS = c'
    , dependencySSHFS = s'
    , dependencyVeracrypt = v'
    }
  where
    getDepConfigs aliases getConfig = fromConfig' devConf
      $ M.elems . M.filterWithKey (\k _ -> k `elem` V.toList aliases) . getConfig

mountDependencies :: Dependency -> RofiIO MountConf ()
mountDependencies Dependency { dependencyCIFS = c
                             , dependencySSHFS = s
                             , dependencyVeracrypt = v
                             } =
  mountAll c >> mountAll s >> mountAll v
  where
    mountAll :: Mountable a => [a] -> RofiIO MountConf ()
    mountAll = mapM_ (\d -> isMounted d >>= (\r -> unless r $ mount d False))

--------------------------------------------------------------------------------
-- | MTP devices
--
-- These devices are a bit special because they are not based on Removable
-- devices (eg they don't have a label and a device spec). Instead they
-- are defined by a bus:device path. The program used for this is jmtpfs
-- (which seems to be the fastest and most robust)

data MTPFS = MTPFS
    { bus         :: String
    , device      :: String
    , mountpoint  :: FilePath
    , description :: String
    }
    deriving (Eq, Show)

instance Mountable MTPFS where
  mount MTPFS {..} False = do
    -- TODO add autodismount to options
    let dev = "-device=" ++ bus ++ "," ++ device
    bracketOnError_
      (mkDirMaybe mountpoint)
      (rmDirMaybe mountpoint)
      (io $ runMountNotify "jmtpfs" [dev, mountpoint] description False)

  mount MTPFS { mountpoint = m, description = d } True = umountNotify d m

  -- | return True always since the list won't even show without jmtpfs
  allInstalled _ = return True

  isMounted MTPFS { mountpoint = dir } = io $ isDirMounted dir

  fmtEntry MTPFS { description = d } = d

-- | Return list of all available MTP devices
getMTPDevices :: RofiIO MountConf [MTPFS]
getMTPDevices = do
  dir <- asks mountconfVolatilePath
  res <- io $ readProcess "jmtpfs" ["-l"] ""
  return $ fromLines (toDev dir) $ toDevList res
  where
    toDevList = reverse
      . takeWhile (not . isPrefixOf "Available devices")
      . reverse
      . lines
    toDev dir s = case splitOn ", " s of
      [busNum, devNum, _, _, desc, vendor] -> let d = unwords [vendor, desc]
        in Just $ MTPFS
           { bus = busNum
           , device = devNum
           , mountpoint = dir </> canonicalize d
           , description = d
           }
      _ -> Nothing
    canonicalize = mapMaybe repl
    repl c
      | c `elem` ("\"*/:<>?\\|" :: String) = Nothing
      | c == ' ' = Just '-'
      | otherwise = Just c

--------------------------------------------------------------------------------
-- | Systemd typeclass

data SystemdMountType = SystemdVeracrypt | SystemdSSHFS deriving (Eq, Show)
  
data Systemd = Systemd
    { sysdType     :: SystemdMountType
    , sysdInstance :: String
    }
    deriving (Eq, Show)

instance Mountable Systemd where
  mount s@Systemd { sysdInstance = i } m = let
    unit = fmtSysdInstanceName s
    operation = if m then "stop" else "start" in
    io $ runMountNotify "systemctl" ["--user", operation, unit] i m

  allInstalled Systemd { sysdType = SystemdVeracrypt } =
    io $ isJust <$> findExecutable "veracrypt"

  allInstalled Systemd { sysdType = SystemdSSHFS } =
    io $ isJust <$> findExecutable "sshfs"

  isMounted s = let
    unit = fmtSysdInstanceName s
    args = ["--user", "is-active", "--quiet", unit] in
    io $ (\(ec, _, _) -> ec == ExitSuccess)
    <$> readProcessWithExitCode "systemctl" args ""

  fmtEntry Systemd { sysdInstance = i } = i ++ alignSepPre ++ "Systemd"

fmtSysdInstanceName :: Systemd -> String
fmtSysdInstanceName Systemd { sysdType = SystemdVeracrypt, sysdInstance = i } =
  "mount-veracrypt@" ++ i ++ ".service"
fmtSysdInstanceName Systemd { sysdType = SystemdSSHFS, sysdInstance = i } =
  "mount-sshfs@" ++ i ++ ".service"

getSystemdDevices :: IO [Systemd]
getSystemdDevices = do
  systemdHome <- io $ getXdgDirectory XdgConfig "systemd/user"
  io $ mapMaybe toDev
    <$> (filterM (doesDirectoryExist . (systemdHome </>))
    =<< listDirectory systemdHome)
  where
    toDev (splitInstance "mount-veracrypt@" -> Just s) =
      Just $ Systemd { sysdType = SystemdVeracrypt , sysdInstance = s }
    toDev (splitInstance "mount-sshfs@" -> Just s) =
      Just $ Systemd { sysdType = SystemdSSHFS , sysdInstance = s }
    toDev _ = Nothing
    splitInstance p = fmap (takeWhile (not . (==) '.')) . stripPrefix p

--------------------------------------------------------------------------------
-- | Mountable typeclass
--
-- Let this class represent anything that can be mounted. The end goal is to
-- create a Rofi action which will define an entry in the rofi prompt for the
-- device at hand. In order to make an action, we need functions to mount the
-- device, check if the necessary mounting program(s) is installed, make the
-- entry to go in the prompt, and test if the device is mounted.

class Mountable a where
  -- | Mount the given type (or dismount if False is passed)
  mount :: a -> Bool -> RofiIO MountConf ()

  -- | Check if the mounting utilities are present
  allInstalled :: a -> RofiIO MountConf Bool

  -- | Return a string to go in the Rofi menu for the given type
  fmtEntry :: a -> String

  -- | Determine if the given type is mounted or not
  isMounted :: a -> RofiIO MountConf Bool

  -- | Given a mountable type, return a rofi action (string to go in the
  -- Rofi prompt and an action to perform when it is selected)
  mkAction :: a -> RofiIO MountConf (String, RofiIO MountConf ())
  mkAction dev = do
    m <- isMounted dev
    i <- allInstalled dev
    let a = when i $ mount dev m
    let s = mountedPrefix m i ++ fmtEntry dev
    return (s, a)
    where
      mountedPrefix False True = "  "
      mountedPrefix True True  = "* "
      mountedPrefix _ False    = "! "

--------------------------------------------------------------------------------
-- | Low-level mount functions

-- ASSUME these will never fail because the format of /proc/mounts is fixed

curMountField :: Int -> IO [String]
curMountField i = fmap ((!! i) . words) . lines <$> readFile "/proc/mounts"

curDeviceSpecs :: IO [String]
curDeviceSpecs = curMountField 0

curMountpoints :: IO [String]
curMountpoints = curMountField 1

-- ASSUME the base mount path will always be created because
-- 'createDirectoryIfMissing' will make parents if missing, and that removing
-- all the directories will leave the base mount path intact regardless of if it
-- was present before doing anything (which matters here since I'm putting the
-- base path in /tmp, so all this is saying is that umounting everything will
-- leave /tmp/media/USER without removing all the way down to /tmp)

mkDirMaybe :: FilePath -> RofiIO MountConf ()
mkDirMaybe fp = whenInMountDir fp $ io $ createDirectoryIfMissing True fp

rmDirMaybe :: FilePath -> RofiIO MountConf ()
rmDirMaybe fp = whenInMountDir fp $ unlessMountpoint fp
  $ asks mountconfVolatilePath >>= io . rmUntil fp
  where
    rmUntil cur target = unless (target == cur) $ do
      removePathForcibly cur
      rmUntil (takeDirectory cur) target

whenInMountDir :: FilePath -> RofiIO MountConf () -> RofiIO MountConf ()
whenInMountDir fp f = do
  mDir <- asks mountconfVolatilePath
  when (mDir `isPrefixOf` fp) f

unlessMountpoint :: FilePath -> RofiIO MountConf () -> RofiIO MountConf ()
unlessMountpoint fp f = do
  mounted <- io $ isDirMounted fp
  unless mounted f

isDirMounted :: FilePath -> IO Bool
isDirMounted fp = elem fp <$> curMountpoints

runMountNotify :: String -> [String] -> String -> Bool -> IO ()
runMountNotify cmd args msg mounted = do
  res <- readCmdEither cmd args ""
  notifyMounted (isRight res) mounted msg

umountNotify' :: String -> String -> FilePath -> RofiIO MountConf ()
umountNotify' cmd msg dir = finally
  (io $ runMountNotify cmd [dir] msg True)
  (rmDirMaybe dir)

umountNotify :: String -> FilePath -> RofiIO MountConf ()
umountNotify = umountNotify' "umount"

-- | Send a notification indicating the mount succeeded
notifyMounted :: Bool -> Bool -> String -> IO ()
notifyMounted succeeded mounted label = notify icon body
  where
    (format, icon) = if succeeded
      then ("Successfully %sed %s", "dialog-information-symbolic")
      else ("Failed to %s %s", "dialog-error-symbolic")
    m = if mounted then "unmount" else "mount" :: String
    body = printf format m label

notify :: String -> String -> IO ()
notify icon body = void $ spawnProcess "notify-send" ["-i", icon, body]

--------------------------------------------------------------------------------
-- | Other functions

fromLines :: (String -> Maybe a) -> [String] -> [a]
fromLines f = mapMaybe (f . stripWS)

-- TODO this exists somewhere...
splitBy :: Char -> String -> [String]
splitBy delimiter = foldr f [[]]
  where
    f _ [] = []
    f c l@(x:xs) | c == delimiter = []:l
                 | otherwise = (c:x):xs

appendRoot :: FilePath -> FilePath -> FilePath
appendRoot root path = if isRelative path then root </> path else path