From a5ef68ffc8591b079094f4cf680d1d11c966512a Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Tue, 23 Mar 2021 21:39:41 -0400 Subject: [PATCH] REF rearrange code --- app/rofi-dev.hs | 566 ++++++++++++++++++++++++------------------------ 1 file changed, 285 insertions(+), 281 deletions(-) diff --git a/app/rofi-dev.hs b/app/rofi-dev.hs index 1b44f99..8720255 100644 --- a/app/rofi-dev.hs +++ b/app/rofi-dev.hs @@ -74,10 +74,168 @@ data Opts = Opts } deriving Show -------------------------------------------------------------------------------- --- | Static configuration +-- | Main prompt -- --- This is defined in a YAML file which describes how to mount each device. Here --- I define a parser for said YAML file +-- This command will have one Rofi prompt and will display all available +-- mounts grouped by device type (eg removable, sshfs, cifs, etc). I like +-- pretty things, so ensure the entries are aligned properly as well + +runMounts :: Opts -> IO () +runMounts opts = do + static <- join <$> traverse parseStaticConfig (optsConfig opts) + defaultTmpPath <- ("/tmp/media" ) <$> getEffectiveUserName + let tmpPath = fromMaybe defaultTmpPath $ _staticconfigTmpPath =<< static + let staticDevs = maybe M.empty _staticconfigDevices static + let verbose = fromMaybe False $ _staticconfigVerbose =<< static + let mountconf = MountConf + { mountconfVolatilePath = tmpPath + , mountconfRofiArgs = optsRofiArgs opts + , mountconfStaticDevs = staticDevs + , mountconfVerbose = verbose + } + let byAlias = mountByAlias $ optsUnmount opts + let byPrompt = runPrompt =<< getGroups + runRofiIO mountconf $ maybe byPrompt byAlias $ optsAlias opts + +parseStaticConfig :: FilePath -> IO (Maybe StaticConfig) +parseStaticConfig p = do + res <- decodeFileEither p + case res of + Left e -> print e >> return Nothing + Right c -> return $ Just c + +runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c () +runPrompt gs = selectAction $ emptyMenu + { groups = gs + , prompt = Just "Select Device" + } + +getGroups :: RofiMountIO [RofiGroup MountConf] +getGroups = do + staticDevs <- asks mountconfStaticDevs + staticActions <- mapM mkAction $ configToTree' staticDevs + removableActions <- mapM mkAction =<< getRemovableDevices + mtpActions <- mapM mkAction =<< getMTPDevices + return $ mapMaybe mkGroup + $ groupBy (\(hx, _) (hy, _) -> hx == hy) + $ sortBy (\(hx, _) (hy, _) -> compare hx hy) + $ staticActions ++ removableActions ++ mtpActions + +mountByAlias :: Bool -> String -> RofiMountIO () +mountByAlias unmountFlag alias = do + static <- asks mountconfStaticDevs + mapM_ (`mountMaybe` unmountFlag) $ configToTree static <$> M.lookup alias static + +mkGroup :: [(Header, ProtoAction [String])] -> Maybe (RofiGroup MountConf) +mkGroup [] = Nothing +mkGroup as = let ((Header title _, _):_) = as in + Just $ titledGroup title $ toRofiActions $ alignEntries $ fmap snd as + +alignSep :: String +alignSep = " | " + +alignEntries :: [ProtoAction [String]] -> [(String, RofiMountIO ())] +alignEntries ps = zip (align es) as + where + (es, as) = unzip $ fmap (\(ProtoAction e a) -> (e, a)) ps + align = fmap (intercalate alignSep) + . transpose + . mapToLast pad + . transpose + pad xs = let m = getMax xs in fmap (\x -> take m (x ++ repeat ' ')) xs + getMax = maximum . fmap length + mapToLast _ [] = [] + mapToLast _ [x] = [x] + mapToLast f (x:xs) = f x : mapToLast f xs + +-------------------------------------------------------------------------------- +-- | Global config used in the reader monad stack + +data MountConf = MountConf + { mountconfVolatilePath :: FilePath + , mountconfRofiArgs :: [String] + , mountconfStaticDevs :: M.Map String TreeConfig + , mountconfVerbose :: Bool + } deriving Show + +instance RofiConf MountConf where + defArgs MountConf { mountconfRofiArgs = a } = a + +-------------------------------------------------------------------------------- +-- | Mountable typeclass +-- +-- Class to provide common interface for anything that can be mounted. + +class Mountable a where + -- | Mount the given type (or dismount if False is passed) + mount :: a -> Bool -> RofiMountIO () + + mountMaybe :: a -> Bool -> RofiMountIO () + mountMaybe dev mountFlag = do + mounted <- isMounted dev + verbose <- asks mountconfVerbose + if mountFlag == mounted then mount dev mountFlag + else when verbose notify' + where + notify' = io $ notify "dialog-information-symbolic" + $ getLabel dev ++ " already mounted" + + -- | Check if the mounting utilities are present + allInstalled :: a -> RofiMountIO Bool + + -- | Return a string representing the label of the device + getLabel :: a -> String + + -- | Determine if the given type is mounted or not + isMounted :: a -> RofiMountIO Bool + +-------------------------------------------------------------------------------- +-- | Actionable typeclass +-- +-- Class to provide common interface for anything that can be presented in the +-- Rofi menu as an action. Note that this must be separate from the Mountable +-- class above because some devices are represented as trees, and displaying +-- these trees in the rofi menu only requires that the tree itself be presented +-- and not its subcomponents. + +class Mountable a => Actionable a where + -- | Return a string to go in the Rofi menu for the given type + fmtEntry :: a -> [String] + fmtEntry d = [getLabel d] + + groupHeader :: a -> Header + + -- | Given a mountable type, return a rofi action (string to go in the + -- Rofi prompt and an action to perform when it is selected) + mkAction :: a -> RofiMountIO (Header, ProtoAction [String]) + mkAction dev = do + m <- isMounted dev + i <- allInstalled dev + let h = groupHeader dev + let action = when i $ mountMaybe dev m + let entry = case fmtEntry dev of + (e:es) -> (mountedPrefix m i ++ e):es + _ -> [] + return (h, ProtoAction entry action) + where + mountedPrefix False True = " " + mountedPrefix True True = "* " + mountedPrefix _ False = "! " + +type RofiMountIO a = RofiIO MountConf a + +data Header = Header String Integer deriving (Show, Eq) + +data ProtoAction a = ProtoAction a (RofiMountIO ()) + +instance Ord Header where + compare (Header _ x) (Header _ y) = compare x y + +-------------------------------------------------------------------------------- +-- | Static device configuration +-- +-- Static devices are defined in a YAML file. These types/instances describe how +-- to parse said YAML file. defaultTries :: Integer defaultTries = 2 @@ -192,27 +350,123 @@ instance FromJSON StaticConfig where <*> o .: "devices" -------------------------------------------------------------------------------- --- | Global config used in the reader monad stack +-- | Static devices trees -- --- This is defined by the mount options on the command line, and holds: --- - a map between mountpoints and a means to get passwords when mounting those --- mountpoints --- - a mount directory where mountpoints will be created if needed (defaults --- to '/tmp/media/USER' --- - any arguments to be passed to the rofi command +-- Static devices as defined in the config file may declare dependencies on +-- other static devices, and thus are best represented as a tree. Note that the +-- tree is both Actionable and Mountable, where each node in the tree is only +-- Mountable; this is because trees need to be displayed and chosen in the Rofi +-- menu. -data MountConf = MountConf - { mountconfVolatilePath :: FilePath - , mountconfRofiArgs :: [String] - , mountconfStaticDevs :: M.Map String TreeConfig - , mountconfVerbose :: Bool - } +data Tree a = Tree a [Tree a] deriving (Eq, Show) -instance RofiConf MountConf where - defArgs MountConf { mountconfRofiArgs = a } = a +type StaticConfigTree = Tree DeviceConfig + +instance Mountable a => Mountable (Tree a) where + mount (Tree p cs) False = mapM_ (`mountMaybe` False) cs >> mount p False + mount (Tree p _) True = mount p True + + isMounted (Tree p _) = isMounted p + + allInstalled (Tree p cs) = do + res <- and <$> mapM allInstalled cs + if res then allInstalled p else return res + + getLabel (Tree p _) = getLabel p + +instance Actionable (Tree DeviceConfig) where + fmtEntry (Tree p@DeviceConfig{ _deviceData = d } _) = [getLabel p, target d] + where + target CIFSConfig{ _cifsRemote = r } = r + target SSHFSConfig{ _sshfsRemote = r } = r + target VeracryptConfig{ _veracryptVolume = v } = v + + groupHeader (Tree DeviceConfig{ _deviceData = d } _) = + case d of + CIFSConfig{} -> Header "CIFS Devices" 0 + SSHFSConfig{} -> Header "SSHFS Devices" 1 + VeracryptConfig{} -> Header "Veracrypt Devices" 2 + +configToTree' :: M.Map String TreeConfig -> [StaticConfigTree] +configToTree' devMap = configToTree devMap <$> M.elems devMap + +configToTree :: M.Map String TreeConfig -> TreeConfig -> StaticConfigTree +configToTree devMap TreeConfig{ _treeParent = p, _treeChildren = c } = + Tree p $ fmap go V.toList c + where + go ds = configToTree devMap <$> mapMaybe (`M.lookup` devMap) ds -------------------------------------------------------------------------------- --- | Password-getting functions +-- | Static devices +-- +-- This is complex because there may be multiple classes of static devices +-- in the config file, and each device may depend on another device that is +-- a different class (eg sshfs on cifs). I deal with this by abstracting the +-- differences between each class in a sum-record type; in this way the +-- processing "splits" and "converges" entirely in this function, so nothing +-- outside of these needs to be aware of these different classes. + +instance Mountable DeviceConfig where + mount c@DeviceConfig{ _deviceMount = m, _deviceData = devData} False = do + m' <- getAbsMountpoint m + bracketOnError_ (mkDirMaybe m') (rmDirMaybe m') $ mount' m' + where + mount' mountpoint = io $ case devData of + SSHFSConfig{ _sshfsRemote = r } -> do + runMountNotify "sshfs" [r, mountpoint] (getLabel c) False + CIFSConfig{ _cifsPassword = p } -> do + res <- case p of + Just pwd -> do + pwd' <- maybe [] (\p' -> [("PASSWD", p')]) <$> configToPwd pwd + readCmdEither' "mount" [mountpoint] "" pwd' + Nothing -> readCmdEither "mount" [mountpoint] "" + notifyMounted (isRight res) False (getLabel c) + VeracryptConfig{ _veracryptPassword = getPwd, _veracryptVolume = v } -> + maybe (runVeraCryptWith "" []) (runVeraCryptWithPwd =<<) (configToPwd <$> getPwd) + where + label = getLabel c + runVeraCryptWithPwd = maybe notifyFail (\p -> runVeraCryptWith p ["--stdin"]) + runVeraCryptWith stdin args = (\res -> notifyMounted (isRight res) False label) + =<< runVeraCrypt stdin ([v, mountpoint] ++ args) + notifyFail = notify "dialog-error-symbolic" $ + printf "Failed to get volume password for %s" label + + mount c@DeviceConfig{ _deviceMount = m, _deviceData = VeracryptConfig{} } True = do + m' <- getAbsMountpoint m + res <- io $ runVeraCrypt "" ["-d", m'] + io $ notifyMounted (isRight res) True (getLabel c) + + mount c@DeviceConfig{ _deviceMount = m } True = + umountNotify (getLabel c) =<< getAbsMountpoint m + + allInstalled DeviceConfig{ _deviceData = devData } = io $ isJust + <$> findExecutable (exe devData) + where + exe SSHFSConfig{} = "sshfs" + exe CIFSConfig{} = "mount.cifs" + exe VeracryptConfig{} = "veracrypt" + + isMounted DeviceConfig{ _deviceMount = m } = + (io . isDirMounted) =<< getAbsMountpoint m + + getLabel DeviceConfig + { _deviceMount = MountConfig { _mountMountPoint = p, _mountLabel = l } + } = fromMaybe (takeFileName p) l + +getAbsMountpoint :: MountConfig -> RofiMountIO FilePath +getAbsMountpoint MountConfig{ _mountMountPoint = m } = + asks $ flip appendRoot m . mountconfVolatilePath + +-- NOTE: the user is assumed to have added themselves to the sudoers file so +-- that this command will work +runVeraCrypt :: String -> [String] -> IO (Either (Int, String, String) String) +runVeraCrypt stdin args = do + readCmdEither "sudo" (defaultArgs ++ args) stdin + where + defaultArgs = ["/usr/bin/veracrypt", "--text", "--non-interactive"] + +-------------------------------------------------------------------------------- +-- | Password-getting functions for static devices type PasswordGetter = IO (Maybe String) @@ -252,86 +506,12 @@ configToPwd PasswordConfig{ _passwordBitwarden = b res <- x if isNothing res then y else return res --------------------------------------------------------------------------------- --- | Main prompt --- --- This command will have one Rofi prompt and will display all available --- mounts grouped by device type (eg removable, sshfs, cifs, etc). I like --- pretty things, so ensure the entries are aligned properly as well - -runMounts :: Opts -> IO () -runMounts opts = do - static <- join <$> traverse parseStaticConfig (optsConfig opts) - defaultTmpPath <- ("/tmp/media" ) <$> getEffectiveUserName - let tmpPath = fromMaybe defaultTmpPath $ _staticconfigTmpPath =<< static - let staticDevs = maybe M.empty _staticconfigDevices static - let verbose = fromMaybe False $ _staticconfigVerbose =<< static - let mountconf = MountConf - { mountconfVolatilePath = tmpPath - , mountconfRofiArgs = optsRofiArgs opts - , mountconfStaticDevs = staticDevs - , mountconfVerbose = verbose - } - let byAlias = mountByAlias $ optsUnmount opts - let byPrompt = runPrompt =<< getGroups - runRofiIO mountconf $ maybe byPrompt byAlias $ optsAlias opts - -parseStaticConfig :: FilePath -> IO (Maybe StaticConfig) -parseStaticConfig p = do - res <- decodeFileEither p - case res of - Left e -> print e >> return Nothing - Right c -> return $ Just c - -runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c () -runPrompt gs = selectAction $ emptyMenu - { groups = gs - , prompt = Just "Select Device" - } - -getGroups :: RofiIO MountConf [RofiGroup MountConf] -getGroups = do - staticDevs <- asks mountconfStaticDevs - staticActions <- mapM mkAction $ configToTree' staticDevs - removableActions <- mapM mkAction =<< getRemovableDevices - mtpActions <- mapM mkAction =<< getMTPDevices - return $ mapMaybe mkGroup - $ groupBy (\(hx, _) (hy, _) -> hx == hy) - $ sortBy (\(hx, _) (hy, _) -> compare hx hy) - $ staticActions ++ removableActions ++ mtpActions - -mountByAlias :: Bool -> String -> RofiIO MountConf () -mountByAlias unmountFlag alias = do - static <- asks mountconfStaticDevs - mapM_ (`mountMaybe` unmountFlag) $ configToTree static <$> M.lookup alias static - -mkGroup :: [(Header, ProtoAction [String])] -> Maybe (RofiGroup MountConf) -mkGroup [] = Nothing -mkGroup as = let ((Header title _, _):_) = as in - Just $ titledGroup title $ toRofiActions $ alignEntries $ fmap snd as - -alignSep :: String -alignSep = " | " - -alignEntries :: [ProtoAction [String]] -> [(String, RofiIO MountConf ())] -alignEntries ps = zip (align es) as - where - (es, as) = unzip $ fmap (\(ProtoAction e a) -> (e, a)) ps - align = fmap (intercalate alignSep) - . transpose - . mapToLast pad - . transpose - pad xs = let m = getMax xs in fmap (\x -> take m (x ++ repeat ' ')) xs - getMax = maximum . fmap length - mapToLast _ [] = [] - mapToLast _ [x] = [x] - mapToLast f (x:xs) = f x : mapToLast f xs - -------------------------------------------------------------------------------- -- | Removable devices -- --- A device which can be removed (which is all the devices we care about) --- This can be minimally described by a device DEVICESPEC and LABEL. +-- A device which can be removed (such as a flash drive). These are distinct +-- from any device in the static configuration in that they only have device +-- addresses (eg in /dev) and labels. data Removable = Removable { deviceSpec :: String @@ -374,25 +554,8 @@ getRemovableDevices = fromLines toDev . lines _ -> Nothing mk d l = Just $ Removable { deviceSpec = d, label = l } --------------------------------------------------------------------------------- --- | VeraCrypt Devices --- - --- NOTE: the user is assumed to have added themselves to the sudoers file so --- that this command will work -runVeraCrypt :: String -> [String] -> IO (Either (Int, String, String) String) -runVeraCrypt stdin args = do - readCmdEither "sudo" (defaultArgs ++ args) stdin - where - defaultArgs = ["/usr/bin/veracrypt", "--text", "--non-interactive"] - -------------------------------------------------------------------------------- -- | MTP devices --- --- These devices are a bit special because they are not based on Removable --- devices (eg they don't have a label and a device spec). Instead they --- are defined by a bus:device path. The program used for this is jmtpfs --- (which seems to be the fastest and most robust) data MTPFS = MTPFS { bus :: String @@ -420,13 +583,8 @@ instance Mountable MTPFS where getLabel MTPFS { description = d } = d -instance Actionable MTPFS where - fmtEntry d = [getLabel d] - - groupHeader _ = Header "MTP Devices" 5 - -- | Return list of all available MTP devices -getMTPDevices :: RofiIO MountConf [MTPFS] +getMTPDevices :: RofiMountIO [MTPFS] getMTPDevices = do dir <- asks mountconfVolatilePath res <- io $ readProcess "jmtpfs" ["-l"] "" @@ -451,164 +609,10 @@ getMTPDevices = do | c == ' ' = Just '-' | otherwise = Just c --------------------------------------------------------------------------------- --- | Static Device Wrapper --- --- In order to make a consistent interface for the static device types, create --- a wrapper type to encapsulate them. - -data Tree a = Tree a [Tree a] deriving (Eq, Show) - -type StaticConfigTree = Tree DeviceConfig - -instance Actionable (Tree DeviceConfig) where - fmtEntry (Tree p@DeviceConfig{ _deviceData = d } _) = [getLabel p, target d] - where - target CIFSConfig{ _cifsRemote = r } = r - target SSHFSConfig{ _sshfsRemote = r } = r - target VeracryptConfig{ _veracryptVolume = v } = v - - groupHeader (Tree DeviceConfig{ _deviceData = d } _) = - case d of - CIFSConfig{} -> Header "CIFS Devices" 0 - SSHFSConfig{} -> Header "SSHFS Devices" 1 - VeracryptConfig{} -> Header "Veracrypt Devices" 2 - -configToTree' :: M.Map String TreeConfig -> [StaticConfigTree] -configToTree' devMap = configToTree devMap <$> M.elems devMap - -configToTree :: M.Map String TreeConfig -> TreeConfig -> StaticConfigTree -configToTree devMap TreeConfig{ _treeParent = p, _treeChildren = c } = - Tree p $ fmap go V.toList c - where - go ds = configToTree devMap <$> mapMaybe (`M.lookup` devMap) ds - -instance Mountable a => Mountable (Tree a) where - mount (Tree p cs) False = mapM_ (`mountMaybe` False) cs >> mount p False - mount (Tree p _) True = mount p True - - isMounted (Tree p _) = isMounted p - - allInstalled (Tree p cs) = do - res <- and <$> mapM allInstalled cs - if res then allInstalled p else return res - - getLabel (Tree p _) = getLabel p - -instance Mountable DeviceConfig where - mount c@DeviceConfig{ _deviceMount = MountConfig { _mountMountPoint = m } - , _deviceData = devData - } False = do - m' <- getAbsMountpoint m - bracketOnError_ (mkDirMaybe m') (rmDirMaybe m') $ mount' m' - where - mount' mountpoint = io $ case devData of - SSHFSConfig{ _sshfsRemote = r } -> do - runMountNotify "sshfs" [r, mountpoint] (getLabel c) False - CIFSConfig{ _cifsPassword = p } -> do - res <- case p of - Just pwd -> do - pwd' <- maybe [] (\p' -> [("PASSWD", p')]) <$> configToPwd pwd - readCmdEither' "mount" [mountpoint] "" pwd' - Nothing -> readCmdEither "mount" [mountpoint] "" - notifyMounted (isRight res) False (getLabel c) - VeracryptConfig{ _veracryptPassword = getPwd, _veracryptVolume = v } -> - maybe (runVeraCryptWith "" []) (runVeraCryptWithPwd =<<) (configToPwd <$> getPwd) - where - l = getLabel c - runVeraCryptWithPwd = maybe notifyFail (\p -> runVeraCryptWith p ["--stdin"]) - runVeraCryptWith stdin args = (\res -> notifyMounted (isRight res) False l) - =<< runVeraCrypt stdin ([v, mountpoint] ++ args) - notifyFail = notify "dialog-error-symbolic" $ - printf "Failed to get volume password for %s" l - - mount c@DeviceConfig{ _deviceMount = MountConfig{ _mountMountPoint = m } - , _deviceData = VeracryptConfig{} } True = do - m' <- getAbsMountpoint m - res <- io $ runVeraCrypt "" ["-d", m'] - io $ notifyMounted (isRight res) True (getLabel c) - - mount c@DeviceConfig{ _deviceMount = MountConfig { _mountMountPoint = m }} True = - umountNotify (getLabel c) =<< getAbsMountpoint m - - allInstalled DeviceConfig{ _deviceData = devData } = io $ isJust - <$> findExecutable (exe devData) - where - exe SSHFSConfig{} = "sshfs" - exe CIFSConfig{} = "mount.cifs" - exe VeracryptConfig{} = "veracrypt" - - isMounted DeviceConfig{ _deviceMount = MountConfig{ _mountMountPoint = m }} = - (io . isDirMounted) =<< getAbsMountpoint m - - getLabel DeviceConfig{ _deviceMount = MountConfig{ _mountMountPoint = p, _mountLabel = l }} = - fromMaybe (takeFileName p) l - -getAbsMountpoint :: FilePath -> RofiIO MountConf FilePath -getAbsMountpoint p = asks $ flip appendRoot p . mountconfVolatilePath - --------------------------------------------------------------------------------- --- | Mountable typeclass --- --- Let this class represent anything that can be mounted. The end goal is to --- create a Rofi action which will define an entry in the rofi prompt for the --- device at hand. In order to make an action, we need functions to mount the --- device, check if the necessary mounting program(s) is installed, make the --- entry to go in the prompt, and test if the device is mounted. - -class Mountable a where - -- | Mount the given type (or dismount if False is passed) - mount :: a -> Bool -> RofiIO MountConf () - - mountMaybe :: a -> Bool -> RofiIO MountConf () - mountMaybe dev mountFlag = do - mounted <- isMounted dev - verbose <- asks mountconfVerbose - if mountFlag == mounted then mount dev mountFlag - else when verbose notify' - where - notify' = io $ notify "dialog-information-symbolic" - $ getLabel dev ++ " already mounted" - - -- | Check if the mounting utilities are present - allInstalled :: a -> RofiIO MountConf Bool - - -- | Return a string representing the label of the device - getLabel :: a -> String - - -- | Determine if the given type is mounted or not - isMounted :: a -> RofiIO MountConf Bool - -data Header = Header String Integer deriving (Show, Eq) - -data ProtoAction a = ProtoAction a (RofiIO MountConf ()) - -instance Ord Header where - compare (Header _ x) (Header _ y) = compare x y - -class Mountable a => Actionable a where - -- | Return a string to go in the Rofi menu for the given type - fmtEntry :: a -> [String] +instance Actionable MTPFS where fmtEntry d = [getLabel d] - groupHeader :: a -> Header - - -- | Given a mountable type, return a rofi action (string to go in the - -- Rofi prompt and an action to perform when it is selected) - mkAction :: a -> RofiIO MountConf (Header, ProtoAction [String]) - mkAction dev = do - m <- isMounted dev - i <- allInstalled dev - let h = groupHeader dev - let action = when i $ mountMaybe dev m - let entry = case fmtEntry dev of - (e:es) -> (mountedPrefix m i ++ e):es - _ -> [] - return (h, ProtoAction entry action) - where - mountedPrefix False True = " " - mountedPrefix True True = "* " - mountedPrefix _ False = "! " + groupHeader _ = Header "MTP Devices" 5 -------------------------------------------------------------------------------- -- | Low-level mount functions @@ -631,10 +635,10 @@ curMountpoints = curMountField 1 -- base path in /tmp, so all this is saying is that umounting everything will -- leave /tmp/media/USER without removing all the way down to /tmp) -mkDirMaybe :: FilePath -> RofiIO MountConf () +mkDirMaybe :: FilePath -> RofiMountIO () mkDirMaybe fp = whenInMountDir fp $ io $ createDirectoryIfMissing True fp -rmDirMaybe :: FilePath -> RofiIO MountConf () +rmDirMaybe :: FilePath -> RofiMountIO () rmDirMaybe fp = whenInMountDir fp $ unlessMountpoint fp $ asks mountconfVolatilePath >>= io . rmUntil fp where @@ -642,12 +646,12 @@ rmDirMaybe fp = whenInMountDir fp $ unlessMountpoint fp removePathForcibly cur rmUntil (takeDirectory cur) target -whenInMountDir :: FilePath -> RofiIO MountConf () -> RofiIO MountConf () +whenInMountDir :: FilePath -> RofiMountIO () -> RofiIO MountConf () whenInMountDir fp f = do mDir <- asks mountconfVolatilePath when (mDir `isPrefixOf` fp) f -unlessMountpoint :: FilePath -> RofiIO MountConf () -> RofiIO MountConf () +unlessMountpoint :: MonadIO m => FilePath -> m () -> m () unlessMountpoint fp f = do mounted <- io $ isDirMounted fp unless mounted f @@ -660,12 +664,12 @@ runMountNotify cmd args msg mounted = do res <- readCmdEither cmd args "" notifyMounted (isRight res) mounted msg -umountNotify' :: String -> String -> FilePath -> RofiIO MountConf () +umountNotify' :: String -> String -> FilePath -> RofiMountIO () umountNotify' cmd msg dir = finally (io $ runMountNotify cmd [dir] msg True) (rmDirMaybe dir) -umountNotify :: String -> FilePath -> RofiIO MountConf () +umountNotify :: String -> FilePath -> RofiMountIO () umountNotify = umountNotify' "umount" -- | Send a notification indicating the mount succeeded