more command line interface improvements

8 files changed, 124 insertions, 61 deletions

diff --git a/CmdLine.hs b/CmdLine.hs
index ca574bb..6413cf7 100644
--- a/CmdLine.hs
+++ b/CmdLine.hs
@@ -3,14 +3,16 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-module CmdLine (CmdLine(..), Mode(..), get, parse) where
+module CmdLine (CmdLine(..), Mode(..), get, parse, selectMode) where
 
 import Types
+import qualified Gpg
 import Options.Applicative
 import qualified Data.ByteString.UTF8 as BU8
+import System.Directory
 
 data CmdLine = CmdLine
-	{ mode :: Mode
+	{ mode :: Maybe Mode
 	, secretkeysource :: Maybe SecretKeySource
 	, testMode :: Bool
 	, gui :: Bool
@@ -22,7 +24,7 @@ data Mode = Backup | Restore | Benchmark
 
 parse :: Parser CmdLine
 parse = CmdLine
-	<$> (backup <|> restore <|> benchmark)
+	<$> optional (backup <|> restore <|> benchmark)
 	<*> optional (gpgswitch <|> fileswitch)
 	<*> testmodeswitch
 	<*> guiswitch
@@ -63,3 +65,15 @@ get = execParser opts
 		( fullDesc
 		<> header "keysafe - securely back up secret keys"
 		)
+
+-- | When a mode is not specified on the command line,
+-- default to backing up if a secret key exists, and otherwise restoring.
+selectMode :: CmdLine -> IO Mode
+selectMode cmdline = case mode cmdline of
+	Just m -> return m
+	Nothing -> case secretkeysource cmdline of
+		Just (KeyFile f) -> present <$> doesFileExist f
+		_ -> present . not . null <$> Gpg.listSecretKeys
+  where
+	present True = Backup
+	present False = Restore
diff --git a/Gpg.hs b/Gpg.hs
index bf4cbe6..9794395 100644
--- a/Gpg.hs
+++ b/Gpg.hs
@@ -8,14 +8,17 @@ module Gpg where
 import Types
 import System.Process
 
--- | Converts an input KeyId, which can be short, or even a name or email,
--- to a long-form gpg KeyId of a secret key.
-getFullKeyId :: KeyId -> IO (Maybe KeyId)
+listSecretKeys :: IO [(Name, KeyId)]
+listSecretKeys = undefined
 -- gpg --batch --with-colons --list-secret-keys
 -- extract from eg, sec::4096:1:C910D9222512E3C7:...
 
+getSecretKey :: KeyId -> IO SecretKey
+getSecretKey = undefined
+
 -- | Check if a given gpg key is present on the keyserver.
 -- (Without downloading the key.)
 knownByKeyServer :: KeyId -> IO Bool
+knownByKeyServer kid = undefined
 -- gpg --batch --with-colons --search-keys 2>/dev/null
 -- check if output includes pub: line
diff --git a/Types.hs b/Types.hs
index d3eeccb..5e06a74 100644
--- a/Types.hs
+++ b/Types.hs
@@ -52,8 +52,7 @@ data SecretKeySource = GpgKey KeyId | KeyFile FilePath
 -- | The keyid is any value that is unique to a private key, and can be
 -- looked up somehow without knowing the private key.
 --
--- A gpg keyid is the obvious example. But, if a gpg key is not
--- stored on the key servers, keysafe will instead use "".
+-- A gpg keyid is the obvious example.
 data KeyId = KeyId B.ByteString
 	deriving (Show)
 
diff --git a/Types/UI.hs b/Types/UI.hs
index bba3d38..561aa65 100644
--- a/Types/UI.hs
+++ b/Types/UI.hs
@@ -9,8 +9,10 @@ import Types
 
 data UI = UI
 	{ isAvailable :: IO Bool
+	, showError :: Desc -> IO ()
 	, promptName :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name)
 	, promptPassword :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password)
+	, promptKeyId :: Title -> Desc -> [(Name, KeyId)] -> IO (Maybe KeyId)
 	, withProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO ()
 	}
 
diff --git a/UI/Readline.hs b/UI/Readline.hs
index 50f2e99..086da1e 100644
--- a/UI/Readline.hs
+++ b/UI/Readline.hs
@@ -17,13 +17,18 @@ import qualified Data.ByteString.UTF8 as BU8
 readlineUI :: UI
 readlineUI = UI
 	{ isAvailable = queryTerminal stdInput
-	, promptName = name
-	, promptPassword = password
-	, withProgress = progress
+	, showError = myShowError
+	, promptName = myPromptName
+	, promptPassword = myPromptPassword
+	, withProgress = myWithProgress
 	}
 
-name :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name)
-name title desc (Name suggested) checkproblem = do
+myShowError :: Desc -> IO ()
+myShowError desc = do
+	hPutStrLn stderr $ "Error: " ++ desc
+
+myPromptName :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name)
+myPromptName title desc (Name suggested) checkproblem = do
 	showTitle title
 	putStrLn desc
 	go
