704 lines
24 KiB
Haskell
704 lines
24 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | 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 Data.Maybe
|
|
import qualified Data.Text as T
|
|
import qualified Data.Vector as V
|
|
import Data.Yaml
|
|
|
|
import Rofi.Command
|
|
|
|
import Text.Printf
|
|
|
|
import System.Console.GetOpt
|
|
import System.Directory
|
|
import System.Environment
|
|
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, []) -> 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
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | 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 = maybe M.empty _staticconfigDevices static
|
|
let verbose = fromMaybe False $ _staticconfigVerbose =<< static
|
|
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
|
|
staticDevs <- asks mountconfStaticDevs
|
|
staticActions <- mapM mkAction $ configToTree' staticDevs
|
|
removableActions <- mapM mkAction =<< getRemovableDevices
|
|
mtpActions <- mapM mkAction =<< getMTPDevices
|
|
return $ mapMaybe mkGroup
|
|
$ groupBy (\(hx, _) (hy, _) -> hx == hy)
|
|
$ sortBy (\(hx, _) (hy, _) -> compare hx hy)
|
|
$ staticActions ++ removableActions ++ mtpActions
|
|
|
|
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
|
|
mkGroup as = let ((Header title _, _):_) = as in
|
|
Just $ titledGroup title $ toRofiActions $ alignEntries $ fmap snd as
|
|
|
|
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
|
|
{ mountconfVolatilePath :: FilePath
|
|
, mountconfRofiArgs :: [String]
|
|
, mountconfStaticDevs :: M.Map String TreeConfig
|
|
, mountconfVerbose :: Bool
|
|
} deriving Show
|
|
|
|
instance RofiConf MountConf where
|
|
defArgs MountConf { mountconfRofiArgs = a } = a
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Mountable typeclass
|
|
--
|
|
-- 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)
|
|
mount :: a -> Bool -> RofiMountIO ()
|
|
|
|
mountMaybe :: a -> Bool -> RofiMountIO ()
|
|
mountMaybe dev mountFlag = do
|
|
mounted <- isMounted dev
|
|
verbose <- asks mountconfVerbose
|
|
if mountFlag == mounted then mount dev mountFlag
|
|
else when verbose notify'
|
|
where
|
|
notify' = io $ notify "dialog-information-symbolic"
|
|
$ getLabel dev ++ " already mounted"
|
|
|
|
-- | 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 = "! "
|
|
|
|
type RofiMountIO a = RofiIO MountConf a
|
|
|
|
data Header = Header String Integer deriving (Show, Eq)
|
|
|
|
data ProtoAction a = ProtoAction a (RofiMountIO ())
|
|
|
|
instance Ord Header where
|
|
compare (Header _ x) (Header _ y) = compare x y
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Static device configuration
|
|
--
|
|
-- Static devices are defined in a YAML file. These types/instances describe how
|
|
-- to parse 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 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 DataConfig = VeracryptConfig
|
|
{ _veracryptVolume :: String
|
|
, _veracryptPassword :: Maybe PasswordConfig
|
|
} | SSHFSConfig
|
|
{ _sshfsRemote :: String
|
|
} | CIFSConfig
|
|
{ _cifsRemote :: String
|
|
, _cifsPassword :: Maybe PasswordConfig
|
|
} deriving Show
|
|
|
|
data DeviceConfig = DeviceConfig
|
|
{ _deviceMount :: MountConfig
|
|
, _deviceData :: DataConfig
|
|
} deriving Show
|
|
|
|
data TreeConfig = TreeConfig
|
|
{ _treeParent :: DeviceConfig
|
|
, _treeChildren :: V.Vector String
|
|
} deriving Show
|
|
|
|
instance FromJSON TreeConfig where
|
|
parseJSON = withObject "devices" $ \o -> do
|
|
devType <- o .: "type"
|
|
deps <- o .:& "depends"
|
|
mountconf <- o .: "mount"
|
|
devData <- case (devType :: String) of
|
|
"cifs" -> CIFSConfig
|
|
<$> o .: "remote"
|
|
<*> o .:? "password"
|
|
"sshfs" -> SSHFSConfig
|
|
<$> o .: "remote"
|
|
"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
|
|
{ _treeParent = DeviceConfig
|
|
{ _deviceMount = mountconf
|
|
, _deviceData = devData
|
|
}
|
|
, _treeChildren = deps
|
|
}
|
|
|
|
data StaticConfig = StaticConfig
|
|
{ _staticconfigTmpPath :: Maybe String
|
|
, _staticconfigVerbose :: Maybe Bool
|
|
, _staticconfigDevices :: M.Map String TreeConfig
|
|
} deriving Show
|
|
|
|
instance FromJSON StaticConfig where
|
|
parseJSON = withObject "devices" $ \o -> StaticConfig
|
|
<$> o .:? "mountdir"
|
|
<*> o .:? "verbose"
|
|
<*> o .: "devices"
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Static devices trees
|
|
--
|
|
-- 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.
|
|
|
|
data Tree a = Tree a [Tree a] deriving (Eq, Show)
|
|
|
|
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
|
|
|
|
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]
|
|
where
|
|
target CIFSConfig{ _cifsRemote = r } = r
|
|
target SSHFSConfig{ _sshfsRemote = r } = r
|
|
target VeracryptConfig{ _veracryptVolume = v } = v
|
|
|
|
groupHeader (Tree DeviceConfig{ _deviceData = d } _) =
|
|
case d of
|
|
CIFSConfig{} -> Header "CIFS Devices" 0
|
|
SSHFSConfig{} -> Header "SSHFS Devices" 1
|
|
VeracryptConfig{} -> Header "Veracrypt Devices" 2
|
|
|
|
configToTree' :: M.Map String TreeConfig -> [StaticConfigTree]
|
|
configToTree' devMap = configToTree devMap <$> M.elems devMap
|
|
|
|
configToTree :: M.Map String TreeConfig -> TreeConfig -> StaticConfigTree
|
|
configToTree devMap TreeConfig{ _treeParent = p, _treeChildren = c } =
|
|
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
|
|
mount c@DeviceConfig{ _deviceMount = m, _deviceData = devData} False = do
|
|
m' <- getAbsMountpoint m
|
|
bracketOnError_ (mkDirMaybe m') (rmDirMaybe m') $ mount' m'
|
|
where
|
|
mount' mountpoint = io $ case devData of
|
|
SSHFSConfig{ _sshfsRemote = r } -> do
|
|
runMountNotify "sshfs" [r, mountpoint] (getLabel c) False
|
|
CIFSConfig{ _cifsPassword = p } -> do
|
|
res <- case p of
|
|
Just pwd -> do
|
|
pwd' <- maybe [] (\p' -> [("PASSWD", p')]) <$> configToPwd pwd
|
|
readCmdEither' "mount" [mountpoint] "" pwd'
|
|
Nothing -> readCmdEither "mount" [mountpoint] ""
|
|
notifyMounted (isRight res) False (getLabel c)
|
|
VeracryptConfig{ _veracryptPassword = getPwd, _veracryptVolume = v } ->
|
|
maybe (runVeraCryptWith "" []) (runVeraCryptWithPwd =<<) (configToPwd <$> getPwd)
|
|
where
|
|
label = getLabel c
|
|
runVeraCryptWithPwd = maybe notifyFail (\p -> runVeraCryptWith p ["--stdin"])
|
|
runVeraCryptWith stdin args = (\res -> notifyMounted (isRight res) False label)
|
|
=<< runVeraCrypt stdin ([v, mountpoint] ++ args)
|
|
notifyFail = notify "dialog-error-symbolic" $
|
|
printf "Failed to get volume password for %s" label
|
|
|
|
mount c@DeviceConfig{ _deviceMount = m, _deviceData = VeracryptConfig{} } True = do
|
|
m' <- getAbsMountpoint m
|
|
res <- io $ runVeraCrypt "" ["-d", m']
|
|
io $ notifyMounted (isRight res) True (getLabel c)
|
|
|
|
mount c@DeviceConfig{ _deviceMount = m } True =
|
|
umountNotify (getLabel c) =<< getAbsMountpoint m
|
|
|
|
allInstalled DeviceConfig{ _deviceData = devData } = io $ isJust
|
|
<$> findExecutable (exe devData)
|
|
where
|
|
exe SSHFSConfig{} = "sshfs"
|
|
exe CIFSConfig{} = "mount.cifs"
|
|
exe VeracryptConfig{} = "veracrypt"
|
|
|
|
isMounted DeviceConfig{ _deviceMount = m } =
|
|
(io . isDirMounted) =<< getAbsMountpoint m
|
|
|
|
getLabel DeviceConfig
|
|
{ _deviceMount = MountConfig { _mountMountPoint = p, _mountLabel = l }
|
|
} = fromMaybe (takeFileName p) l
|
|
|
|
getAbsMountpoint :: MountConfig -> RofiMountIO FilePath
|
|
getAbsMountpoint MountConfig{ _mountMountPoint = m } =
|
|
asks $ flip appendRoot m . mountconfVolatilePath
|
|
|
|
-- 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"]
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Password-getting functions for static devices
|
|
|
|
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
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Removable devices
|
|
--
|
|
-- 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.
|
|
|
|
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
|
|
|
|
getLabel Removable { label = l } = l
|
|
|
|
instance Actionable Removable where
|
|
fmtEntry Removable { deviceSpec = d, label = l } = [l, d]
|
|
|
|
groupHeader _ = Header "Removable Devices" 3
|
|
|
|
-- | 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 }
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | MTP devices
|
|
|
|
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
|
|
|
|
getLabel MTPFS { description = d } = d
|
|
|
|
-- | Return list of all available MTP devices
|
|
getMTPDevices :: RofiMountIO [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
|
|
|
|
instance Actionable MTPFS where
|
|
fmtEntry d = [getLabel d]
|
|
|
|
groupHeader _ = Header "MTP Devices" 5
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | 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 -> RofiMountIO ()
|
|
mkDirMaybe fp = whenInMountDir fp $ io $ createDirectoryIfMissing True fp
|
|
|
|
rmDirMaybe :: FilePath -> RofiMountIO ()
|
|
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 -> RofiMountIO () -> RofiIO MountConf ()
|
|
whenInMountDir fp f = do
|
|
mDir <- asks mountconfVolatilePath
|
|
when (mDir `isPrefixOf` fp) f
|
|
|
|
unlessMountpoint :: MonadIO m => FilePath -> m () -> m ()
|
|
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 -> RofiMountIO ()
|
|
umountNotify' cmd msg dir = finally
|
|
(io $ runMountNotify cmd [dir] msg True)
|
|
(rmDirMaybe dir)
|
|
|
|
umountNotify :: String -> FilePath -> RofiMountIO ()
|
|
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
|