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 #-}
|
{-# 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
|
||||||
|
|
Loading…
Reference in New Issue