ADD dismount all option

This commit is contained in:
Nathan Dwarshuis 2023-01-24 09:22:19 -05:00
parent 7094dac44e
commit cfe0607e2e
1 changed files with 342 additions and 270 deletions

View File

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