ENH improve error output

app/rofi-dev.hs

@@ -15,7 +15,6 @@ import           Bitwarden.Internal
 import           Control.Monad
 import           Control.Monad.Reader
 
-import           Data.Either
 import           Data.List
 import           Data.List.Split       (splitOn)
 import qualified Data.Map              as M
@@ -111,14 +110,11 @@ runPrompt gs = selectAction $ emptyMenu
 
 getGroups :: RofiMountIO [RofiGroup MountConf]
 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
     $ groupBy (\(hx, _) (hy, _) -> hx == hy)
     $ sortBy (\(hx, _) (hy, _) -> compare hx hy)
-    $ staticActions ++ removableActions ++ mtpActions
+    $ concat actions
 
 mountByAlias :: Bool -> String -> RofiMountIO ()
 mountByAlias unmountFlag alias = do
@@ -151,11 +147,11 @@ alignEntries ps = zip (align es) as
 -- | Global config used in the reader monad stack
 
 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
   defArgs MountConf { mountconfRofiArgs = a } = a
@@ -167,17 +163,17 @@ instance RofiConf MountConf where
 
 class Mountable a where
   -- | Mount the given type (or dismount if False is passed)
-  mount :: a -> Bool -> RofiMountIO ()
+  mount :: a -> Bool -> RofiMountIO MountResult
 
   mountMaybe :: a -> Bool -> RofiMountIO ()
   mountMaybe dev mountFlag = do
     mounted <- isMounted dev
     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'
     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
   allInstalled :: a -> RofiMountIO Bool
@@ -221,6 +217,9 @@ class Mountable a => Actionable a where
       mountedPrefix True True  = "* "
       mountedPrefix _ False    = "! "
 
+mountableToAction :: Actionable a => RofiMountIO [a] -> RofiMountIO [(Header, ProtoAction [String])]
+mountableToAction ms = mapM mkAction =<< ms
+
 type RofiMountIO a = RofiIO MountConf a
 
 -- headers appear in the order listed here (per Enum)
@@ -241,11 +240,11 @@ instance Show Header where
     where
       suffix = (++ " Devices")
 
-data ProtoAction a = ProtoAction a (RofiMountIO ())
-
 instance Ord Header where
   compare x y = compare (fromEnum x) (fromEnum y)
 
+data ProtoAction a = ProtoAction a (RofiMountIO ())
+
 --------------------------------------------------------------------------------
 -- | 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.
 
 instance Mountable DeviceConfig where
-  mount c@DeviceConfig{ deviceMount = m, deviceData = devData} False = do
+  mount DeviceConfig{ deviceMount = m, deviceData = devData} False = do
     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
-    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
     <$> findExecutable (exe devData)
@@ -468,17 +451,35 @@ instance Mountable DeviceConfig where
     { deviceMount = MountConfig { mountMountpoint = p, mountLabel = 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{ mountMountpoint = m } =
   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
@@ -516,6 +517,13 @@ configToPwd PasswordConfig
     getPrompt = maybe (return Nothing) (flip runPromptLoop readPassword . promptTries)
     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
 --
@@ -524,14 +532,14 @@ configToPwd PasswordConfig
 -- addresses (eg in /dev) and labels.
 
 data Removable = Removable
-    { removablePath :: String
+    { removablePath  :: String
-    , removableLabel      :: String
+    , removableLabel :: String
     }
     deriving (Eq, Show)
 
 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
       c = if m then "unmount" else "mount"
 
@@ -564,6 +572,9 @@ getRemovableDevices = fromLines toDev . lines
       _                  -> Nothing
     mk d l = Just $ Removable { removablePath = d, removableLabel = l }
 
+getRemovableActions :: RofiMountIO [(Header, ProtoAction [String])]
+getRemovableActions = mountableToAction getRemovableDevices
+
 --------------------------------------------------------------------------------
 -- | MTP devices
 
@@ -576,19 +587,13 @@ data MTPFS = MTPFS
     deriving (Eq, Show)
 
 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
     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
   allInstalled _ = return True
@@ -623,11 +628,52 @@ getMTPDevices = do
       | c == ' ' = Just '-'
       | otherwise = Just c
 
+getMTPActions :: RofiMountIO [(Header, ProtoAction [String])]
+getMTPActions = mountableToAction getMTPDevices
+
 instance Actionable MTPFS where
   fmtEntry d = [getLabel d]
 
   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
 
@@ -649,6 +695,19 @@ 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)
 
+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 fp = whenInMountDir fp $ io $ createDirectoryIfMissing True fp
 
@@ -660,7 +719,7 @@ rmDirMaybe fp = whenInMountDir fp $ unlessMountpoint fp
       removePathForcibly cur
       rmUntil (takeDirectory cur) target
 
-whenInMountDir :: FilePath -> RofiMountIO () -> RofiIO MountConf ()
+whenInMountDir :: FilePath -> RofiMountIO () -> RofiMountIO ()
 whenInMountDir fp f = do
   mDir <- asks mountconfVolatilePath
   when (mDir `isPrefixOf` fp) f
@@ -673,32 +732,6 @@ unlessMountpoint fp f = do
 isDirMounted :: FilePath -> IO Bool
 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