ADD password prompt to sshfs and FIX password prompt since it never actually worked

app/rofi-dev.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 --------------------------------------------------------------------------------
 -- | rofi-dev - a rofi prompt for mountable devices
@@ -19,8 +19,8 @@ import           Data.List
 import           Data.List.Split       (splitOn)
 import qualified Data.Map              as M
 import           Data.Maybe
-import qualified Data.Text as T
+import qualified Data.Text             as T
-import qualified Data.Vector as V
+import qualified Data.Vector           as V
 import           Data.Yaml
 
 import           Rofi.Command
@@ -259,7 +259,7 @@ defaultTries = 2
 
 data MountConfig = MountConfig
   { mountMountpoint :: FilePath
-  , mountLabel :: Maybe String
+  , mountLabel      :: Maybe String
   } deriving Show
 
 instance FromJSON MountConfig where
@@ -268,7 +268,7 @@ instance FromJSON MountConfig where
     <*> o .:? "label"
 
 data BitwardenConfig = BitwardenConfig
-  { bitwardenKey :: String
+  { bitwardenKey   :: String
   , bitwardenTries :: Integer }
   deriving Show
 
@@ -290,27 +290,27 @@ newtype PromptConfig = PromptConfig
   deriving Show
 
 instance FromJSON PromptConfig where
-  parseJSON = withObject "libsecret" $ \o -> PromptConfig
+  parseJSON = withObject "prompt" $ \o -> PromptConfig
-    <$> o .: "tries" .!= defaultTries
+    <$> o .:? "tries" .!= defaultTries
 
-data PasswordConfig = PasswordConfig
+data PasswordConfig = PwdBW BitwardenConfig
-  { passwordBitwarden :: Maybe BitwardenConfig
+  | PwdLS LibSecretConfig
-  , passwordLibSecret :: Maybe LibSecretConfig
+  | PwdPr PromptConfig
-  , passwordPrompt    :: Maybe PromptConfig
-  }
   deriving Show
 
 instance FromJSON PasswordConfig where
-  parseJSON = withObject "password" $ \o -> PasswordConfig
+  parseJSON = withObject "password" $ \o -> do
-    <$> o .:? "bitwarden"
+    br <- fmap PwdBW <$> o .:? "bitwarden"
-    <*> o .:? "libsecret"
+    ls <- maybe (fmap PwdLS <$> o .:? "libsecret") (return . Just) br
-    <*> o .:? "prompt"
+    -- TODO this is silly because I need to pass 'prompt: {}' instead of
+    -- just 'prompt:' if I just want the defaults
+    maybe (PwdPr <$> o .: "prompt") return ls
 
 data CIFSOptsConfig = CIFSOptsConfig
-  { cifsoptsUsername   :: Maybe String
+  { cifsoptsUsername  :: Maybe String
-  , cifsoptsWorkgroup  :: Maybe String
+  , cifsoptsWorkgroup :: Maybe String
-  , cifsoptsUID        :: Maybe Integer
+  , cifsoptsUID       :: Maybe Integer
-  , cifsoptsGID        :: Maybe Integer
+  , cifsoptsGID       :: Maybe Integer
   , cifsoptsIocharset :: Maybe String
   } deriving Show
 
@@ -326,12 +326,13 @@ data DataConfig = VeracryptConfig
   { veracryptVolume   :: String
   , veracryptPassword :: Maybe PasswordConfig
   } | SSHFSConfig
-  { sshfsRemote :: String
+  { sshfsRemote   :: String
+  , sshfsPassword :: Maybe PasswordConfig
   } | CIFSConfig
-  { cifsRemote     :: String
+  { cifsRemote   :: String
-  , cifsSudo       :: Bool
+  , cifsSudo     :: Bool
-  , cifsPassword   :: Maybe PasswordConfig
+  , cifsPassword :: Maybe PasswordConfig
-  , cifsOpts       :: Maybe CIFSOptsConfig
+  , cifsOpts     :: Maybe CIFSOptsConfig
   } deriving Show
 
 data DeviceConfig = DeviceConfig
@@ -357,6 +358,7 @@ instance FromJSON TreeConfig where
                    <*> o .:? "options"
                  "sshfs"     -> SSHFSConfig
                    <$> o .: "remote"
+                   <*> o .:? "password"
                  "veracrypt" -> VeracryptConfig
                    <$> o .: "volume"
                    <*> o .:? "password"
@@ -398,7 +400,7 @@ 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
+  mount (Tree p _) True   = mount p True
 
   isMounted (Tree p _) = isMounted p
 
@@ -409,16 +411,16 @@ instance Mountable a => Mountable (Tree a) where
   getLabel (Tree p _) = getLabel p
 
 instance Actionable (Tree DeviceConfig) where
-  fmtEntry (Tree p@DeviceConfig{ deviceData = d } _) = [getLabel p, target d] 
+  fmtEntry (Tree p@DeviceConfig{ deviceData = d } _) = [getLabel p, target d]
     where
-      target CIFSConfig{ cifsRemote = r } = r
+      target CIFSConfig{ cifsRemote = r }           = r
-      target SSHFSConfig{ sshfsRemote = r } = r
+      target SSHFSConfig{ sshfsRemote = r }         = r
       target VeracryptConfig{ veracryptVolume = v } = v
 
   groupHeader (Tree DeviceConfig{ deviceData = d } _) =
     case d of
-      CIFSConfig{} -> CIFSHeader
+      CIFSConfig{}      -> CIFSHeader
-      SSHFSConfig{} -> SSHFSHeader
+      SSHFSConfig{}     -> SSHFSHeader
       VeracryptConfig{} -> VeracryptHeader
 
 configToTree' :: M.Map String TreeConfig -> [StaticConfigTree]
@@ -446,7 +448,7 @@ instance Mountable DeviceConfig where
     withTmpMountDir m'
       $ io
       $ case devData of
-          SSHFSConfig{ sshfsRemote = r } -> mountSSHFS m' r
+          SSHFSConfig{ sshfsRemote = r, sshfsPassword = p } -> mountSSHFS m' p r
           CIFSConfig
             { cifsRemote = r
             , cifsSudo = s
@@ -459,15 +461,15 @@ instance Mountable DeviceConfig where
   mount DeviceConfig{ deviceMount = m, deviceData = d } True = do
     m' <- getAbsMountpoint m
     runAndRemoveDir m' $ io $ case d of
-      CIFSConfig{ cifsSudo = s } -> runMountSudoMaybe s "umount" [m'] 
+      CIFSConfig{ cifsSudo = s } -> runMountSudoMaybe s "umount" [m']
       VeracryptConfig{}          -> runVeraCrypt ["-d", m'] ""
       _                          -> runMount "umount" [m'] ""
 
   allInstalled DeviceConfig{ deviceData = devData } = io $ isJust
     <$> findExecutable (exe devData)
     where
-      exe SSHFSConfig{} = "sshfs"
+      exe SSHFSConfig{}     = "sshfs"
-      exe CIFSConfig{} = "mount.cifs"
+      exe CIFSConfig{}      = "mount.cifs"
       exe VeracryptConfig{} = "veracrypt"
 
   isMounted DeviceConfig{ deviceMount = m } =
@@ -477,10 +479,13 @@ instance Mountable DeviceConfig where
     { deviceMount = MountConfig { mountMountpoint = p, mountLabel = l }
     } = fromMaybe (takeFileName p) l
 
-mountSSHFS :: FilePath -> String -> IO MountResult
+mountSSHFS :: FilePath -> Maybe PasswordConfig -> String -> IO MountResult
-mountSSHFS mountpoint remote = runMount "sshfs" [remote, mountpoint] ""
+mountSSHFS mountpoint pwdConfig remote =
+  withPasswordGetter pwdConfig (run ["-o", "password_stdin"]) $ run [] ""
+  where
+    run other = runMount "sshfs" (other ++ [remote, mountpoint])
 
-mountCIFS :: Bool -> String -> FilePath -> Maybe CIFSOptsConfig 
+mountCIFS :: Bool -> String -> FilePath -> Maybe CIFSOptsConfig
   -> Maybe PasswordConfig -> IO MountResult
 mountCIFS useSudo remote mountpoint opts pwdConfig =
   withPasswordGetter pwdConfig runPwd run
@@ -501,7 +506,7 @@ fromCIFSOpts o = intercalate "," $ mapMaybe concatMaybe fs
     concatMaybe (k, f) = (\v -> k ++ "=" ++ v) <$> f o
 
 mountVeracrypt :: FilePath -> Maybe PasswordConfig -> String -> IO MountResult
-mountVeracrypt mountpoint pwdConfig volume = 
+mountVeracrypt mountpoint pwdConfig volume =
   withPasswordGetter pwdConfig (runVeraCrypt (args ++ ["--stdin"]))
   $ runVeraCrypt args ""
   where
@@ -519,7 +524,7 @@ getAbsMountpoint MountConfig{ mountMountpoint = m } =
   asks $ flip appendRoot m . mountconfVolatilePath
 
 getStaticActions :: RofiMountIO [(Header, ProtoAction [String])]
-getStaticActions = mountableToAction $ asks $ configToTree' . mountconfStaticDevs 
+getStaticActions = mountableToAction $ asks $ configToTree' . mountconfStaticDevs
 
 --------------------------------------------------------------------------------
 -- | Password-getting functions for static devices
@@ -529,7 +534,7 @@ type PasswordGetter = IO (Maybe String)
 runSecret :: M.Map String String -> PasswordGetter
 runSecret kvs = readCmdSuccess "secret-tool" ("lookup":kvs') ""
   where
-    kvs' = concatMap (\(k, v) -> [k, v]) $ M.toList kvs 
+    kvs' = concatMap (\(k, v) -> [k, v]) $ M.toList kvs
 
 runBitwarden :: String -> PasswordGetter
 runBitwarden pname = ((password . login) <=< find (\i -> name i == pname))
@@ -542,20 +547,26 @@ runPromptLoop n pwd = do
     if n <= 0 then return Nothing else runPromptLoop (n-1) pwd
     else return res
 
+-- configToPwd :: PasswordConfig -> PasswordGetter
+-- configToPwd PasswordConfig
+--   { passwordBitwarden = b
+--   , passwordLibSecret = s
+--   , passwordPrompt = p
+--   } =
+--     getBW b `runMaybe` getLS s `runMaybe` getPrompt p
+--   where
+--     getBW (Just BitwardenConfig{ bitwardenKey = k, bitwardenTries = n }) =
+--       runPromptLoop n $ runBitwarden k
+--     getBW _ = return Nothing
+--     getLS = maybe (return Nothing) (runSecret . libsecretAttributes)
+--     getPrompt = maybe (return Nothing) (flip runPromptLoop readPassword . promptTries)
+--     runMaybe x y = (\r -> if isNothing r then y else return r) =<< x
+
 configToPwd :: PasswordConfig -> PasswordGetter
-configToPwd PasswordConfig
+configToPwd (PwdBW (BitwardenConfig { bitwardenKey = k, bitwardenTries = n })) =
-  { passwordBitwarden = b
+  runPromptLoop n $ runBitwarden k
-  , passwordLibSecret = s
+configToPwd (PwdLS s) = runSecret $ libsecretAttributes s
-  , passwordPrompt = p
+configToPwd (PwdPr p) = flip runPromptLoop readPassword $ promptTries p
-  } =
-    getBW b `runMaybe` getLS s `runMaybe` getPrompt p
-  where
-    getBW (Just BitwardenConfig{ bitwardenKey = k, bitwardenTries = n }) =
-      runPromptLoop n $ runBitwarden k
-    getBW _ = return Nothing
-    getLS = maybe (return Nothing) (runSecret . libsecretAttributes)
-    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
@@ -683,7 +694,7 @@ data NotifyIcon = IconError | IconInfo
 
 instance Show NotifyIcon where
   show IconError = "dialog-error-symbolic"
-  show IconInfo = "dialog-information-symbolic"
+  show IconInfo  = "dialog-information-symbolic"
 
 notifyMountResult :: Bool -> String -> MountResult -> IO ()
 notifyMountResult mounted label result = case result of
@@ -731,8 +742,8 @@ runSudoMount' rootpass cmd args environ = runMount "sudo" args' rootpass
     environ' = fmap (\(k, v) -> k ++ "=" ++ v) environ
 
 eitherToMountResult :: Either (Int, String, String) String -> MountResult
-eitherToMountResult (Right _) = MountSuccess
+eitherToMountResult (Right _)        = MountSuccess
-eitherToMountResult (Left (_, _, e)) = MountError e 
+eitherToMountResult (Left (_, _, e)) = MountError e
 
 --------------------------------------------------------------------------------
 -- | Low-level mount functions