prompt for name

5 files changed, 66 insertions, 31 deletions

diff --git a/CmdLine.hs b/CmdLine.hs
index 2b494db..b47d609 100644
--- a/CmdLine.hs
+++ b/CmdLine.hs
@@ -11,7 +11,6 @@ import qualified Data.ByteString.UTF8 as BU8
 
 data CmdLine = CmdLine
 	{ mode :: Mode
-	, name :: Name
 	, keytype :: KeyType
 	, testMode :: Bool
 	, gui :: Bool
@@ -24,7 +23,6 @@ data Mode = Backup | Restore
 parse :: Parser CmdLine
 parse = CmdLine
 	<$> (backup <|> restore)
-	<*> nameopt
 	<*> keytypeopt
 	<*> testmodeswitch
 	<*> guiswitch
@@ -37,10 +35,6 @@ parse = CmdLine
 		( long "restore"
 		<> help "Retrieve a secret key from keysafe."
 		)
-	nameopt = Name . BU8.fromString <$> strOption
-		( long "name"
-		<> help "Some name that is associated with the key. Should be something you can remember when restoring it."
-		)
 	keytypeopt = KeyType . BU8.fromString <$> strOption
 		( long "type"
 		<> help "Type of key (eg, \"gpg\")."
diff --git a/UI.hs b/UI.hs
index a97f3c1..279f6b9 100644
--- a/UI.hs
+++ b/UI.hs
@@ -3,7 +3,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-module UI where
+module UI (module UI, module Types.UI) where
 
 import Types.UI
 import Control.Monad
@@ -11,7 +11,7 @@ import UI.Zenity
 import UI.Readline
 
 availableUIs :: IO [UI]
-availableUIs = filterM isAvailable [zenityUI, readlineUI]
+availableUIs = filterM isAvailable [readlineUI, zenityUI]
 
 selectUI :: Bool -> IO UI
 selectUI needgui
diff --git a/UI/Readline.hs b/UI/Readline.hs
index bcbe27e..50f2e99 100644
--- a/UI/Readline.hs
+++ b/UI/Readline.hs
@@ -10,7 +10,6 @@ import Types
 import System.Console.Readline
 import System.Posix.Terminal
 import System.Posix.IO
-import Control.Monad
 import Control.Exception
 import System.IO
 import qualified Data.ByteString.UTF8 as BU8
@@ -23,15 +22,14 @@ readlineUI = UI
 	, withProgress = progress
 	}
 
-name :: Title -> Desc -> (Name -> Maybe Problem) -> IO (Maybe Name)
-name title desc checkproblem = go ""
+name :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name)
+name title desc (Name suggested) checkproblem = do
+	showTitle title
+	putStrLn desc
+	go
   where
-	go extradesc = do
-		putStrLn title
-		putStrLn ""
-		putStrLn desc
-		unless (null extradesc) $
-			putStrLn extradesc
+	go = do
+		addHistory (BU8.toString suggested)
 		mname <- readline "Name> "
 		case mname of
 			Just s -> do
@@ -41,15 +39,16 @@ name title desc checkproblem = go ""
 					Nothing -> do
 						putStrLn ""
 						return $ Just n
-					Just problem -> go problem
+					Just problem -> do
+						putStrLn problem
+						go
 			Nothing -> return Nothing
 
 password :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password)
 password title desc checkproblem = bracket setup teardown (const go)
   where
 	setup = do
-		putStrLn title
-		putStrLn ""
+		showTitle title
 		putStrLn desc
 		origattr <- getTerminalAttributes stdInput
 		let newattr = origattr `withoutMode` EnableEcho
@@ -83,10 +82,15 @@ progress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO ()
 progress title desc a = bracket_ setup teardown (a sendpercent)
   where
 	setup = do
-		putStrLn title
-		putStrLn ""
+		showTitle title
 		putStrLn desc
 	sendpercent p = do
 		putStr (show p ++ "%  ")
 		hFlush stdout
 	teardown = putStrLn "done"
+
+showTitle :: Title -> IO ()
+showTitle title = do
+	putStrLn title
+	putStrLn (replicate (length title) '-')
+	putStrLn ""
diff --git a/UI/Zenity.hs b/UI/Zenity.hs
index 3b8b028..f61bb44 100644
--- a/UI/Zenity.hs
+++ b/UI/Zenity.hs
@@ -27,14 +27,15 @@ zenityUI = UI
 	, withProgress = progress
 	}
 
