ENH improve error output

This commit is contained in:
Nathan Dwarshuis 2021-03-25 00:35:59 -04:00
parent 144b4d9afe
commit 165410af84
1 changed files with 126 additions and 93 deletions

View File

@ -15,7 +15,6 @@ import Bitwarden.Internal
import Control.Monad import Control.Monad
import Control.Monad.Reader import Control.Monad.Reader
import Data.Either
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
@ -111,14 +110,11 @@ runPrompt gs = selectAction $ emptyMenu
getGroups :: RofiMountIO [RofiGroup MountConf] getGroups :: RofiMountIO [RofiGroup MountConf]
getGroups = do getGroups = do
staticDevs <- asks mountconfStaticDevs actions <- sequence [getStaticActions, getRemovableActions, getMTPActions]
staticActions <- mapM mkAction $ configToTree' staticDevs
removableActions <- mapM mkAction =<< getRemovableDevices
mtpActions <- mapM mkAction =<< getMTPDevices
return $ mapMaybe mkGroup return $ mapMaybe mkGroup
$ groupBy (\(hx, _) (hy, _) -> hx == hy) $ groupBy (\(hx, _) (hy, _) -> hx == hy)
$ sortBy (\(hx, _) (hy, _) -> compare hx hy) $ sortBy (\(hx, _) (hy, _) -> compare hx hy)
$ staticActions ++ removableActions ++ mtpActions $ concat actions
mountByAlias :: Bool -> String -> RofiMountIO () mountByAlias :: Bool -> String -> RofiMountIO ()
mountByAlias unmountFlag alias = do mountByAlias unmountFlag alias = do
@ -151,11 +147,11 @@ alignEntries ps = zip (align es) as
-- | 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
@ -167,17 +163,17 @@ instance RofiConf MountConf where
class Mountable a where class Mountable a where
-- | Mount the given type (or dismount if False is passed) -- | Mount the given type (or dismount if False is passed)
mount :: a -> Bool -> RofiMountIO () mount :: a -> Bool -> RofiMountIO MountResult
mountMaybe :: a -> Bool -> RofiMountIO () mountMaybe :: a -> Bool -> RofiMountIO ()
mountMaybe dev mountFlag = do mountMaybe dev mountFlag = do
mounted <- isMounted dev mounted <- isMounted dev
verbose <- asks mountconfVerbose verbose <- asks mountconfVerbose
if mountFlag == mounted then mount dev mountFlag if mountFlag == mounted
then (io . notifyMountResult mounted (getLabel dev)) =<< mount dev mountFlag
else when verbose notify' else when verbose notify'
where where
notify' = io $ notify "dialog-information-symbolic" notify' = io $ notify IconInfo (getLabel dev ++ " already mounted") Nothing
$ getLabel dev ++ " already mounted"
-- | Check if the mounting utilities are present -- | Check if the mounting utilities are present
allInstalled :: a -> RofiMountIO Bool allInstalled :: a -> RofiMountIO Bool
@ -221,6 +217,9 @@ class Mountable a => Actionable a where
mountedPrefix True True = "* " mountedPrefix True True = "* "
mountedPrefix _ False = "! " mountedPrefix _ False = "! "
mountableToAction :: Actionable a => RofiMountIO [a] -> RofiMountIO [(Header, ProtoAction [String])]
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)
@ -241,11 +240,11 @@ instance Show Header where
where where
suffix = (++ " Devices") suffix = (++ " Devices")
data ProtoAction a = ProtoAction a (RofiMountIO ())
instance Ord Header where instance Ord Header where
compare x y = compare (fromEnum x) (fromEnum y) compare x y = compare (fromEnum x) (fromEnum y)
data ProtoAction a = ProtoAction a (RofiMountIO ())
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Static device configuration -- | Static device configuration
-- --
@ -422,37 +421,21 @@ configToTree devMap TreeConfig{ treeParent = p, treeconfigChildren = c } =
-- outside of these needs to be aware of these different classes. -- outside of these needs to be aware of these different classes.
instance Mountable DeviceConfig where instance Mountable DeviceConfig where
mount c@DeviceConfig{ deviceMount = m, deviceData = devData} False = do mount DeviceConfig{ deviceMount = m, deviceData = devData} False = do
m' <- getAbsMountpoint m m' <- getAbsMountpoint m
bracketOnError_ (mkDirMaybe m') (rmDirMaybe m') $ mount' m' withTmpMountDir m'
where $ io
mount' mountpoint = io $ case devData of $ case devData of
SSHFSConfig{ sshfsRemote = r } -> do SSHFSConfig{ sshfsRemote = r } -> mountSSHFS m' r
runMountNotify "sshfs" [r, mountpoint] (getLabel c) False CIFSConfig{ cifsPassword = p } -> mountCIFS m' p
CIFSConfig{ cifsPassword = p } -> do VeracryptConfig{ veracryptPassword = p, veracryptVolume = v } ->
res <- case p of mountVeracrypt m' p v
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 mount DeviceConfig{ deviceMount = m, deviceData = d } True = do
m' <- getAbsMountpoint m m' <- getAbsMountpoint m
res <- io $ runVeraCrypt "" ["-d", m'] runAndRemoveDir m' $ io $ case d of
io $ notifyMounted (isRight res) True (getLabel c) VeracryptConfig{} -> runVeraCrypt ["-d", m'] ""
_ -> runMount "umount" [m'] ""
mount c@DeviceConfig{ deviceMount = m } True =
umountNotify (getLabel c) =<< getAbsMountpoint m
allInstalled DeviceConfig{ deviceData = devData } = io $ isJust allInstalled DeviceConfig{ deviceData = devData } = io $ isJust
<$> findExecutable (exe devData) <$> findExecutable (exe devData)
@ -468,17 +451,35 @@ instance Mountable DeviceConfig where
{ deviceMount = MountConfig { mountMountpoint = p, mountLabel = l } { deviceMount = MountConfig { mountMountpoint = p, mountLabel = l }
} = fromMaybe (takeFileName p) l } = fromMaybe (takeFileName p) l
mountSSHFS :: FilePath -> String -> IO MountResult
mountSSHFS mountpoint remote = runMount "sshfs" [remote, mountpoint] ""
mountCIFS :: FilePath -> Maybe PasswordConfig -> IO MountResult
mountCIFS mountpoint pwdConfig = withPasswordGetter pwdConfig runPwd run
where
run = runMount "mount" [mountpoint] ""
runPwd p = runMount' "mount" [mountpoint] "" [("PASSWD", p)]
mountVeracrypt :: FilePath -> Maybe PasswordConfig -> String -> IO MountResult
mountVeracrypt mountpoint pwdConfig volume =
withPasswordGetter pwdConfig (runVeraCrypt (args ++ ["--stdin"]))
$ runVeraCrypt args ""
where
args = [volume, mountpoint]
-- NOTE: the user is assumed to have added themselves to the sudoers file so
-- that this command will work
runVeraCrypt :: [String] -> String -> IO MountResult
runVeraCrypt args = runMount "sudo" (defaultArgs ++ args)
where
defaultArgs = ["/usr/bin/veracrypt", "--text", "--non-interactive"]
getAbsMountpoint :: MountConfig -> RofiMountIO FilePath getAbsMountpoint :: MountConfig -> RofiMountIO FilePath
getAbsMountpoint MountConfig{ mountMountpoint = m } = getAbsMountpoint MountConfig{ mountMountpoint = m } =
asks $ flip appendRoot m . mountconfVolatilePath asks $ flip appendRoot m . mountconfVolatilePath
-- NOTE: the user is assumed to have added themselves to the sudoers file so getStaticActions :: RofiMountIO [(Header, ProtoAction [String])]
-- that this command will work getStaticActions = mountableToAction $ asks $ configToTree' . mountconfStaticDevs
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 -- | Password-getting functions for static devices
@ -516,6 +517,13 @@ configToPwd PasswordConfig
getPrompt = maybe (return Nothing) (flip runPromptLoop readPassword . promptTries) getPrompt = maybe (return Nothing) (flip runPromptLoop readPassword . promptTries)
runMaybe x y = (\r -> if isNothing r then y else return r) =<< x runMaybe x y = (\r -> if isNothing r then y else return r) =<< x
withPasswordGetter :: Maybe PasswordConfig -> (String -> IO MountResult)
-> IO MountResult -> IO MountResult
withPasswordGetter (Just pwdConfig) runPwd _ =
maybe (return $ MountError "Password could not be obtained") runPwd
=<< configToPwd pwdConfig
withPasswordGetter Nothing _ run = run
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Removable devices -- | Removable devices
-- --
@ -524,14 +532,14 @@ configToPwd PasswordConfig
-- addresses (eg in /dev) and labels. -- addresses (eg in /dev) and labels.
data Removable = Removable data Removable = Removable
{ removablePath :: String { removablePath :: String
, removableLabel :: String , removableLabel :: String
} }
deriving (Eq, Show) deriving (Eq, Show)
instance Mountable Removable where instance Mountable Removable where
mount Removable { removablePath = d, removableLabel = l } m = mount Removable { removablePath = d } m =
io $ runMountNotify "udisksctl" [c, "-b", d] l m io $ runMount "udisksctl" [c, "-b", d] ""
where where
c = if m then "unmount" else "mount" c = if m then "unmount" else "mount"
@ -564,6 +572,9 @@ getRemovableDevices = fromLines toDev . lines
_ -> Nothing _ -> Nothing
mk d l = Just $ Removable { removablePath = d, removableLabel = l } mk d l = Just $ Removable { removablePath = d, removableLabel = l }
getRemovableActions :: RofiMountIO [(Header, ProtoAction [String])]
getRemovableActions = mountableToAction getRemovableDevices
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | MTP devices -- | MTP devices
@ -576,19 +587,13 @@ data MTPFS = MTPFS
deriving (Eq, Show) deriving (Eq, Show)
instance Mountable MTPFS where instance Mountable MTPFS where
mount MTPFS { mtpfsBus = b mount MTPFS { mtpfsBus = b, mtpfsDevice = n, mtpfsMountpoint = m } False = do
, mtpfsDevice = n
, mtpfsMountpoint = m
, mtpfsDescription = d
} False = do
-- TODO add autodismount to options -- TODO add autodismount to options
let dev = "-device=" ++ b ++ "," ++ n let dev = "-device=" ++ b ++ "," ++ n
bracketOnError_ withTmpMountDir m $ io $ runMount "jmtpfs" [dev, m] ""
(mkDirMaybe m)
(rmDirMaybe m)
$ io $ runMountNotify "jmtpfs" [dev, m] d False
mount MTPFS { mtpfsMountpoint = m, mtpfsDescription = d } True = umountNotify d m mount MTPFS { mtpfsMountpoint = m } True =
runAndRemoveDir m $ io $ runMount "nmount" [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
@ -623,11 +628,52 @@ getMTPDevices = do
| c == ' ' = Just '-' | c == ' ' = Just '-'
| otherwise = Just c | otherwise = Just c
getMTPActions :: RofiMountIO [(Header, ProtoAction [String])]
getMTPActions = mountableToAction getMTPDevices
instance Actionable MTPFS where instance Actionable MTPFS where
fmtEntry d = [getLabel d] fmtEntry d = [getLabel d]
groupHeader _ = MTPFSHeader groupHeader _ = MTPFSHeader
--------------------------------------------------------------------------------
-- | Notifications
data NotifyIcon = IconError | IconInfo
instance Show NotifyIcon where
show IconError = "dialog-error-symbolic"
show IconInfo = "dialog-information-symbolic"
notifyMountResult :: Bool -> String -> MountResult -> IO ()
notifyMountResult mounted label result = case result of
MountError e -> notify IconError (printf "Failed to %s %s" verb label) $ Just e
MountSuccess -> notify IconInfo (printf "Successfully %sed %s" verb label) Nothing
where
verb = if mounted then "unmount" else "mount" :: String
notify :: NotifyIcon -> String -> Maybe String -> IO ()
notify icon summary body = void $ spawnProcess "notify-send"
$ maybe args (\b -> args ++ [b]) body
where
args = ["-i", show icon, summary]
--------------------------------------------------------------------------------
-- | Mount commands
data MountResult = MountSuccess | MountError String deriving (Show, Eq)
runMount :: String -> [String] -> String -> IO MountResult
runMount cmd args stdin = eitherToMountResult <$> readCmdEither cmd args stdin
runMount' :: String -> [String] -> String -> [(String, String)] -> IO MountResult
runMount' cmd args stdin environ = eitherToMountResult
<$> readCmdEither' cmd args stdin environ
eitherToMountResult :: Either (Int, String, String) String -> MountResult
eitherToMountResult (Right _) = MountSuccess
eitherToMountResult (Left (_, _, e)) = MountError e
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Low-level mount functions -- | Low-level mount functions
@ -649,6 +695,19 @@ curMountpoints = curMountField 1
-- base path in /tmp, so all this is saying is that umounting everything will -- 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) -- leave /tmp/media/USER without removing all the way down to /tmp)
rmDirOnMountError :: FilePath -> RofiMountIO MountResult -> RofiMountIO MountResult
rmDirOnMountError d f = do
res <- f
unless (res == MountSuccess) $ rmDirMaybe d
return res
withTmpMountDir :: FilePath -> RofiMountIO MountResult -> RofiMountIO MountResult
withTmpMountDir m = rmDirOnMountError m
. bracketOnError_ (mkDirMaybe m) (rmDirMaybe m)
runAndRemoveDir :: FilePath -> RofiMountIO MountResult -> RofiMountIO MountResult
runAndRemoveDir m f = rmDirOnMountError m $ finally f (rmDirMaybe m)
mkDirMaybe :: FilePath -> RofiMountIO () mkDirMaybe :: FilePath -> RofiMountIO ()
mkDirMaybe fp = whenInMountDir fp $ io $ createDirectoryIfMissing True fp mkDirMaybe fp = whenInMountDir fp $ io $ createDirectoryIfMissing True fp
@ -660,7 +719,7 @@ rmDirMaybe fp = whenInMountDir fp $ unlessMountpoint fp
removePathForcibly cur removePathForcibly cur
rmUntil (takeDirectory cur) target rmUntil (takeDirectory cur) target
whenInMountDir :: FilePath -> RofiMountIO () -> RofiIO MountConf () whenInMountDir :: FilePath -> RofiMountIO () -> RofiMountIO ()
whenInMountDir fp f = do whenInMountDir fp f = do
mDir <- asks mountconfVolatilePath mDir <- asks mountconfVolatilePath
when (mDir `isPrefixOf` fp) f when (mDir `isPrefixOf` fp) f
@ -673,32 +732,6 @@ unlessMountpoint fp f = do
isDirMounted :: FilePath -> IO Bool isDirMounted :: FilePath -> IO Bool
isDirMounted fp = elem fp <$> curMountpoints isDirMounted fp = elem fp <$> curMountpoints
runMountNotify :: String -> [String] -> String -> Bool -> IO ()
runMountNotify cmd args msg mounted = do
res <- readCmdEither cmd args ""
notifyMounted (isRight res) mounted msg
umountNotify' :: String -> String -> FilePath -> RofiMountIO ()
umountNotify' cmd msg dir = finally
(io $ runMountNotify cmd [dir] msg True)
(rmDirMaybe dir)
umountNotify :: String -> FilePath -> RofiMountIO ()
umountNotify = umountNotify' "umount"
-- | Send a notification indicating the mount succeeded
notifyMounted :: Bool -> Bool -> String -> IO ()
notifyMounted succeeded mounted label = notify icon body
where
(format, icon) = if succeeded
then ("Successfully %sed %s", "dialog-information-symbolic")
else ("Failed to %s %s", "dialog-error-symbolic")
m = if mounted then "unmount" else "mount" :: String
body = printf format m label
notify :: String -> String -> IO ()
notify icon body = void $ spawnProcess "notify-send" ["-i", icon, body]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Other functions -- | Other functions