ADD dismount all option
This commit is contained in:
parent
7094dac44e
commit
cfe0607e2e
250
app/rofi-dev.hs
250
app/rofi-dev.hs
|
|
@ -5,7 +5,7 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | rofi-dev - a rofi prompt for mountable devices
|
||||
-- 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
|
||||
|
|
@ -14,11 +14,9 @@
|
|||
module Main (main) where
|
||||
|
||||
import Bitwarden.Internal
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
|
||||
import Data.List
|
||||
import Data.List.Split (splitOn)
|
||||
import qualified Data.Map as M
|
||||
|
|
@ -26,21 +24,16 @@ import Data.Maybe
|
|||
import qualified Data.Text as T
|
||||
import Data.Typeable
|
||||
import qualified Data.Vector as V
|
||||
|
||||
import Dhall hiding (maybe, sequence, void)
|
||||
import qualified Dhall.Map as DM
|
||||
|
||||
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 Text.Printf
|
||||
import UnliftIO.Exception
|
||||
|
||||
main :: IO ()
|
||||
|
|
@ -52,7 +45,8 @@ parse args = case getOpt Permute options args of
|
|||
(_, _, errs) -> ioError $ userError $ concat errs ++ usageInfo h options
|
||||
where
|
||||
h = "Usage: rofi-dev [OPTIONS] [-- ROFI-OPTIONS]"
|
||||
defaultOpts r = Opts
|
||||
defaultOpts r =
|
||||
Opts
|
||||
{ optsConfig = Nothing
|
||||
, optsAlias = Nothing
|
||||
, optsUnmount = False
|
||||
|
|
@ -61,13 +55,20 @@ parse args = case getOpt Permute options args of
|
|||
|
||||
options :: [OptDescr (Opts -> Opts)]
|
||||
options =
|
||||
[ Option ['c'] ["config"]
|
||||
[ Option
|
||||
['c']
|
||||
["config"]
|
||||
(ReqArg (\s m -> m {optsConfig = Just s}) "CONF")
|
||||
"The path to the config file"
|
||||
, Option ['m'] ["mount"]
|
||||
, 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 } ))
|
||||
, Option
|
||||
['u']
|
||||
["unmount"]
|
||||
(NoArg (\m -> m {optsUnmount = True}))
|
||||
"Unmount the device specified by ALIAS instead of mounting it."
|
||||
]
|
||||
|
||||
|
|
@ -76,10 +77,11 @@ data Opts = Opts
|
|||
, optsAlias :: Maybe String
|
||||
, optsUnmount :: Bool
|
||||
, optsRofiArgs :: [String]
|
||||
} deriving Show
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Main prompt
|
||||
-- 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
|
||||
|
|
@ -92,7 +94,8 @@ runMounts opts = do
|
|||
let tmpPath = fromMaybe defaultTmpPath $ scTmpPath =<< static
|
||||
let staticDevs = maybe M.empty scDevices static
|
||||
let verbose = fromMaybe False $ scVerbose =<< static
|
||||
let mountconf = MountConf
|
||||
let mountconf =
|
||||
MountConf
|
||||
{ mountconfVolatilePath = tmpPath
|
||||
, mountconfRofiArgs = optsRofiArgs opts
|
||||
, mountconfStaticDevs = staticDevs
|
||||
|
|
@ -110,7 +113,9 @@ parseStaticConfig p = do
|
|||
Right c -> return $ Just (c :: StaticConfig)
|
||||
where
|
||||
es = over substitutions (DM.union vars) defaultEvaluateSettings
|
||||
vars = DM.fromList $ catMaybes
|
||||
vars =
|
||||
DM.fromList $
|
||||
catMaybes
|
||||
[ toVar (auto :: Decoder TreeConfig)
|
||||
, toVar (auto :: Decoder DeviceConfig)
|
||||
, toVar (auto :: Decoder DataConfig)
|
||||
|
|
@ -124,11 +129,17 @@ parseStaticConfig p = do
|
|||
, toVar (auto :: Decoder BitwardenConfig)
|
||||
, toVar (auto :: Decoder MountConfig)
|
||||
]
|
||||
toVar a = fmap (\n -> (T.pack $ show n, maximum $ expected a))
|
||||
$ listToMaybe $ snd $ splitTyConApp $ typeOf a
|
||||
toVar a =
|
||||
fmap (\n -> (T.pack $ show n, maximum $ expected a)) $
|
||||
listToMaybe $
|
||||
snd $
|
||||
splitTyConApp $
|
||||
typeOf a
|
||||
|
||||
runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c ()
|
||||
runPrompt gs = selectAction $ emptyMenu
|
||||
runPrompt gs =
|
||||
selectAction $
|
||||
emptyMenu
|
||||
{ groups = gs
|
||||
, prompt = Just "Select Device"
|
||||
}
|
||||
|
|
@ -136,10 +147,26 @@ runPrompt gs = selectAction $ emptyMenu
|
|||
getGroups :: RofiMountIO [RofiGroup MountConf]
|
||||
getGroups = do
|
||||
actions <- sequence [getStaticActions, getRemovableActions, getMTPActions]
|
||||
return $ mapMaybe mkGroup
|
||||
$ groupBy (\(hx, _) (hy, _) -> hx == hy)
|
||||
$ sortBy (\(hx, _) (hy, _) -> compare hx hy)
|
||||
$ concat actions
|
||||
return $
|
||||
(++ [metaActions]) $
|
||||
mapMaybe mkGroup $
|
||||
groupBy (\(hx, _) (hy, _) -> hx == hy) $
|
||||
sortBy (\(hx, _) (hy, _) -> compare hx hy) $
|
||||
concat actions
|
||||
where
|
||||
metaActions =
|
||||
titledGroup "Meta Actions" $
|
||||
toRofiActions [(" Dismount All", dismountAll)]
|
||||
|
||||
dismountAll :: RofiMountIO ()
|
||||
dismountAll = do
|
||||
umount =<< asks (configToTree' . mountconfStaticDevs)
|
||||
umount =<< getRemovableDevices
|
||||
umount =<< getMTPDevices
|
||||
return ()
|
||||
where
|
||||
umount :: Mountable a => [a] -> RofiMountIO ()
|
||||
umount = mapM_ (`mountMaybe` True)
|
||||
|
||||
mountByAlias :: Bool -> String -> RofiMountIO ()
|
||||
mountByAlias unmountFlag alias = do
|
||||
|
|
@ -148,8 +175,9 @@ mountByAlias unmountFlag alias = do
|
|||
|
||||
mkGroup :: [(Header, ProtoAction [String])] -> Maybe (RofiGroup MountConf)
|
||||
mkGroup [] = Nothing
|
||||
mkGroup as = let ((h, _):_) = as in
|
||||
Just $ titledGroup (show h) $ toRofiActions $ alignEntries $ fmap snd as
|
||||
mkGroup as =
|
||||
let ((h, _) : _) = as
|
||||
in Just $ titledGroup (show h) $ toRofiActions $ alignEntries $ fmap snd as
|
||||
|
||||
alignSep :: String
|
||||
alignSep = " | "
|
||||
|
|
@ -158,7 +186,8 @@ 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)
|
||||
align =
|
||||
fmap (intercalate alignSep)
|
||||
. transpose
|
||||
. mapToLast pad
|
||||
. transpose
|
||||
|
|
@ -169,20 +198,21 @@ alignEntries ps = zip (align es) as
|
|||
mapToLast f (x : xs) = f x : mapToLast f xs
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Global config used in the reader monad stack
|
||||
-- Global config used in the reader monad stack
|
||||
|
||||
data MountConf = MountConf
|
||||
{ mountconfVolatilePath :: FilePath
|
||||
, mountconfRofiArgs :: [String]
|
||||
, mountconfStaticDevs :: M.Map String TreeConfig
|
||||
, mountconfVerbose :: Bool
|
||||
} deriving Show
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance RofiConf MountConf where
|
||||
defArgs MountConf {mountconfRofiArgs = a} = a
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Mountable typeclass
|
||||
-- Mountable typeclass
|
||||
--
|
||||
-- Class to provide common interface for anything that can be mounted.
|
||||
|
||||
|
|
@ -219,7 +249,7 @@ class Mountable a where
|
|||
mountState :: a -> RofiMountIO MountState
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Actionable typeclass
|
||||
-- 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
|
||||
|
|
@ -252,13 +282,17 @@ class Mountable a => Actionable a where
|
|||
mountedPrefix Mounted True = "* "
|
||||
mountedPrefix Partial True = "- "
|
||||
|
||||
mountableToAction :: Actionable a => RofiMountIO [a] -> RofiMountIO [(Header, ProtoAction [String])]
|
||||
mountableToAction
|
||||
:: Actionable a
|
||||
=> RofiMountIO [a]
|
||||
-> RofiMountIO [(Header, ProtoAction [String])]
|
||||
mountableToAction ms = mapM mkAction =<< ms
|
||||
|
||||
type RofiMountIO a = RofiIO MountConf a
|
||||
|
||||
-- headers appear in the order listed here (per Enum)
|
||||
data Header = CIFSHeader
|
||||
data Header
|
||||
= CIFSHeader
|
||||
| SSHFSHeader
|
||||
| VeracryptHeader
|
||||
| RemovableHeader
|
||||
|
|
@ -281,16 +315,18 @@ instance Ord Header where
|
|||
data ProtoAction a = ProtoAction a (RofiMountIO ())
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Static device configuration (dhall)
|
||||
-- Static device configuration (dhall)
|
||||
|
||||
data MountConfig = MountConfig
|
||||
{ mpPath :: FilePath
|
||||
, mpLabel :: Maybe String
|
||||
} deriving (Show, Generic, FromDhall)
|
||||
}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
data BitwardenConfig = BitwardenConfig
|
||||
{ bwKey :: String
|
||||
, bwTries :: Integer }
|
||||
, bwTries :: Integer
|
||||
}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
newtype SecretConfig = SecretConfig
|
||||
|
|
@ -301,7 +337,8 @@ newtype PromptConfig = PromptConfig
|
|||
{promptTries :: Integer}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
data PasswordConfig = PwdBW BitwardenConfig
|
||||
data PasswordConfig
|
||||
= PwdBW BitwardenConfig
|
||||
| PwdLS SecretConfig
|
||||
| PwdPr PromptConfig
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
|
@ -312,9 +349,11 @@ data CIFSOpts = CIFSOpts
|
|||
, cifsoptsUID :: Maybe Integer
|
||||
, cifsoptsGID :: Maybe Integer
|
||||
, cifsoptsIocharset :: Maybe String
|
||||
} deriving (Show, Generic, FromDhall)
|
||||
}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
data DataConfig = VeracryptConfig VeracryptData
|
||||
data DataConfig
|
||||
= VeracryptConfig VeracryptData
|
||||
| SSHFSConfig SSHFSData
|
||||
| CIFSConfig CIFSData
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
|
@ -322,39 +361,45 @@ data DataConfig = VeracryptConfig VeracryptData
|
|||
data VeracryptData = VeracryptData
|
||||
{ vcVolume :: String
|
||||
, vcPassword :: Maybe PasswordConfig
|
||||
} deriving (Show, Generic, FromDhall)
|
||||
}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
data SSHFSData = SSHFSData
|
||||
{ sshfsRemote :: String
|
||||
, sshfsPassword :: Maybe PasswordConfig
|
||||
} deriving (Show, Generic, FromDhall)
|
||||
}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
data CIFSData = CIFSData
|
||||
{ cifsRemote :: String
|
||||
, cifsSudo :: Bool
|
||||
, cifsPassword :: Maybe PasswordConfig
|
||||
, cifsOpts :: Maybe CIFSOpts
|
||||
} deriving (Show, Generic, FromDhall)
|
||||
}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
data DeviceConfig = DeviceConfig
|
||||
{ deviceMount :: MountConfig
|
||||
, deviceData :: DataConfig
|
||||
} deriving (Show, Generic, FromDhall)
|
||||
}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
data TreeConfig = TreeConfig
|
||||
{ tcParent :: DeviceConfig
|
||||
, tcChildren :: V.Vector String
|
||||
} deriving (Show, Generic, FromDhall)
|
||||
}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
data StaticConfig = StaticConfig
|
||||
{ scTmpPath :: Maybe String
|
||||
, scVerbose :: Maybe Bool
|
||||
, scDevices :: M.Map String TreeConfig
|
||||
} deriving (Show, Generic, FromDhall)
|
||||
}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Static devices trees
|
||||
--
|
||||
-- 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
|
||||
|
|
@ -400,7 +445,7 @@ configToTree devMap TreeConfig{ tcParent = p, tcChildren = c } =
|
|||
go ds = configToTree devMap <$> mapMaybe (`M.lookup` devMap) ds
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Static devices
|
||||
-- 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
|
||||
|
|
@ -412,24 +457,27 @@ configToTree devMap TreeConfig{ tcParent = p, tcChildren = c } =
|
|||
instance Mountable DeviceConfig where
|
||||
mount DeviceConfig {deviceMount = m, deviceData = devData} False = do
|
||||
m' <- getAbsMountpoint m
|
||||
withTmpMountDir m'
|
||||
$ io
|
||||
$ case devData of
|
||||
withTmpMountDir m' $
|
||||
io $
|
||||
case devData of
|
||||
SSHFSConfig (SSHFSData {sshfsRemote = r, sshfsPassword = p}) ->
|
||||
mountSSHFS m' p r
|
||||
CIFSConfig (CIFSData
|
||||
CIFSConfig
|
||||
( CIFSData
|
||||
{ cifsRemote = r
|
||||
, cifsSudo = s
|
||||
, cifsPassword = p
|
||||
, cifsOpts = o
|
||||
}) ->
|
||||
}
|
||||
) ->
|
||||
mountCIFS s r m' o p
|
||||
VeracryptConfig (VeracryptData
|
||||
VeracryptConfig
|
||||
( VeracryptData
|
||||
{ vcPassword = p
|
||||
, vcVolume = v
|
||||
}) ->
|
||||
}
|
||||
) ->
|
||||
mountVeracrypt m' p v
|
||||
|
||||
mount DeviceConfig {deviceMount = m, deviceData = d} True = do
|
||||
m' <- getAbsMountpoint m
|
||||
runAndRemoveDir m' $ io $ case d of
|
||||
|
|
@ -437,7 +485,9 @@ instance Mountable DeviceConfig where
|
|||
VeracryptConfig _ -> runVeraCrypt ["-d", m'] ""
|
||||
_ -> runMount "umount" [m'] ""
|
||||
|
||||
allInstalled DeviceConfig{ deviceData = devData } = io $ isJust
|
||||
allInstalled DeviceConfig {deviceData = devData} =
|
||||
io $
|
||||
isJust
|
||||
<$> findExecutable (exe devData)
|
||||
where
|
||||
exe SSHFSConfig {} = "sshfs"
|
||||
|
|
@ -452,7 +502,8 @@ instance Mountable DeviceConfig where
|
|||
b <- (io . isDirMounted) =<< getAbsMountpoint m
|
||||
return $ if b then Mounted else Unmounted
|
||||
|
||||
getLabel DeviceConfig
|
||||
getLabel
|
||||
DeviceConfig
|
||||
{ deviceMount = MountConfig {mpPath = p, mpLabel = l}
|
||||
} = fromMaybe (takeFileName p) l
|
||||
|
||||
|
|
@ -462,8 +513,13 @@ mountSSHFS mountpoint pwdConfig remote =
|
|||
where
|
||||
run other = runMount "sshfs" (other ++ [remote, mountpoint])
|
||||
|
||||
mountCIFS :: Bool -> String -> FilePath -> Maybe CIFSOpts
|
||||
-> Maybe PasswordConfig -> IO MountResult
|
||||
mountCIFS
|
||||
:: Bool
|
||||
-> String
|
||||
-> FilePath
|
||||
-> Maybe CIFSOpts
|
||||
-> Maybe PasswordConfig
|
||||
-> IO MountResult
|
||||
mountCIFS useSudo remote mountpoint opts pwdConfig =
|
||||
withPasswordGetter pwdConfig runPwd run
|
||||
where
|
||||
|
|
@ -474,7 +530,8 @@ mountCIFS useSudo remote mountpoint opts pwdConfig =
|
|||
fromCIFSOpts :: CIFSOpts -> String
|
||||
fromCIFSOpts o = intercalate "," $ mapMaybe concatMaybe fs
|
||||
where
|
||||
fs = [ ("username", cifsoptsUsername)
|
||||
fs =
|
||||
[ ("username", cifsoptsUsername)
|
||||
, ("workgroup", cifsoptsWorkgroup)
|
||||
, ("uid", fmap show . cifsoptsUID)
|
||||
, ("gid", fmap show . cifsoptsGID)
|
||||
|
|
@ -484,8 +541,8 @@ fromCIFSOpts o = intercalate "," $ mapMaybe concatMaybe fs
|
|||
|
||||
mountVeracrypt :: FilePath -> Maybe PasswordConfig -> String -> IO MountResult
|
||||
mountVeracrypt mountpoint pwdConfig volume =
|
||||
withPasswordGetter pwdConfig (runVeraCrypt (args ++ ["--stdin"]))
|
||||
$ runVeraCrypt args ""
|
||||
withPasswordGetter pwdConfig (runVeraCrypt (args ++ ["--stdin"])) $
|
||||
runVeraCrypt args ""
|
||||
where
|
||||
args = [volume, mountpoint]
|
||||
|
||||
|
|
@ -521,7 +578,7 @@ getStaticActions :: RofiMountIO [(Header, ProtoAction [String])]
|
|||
getStaticActions = mountableToAction $ asks $ configToTree' . mountconfStaticDevs
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Password-getting functions for static devices
|
||||
-- Password-getting functions for static devices
|
||||
|
||||
type PasswordGetter = IO (Maybe String)
|
||||
|
||||
|
|
@ -531,14 +588,15 @@ runSecret kvs = readCmdSuccess "secret-tool" ("lookup":kvs') ""
|
|||
kvs' = concatMap (\(k, v) -> [k, v]) $ M.toList kvs
|
||||
|
||||
runBitwarden :: String -> PasswordGetter
|
||||
runBitwarden pname = ((password . login) <=< find (\i -> name i == pname))
|
||||
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
|
||||
if isNothing res
|
||||
then if n <= 0 then return Nothing else runPromptLoop (n - 1) pwd
|
||||
else return res
|
||||
|
||||
-- configToPwd :: PasswordConfig -> PasswordGetter
|
||||
|
|
@ -562,15 +620,18 @@ configToPwd (PwdBW (BitwardenConfig { bwKey = k, bwTries = n })) =
|
|||
configToPwd (PwdLS s) = runSecret $ secretAttributes s
|
||||
configToPwd (PwdPr p) = flip runPromptLoop readPassword $ promptTries p
|
||||
|
||||
withPasswordGetter :: Maybe PasswordConfig -> (String -> IO MountResult)
|
||||
-> IO MountResult -> IO MountResult
|
||||
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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Removable devices
|
||||
-- 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
|
||||
|
|
@ -607,7 +668,8 @@ instance Actionable Removable where
|
|||
-- 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
|
||||
getRemovableDevices =
|
||||
fromLines toDev . lines
|
||||
<$> io (readProcess "lsblk" ["-n", "-r", "-o", columns] "")
|
||||
where
|
||||
columns = "FSTYPE,HOTPLUG,PATH,LABEL,SIZE"
|
||||
|
|
@ -623,7 +685,7 @@ getRemovableActions :: RofiMountIO [(Header, ProtoAction [String])]
|
|||
getRemovableActions = mountableToAction getRemovableDevices
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | MTP devices
|
||||
-- MTP devices
|
||||
|
||||
mtpExe :: String
|
||||
mtpExe = "jmtpfs"
|
||||
|
|
@ -641,11 +703,10 @@ instance Mountable MTPFS where
|
|||
-- TODO add autodismount to options
|
||||
let dev = "-device=" ++ b ++ "," ++ n
|
||||
withTmpMountDir m $ io $ runMount mtpExe [dev, m] ""
|
||||
|
||||
mount MTPFS {mtpfsMountpoint = m} True =
|
||||
runAndRemoveDir m $ io $ runMount "umount" [m] ""
|
||||
|
||||
-- | return True always since the list won't even show without jmtpfs
|
||||
-- \| return True always since the list won't even show without jmtpfs
|
||||
allInstalled _ = return True
|
||||
|
||||
mountState MTPFS {mtpfsMountpoint = m} = do
|
||||
|
|
@ -664,13 +725,16 @@ getMTPDevices = do
|
|||
dir <- asks mountconfVolatilePath
|
||||
res <- io $ readProcess mtpExe ["-l"] ""
|
||||
return $ fromLines (toDev dir) $ toDevList res
|
||||
toDevList = reverse
|
||||
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
|
||||
[busNum, devNum, _, _, desc, vendor] ->
|
||||
let d = unwords [vendor, desc]
|
||||
in Just $
|
||||
MTPFS
|
||||
{ mtpfsBus = busNum
|
||||
, mtpfsDevice = devNum
|
||||
, mtpfsMountpoint = dir </> canonicalize d
|
||||
|
|
@ -695,7 +759,7 @@ instance Actionable MTPFS where
|
|||
groupHeader _ = MTPFSHeader
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Notifications
|
||||
-- Notifications
|
||||
|
||||
data NotifyIcon = IconError | IconInfo
|
||||
|
||||
|
|
@ -711,13 +775,15 @@ notifyMountResult mounted label result = case result of
|
|||
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
|
||||
notify icon summary body =
|
||||
void $
|
||||
spawnProcess "notify-send" $
|
||||
maybe args (\b -> args ++ [b]) body
|
||||
where
|
||||
args = ["-i", show icon, summary]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Mount commands
|
||||
-- Mount commands
|
||||
|
||||
data MountResult = MountSuccess | MountError String deriving (Show, Eq)
|
||||
|
||||
|
|
@ -725,7 +791,8 @@ 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
|
||||
runMount' cmd args stdin environ =
|
||||
eitherToMountResult
|
||||
<$> readCmdEither' cmd args stdin environ
|
||||
|
||||
runMountSudoMaybe :: Bool -> String -> [String] -> IO MountResult
|
||||
|
|
@ -733,7 +800,8 @@ runMountSudoMaybe useSudo cmd args =
|
|||
runMountSudoMaybe' useSudo cmd args []
|
||||
|
||||
runMountSudoMaybe' :: Bool -> String -> [String] -> [(String, String)] -> IO MountResult
|
||||
runMountSudoMaybe' useSudo cmd args environ = maybe
|
||||
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
|
||||
|
|
@ -753,7 +821,7 @@ eitherToMountResult (Right _) = MountSuccess
|
|||
eitherToMountResult (Left (_, _, e)) = MountError e
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Low-level mount functions
|
||||
-- Low-level mount functions
|
||||
|
||||
mountMap :: IO (M.Map FilePath String)
|
||||
mountMap = do
|
||||
|
|
@ -789,7 +857,8 @@ rmDirOnMountError d f = do
|
|||
-- | Run a mount command and create the mountpoint if it does not exist, and
|
||||
-- remove the mountpoint if a mount error occurs
|
||||
withTmpMountDir :: FilePath -> RofiMountIO MountResult -> RofiMountIO MountResult
|
||||
withTmpMountDir m = rmDirOnMountError m
|
||||
withTmpMountDir m =
|
||||
rmDirOnMountError m
|
||||
. bracketOnError_ (mkDirMaybe m) (rmDirMaybe m)
|
||||
|
||||
-- | Run an unmount command and remove the mountpoint if no errors occur
|
||||
|
|
@ -803,8 +872,10 @@ 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
|
||||
rmDirMaybe fp =
|
||||
whenInMountDir fp $
|
||||
unlessMountpoint fp $
|
||||
asks mountconfVolatilePath >>= io . rmUntil fp
|
||||
where
|
||||
rmUntil cur target = unless (target == cur) $ do
|
||||
removePathForcibly cur
|
||||
|
|
@ -824,7 +895,7 @@ isDirMounted :: FilePath -> IO Bool
|
|||
isDirMounted fp = elem fp <$> curMountpoints
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Other functions
|
||||
-- Other functions
|
||||
|
||||
fromLines :: (String -> Maybe a) -> [String] -> [a]
|
||||
fromLines f = mapMaybe (f . stripWS)
|
||||
|
|
@ -834,7 +905,8 @@ splitBy :: Char -> String -> [String]
|
|||
splitBy delimiter = foldr f [[]]
|
||||
where
|
||||
f _ [] = []
|
||||
f c l@(x:xs) | c == delimiter = []:l
|
||||
f c l@(x : xs)
|
||||
| c == delimiter = [] : l
|
||||
| otherwise = (c : x) : xs
|
||||
|
||||
appendRoot :: FilePath -> FilePath -> FilePath
|
||||
|
|
|
|||
Loading…
Reference in New Issue