key selection working

2 files changed, 106 insertions, 28 deletions

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