685 lines
25 KiB
Haskell
685 lines
25 KiB
Haskell
{-# 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 Data.Text (unpack)
|
|
|
|
import Rofi.Command
|
|
|
|
import Text.Printf
|
|
import Text.Regex.TDFA
|
|
import Text.Wrap
|
|
|
|
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
|
|
(_, _, errs) -> ioError $ userError $ concat errs ++ usageInfo h options
|
|
where
|
|
h = "Usage: rofi-dev [OPTIONS] [-- ROFI-OPTIONS]"
|
|
|
|
options :: [OptDescr (MountConf -> MountConf)]
|
|
options =
|
|
[ Option ['s'] ["secret"]
|
|
(ReqArg (\s m -> m { passwords = addSecret (passwords m) s } ) "SECRET")
|
|
$ wrap "Use libsecret to retrieve password for DIR using ATTR/VAL pairs. \
|
|
\The pairs will be supplied to a 'secret-tool lookup' call. \
|
|
\ Argument is formatted like 'DIR:ATTR1=VAL1,ATTR2=VAL2...'"
|
|
, Option ['b'] ["bitwarden"]
|
|
(ReqArg (\s m -> m { passwords = addBitwarden (passwords m) s } ) "BW")
|
|
$ wrap "Use the Bitwarden CLI to retrieve a password for DIR. \
|
|
\The argument is formatted like 'DIR:NAME' where NAME is the \
|
|
\name of the Bitwarden entry to find."
|
|
, Option ['p'] ["password"]
|
|
(ReqArg (\s m -> m { passwords = addPwdPrompt (passwords m) s } ) "DIR")
|
|
"Prompt for password when mounting DIR."
|
|
, Option ['d'] ["directory"]
|
|
(ReqArg (\s m -> m { mountDir = s } ) "DIR")
|
|
$ wrap "The DIR in which new mountpoints will be created. This is assumed \
|
|
\to be writable to the current user, and will be used for fuse \
|
|
\entries as well as user mounts in fstab. For the latter, it is \
|
|
\assumed that all user mounts contain this directory if a \
|
|
\mountpoint does not already exist for them. If not given this will \
|
|
\default to '/tmp/media/USER'."
|
|
, Option ['v'] ["veracrypt"]
|
|
(ReqArg (\s m -> m { vcMounts = addVeracryptMount (vcMounts m) s } ) "VC")
|
|
$ wrap "A veracrypt mount specification formatted like DIR:VOL where \
|
|
\DIR is the mountpoint and VOL is the path to the encrypted \
|
|
\volume. To specify a password, use the -p, -b- or -s options."
|
|
]
|
|
where
|
|
wrap = unpack . wrapText defaultWrapSettings 40
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Static configuration
|
|
--
|
|
-- 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
|
|
|
|
type PasswordGetter = IO (Maybe String)
|
|
|
|
type MountpointPasswords = M.Map String PasswordGetter
|
|
|
|
type VeracryptMount = (FilePath, FilePath)
|
|
|
|
addVeracryptMount :: [VeracryptMount] -> String -> [VeracryptMount]
|
|
addVeracryptMount l s = case splitPrefix s of
|
|
(dir, ":", vol) -> (dir, vol):l
|
|
_ -> l
|
|
|
|
-- TODO check if mountdir exists or puke
|
|
data MountConf = MountConf
|
|
{ passwords :: MountpointPasswords
|
|
, mountDir :: FilePath
|
|
, rofiArgs :: [String]
|
|
, vcMounts :: [VeracryptMount]
|
|
}
|
|
|
|
instance RofiConf MountConf where
|
|
defArgs MountConf { rofiArgs = a } = a
|
|
|
|
initMountConf :: [String] -> IO MountConf
|
|
initMountConf a = conf <$> getEffectiveUserName
|
|
where
|
|
conf u = MountConf
|
|
{ passwords = M.empty
|
|
, mountDir = "/tmp/media" </> u
|
|
, rofiArgs = a
|
|
, vcMounts = []
|
|
}
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Password-getting functions
|
|
|
|
addSecret :: MountpointPasswords -> String -> MountpointPasswords
|
|
addSecret pwds c = case splitPrefix c of
|
|
(dir, ":", r) -> M.insert dir (runSecret $ fromCommaSepString' r) pwds
|
|
_ -> pwds
|
|
|
|
runSecret :: [(String, String)] -> PasswordGetter
|
|
runSecret kvs = readCmdSuccess "secret-tool" ("lookup":kvs') ""
|
|
where
|
|
kvs' = concatMap (\(k, v) -> [k, v]) kvs
|
|
|
|
addBitwarden :: MountpointPasswords -> String -> MountpointPasswords
|
|
addBitwarden pwds c = case splitPrefix c of
|
|
(dir, ":", name) -> M.insert dir (runBitwarden name) pwds
|
|
_ -> pwds
|
|
|
|
runBitwarden :: String -> PasswordGetter
|
|
runBitwarden pname = ((password . login) <=< find (\i -> name i == pname))
|
|
<$> getItems
|
|
|
|
addPwdPrompt :: MountpointPasswords -> String -> MountpointPasswords
|
|
addPwdPrompt pwds dir = M.insert dir readPassword pwds
|
|
|
|
splitPrefix :: String -> (String, String, String)
|
|
splitPrefix s = s =~ (":" :: String)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | 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 :: MountConf -> IO ()
|
|
runMounts c = runRofiIO c $ runPrompt =<< getGroups
|
|
|
|
runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c ()
|
|
runPrompt gs = selectAction $ emptyMenu
|
|
{ groups = gs
|
|
, prompt = Just "Select Device"
|
|
}
|
|
|
|
getGroups :: RofiIO MountConf [RofiGroup MountConf]
|
|
getGroups = do
|
|
fstab <- readFSTab
|
|
sysd <- io getSystemdDevices
|
|
sequence
|
|
[ mkGroup2 "SSHFS Devices" (filterSysd SystemdSSHFS sysd) $ sshfsDevices fstab
|
|
, mkGroup "CIFS Devices" $ cifsDevices fstab
|
|
, mkGroup2 "Veracrypt Devices" (filterSysd SystemdVeracrypt sysd) =<< getVeracryptDevices
|
|
, mkGroup "Removable Devices" =<< getRemovableDevices
|
|
, mkGroup "MTP Devices" =<< getMTPDevices
|
|
]
|
|
where
|
|
filterSysd t = filter (\s -> sysdType s == t)
|
|
|
|
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)
|
|
|
|
instance Mountable CIFS where
|
|
mount (CIFS Removable{ label = l } m getPwd) False =
|
|
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
|
|
|
|
-- TODO this smells like something that should be in a typeclass
|
|
fstabToCIFS :: FSTabEntry -> RofiIO MountConf CIFS
|
|
fstabToCIFS FSTabEntry{ fstabSpec = s, fstabDir = d, fstabOptions = o } = do
|
|
-- If the options specify "guest" don't require a password. Else try to find a
|
|
-- means to get the password from the command line options provided for the
|
|
-- this mountpoint. If nothing is found, prompt for a password. In any case,
|
|
-- the output will be passed to env variable PASSWD when mounting this cifs
|
|
-- directory and cause it to fail. Setting the env variable is necessary as
|
|
-- the cifs mount call will prompt for a password and hang otherwise.
|
|
pwd <- if M.member "guest" o
|
|
then return Nothing
|
|
else asks $ Just . M.findWithDefault readPassword d . passwords
|
|
let r = Removable { deviceSpec = smartSlashPrefix s, label = takeFileName d }
|
|
return $ CIFS r d pwd
|
|
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
|
|
|
|
instance Mountable SSHFS where
|
|
mount (SSHFS Removable{ label = l } m) False =
|
|
bracketOnError_
|
|
(mkDirMaybe m)
|
|
(rmDirMaybe m)
|
|
(io $ runMountNotify "mount" [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
|
|
|
|
fstabToSSHFS :: FSTabEntry -> RofiIO MountConf SSHFS
|
|
fstabToSSHFS FSTabEntry{ fstabSpec = s, fstabDir = d } = return $ SSHFS r d
|
|
where
|
|
r = Removable { deviceSpec = s, label = takeFileName d }
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | VeraCrypt Devices
|
|
--
|
|
|
|
data VeraCrypt = VeraCrypt Removable FilePath (Maybe PasswordGetter)
|
|
|
|
instance Mountable VeraCrypt where
|
|
mount (VeraCrypt Removable{ deviceSpec = s, label = l } m getPwd) False =
|
|
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"]
|
|
|
|
getVeracryptDevices :: RofiIO MountConf [VeraCrypt]
|
|
getVeracryptDevices = mapM toDev =<< asks vcMounts
|
|
where
|
|
toDev (d, s) = do
|
|
pwd <- asks $ Just . M.findWithDefault readPassword d . passwords
|
|
let r = Removable { deviceSpec = s, label = takeFileName d }
|
|
return $ VeraCrypt r d pwd
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | 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 mountDir
|
|
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
|
|
op = if m then "stop" else "start" in
|
|
io $ runMountNotify "systemctl" ["--user", op, 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 = "! "
|
|
|
|
-- TODO add truecrypt volumes
|
|
--------------------------------------------------------------------------------
|
|
-- | Fstab devices
|
|
--
|
|
-- Functions to gather all user fstab mounts on the system
|
|
|
|
-- | Intermediate structure to hold fstab devices
|
|
data FSTab = FSTab
|
|
{ sshfsDevices :: [SSHFS]
|
|
, cifsDevices :: [CIFS]
|
|
-- , veracryptDevices :: [VeraCrypt]
|
|
}
|
|
|
|
-- | Data structure representing an fstab device (or one line in the fstab file)
|
|
data FSTabEntry = FSTabEntry
|
|
{ fstabSpec :: String
|
|
, fstabDir :: FilePath
|
|
, fstabType :: String
|
|
, fstabOptions :: MountOptions
|
|
}
|
|
|
|
-- | Key/val pairs to represent mount options. A Nothing for the value signifies
|
|
-- a standalone option (eg 'rw' and 'ro')
|
|
type MountOptions = M.Map String (Maybe String)
|
|
|
|
-- | Return all user fstab devices from /etc/fstab
|
|
readFSTab :: RofiIO MountConf FSTab
|
|
readFSTab = do
|
|
-- let i = FSTab { sshfsDevices = [], cifsDevices = [], veracryptDevices = []}
|
|
let i = FSTab { sshfsDevices = [], cifsDevices = []}
|
|
fstab <- io $ readFile "/etc/fstab"
|
|
foldM addFstabDevice i $ fromLines toEntry $ lines fstab
|
|
where
|
|
toEntry line = case words line of
|
|
(('#':_):_) -> Nothing
|
|
[spec, dir, fsType, opts, _, _] -> Just $ FSTabEntry
|
|
{ fstabSpec = spec
|
|
, fstabDir = dir
|
|
, fstabType = fsType
|
|
, fstabOptions = parseOptions opts
|
|
}
|
|
_ -> Nothing
|
|
parseOptions = M.fromList . fromCommaSepString
|
|
|
|
-- | Add entry to the fstab devices list, but only if it is a known user mount
|
|
addFstabDevice :: FSTab -> FSTabEntry -> RofiIO MountConf FSTab
|
|
addFstabDevice f@FSTab{..} e@FSTabEntry{..}
|
|
| M.notMember "users" fstabOptions = return f
|
|
| fstabType == "cifs" =
|
|
(\d -> f { cifsDevices = append d cifsDevices }) <$> fstabToCIFS e
|
|
| fstabType == "fuse.sshfs" =
|
|
(\d -> f { sshfsDevices = append d sshfsDevices }) <$> fstabToSSHFS e
|
|
-- | fstabType == "veracrypt" =
|
|
-- (\d -> f { veracryptDevices = append d veracryptDevices }) <$> fstabToVeraCrypt e
|
|
| otherwise = return f
|
|
where
|
|
append x xs = xs ++ [x]
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | 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 mountDir >>= 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 mountDir
|
|
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
|
|
|
|
-- | Like fromCommaSepString but only return substrings with '='
|
|
fromCommaSepString' :: String -> [(String, String)]
|
|
fromCommaSepString' s = [(k, v) | (k, Just v) <- fromCommaSepString s]
|
|
|
|
-- | Split a string of comma-separated values into an alist
|
|
-- If the substrings have an '=' in them, the left side will become the key and
|
|
-- the right will become the value of the cell. If there is not '=' then the
|
|
-- entire substring will become the key and the value will be Nothing
|
|
fromCommaSepString :: String -> [(String, Maybe String)]
|
|
fromCommaSepString = fmap (toCell . splitEq) . splitBy ','
|
|
where
|
|
splitEq e = e =~ ("=" :: String) :: (String, String, String)
|
|
toCell (k, "=", v) = (k, Just v)
|
|
toCell (k, _, _) = (k, Nothing)
|