ADD support for partially mounted things

This commit is contained in:
Nathan Dwarshuis 2022-07-22 00:19:41 -04:00
parent fa8a7668d8
commit 4451541417
2 changed files with 60 additions and 16 deletions

View File

@ -161,6 +161,12 @@ instance RofiConf MountConf where
--
-- Class to provide common interface for anything that can be mounted.
data MountState = Unmounted | Mounted | Partial deriving (Show, Eq)
mountedState :: MountState -> Bool
mountedState Mounted = True
mountedState _ = False
class Mountable a where
-- | Mount the given type (or dismount if False is passed)
mount :: a -> Bool -> RofiMountIO MountResult
@ -183,6 +189,9 @@ class Mountable a where
-- | Determine if the given type is mounted or not
isMounted :: a -> RofiMountIO Bool
isMounted dev = mountedState <$> mountState dev
mountState :: a -> RofiMountIO MountState
--------------------------------------------------------------------------------
-- | Actionable typeclass
@ -204,18 +213,19 @@ class Mountable a => Actionable a where
-- Rofi prompt and an action to perform when it is selected)
mkAction :: a -> RofiMountIO (Header, ProtoAction [String])
mkAction dev = do
m <- isMounted dev
m <- mountState dev
i <- allInstalled dev
let h = groupHeader dev
let action = when i $ mountMaybe dev m
let action = when i $ mountMaybe dev $ mountedState m
let entry = case fmtEntry dev of
(e:es) -> (mountedPrefix m i ++ e):es
_ -> []
return (h, ProtoAction entry action)
where
mountedPrefix False True = " "
mountedPrefix True True = "* "
mountedPrefix _ False = "! "
mountedPrefix Unmounted True = " "
mountedPrefix Mounted True = "* "
mountedPrefix Partial True = "- "
mountableToAction :: Actionable a => RofiMountIO [a] -> RofiMountIO [(Header, ProtoAction [String])]
mountableToAction ms = mapM mkAction =<< ms
@ -402,7 +412,7 @@ instance Mountable a => Mountable (Tree a) where
mount (Tree p cs) False = mapM_ (`mountMaybe` False) cs >> mount p False
mount (Tree p _) True = mount p True
isMounted (Tree p _) = isMounted p
mountState (Tree p _) = mountState p
allInstalled (Tree p cs) = do
res <- and <$> mapM allInstalled cs
@ -472,8 +482,13 @@ instance Mountable DeviceConfig where
exe CIFSConfig{} = "mount.cifs"
exe VeracryptConfig{} = "veracrypt"
isMounted DeviceConfig{ deviceMount = m } =
(io . isDirMounted) =<< getAbsMountpoint m
mountState DeviceConfig{ deviceMount = m, deviceData = d } = do
-- mountState DeviceConfig{ deviceMount = m } = do
case d of
VeracryptConfig{} -> veracryptMountState m
_ -> do
b <- (io . isDirMounted) =<< getAbsMountpoint m
return $ if b then Mounted else Unmounted
getLabel DeviceConfig
{ deviceMount = MountConfig { mountMountpoint = p, mountLabel = l }
@ -519,6 +534,23 @@ runVeraCrypt args = runMount "sudo" (defaultArgs ++ args)
where
defaultArgs = ["/usr/bin/veracrypt", "--text", "--non-interactive"]
veracryptMountState :: MountConfig -> RofiMountIO MountState
veracryptMountState mc = do
mp <- getAbsMountpoint mc
primary <- io $ lookupSpec mp
aux <- io $ fmap join $ mapM lookupSpec $ auxPath =<< primary
return $ case (primary, aux) of
(Just _, Just _) -> Mounted
(Nothing, Nothing) -> Unmounted
_ -> Partial
where
-- TODO don't hardcode the tmp directory
auxPath = fmap (\i -> "/tmp/.veracrypt_aux_mnt" ++ [i]) . vcIndex
vcIndex spec = case reverse spec of
-- TODO what if I have more than one digit?
(i:_) -> if i `elem` ['0'..'9'] then Just i else Nothing
_ -> Nothing
getAbsMountpoint :: MountConfig -> RofiMountIO FilePath
getAbsMountpoint MountConfig{ mountMountpoint = m } =
asks $ flip appendRoot m . mountconfVolatilePath
@ -596,7 +628,9 @@ instance Mountable Removable where
allInstalled _ = fmap isJust $ io $ findExecutable "udisksctl"
isMounted Removable { removablePath = d } = elem d <$> io curDeviceSpecs
mountState Removable { removablePath = d } = do
s <- elem d <$> io curDeviceSpecs
return $ if s then Mounted else Unmounted
getLabel Removable { removableLabel = l } = l
@ -649,7 +683,9 @@ instance Mountable MTPFS where
-- | return True always since the list won't even show without jmtpfs
allInstalled _ = return True
isMounted = io . isDirMounted <$> mtpfsMountpoint
mountState MTPFS { mtpfsMountpoint = m } = do
s <- io $ isDirMounted m
return $ if s then Mounted else Unmounted
getLabel = mtpfsDescription
@ -748,16 +784,23 @@ eitherToMountResult (Left (_, _, e)) = MountError e
--------------------------------------------------------------------------------
-- | Low-level mount functions
-- ASSUME these will never fail because the format of /proc/mounts is fixed
curMountField :: Int -> IO [String]
curMountField i = fmap ((!! i) . words) . lines <$> readFile "/proc/mounts"
mountMap :: IO (M.Map FilePath String)
mountMap = do
parseFile <$> readFile "/proc/mounts"
where
parseFile = M.fromList . mapMaybe (parseLine . words) . lines
-- none of these should fail since this file format will never change
parseLine [spec, mountpoint, _, _, _, _] = Just (mountpoint, spec)
parseLine _ = Nothing
curDeviceSpecs :: IO [String]
curDeviceSpecs = curMountField 0
curDeviceSpecs = M.elems <$> mountMap
curMountpoints :: IO [String]
curMountpoints = curMountField 1
curMountpoints = M.keys <$> mountMap
lookupSpec :: FilePath -> IO (Maybe String)
lookupSpec mountpoint = M.lookup mountpoint <$> mountMap
-- ASSUME the base mount path will always be created because
-- 'createDirectoryIfMissing' will make parents if missing, and that removing

View File

@ -39,6 +39,7 @@ dependencies:
- X11 >= 1.9.1
- yaml >= 0.11.1.2
- vector >= 0.12.0.3
- bimap >= 0.2.4
library:
source-dirs: lib/