ADD password prompt to sshfs and FIX password prompt since it never actually worked
This commit is contained in:
parent
ded4f4a0b4
commit
e3ecbad62d
111
app/rofi-dev.hs
111
app/rofi-dev.hs
|
@ -1,5 +1,5 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | rofi-dev - a rofi prompt for mountable devices
|
-- | rofi-dev - a rofi prompt for mountable devices
|
||||||
|
@ -19,8 +19,8 @@ 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
|
||||||
import Data.Maybe
|
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 Data.Yaml
|
||||||
|
|
||||||
import Rofi.Command
|
import Rofi.Command
|
||||||
|
@ -259,7 +259,7 @@ defaultTries = 2
|
||||||
|
|
||||||
data MountConfig = MountConfig
|
data MountConfig = MountConfig
|
||||||
{ mountMountpoint :: FilePath
|
{ mountMountpoint :: FilePath
|
||||||
, mountLabel :: Maybe String
|
, mountLabel :: Maybe String
|
||||||
} deriving Show
|
} deriving Show
|
||||||
|
|
||||||
instance FromJSON MountConfig where
|
instance FromJSON MountConfig where
|
||||||
|
@ -268,7 +268,7 @@ instance FromJSON MountConfig where
|
||||||
<*> o .:? "label"
|
<*> o .:? "label"
|
||||||
|
|
||||||
data BitwardenConfig = BitwardenConfig
|
data BitwardenConfig = BitwardenConfig
|
||||||
{ bitwardenKey :: String
|
{ bitwardenKey :: String
|
||||||
, bitwardenTries :: Integer }
|
, bitwardenTries :: Integer }
|
||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
|
@ -290,27 +290,27 @@ newtype PromptConfig = PromptConfig
|
||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
instance FromJSON PromptConfig where
|
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
|
deriving Show
|
||||||
|
|
||||||
instance FromJSON PasswordConfig where
|
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
|
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
|
, cifsoptsIocharset :: Maybe String
|
||||||
} deriving Show
|
} deriving Show
|
||||||
|
|
||||||
|
@ -326,12 +326,13 @@ data DataConfig = VeracryptConfig
|
||||||
{ veracryptVolume :: String
|
{ veracryptVolume :: String
|
||||||
, veracryptPassword :: Maybe PasswordConfig
|
, veracryptPassword :: Maybe PasswordConfig
|
||||||
} | SSHFSConfig
|
} | SSHFSConfig
|
||||||
{ sshfsRemote :: String
|
{ sshfsRemote :: String
|
||||||
|
, sshfsPassword :: Maybe PasswordConfig
|
||||||
} | CIFSConfig
|
} | CIFSConfig
|
||||||
{ cifsRemote :: String
|
{ cifsRemote :: String
|
||||||
, cifsSudo :: Bool
|
, cifsSudo :: Bool
|
||||||
, cifsPassword :: Maybe PasswordConfig
|
, cifsPassword :: Maybe PasswordConfig
|
||||||
, cifsOpts :: Maybe CIFSOptsConfig
|
, cifsOpts :: Maybe CIFSOptsConfig
|
||||||
} deriving Show
|
} deriving Show
|
||||||
|
|
||||||
data DeviceConfig = DeviceConfig
|
data DeviceConfig = DeviceConfig
|
||||||
|
@ -357,6 +358,7 @@ instance FromJSON TreeConfig where
|
||||||
<*> o .:? "options"
|
<*> o .:? "options"
|
||||||
"sshfs" -> SSHFSConfig
|
"sshfs" -> SSHFSConfig
|
||||||
<$> o .: "remote"
|
<$> o .: "remote"
|
||||||
|
<*> o .:? "password"
|
||||||
"veracrypt" -> VeracryptConfig
|
"veracrypt" -> VeracryptConfig
|
||||||
<$> o .: "volume"
|
<$> o .: "volume"
|
||||||
<*> o .:? "password"
|
<*> o .:? "password"
|
||||||
|
@ -398,7 +400,7 @@ type StaticConfigTree = Tree DeviceConfig
|
||||||
|
|
||||||
instance Mountable a => Mountable (Tree a) where
|
instance Mountable a => Mountable (Tree a) where
|
||||||
mount (Tree p cs) False = mapM_ (`mountMaybe` False) cs >> mount p False
|
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
|
isMounted (Tree p _) = isMounted p
|
||||||
|
|
||||||
|
@ -411,14 +413,14 @@ instance Mountable a => Mountable (Tree a) where
|
||||||
instance Actionable (Tree DeviceConfig) where
|
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
|
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
|
target VeracryptConfig{ veracryptVolume = v } = v
|
||||||
|
|
||||||
groupHeader (Tree DeviceConfig{ deviceData = d } _) =
|
groupHeader (Tree DeviceConfig{ deviceData = d } _) =
|
||||||
case d of
|
case d of
|
||||||
CIFSConfig{} -> CIFSHeader
|
CIFSConfig{} -> CIFSHeader
|
||||||
SSHFSConfig{} -> SSHFSHeader
|
SSHFSConfig{} -> SSHFSHeader
|
||||||
VeracryptConfig{} -> VeracryptHeader
|
VeracryptConfig{} -> VeracryptHeader
|
||||||
|
|
||||||
configToTree' :: M.Map String TreeConfig -> [StaticConfigTree]
|
configToTree' :: M.Map String TreeConfig -> [StaticConfigTree]
|
||||||
|
@ -446,7 +448,7 @@ instance Mountable DeviceConfig where
|
||||||
withTmpMountDir m'
|
withTmpMountDir m'
|
||||||
$ io
|
$ io
|
||||||
$ case devData of
|
$ case devData of
|
||||||
SSHFSConfig{ sshfsRemote = r } -> mountSSHFS m' r
|
SSHFSConfig{ sshfsRemote = r, sshfsPassword = p } -> mountSSHFS m' p r
|
||||||
CIFSConfig
|
CIFSConfig
|
||||||
{ cifsRemote = r
|
{ cifsRemote = r
|
||||||
, cifsSudo = s
|
, cifsSudo = s
|
||||||
|
@ -466,8 +468,8 @@ instance Mountable DeviceConfig where
|
||||||
allInstalled DeviceConfig{ deviceData = devData } = io $ isJust
|
allInstalled DeviceConfig{ deviceData = devData } = io $ isJust
|
||||||
<$> findExecutable (exe devData)
|
<$> findExecutable (exe devData)
|
||||||
where
|
where
|
||||||
exe SSHFSConfig{} = "sshfs"
|
exe SSHFSConfig{} = "sshfs"
|
||||||
exe CIFSConfig{} = "mount.cifs"
|
exe CIFSConfig{} = "mount.cifs"
|
||||||
exe VeracryptConfig{} = "veracrypt"
|
exe VeracryptConfig{} = "veracrypt"
|
||||||
|
|
||||||
isMounted DeviceConfig{ deviceMount = m } =
|
isMounted DeviceConfig{ deviceMount = m } =
|
||||||
|
@ -477,8 +479,11 @@ 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 :: 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
|
-> Maybe PasswordConfig -> IO MountResult
|
||||||
|
@ -542,20 +547,26 @@ runPromptLoop n pwd = do
|
||||||
if n <= 0 then return Nothing else runPromptLoop (n-1) pwd
|
if n <= 0 then return Nothing else runPromptLoop (n-1) pwd
|
||||||
else return res
|
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 -> 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)
|
withPasswordGetter :: Maybe PasswordConfig -> (String -> IO MountResult)
|
||||||
-> IO MountResult -> IO MountResult
|
-> IO MountResult -> IO MountResult
|
||||||
|
@ -683,7 +694,7 @@ data NotifyIcon = IconError | IconInfo
|
||||||
|
|
||||||
instance Show NotifyIcon where
|
instance Show NotifyIcon where
|
||||||
show IconError = "dialog-error-symbolic"
|
show IconError = "dialog-error-symbolic"
|
||||||
show IconInfo = "dialog-information-symbolic"
|
show IconInfo = "dialog-information-symbolic"
|
||||||
|
|
||||||
notifyMountResult :: Bool -> String -> MountResult -> IO ()
|
notifyMountResult :: Bool -> String -> MountResult -> IO ()
|
||||||
notifyMountResult mounted label result = case result of
|
notifyMountResult mounted label result = case result of
|
||||||
|
@ -731,7 +742,7 @@ runSudoMount' rootpass cmd args environ = runMount "sudo" args' rootpass
|
||||||
environ' = fmap (\(k, v) -> k ++ "=" ++ v) environ
|
environ' = fmap (\(k, v) -> k ++ "=" ++ v) environ
|
||||||
|
|
||||||
eitherToMountResult :: Either (Int, String, String) String -> MountResult
|
eitherToMountResult :: Either (Int, String, String) String -> MountResult
|
||||||
eitherToMountResult (Right _) = MountSuccess
|
eitherToMountResult (Right _) = MountSuccess
|
||||||
eitherToMountResult (Left (_, _, e)) = MountError e
|
eitherToMountResult (Left (_, _, e)) = MountError e
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
Loading…
Reference in New Issue