-name :: Title -> Desc -> (Name -> Maybe Problem) -> IO (Maybe Name)
-name title desc checkproblem = go ""
+name :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name)
+name title desc (Name suggested) checkproblem = go ""
   where
 	go extradesc = do
 		h <- runZenity
 			[ "--entry"
 			, "--title", title
 			, "--text", desc ++ "\n" ++ extradesc
+			, "--entry-text", BU8.toString suggested
 			]
 		(ret, ok) <- waitZenity h
 		if ok
diff --git a/keysafe.hs b/keysafe.hs
index 94a7b09..6306511 100644
--- a/keysafe.hs
+++ b/keysafe.hs
@@ -16,25 +16,32 @@ import Cost
 import Shard
 import Storage
 import Storage.LocalFiles
+import Data.Maybe
+import qualified Data.ByteString as B
+import qualified Data.ByteString.UTF8 as BU8
+import System.Posix.User (userGecos, getUserEntryForID, getEffectiveUserID)
 
 main :: IO ()
 main = do
 	cmdline <- CmdLine.get
 	ui <- selectUI (CmdLine.gui cmdline)
-	let name = CmdLine.name cmdline
 	let keytype = CmdLine.keytype cmdline
 	-- TODO determine gpg key id by examining secret key,
 	-- or retrieving public key from keyserver and examining it.
 	let keyid = KeyId keytype "dummy key id"
 	case CmdLine.mode cmdline of
-		CmdLine.Backup -> storedemo name keyid $
+		CmdLine.Backup -> storedemo ui keyid $
 			if CmdLine.testMode cmdline
 				then testModeTunables
 				else defaultTunables
-		CmdLine.Restore -> retrievedemo name keyid
+		CmdLine.Restore -> retrievedemo ui keyid
 
-storedemo :: Name -> KeyId -> Tunables -> IO ()
-storedemo name keyid tunables = do
+storedemo :: UI -> KeyId -> Tunables -> IO ()
+storedemo ui keyid tunables = do
+	username <- userName
+	name <- fromMaybe (error "Aborting on no name") 
+		<$> promptName ui "Enter a name"
+			namedesc username validateName
 	kek <- genKeyEncryptionKey tunables name password
 	putStrLn "Very rough estimate of cost to brute-force the password:"
 	print $ estimateAttack spotAWS $ estimateBruteforceOf kek
@@ -47,9 +54,22 @@ storedemo name keyid tunables = do
   where
 	password = Password "correct horse battery staple"
 	secretkey = SecretKey "this is a gpg private key"
+	namedesc = unlines
+		[ "To back up your key, you will need to enter a name and a password."
+		, ""
+		, "Make sure to pick a name you will remember at some point in the future,"
+		, "perhaps years from now, when you will need to enter it with the same"
+		, "spelling and capitalization in order to restore the key."
+		, ""
+		, "(Your own full name is a pretty good choice for the name to enter here.)"
+		]
 
-retrievedemo :: Name -> KeyId -> IO ()
-retrievedemo name keyid = do
+retrievedemo :: UI -> KeyId -> IO ()
+retrievedemo ui keyid = do
+	username <- userName
+	name <- fromMaybe (error "Aborting on no name") 
+		<$> promptName ui "Enter the name of the key to restore"
+			namedesc username validateName
 	let sis = shardIdents tunables name keyid
 	-- we drop 1 to simulate not getting all shards from the servers
 	let l = drop 1 $ zip [1..] (getIdents sis)
@@ -68,3 +88,19 @@ retrievedemo name keyid = do
 	password = Password "correct horse battery staple"
 	-- TODO: derive by probing to find objects
 	tunables = testModeTunables -- defaultTunables
+	namedesc = unlines
+		[ "When you backed up the key, you entered a name and a password."
+		, "Now it's time to remember what you entered back then."
+		, ""
+		, "(If you can't remember the name you used, your own full name is the best guess.)"
+		]
+
+validateName :: Name -> Maybe Problem
+validateName (Name n)
+	| B.length n < 6 = Just "The name should be at least 6 letters long."
+	| otherwise = Nothing
+
+userName :: IO Name
+userName = do
+	u <- getUserEntryForID =<< getEffectiveUserID
+	return $ Name $ BU8.fromString $ takeWhile (/= ',') (userGecos u)