@@ -44,8 +49,8 @@ name title desc (Name suggested) checkproblem = do
 						go
 			Nothing -> return Nothing
 
-password :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password)
-password title desc checkproblem = bracket setup teardown (const go)
+myPromptPassword :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password)
+myPromptPassword title desc checkproblem = bracket setup teardown (const go)
   where
 	setup = do
 		showTitle title
@@ -78,8 +83,8 @@ password title desc checkproblem = bracket setup teardown (const go)
 						putStrLn problem
 						go
 
-progress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO ()
-progress title desc a = bracket_ setup teardown (a sendpercent)
+myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO ()
+myWithProgress title desc a = bracket_ setup teardown (a sendpercent)
   where
 	setup = do
 		showTitle title
diff --git a/UI/Zenity.hs b/UI/Zenity.hs
index f61bb44..c8fca2d 100644
--- a/UI/Zenity.hs
+++ b/UI/Zenity.hs
@@ -22,13 +22,26 @@ zenityUI = UI
 		ps <- getSearchPath
 		loc <- filterM (\p -> doesFileExist (p </> "zenity")) ps
 		return (not (null loc))
-	, promptName = name
-	, promptPassword = password
-	, withProgress = progress
+	, showError = myShowError
+	, promptName = myPromptName
+	, promptPassword = myPromptPassword
+	, withProgress = myWithProgress
 	}
 
-name :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name)
-name title desc (Name suggested) checkproblem = go ""
+myShowError :: Desc -> IO ()
+myShowError desc = bracket go cleanup (\_ -> return ())
+  where
+	go = runZenity
+		[ "--error"
+		, "--title", "keysafe"
+		, "--text", "Error: " ++ desc
+		]
+	cleanup h = do
+		_ <- waitZenity h
+		return ()
+
+myPromptName :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name)
+myPromptName title desc (Name suggested) checkproblem = go ""
   where
 	go extradesc = do
 		h <- runZenity
@@ -46,8 +59,8 @@ name title desc (Name suggested) checkproblem = go ""
 					Just problem -> go problem
 			else return Nothing
 
-password :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password)
-password title desc checkproblem = go ""
+myPromptPassword :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password)
+myPromptPassword title desc checkproblem = go ""
   where
 	go extradesc = do
 		h <- runZenity
@@ -71,8 +84,8 @@ password title desc checkproblem = go ""
 							Just problem -> go problem
 			else return Nothing
 
-progress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO ()
-progress title desc a = bracket setup teardown (a . sendpercent)
+myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO ()
+myWithProgress title desc a = bracket setup teardown (a . sendpercent)
   where
 	setup = do
 		h <- runZenity
diff --git a/keysafe.cabal b/keysafe.cabal
index 175bb9f..f92656a 100644
--- a/keysafe.cabal
+++ b/keysafe.cabal
@@ -57,6 +57,7 @@ Executable keysafe
     Encryption
     Entropy
     ExpensiveHash
+    Gpg
     Serialization
     Shard
     Storage
diff --git a/keysafe.hs b/keysafe.hs
index 7f89004..056003a 100644
--- a/keysafe.hs
+++ b/keysafe.hs
@@ -18,7 +18,9 @@ import Cost
 import Shard
 import Storage
 import Storage.LocalFiles
+import qualified Gpg
 import Data.Maybe
+import Control.Monad
 import qualified Data.ByteString as B
 import qualified Data.ByteString.UTF8 as BU8
 import System.Posix.User (userGecos, getUserEntryForID, getEffectiveUserID)
@@ -27,49 +29,64 @@ main :: IO ()
 main = do
 	cmdline <- CmdLine.get
 	ui <- selectUI (CmdLine.gui cmdline)
-	-- TODO determine gpg key id by examining secret key,
-	-- or retrieving public key from keyserver and examining it.
 	let tunables = if CmdLine.testMode cmdline
 		then testModeTunables
 		else defaultTunables
-	case (CmdLine.mode cmdline, CmdLine.secretkeysource cmdline) of
-		(CmdLine.Backup, Just secretkeysource) ->
-			backup ui tunables =<< normalize secretkeysource
-		(CmdLine.Backup, Nothing) -> do
-			backup ui tunables =<< normalize =<< pickGpgKey CmdLine.Backup ui
-		(CmdLine.Restore, Just secretkeydest) ->
-			restore ui =<< normalize secretkeydest
-		(CmdLine.Restore, Nothing) -> do
-			restore ui =<< normalize =<< pickGpgKey CmdLine.Backup ui
-		(CmdLine.Benchmark, _) -> benchmarkTunables tunables
+	mode <- CmdLine.selectMode cmdline
+	go mode (CmdLine.secretkeysource cmdline) tunables ui
+  where
+	go CmdLine.Backup (Just secretkeysource@(GpgKey kid)) tunables ui = do
+		ok <- Gpg.knownByKeyServer kid
+		unless ok $
+			error "Your gpg public key has to be stored on the keyservers before you can back it up by keyid. Either use gpg --send-key to store the public key on the keyservers, or omit the --gpgkeyid option"
+		backup ui tunables secretkeysource
+			=<< getSecretKey secretkeysource
+	go CmdLine.Backup (Just secretkeysource) tunables ui =
+		backup ui tunables secretkeysource
+			=<< getSecretKey secretkeysource
+	go CmdLine.Backup Nothing tunables ui =
+		backup ui tunables anyGpgKey =<< pickGpgKeyToBackup ui
+	go CmdLine.Restore (Just secretkeydest) _ ui =
+		restore ui secretkeydest
+	go CmdLine.Restore Nothing _ ui =
+		restore ui anyGpgKey
+	go CmdLine.Benchmark _ tunables _ =
+		benchmarkTunables tunables
 
