From 9473fee1bb0f9f549de41eec9f7b7d141f2ebfd3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 16 Aug 2016 16:08:13 -0400 Subject: key selection working --- UI/Readline.hs | 73 +++++++++++++++++++++++++++++++++++++++++++++++----------- UI/Zenity.hs | 61 ++++++++++++++++++++++++++++++++++++------------ 2 files changed, 106 insertions(+), 28 deletions(-) (limited to 'UI') diff --git a/UI/Readline.hs b/UI/Readline.hs index 086da1e..ac962d2 100644 --- a/UI/Readline.hs +++ b/UI/Readline.hs @@ -12,14 +12,20 @@ import System.Posix.Terminal import System.Posix.IO import Control.Exception import System.IO +import Data.List +import Data.Char +import Text.Read +import Control.Monad import qualified Data.ByteString.UTF8 as BU8 readlineUI :: UI readlineUI = UI { isAvailable = queryTerminal stdInput , showError = myShowError + , promptQuestion = myPromptQuestion , promptName = myPromptName , promptPassword = myPromptPassword + , promptKeyId = myPromptKeyId , withProgress = myWithProgress } @@ -27,6 +33,24 @@ myShowError :: Desc -> IO () myShowError desc = do hPutStrLn stderr $ "Error: " ++ desc +myPromptQuestion :: Title -> Desc -> IO Bool +myPromptQuestion title desc = do + showTitle title + go + where + go = do + putStrLn desc + mresp <- readline "y/n? " + case mresp of + Just s + | "y" `isPrefixOf` (map toLower s) -> + return True + | "n" `isPrefixOf` (map toLower s) -> + return False + _ -> do + putStrLn "Please enter 'y' or 'n'" + go + myPromptName :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name) myPromptName title desc (Name suggested) checkproblem = do showTitle title @@ -49,8 +73,8 @@ myPromptName title desc (Name suggested) checkproblem = do go Nothing -> return Nothing -myPromptPassword :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password) -myPromptPassword title desc checkproblem = bracket setup teardown (const go) +myPromptPassword :: Bool -> Title -> Desc -> IO (Maybe Password) +myPromptPassword confirm title desc = bracket setup teardown (const prompt) where setup = do showTitle title @@ -60,11 +84,15 @@ myPromptPassword title desc checkproblem = bracket setup teardown (const go) setTerminalAttributes stdInput newattr Immediately return origattr teardown origattr = setTerminalAttributes stdInput origattr Immediately - go = do + prompt = do putStr "Enter password> " hFlush stdout p1 <- getLine putStrLn "" + if confirm + then promptconfirm p1 + else return $ mkpassword p1 + promptconfirm p1 = do putStr "Confirm password> " hFlush stdout p2 <- getLine @@ -72,16 +100,35 @@ myPromptPassword title desc checkproblem = bracket setup teardown (const go) if p1 /= p2 then do putStrLn "Passwords didn't match, try again..." - go - else - let p = Password $ BU8.fromString p1 - in case checkproblem p of - Nothing -> do - putStrLn "" - return $ Just p - Just problem -> do - putStrLn problem - go + prompt + else do + putStrLn "" + return $ mkpassword p1 + mkpassword = Just . Password . BU8.fromString + +myPromptKeyId :: Title -> Desc -> [(Name, KeyId)] -> IO (Maybe KeyId) +myPromptKeyId _ _ [] = return Nothing +myPromptKeyId title desc l = do + showTitle title + putStrLn desc + putStrLn "" + forM_ nl $ \(n, ((Name name), (KeyId kid))) -> + putStrLn $ show n ++ ".\t" ++ BU8.toString name ++ " (keyid " ++ BU8.toString kid ++ ")" + prompt + where + nl = zip [1 :: Integer ..] l + prompt = do + putStr "Enter number> " + hFlush stdout + r <- getLine + putStrLn "" + case readMaybe r of + Just n + | n > 0 && n < length l -> + return $ Just $ snd (l !! n) + _ -> do + putStrLn $ "Enter a number from 1 to " ++ show (length l) + prompt myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO () myWithProgress title desc a = bracket_ setup teardown (a sendpercent) diff --git a/UI/Zenity.hs b/UI/Zenity.hs index c8fca2d..3c3f313 100644 --- a/UI/Zenity.hs +++ b/UI/Zenity.hs @@ -23,8 +23,10 @@ zenityUI = UI loc <- filterM (\p -> doesFileExist (p "zenity")) ps return (not (null loc)) , showError = myShowError + , promptQuestion = myPromptQuestion , promptName = myPromptName , promptPassword = myPromptPassword + , promptKeyId = myPromptKeyId , withProgress = myWithProgress } @@ -40,6 +42,16 @@ myShowError desc = bracket go cleanup (\_ -> return ()) _ <- waitZenity h return () +myPromptQuestion :: Title -> Desc -> IO Bool +myPromptQuestion title desc = do + h <- runZenity + [ "--question" + , "--title", title + , "--text", desc + ] + (_, ok) <- waitZenity h + return ok + myPromptName :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name) myPromptName title desc (Name suggested) checkproblem = go "" where @@ -59,31 +71,50 @@ myPromptName title desc (Name suggested) checkproblem = go "" Just problem -> go problem else return Nothing -myPromptPassword :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password) -myPromptPassword title desc checkproblem = go "" +myPromptPassword :: Bool -> Title -> Desc -> IO (Maybe Password) +myPromptPassword confirm title desc = go "" where go extradesc = do - h <- runZenity + h <- runZenity $ [ "--forms" , "--title", title , "--text", desc ++ "\n" ++ extradesc ++ "\n" - , "--add-password", "Enter password" - , "--add-password", "Confirm password" , "--separator", "\BEL" - ] + , "--add-password", "Enter password" + ] ++ if confirm + then [ "--add-password", "Confirm password" ] + else [] (ret, ok) <- waitZenity h if ok - then - let (p1, _:p2) = break (== '\BEL') ret - in if p1 /= p2 - then go "Passwords didn't match, try again..." - else - let p = Password $ BU8.fromString p1 - in case checkproblem p of - Nothing -> return $ Just p - Just problem -> go problem + then if confirm + then + let (p1, _:p2) = break (== '\BEL') ret + in if p1 /= p2 + then go "Passwords didn't match, try again..." + else return $ Just $ Password $ BU8.fromString p1 + else return $ Just $ Password $ BU8.fromString ret else return Nothing +myPromptKeyId :: Title -> Desc -> [(Name, KeyId)] -> IO (Maybe KeyId) +myPromptKeyId _ _ [] = return Nothing +myPromptKeyId title desc l = do + h <- runZenity $ + [ "--list" + , "--title", title + , "--text", desc + , "--column", "gpg secret key name" + , "--column", "keyid" + , "--print-column", "ALL" + , "--separator", "\BEL" + , "--width", "500" + ] ++ concatMap (\(Name n, KeyId kid) -> [BU8.toString n, BU8.toString kid]) l + (ret, ok) <- waitZenity h + if ok + then do + let (_n, _:kid) = break (== '\BEL') ret + return $ Just (KeyId (BU8.fromString kid)) + else return Nothing + myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO () myWithProgress title desc a = bracket setup teardown (a . sendpercent) where -- cgit v1.2.3