rofi-extras/app/rofi-dev.hs

828 lines
29 KiB
Haskell
Raw Normal View History

2021-03-22 19:20:32 -04:00
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
2020-04-23 23:32:29 -04:00
--------------------------------------------------------------------------------
-- | 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.
2020-04-23 23:32:29 -04:00
module Main (main) where
import Bitwarden.Internal
2020-04-23 23:32:29 -04:00
import Control.Monad
2020-05-01 21:29:54 -04:00
import Control.Monad.Reader
2020-04-23 23:32:29 -04:00
import Data.List
2020-05-01 21:29:54 -04:00
import Data.List.Split (splitOn)
import qualified Data.Map as M
2020-04-23 23:32:29 -04:00
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Vector as V
2021-03-18 00:41:04 -04:00
import Data.Yaml
2020-04-23 23:32:29 -04:00
import Rofi.Command
import Text.Printf
2020-05-01 21:29:54 -04:00
import System.Console.GetOpt
2020-04-23 23:32:29 -04:00
import System.Directory
import System.Environment
2020-05-01 21:29:54 -04:00
import System.FilePath.Posix
import System.Posix.User (getEffectiveUserName)
2020-04-23 23:32:29 -04:00
import System.Process
2020-05-01 21:29:54 -04:00
import UnliftIO.Exception
2020-04-23 23:32:29 -04:00
main :: IO ()
main = getArgs >>= parse
2020-05-01 21:29:54 -04:00
parse :: [String] -> IO ()
parse args = case getOpt Permute options args of
2021-03-19 23:23:45 -04:00
(o, n, []) -> runMounts $ foldl (flip id) (defaultOpts n) o
(_, _, errs) -> ioError $ userError $ concat errs ++ usageInfo h options
2020-05-01 21:29:54 -04:00
where
h = "Usage: rofi-dev [OPTIONS] [-- ROFI-OPTIONS]"
2021-03-19 23:23:45 -04:00
defaultOpts r = Opts
{ optsConfig = Nothing
, optsAlias = Nothing
, optsUnmount = False
, optsRofiArgs = r
}
2020-05-01 21:29:54 -04:00
2021-03-19 23:23:45 -04:00
options :: [OptDescr (Opts -> Opts)]
2020-05-01 21:29:54 -04:00
options =
2021-03-18 00:41:04 -04:00
[ Option ['c'] ["config"]
2021-03-19 23:23:45 -04:00
(ReqArg (\s m -> m { optsConfig = Just s } ) "CONF")
2021-03-18 00:41:04 -04:00
"The path to the config file"
2021-03-19 23:23:45 -04:00
, 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."
2020-05-01 21:29:54 -04:00
]
2021-03-19 23:23:45 -04:00
data Opts = Opts
{ optsConfig :: Maybe FilePath
, optsAlias :: Maybe String
, optsUnmount :: Bool
, optsRofiArgs :: [String]
} deriving Show
--------------------------------------------------------------------------------
2021-03-23 21:39:41 -04:00
-- | 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
2021-03-23 22:39:02 -04:00
let tmpPath = fromMaybe defaultTmpPath $ staticconfigTmpPath =<< static
let staticDevs = maybe M.empty staticconfigDevices static
let verbose = fromMaybe False $ staticconfigVerbose =<< static
2021-03-23 21:39:41 -04:00
let mountconf = MountConf
{ mountconfVolatilePath = tmpPath
, mountconfRofiArgs = optsRofiArgs opts
, mountconfStaticDevs = staticDevs
, mountconfVerbose = verbose
}
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 :: RofiMountIO [RofiGroup MountConf]
getGroups = do
2021-03-25 00:35:59 -04:00
actions <- sequence [getStaticActions, getRemovableActions, getMTPActions]
2021-03-23 21:39:41 -04:00
return $ mapMaybe mkGroup
$ groupBy (\(hx, _) (hy, _) -> hx == hy)
$ sortBy (\(hx, _) (hy, _) -> compare hx hy)
2021-03-25 00:35:59 -04:00
$ concat actions
2021-03-23 21:39:41 -04:00
mountByAlias :: Bool -> String -> RofiMountIO ()
mountByAlias unmountFlag alias = do
static <- asks mountconfStaticDevs
mapM_ (`mountMaybe` unmountFlag) $ configToTree static <$> M.lookup alias static
mkGroup :: [(Header, ProtoAction [String])] -> Maybe (RofiGroup MountConf)
mkGroup [] = Nothing
2021-03-23 22:39:02 -04:00
mkGroup as = let ((h, _):_) = as in
Just $ titledGroup (show h) $ toRofiActions $ alignEntries $ fmap snd as
2021-03-23 21:39:41 -04:00
alignSep :: String
alignSep = " | "
alignEntries :: [ProtoAction [String]] -> [(String, RofiMountIO ())]
alignEntries ps = zip (align es) as
where
(es, as) = unzip $ fmap (\(ProtoAction e a) -> (e, a)) ps
align = fmap (intercalate alignSep)
. transpose
. mapToLast pad
. transpose
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
--------------------------------------------------------------------------------
-- | Global config used in the reader monad stack
data MountConf = MountConf
2021-03-25 00:35:59 -04:00
{ mountconfVolatilePath :: FilePath
, mountconfRofiArgs :: [String]
, mountconfStaticDevs :: M.Map String TreeConfig
, mountconfVerbose :: Bool
} deriving Show
2021-03-23 21:39:41 -04:00
instance RofiConf MountConf where
defArgs MountConf { mountconfRofiArgs = a } = a
--------------------------------------------------------------------------------
-- | Mountable typeclass
--
2021-03-23 21:39:41 -04:00
-- Class to provide common interface for anything that can be mounted.
class Mountable a where
-- | Mount the given type (or dismount if False is passed)
2021-03-25 00:35:59 -04:00
mount :: a -> Bool -> RofiMountIO MountResult
2021-03-23 21:39:41 -04:00
mountMaybe :: a -> Bool -> RofiMountIO ()
mountMaybe dev mountFlag = do
mounted <- isMounted dev
verbose <- asks mountconfVerbose
2021-03-25 00:35:59 -04:00
if mountFlag == mounted
then (io . notifyMountResult mounted (getLabel dev)) =<< mount dev mountFlag
2021-03-23 21:39:41 -04:00
else when verbose notify'
where
2021-03-25 00:35:59 -04:00
notify' = io $ notify IconInfo (getLabel dev ++ " already mounted") Nothing
2021-03-23 21:39:41 -04:00
-- | Check if the mounting utilities are present
allInstalled :: a -> RofiMountIO Bool
-- | Return a string representing the label of the device
getLabel :: a -> String
-- | Determine if the given type is mounted or not
isMounted :: a -> RofiMountIO Bool
--------------------------------------------------------------------------------
-- | Actionable typeclass
--
-- Class to provide common interface for anything that can be presented in the
-- Rofi menu as an action. Note that this must be separate from the Mountable
-- class above because some devices are represented as trees, and displaying
-- these trees in the rofi menu only requires that the tree itself be presented
-- and not its subcomponents.
class Mountable a => Actionable a where
-- | Return a string to go in the Rofi menu for the given type
fmtEntry :: a -> [String]
fmtEntry d = [getLabel d]
groupHeader :: a -> Header
-- | 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 -> RofiMountIO (Header, ProtoAction [String])
mkAction dev = do
m <- isMounted dev
i <- allInstalled dev
let h = groupHeader dev
let action = when i $ mountMaybe dev m
let entry = case fmtEntry dev of
(e:es) -> (mountedPrefix m i ++ e):es
_ -> []
return (h, ProtoAction entry action)
where
mountedPrefix False True = " "
mountedPrefix True True = "* "
mountedPrefix _ False = "! "
2021-03-25 00:35:59 -04:00
mountableToAction :: Actionable a => RofiMountIO [a] -> RofiMountIO [(Header, ProtoAction [String])]
mountableToAction ms = mapM mkAction =<< ms
2021-03-23 21:39:41 -04:00
type RofiMountIO a = RofiIO MountConf a
2021-03-23 22:39:02 -04:00
-- headers appear in the order listed here (per Enum)
data Header = CIFSHeader
| SSHFSHeader
| VeracryptHeader
| RemovableHeader
| MTPFSHeader
deriving (Enum, Eq)
instance Show Header where
show h = case h of
CIFSHeader -> suffix "CIFS"
SSHFSHeader -> suffix "SSHFS"
VeracryptHeader -> suffix "Veracrypt"
RemovableHeader -> suffix "Removable"
MTPFSHeader -> suffix "MTPFS"
where
suffix = (++ " Devices")
2021-03-23 21:39:41 -04:00
instance Ord Header where
2021-03-23 22:39:02 -04:00
compare x y = compare (fromEnum x) (fromEnum y)
2021-03-23 21:39:41 -04:00
2021-03-25 00:35:59 -04:00
data ProtoAction a = ProtoAction a (RofiMountIO ())
2021-03-23 21:39:41 -04:00
--------------------------------------------------------------------------------
-- | Static device configuration
--
-- Static devices are defined in a YAML file. These types/instances describe how
-- to parse said YAML file.
2021-03-18 00:41:04 -04:00
defaultTries :: Integer
defaultTries = 2
2021-03-19 23:23:45 -04:00
(.:&) :: FromJSON a => Object -> T.Text -> Parser (V.Vector a)
(.:&) o t = o .:? t .!= V.empty
2021-03-18 00:41:04 -04:00
data MountConfig = MountConfig
2021-03-23 22:39:02 -04:00
{ mountMountpoint :: FilePath
, mountLabel :: Maybe String
2021-03-18 00:41:04 -04:00
} deriving Show
instance FromJSON MountConfig where
2021-03-23 22:39:02 -04:00
parseJSON = withObject "mount" $ \o -> MountConfig
2021-03-18 00:41:04 -04:00
<$> o .: "mountpoint"
<*> o .:? "label"
data BitwardenConfig = BitwardenConfig
{ bitwardenKey :: String
2021-03-23 22:39:02 -04:00
, bitwardenTries :: Integer }
2021-03-18 00:41:04 -04:00
deriving Show
instance FromJSON BitwardenConfig where
parseJSON = withObject "bitwarden" $ \o -> BitwardenConfig
<$> o .: "key"
<*> o .:? "tries" .!= defaultTries
newtype LibSecretConfig = LibSecretConfig
2021-03-23 22:39:02 -04:00
{ libsecretAttributes :: M.Map String String }
2021-03-18 00:41:04 -04:00
deriving Show
instance FromJSON LibSecretConfig where
parseJSON = withObject "libsecret" $ \o -> LibSecretConfig
<$> o .: "attributes"
newtype PromptConfig = PromptConfig
2021-03-23 22:39:02 -04:00
{ promptTries :: Integer }
2021-03-18 00:41:04 -04:00
deriving Show
instance FromJSON PromptConfig where
parseJSON = withObject "prompt" $ \o -> PromptConfig
<$> o .:? "tries" .!= defaultTries
data PasswordConfig = PwdBW BitwardenConfig
| PwdLS LibSecretConfig
| PwdPr PromptConfig
2021-03-18 00:41:04 -04:00
deriving Show
instance FromJSON PasswordConfig where
parseJSON = withObject "password" $ \o -> do
br <- fmap PwdBW <$> o .:? "bitwarden"
ls <- maybe (fmap PwdLS <$> o .:? "libsecret") (return . Just) br
-- TODO this is silly because I need to pass 'prompt: {}' instead of
-- just 'prompt:' if I just want the defaults
maybe (PwdPr <$> o .: "prompt") return ls
2021-03-20 14:00:47 -04:00
2021-03-26 00:17:13 -04:00
data CIFSOptsConfig = CIFSOptsConfig
{ cifsoptsUsername :: Maybe String
, cifsoptsWorkgroup :: Maybe String
, cifsoptsUID :: Maybe Integer
, cifsoptsGID :: Maybe Integer
2021-03-26 00:17:13 -04:00
, cifsoptsIocharset :: Maybe String
} deriving Show
instance FromJSON CIFSOptsConfig where
parseJSON = withObject "options" $ \o -> CIFSOptsConfig
<$> o .:? "username"
<*> o .:? "workgroup"
<*> o .:? "uid"
<*> o .:? "gid"
<*> o .:? "isocharset"
2021-03-22 19:20:32 -04:00
data DataConfig = VeracryptConfig
2021-03-26 00:17:13 -04:00
{ veracryptVolume :: String
2021-03-23 22:39:02 -04:00
, veracryptPassword :: Maybe PasswordConfig
2021-03-20 14:00:47 -04:00
} | SSHFSConfig
{ sshfsRemote :: String
, sshfsPassword :: Maybe PasswordConfig
2021-03-20 14:00:47 -04:00
} | CIFSConfig
{ cifsRemote :: String
, cifsSudo :: Bool
, cifsPassword :: Maybe PasswordConfig
, cifsOpts :: Maybe CIFSOptsConfig
2021-03-18 00:41:04 -04:00
} deriving Show
2021-03-22 19:20:32 -04:00
data DeviceConfig = DeviceConfig
2021-03-23 22:39:02 -04:00
{ deviceMount :: MountConfig
2021-03-26 00:17:13 -04:00
, deviceData :: DataConfig
2021-03-22 19:20:32 -04:00
} deriving Show
data TreeConfig = TreeConfig
2021-03-26 00:17:13 -04:00
{ treeParent :: DeviceConfig
2021-03-23 22:39:02 -04:00
, treeconfigChildren :: V.Vector String
2021-03-22 19:20:32 -04:00
} deriving Show
instance FromJSON TreeConfig where
2021-03-20 14:00:47 -04:00
parseJSON = withObject "devices" $ \o -> do
devType <- o .: "type"
2021-03-22 19:20:32 -04:00
deps <- o .:& "depends"
mountconf <- o .: "mount"
devData <- case (devType :: String) of
"cifs" -> CIFSConfig
<$> o .: "remote"
2021-03-25 23:16:55 -04:00
<*> o .:? "sudo" .!= False
2021-03-22 19:20:32 -04:00
<*> o .:? "password"
2021-03-26 00:17:13 -04:00
<*> o .:? "options"
2021-03-22 19:20:32 -04:00
"sshfs" -> SSHFSConfig
<$> o .: "remote"
<*> o .:? "password"
2021-03-22 19:20:32 -04:00
"veracrypt" -> VeracryptConfig
<$> o .: "volume"
<*> o .:? "password"
-- TODO make this skip adding an entry to the map rather than
-- skipping the map entirely
_ -> fail $ "unknown device type: " ++ devType
return $ TreeConfig
2021-03-23 22:39:02 -04:00
{ treeParent = DeviceConfig
{ deviceMount = mountconf
, deviceData = devData
2021-03-22 19:20:32 -04:00
}
2021-03-23 22:39:02 -04:00
, treeconfigChildren = deps
2021-03-22 19:20:32 -04:00
}
2021-03-18 00:41:04 -04:00
data StaticConfig = StaticConfig
2021-03-23 22:39:02 -04:00
{ staticconfigTmpPath :: Maybe String
, staticconfigVerbose :: Maybe Bool
, staticconfigDevices :: M.Map String TreeConfig
2021-03-18 00:41:04 -04:00
} deriving Show
instance FromJSON StaticConfig where
parseJSON = withObject "devices" $ \o -> StaticConfig
<$> o .:? "mountdir"
2021-03-23 20:42:14 -04:00
<*> o .:? "verbose"
2021-03-20 14:00:47 -04:00
<*> o .: "devices"
2021-03-18 00:41:04 -04:00
--------------------------------------------------------------------------------
2021-03-23 21:39:41 -04:00
-- | Static devices trees
2021-03-18 00:41:04 -04:00
--
2021-03-23 21:39:41 -04:00
-- Static devices as defined in the config file may declare dependencies on
-- other static devices, and thus are best represented as a tree. Note that the
-- tree is both Actionable and Mountable, where each node in the tree is only
-- Mountable; this is because trees need to be displayed and chosen in the Rofi
-- menu.
2021-03-23 21:39:41 -04:00
data Tree a = Tree a [Tree a] deriving (Eq, Show)
2021-03-23 21:39:41 -04:00
type StaticConfigTree = Tree DeviceConfig
instance Mountable a => Mountable (Tree a) where
mount (Tree p cs) False = mapM_ (`mountMaybe` False) cs >> mount p False
mount (Tree p _) True = mount p True
2021-03-23 21:39:41 -04:00
isMounted (Tree p _) = isMounted p
allInstalled (Tree p cs) = do
res <- and <$> mapM allInstalled cs
if res then allInstalled p else return res
getLabel (Tree p _) = getLabel p
instance Actionable (Tree DeviceConfig) where
fmtEntry (Tree p@DeviceConfig{ deviceData = d } _) = [getLabel p, target d]
2021-03-23 21:39:41 -04:00
where
target CIFSConfig{ cifsRemote = r } = r
target SSHFSConfig{ sshfsRemote = r } = r
2021-03-23 22:39:02 -04:00
target VeracryptConfig{ veracryptVolume = v } = v
2021-03-23 21:39:41 -04:00
2021-03-23 22:39:02 -04:00
groupHeader (Tree DeviceConfig{ deviceData = d } _) =
2021-03-23 21:39:41 -04:00
case d of
CIFSConfig{} -> CIFSHeader
SSHFSConfig{} -> SSHFSHeader
2021-03-23 22:39:02 -04:00
VeracryptConfig{} -> VeracryptHeader
2021-03-23 21:39:41 -04:00
configToTree' :: M.Map String TreeConfig -> [StaticConfigTree]
configToTree' devMap = configToTree devMap <$> M.elems devMap
configToTree :: M.Map String TreeConfig -> TreeConfig -> StaticConfigTree
2021-03-23 22:39:02 -04:00
configToTree devMap TreeConfig{ treeParent = p, treeconfigChildren = c } =
2021-03-23 21:39:41 -04:00
Tree p $ fmap go V.toList c
where
go ds = configToTree devMap <$> mapMaybe (`M.lookup` devMap) ds
--------------------------------------------------------------------------------
-- | Static devices
--
-- This is complex because there may be multiple classes of static devices
-- in the config file, and each device may depend on another device that is
-- a different class (eg sshfs on cifs). I deal with this by abstracting the
-- differences between each class in a sum-record type; in this way the
-- processing "splits" and "converges" entirely in this function, so nothing
-- outside of these needs to be aware of these different classes.
instance Mountable DeviceConfig where
2021-03-25 00:35:59 -04:00
mount DeviceConfig{ deviceMount = m, deviceData = devData} False = do
2021-03-23 21:39:41 -04:00
m' <- getAbsMountpoint m
2021-03-25 00:35:59 -04:00
withTmpMountDir m'
$ io
$ case devData of
SSHFSConfig{ sshfsRemote = r, sshfsPassword = p } -> mountSSHFS m' p r
2021-03-26 00:17:13 -04:00
CIFSConfig
{ cifsRemote = r
, cifsSudo = s
, cifsPassword = p
, cifsOpts = o
} -> mountCIFS s r m' o p
2021-03-25 00:35:59 -04:00
VeracryptConfig{ veracryptPassword = p, veracryptVolume = v } ->
mountVeracrypt m' p v
mount DeviceConfig{ deviceMount = m, deviceData = d } True = do
2021-03-23 21:39:41 -04:00
m' <- getAbsMountpoint m
2021-03-25 00:35:59 -04:00
runAndRemoveDir m' $ io $ case d of
CIFSConfig{ cifsSudo = s } -> runMountSudoMaybe s "umount" [m']
2021-03-25 23:16:55 -04:00
VeracryptConfig{} -> runVeraCrypt ["-d", m'] ""
_ -> runMount "umount" [m'] ""
2021-03-23 21:39:41 -04:00
2021-03-23 22:39:02 -04:00
allInstalled DeviceConfig{ deviceData = devData } = io $ isJust
2021-03-23 21:39:41 -04:00
<$> findExecutable (exe devData)
where
exe SSHFSConfig{} = "sshfs"
exe CIFSConfig{} = "mount.cifs"
2021-03-23 21:39:41 -04:00
exe VeracryptConfig{} = "veracrypt"
2021-03-23 22:39:02 -04:00
isMounted DeviceConfig{ deviceMount = m } =
2021-03-23 21:39:41 -04:00
(io . isDirMounted) =<< getAbsMountpoint m
getLabel DeviceConfig
2021-03-23 22:39:02 -04:00
{ deviceMount = MountConfig { mountMountpoint = p, mountLabel = l }
2021-03-23 21:39:41 -04:00
} = fromMaybe (takeFileName p) l
mountSSHFS :: FilePath -> Maybe PasswordConfig -> String -> IO MountResult
mountSSHFS mountpoint pwdConfig remote =
withPasswordGetter pwdConfig (run ["-o", "password_stdin"]) $ run [] ""
where
run other = runMount "sshfs" (other ++ [remote, mountpoint])
2021-03-25 00:35:59 -04:00
mountCIFS :: Bool -> String -> FilePath -> Maybe CIFSOptsConfig
2021-03-26 00:17:13 -04:00
-> Maybe PasswordConfig -> IO MountResult
mountCIFS useSudo remote mountpoint opts pwdConfig =
withPasswordGetter pwdConfig runPwd run
where
run = runMountSudoMaybe useSudo "mount.cifs" args
runPwd p = runMountSudoMaybe' useSudo "mount.cifs" args [("PASSWD", p)]
args = [remote, mountpoint] ++ maybe [] (\o -> ["-o", fromCIFSOpts o]) opts
fromCIFSOpts :: CIFSOptsConfig -> String
fromCIFSOpts o = intercalate "," $ mapMaybe concatMaybe fs
2021-03-25 00:35:59 -04:00
where
2021-03-26 00:17:13 -04:00
fs = [ ("username", cifsoptsUsername)
, ("workgroup", cifsoptsWorkgroup)
, ("uid", fmap show . cifsoptsUID)
, ("gid", fmap show . cifsoptsGID)
, ("iocharset", cifsoptsIocharset)
]
concatMaybe (k, f) = (\v -> k ++ "=" ++ v) <$> f o
2021-03-25 00:35:59 -04:00
mountVeracrypt :: FilePath -> Maybe PasswordConfig -> String -> IO MountResult
mountVeracrypt mountpoint pwdConfig volume =
2021-03-25 00:35:59 -04:00
withPasswordGetter pwdConfig (runVeraCrypt (args ++ ["--stdin"]))
$ runVeraCrypt args ""
where
args = [volume, mountpoint]
2021-03-23 21:39:41 -04:00
-- NOTE: the user is assumed to have added themselves to the sudoers file so
-- that this command will work
2021-03-25 00:35:59 -04:00
runVeraCrypt :: [String] -> String -> IO MountResult
runVeraCrypt args = runMount "sudo" (defaultArgs ++ args)
2021-03-23 21:39:41 -04:00
where
defaultArgs = ["/usr/bin/veracrypt", "--text", "--non-interactive"]
2020-05-01 21:29:54 -04:00
2021-03-25 00:35:59 -04:00
getAbsMountpoint :: MountConfig -> RofiMountIO FilePath
getAbsMountpoint MountConfig{ mountMountpoint = m } =
asks $ flip appendRoot m . mountconfVolatilePath
getStaticActions :: RofiMountIO [(Header, ProtoAction [String])]
getStaticActions = mountableToAction $ asks $ configToTree' . mountconfStaticDevs
2021-03-25 00:35:59 -04:00
--------------------------------------------------------------------------------
2021-03-23 21:39:41 -04:00
-- | Password-getting functions for static devices
2021-03-18 00:41:04 -04:00
type PasswordGetter = IO (Maybe String)
2020-05-01 21:29:54 -04:00
2021-03-23 22:39:02 -04:00
runSecret :: M.Map String String -> PasswordGetter
runSecret kvs = readCmdSuccess "secret-tool" ("lookup":kvs') ""
2020-05-01 21:29:54 -04:00
where
kvs' = concatMap (\(k, v) -> [k, v]) $ M.toList kvs
2020-05-01 21:29:54 -04:00
runBitwarden :: String -> PasswordGetter
runBitwarden pname = ((password . login) <=< find (\i -> name i == pname))
<$> getItems
2021-03-18 00:41:04 -04:00
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 = maybe (return Nothing) (runSecret . libsecretAttributes)
-- getPrompt = maybe (return Nothing) (flip runPromptLoop readPassword . promptTries)
-- runMaybe x y = (\r -> if isNothing r then y else return r) =<< x
2021-03-18 00:41:04 -04:00
configToPwd :: PasswordConfig -> PasswordGetter
configToPwd (PwdBW (BitwardenConfig { bitwardenKey = k, bitwardenTries = n })) =
runPromptLoop n $ runBitwarden k
configToPwd (PwdLS s) = runSecret $ libsecretAttributes s
configToPwd (PwdPr p) = flip runPromptLoop readPassword $ promptTries p
2021-03-25 00:35:59 -04:00
withPasswordGetter :: Maybe PasswordConfig -> (String -> IO MountResult)
-> IO MountResult -> IO MountResult
withPasswordGetter (Just pwdConfig) runPwd _ =
maybe (return $ MountError "Password could not be obtained") runPwd
=<< configToPwd pwdConfig
withPasswordGetter Nothing _ run = run
2020-04-23 23:32:29 -04:00
--------------------------------------------------------------------------------
-- | Removable devices
--
2021-03-23 21:39:41 -04:00
-- A device which can be removed (such as a flash drive). These are distinct
-- from any device in the static configuration in that they only have device
-- addresses (eg in /dev) and labels.
2020-04-23 23:32:29 -04:00
data Removable = Removable
2021-03-25 00:35:59 -04:00
{ removablePath :: String
, removableLabel :: String
2020-04-23 23:32:29 -04:00
}
deriving (Eq, Show)
instance Mountable Removable where
2021-03-25 00:35:59 -04:00
mount Removable { removablePath = d } m =
io $ runMount "udisksctl" [c, "-b", d] ""
where
c = if m then "unmount" else "mount"
2020-05-01 21:29:54 -04:00
allInstalled _ = fmap isJust $ io $ findExecutable "udisksctl"
2020-04-23 23:32:29 -04:00
2021-03-23 22:39:02 -04:00
isMounted Removable { removablePath = d } = elem d <$> io curDeviceSpecs
2020-04-23 23:32:29 -04:00
2021-03-23 22:39:02 -04:00
getLabel Removable { removableLabel = l } = l
2021-03-22 19:20:32 -04:00
instance Actionable Removable where
2021-03-23 22:39:02 -04:00
fmtEntry Removable { removablePath = d, removableLabel = l } = [l, d]
2020-04-23 23:32:29 -04:00
2021-03-23 22:39:02 -04:00
groupHeader _ = RemovableHeader
2021-03-22 19:20:32 -04:00
2020-04-23 23:32:29 -04:00
-- | 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
2020-05-01 21:29:54 -04:00
getRemovableDevices :: RofiConf c => RofiIO c [Removable]
getRemovableDevices = fromLines toDev . lines
2020-05-01 21:29:54 -04:00
<$> io (readProcess "lsblk" ["-n", "-r", "-o", columns] "")
2020-04-23 23:32:29 -04:00
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
2020-05-01 21:29:54 -04:00
[_, "1", d, "", s] -> mk d $ s ++ " Volume"
[_, "1", d, l, _] -> mk d l
2020-04-23 23:32:29 -04:00
_ -> Nothing
2021-03-23 22:39:02 -04:00
mk d l = Just $ Removable { removablePath = d, removableLabel = l }
2020-04-23 23:32:29 -04:00
2021-03-25 00:35:59 -04:00
getRemovableActions :: RofiMountIO [(Header, ProtoAction [String])]
getRemovableActions = mountableToAction getRemovableDevices
2020-04-23 23:32:29 -04:00
--------------------------------------------------------------------------------
-- | MTP devices
data MTPFS = MTPFS
2021-03-23 22:39:02 -04:00
{ mtpfsBus :: String
, mtpfsDevice :: String
, mtpfsMountpoint :: FilePath
, mtpfsDescription :: String
2020-04-23 23:32:29 -04:00
}
deriving (Eq, Show)
instance Mountable MTPFS where
2021-03-25 00:35:59 -04:00
mount MTPFS { mtpfsBus = b, mtpfsDevice = n, mtpfsMountpoint = m } False = do
2020-04-23 23:32:29 -04:00
-- TODO add autodismount to options
2021-03-23 22:39:02 -04:00
let dev = "-device=" ++ b ++ "," ++ n
2021-03-25 00:35:59 -04:00
withTmpMountDir m $ io $ runMount "jmtpfs" [dev, m] ""
2020-04-23 23:32:29 -04:00
2021-03-25 00:35:59 -04:00
mount MTPFS { mtpfsMountpoint = m } True =
2021-03-25 23:16:55 -04:00
runAndRemoveDir m $ io $ runMount "umount" [m] ""
2020-04-23 23:32:29 -04:00
2020-05-01 21:29:54 -04:00
-- | return True always since the list won't even show without jmtpfs
allInstalled _ = return True
2020-04-23 23:32:29 -04:00
2021-03-23 22:39:02 -04:00
isMounted = io . isDirMounted <$> mtpfsMountpoint
2020-04-23 23:32:29 -04:00
2021-03-23 22:39:02 -04:00
getLabel = mtpfsDescription
2021-03-22 19:20:32 -04:00
-- | Return list of all available MTP devices
2021-03-23 21:39:41 -04:00
getMTPDevices :: RofiMountIO [MTPFS]
2020-05-01 21:29:54 -04:00
getMTPDevices = do
2021-03-19 23:23:45 -04:00
dir <- asks mountconfVolatilePath
2020-05-01 21:29:54 -04:00
res <- io $ readProcess "jmtpfs" ["-l"] ""
return $ fromLines (toDev dir) $ toDevList res
2020-04-23 23:32:29 -04:00
where
toDevList = reverse
. takeWhile (not . isPrefixOf "Available devices")
. reverse
. lines
2020-05-01 21:29:54 -04:00
toDev dir s = case splitOn ", " s of
2020-04-23 23:32:29 -04:00
[busNum, devNum, _, _, desc, vendor] -> let d = unwords [vendor, desc]
in Just $ MTPFS
2021-03-23 22:39:02 -04:00
{ mtpfsBus = busNum
, mtpfsDevice = devNum
, mtpfsMountpoint = dir </> canonicalize d
, mtpfsDescription = d
2020-04-23 23:32:29 -04:00
}
_ -> Nothing
canonicalize = mapMaybe repl
repl c
| c `elem` ("\"*/:<>?\\|" :: String) = Nothing
| c == ' ' = Just '-'
| otherwise = Just c
2021-03-25 00:35:59 -04:00
getMTPActions :: RofiMountIO [(Header, ProtoAction [String])]
getMTPActions = mountableToAction getMTPDevices
2021-03-23 21:39:41 -04:00
instance Actionable MTPFS where
2021-03-23 01:09:43 -04:00
fmtEntry d = [getLabel d]
2021-03-22 19:20:32 -04:00
2021-03-23 22:39:02 -04:00
groupHeader _ = MTPFSHeader
2021-03-25 00:35:59 -04:00
--------------------------------------------------------------------------------
-- | Notifications
data NotifyIcon = IconError | IconInfo
instance Show NotifyIcon where
show IconError = "dialog-error-symbolic"
show IconInfo = "dialog-information-symbolic"
2021-03-25 00:35:59 -04:00
notifyMountResult :: Bool -> String -> MountResult -> IO ()
notifyMountResult mounted label result = case result of
MountError e -> notify IconError (printf "Failed to %s %s" verb label) $ Just e
MountSuccess -> notify IconInfo (printf "Successfully %sed %s" verb label) Nothing
where
verb = if mounted then "unmount" else "mount" :: String
notify :: NotifyIcon -> String -> Maybe String -> IO ()
notify icon summary body = void $ spawnProcess "notify-send"
$ maybe args (\b -> args ++ [b]) body
where
args = ["-i", show icon, summary]
--------------------------------------------------------------------------------
-- | Mount commands
data MountResult = MountSuccess | MountError String deriving (Show, Eq)
runMount :: String -> [String] -> String -> IO MountResult
runMount cmd args stdin = eitherToMountResult <$> readCmdEither cmd args stdin
runMount' :: String -> [String] -> String -> [(String, String)] -> IO MountResult
runMount' cmd args stdin environ = eitherToMountResult
<$> readCmdEither' cmd args stdin environ
2021-03-25 23:16:55 -04:00
runMountSudoMaybe :: Bool -> String -> [String] -> IO MountResult
runMountSudoMaybe useSudo cmd args =
runMountSudoMaybe' useSudo cmd args []
runMountSudoMaybe' :: Bool -> String -> [String] -> [(String, String)] -> IO MountResult
runMountSudoMaybe' useSudo cmd args environ = maybe
(runMount' cmd args "" environ)
(\r -> runSudoMount' r cmd args environ)
=<< if useSudo then readPassword' "Sudo Password" else return Nothing
-- TODO untested
-- runSudoMount :: String -> String -> [String] -> String -> IO MountResult
-- runSudoMount rootpass cmd args stdin = runSudoMount' rootpass cmd args stdin []
runSudoMount' :: String -> String -> [String] -> [(String, String)] -> IO MountResult
runSudoMount' rootpass cmd args environ = runMount "sudo" args' rootpass
where
args' = ["-S"] ++ environ' ++ [cmd] ++ args
environ' = fmap (\(k, v) -> k ++ "=" ++ v) environ
2021-03-25 00:35:59 -04:00
eitherToMountResult :: Either (Int, String, String) String -> MountResult
eitherToMountResult (Right _) = MountSuccess
eitherToMountResult (Left (_, _, e)) = MountError e
2021-03-25 00:35:59 -04:00
2020-04-23 23:32:29 -04:00
--------------------------------------------------------------------------------
-- | Low-level mount functions
-- ASSUME these will never fail because the format of /proc/mounts is fixed
2020-05-01 21:29:54 -04:00
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)
2021-03-25 00:35:59 -04:00
rmDirOnMountError :: FilePath -> RofiMountIO MountResult -> RofiMountIO MountResult
rmDirOnMountError d f = do
res <- f
unless (res == MountSuccess) $ rmDirMaybe d
return res
2021-03-25 23:16:55 -04:00
-- | Run a mount command and create the mountpoint if it does not exist, and
-- remove the mountpoint if a mount error occurs
2021-03-25 00:35:59 -04:00
withTmpMountDir :: FilePath -> RofiMountIO MountResult -> RofiMountIO MountResult
withTmpMountDir m = rmDirOnMountError m
. bracketOnError_ (mkDirMaybe m) (rmDirMaybe m)
2021-03-25 23:16:55 -04:00
-- | Run an unmount command and remove the mountpoint if no errors occur
2021-03-25 00:35:59 -04:00
runAndRemoveDir :: FilePath -> RofiMountIO MountResult -> RofiMountIO MountResult
2021-03-25 23:16:55 -04:00
runAndRemoveDir m f = do
res <- catch f (return . MountError . (displayException :: SomeException -> String))
when (res == MountSuccess) $ rmDirMaybe m
return res
2021-03-25 00:35:59 -04:00
2021-03-23 21:39:41 -04:00
mkDirMaybe :: FilePath -> RofiMountIO ()
2020-05-01 21:29:54 -04:00
mkDirMaybe fp = whenInMountDir fp $ io $ createDirectoryIfMissing True fp
2021-03-23 21:39:41 -04:00
rmDirMaybe :: FilePath -> RofiMountIO ()
2020-05-01 21:29:54 -04:00
rmDirMaybe fp = whenInMountDir fp $ unlessMountpoint fp
2021-03-19 23:23:45 -04:00
$ asks mountconfVolatilePath >>= io . rmUntil fp
2020-05-01 21:29:54 -04:00
where
rmUntil cur target = unless (target == cur) $ do
removePathForcibly cur
rmUntil (takeDirectory cur) target
2021-03-25 00:35:59 -04:00
whenInMountDir :: FilePath -> RofiMountIO () -> RofiMountIO ()
2020-05-01 21:29:54 -04:00
whenInMountDir fp f = do
2021-03-19 23:23:45 -04:00
mDir <- asks mountconfVolatilePath
2020-05-01 21:29:54 -04:00
when (mDir `isPrefixOf` fp) f
2021-03-23 21:39:41 -04:00
unlessMountpoint :: MonadIO m => FilePath -> m () -> m ()
2020-05-01 21:29:54 -04:00
unlessMountpoint fp f = do
mounted <- io $ isDirMounted fp
unless mounted f
isDirMounted :: FilePath -> IO Bool
isDirMounted fp = elem fp <$> curMountpoints
2020-04-23 23:32:29 -04:00
--------------------------------------------------------------------------------
-- | Other functions
fromLines :: (String -> Maybe a) -> [String] -> [a]
fromLines f = mapMaybe (f . stripWS)
2020-04-23 23:32:29 -04:00
-- 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
2021-03-18 00:41:04 -04:00
appendRoot :: FilePath -> FilePath -> FilePath
appendRoot root path = if isRelative path then root </> path else path