--- | Normalize gpg keyids, by querying the gpg keyserver for the key.
--- If the keyserver knows of the key, the long keyid is used.
--- But, if the keyserver does not know of the key, a null keyid is used.
-normalize :: SecretKeySource -> IO SecretKeySource
-normalize = return -- TODO
+getSecretKey :: SecretKeySource -> IO SecretKey
+getSecretKey (GpgKey kid) = Gpg.getSecretKey kid
+getSecretKey (KeyFile f) = SecretKey <$> B.readFile f
 
--- | Pick gpg secret key to back up or restore.
---
--- When backing up, if there is only one secret
--- key, the choice is obvious. Otherwise prompt the user with a list.
+-- | Pick gpg secret key to back up.
 --
--- When restoring, prompt the user for the name of the key,
--- query the keyserver, and let the user pick from a list.
--- The "other" option uses a null keyid, to handle the case where a key is
--- not stored in the keyserver.
-pickGpgKey :: CmdLine.Mode -> UI -> IO SecretKeySource
-pickGpgKey CmdLine.Backup ui = error "TODO"
-pickGpgKey CmdLine.Restore ui = error "TODO"
-pickGpgKey _ ui = error "internal error in pickGpgKey"
+-- If there is only one gpg secret key,
+-- the choice is obvious. Otherwise prompt the user with a list.
+pickGpgKeyToBackup :: UI -> IO SecretKey
+pickGpgKeyToBackup ui = go =<< Gpg.listSecretKeys
+  where
+	go [] = do
+		showError ui "You have no gpg secret keys to back up."
+		error "Aborting on no gpg secret keys."
+	go [(_, kid)] = Gpg.getSecretKey kid
+	go l = maybe (error "Canceled") Gpg.getSecretKey
+		=<< promptKeyId ui "Pick gpg secret key"
+			"Pick gpg secret key to back up:" l
 
-backup :: UI -> Tunables -> SecretKeySource -> IO ()
-backup ui tunables secretkeysource = do
+-- | Use when the gpg keyid will not be known at restore time.
+anyGpgKey :: SecretKeySource
+anyGpgKey = GpgKey (KeyId "")
+
+backup :: UI -> Tunables -> SecretKeySource -> SecretKey -> IO ()
+backup ui tunables secretkeysource secretkey = do
 	username <- userName
 	name <- fromMaybe (error "Aborting on no name") 
 		<$> promptName ui "Enter a name"
 			namedesc username validateName
+	password <- fromMaybe (error "Aborting on no password") 
+		<$> promptPassword ui "Enter a password"
+			passworddesc validatePassword
 	kek <- genKeyEncryptionKey tunables name password
+	-- TODO: show password strength estimate, and verify password.
 	putStrLn "Very rough estimate of cost to brute-force the password:"
 	print $ estimateAttack spotAWS $ estimateBruteforceOf kek
 		(passwordEntropy password [])
@@ -79,17 +96,23 @@ backup ui tunables secretkeysource = do
 	print =<< mapM (uncurry (storeShard localFiles)) (zip (getIdents sis) shards)
 	print =<< obscureShards localFiles
   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."
+		[ "To back up your secret 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."
+		, "spelling and capitalization in order to restore your secret key."
 		, ""
 		, "(Your own full name is a pretty good choice for the name to enter here.)"
 		]
+	passworddesc = unlines
+		[ "Pick a password that will be used to protect your secret key."
+		, ""
+		, "It's very important that this password be hard to guess."
+		, ""
+		, "And, it needs to be one that you will be able to remember years from now"
+		, "in order to restore your secret key."
+		]
 
 restore :: UI -> SecretKeySource -> IO ()
 restore ui secretkeydest = do
@@ -126,6 +149,9 @@ validateName (Name n)
 	| B.length n < 6 = Just "The name should be at least 6 letters long."
 	| otherwise = Nothing
 
+validatePassword :: Password -> Maybe Problem
+validatePassword _ = Nothing
+
 userName :: IO Name
 userName = do
 	u <- getUserEntryForID =<< getEffectiveUserID