record already-existing backup in log after restoring a secret key

This will prevent --autostart from prompting to get the newly restored key
backed up again.

This commit was sponsored by Remy van Elst on Patreon.

4 files changed, 38 insertions, 23 deletions

diff --git a/Storage.hs b/Storage.hs
index aa52d7c..fcd2f7e 100644
--- a/Storage.hs
+++ b/Storage.hs
@@ -90,13 +90,14 @@ storeShares (StorageLocations locs) allsis shares updateprogress = do
 -- Assumes that each location only contains one share. So, once a
 -- share has been found on a location, can avoid asking that location
 -- for any other shares.
-retrieveShares :: StorageLocations -> ShareIdents -> UpdateProgress -> IO (S.Set Share, ShareIdents)
+retrieveShares :: StorageLocations -> ShareIdents -> UpdateProgress -> IO (S.Set Share, ShareIdents, [Server])
 retrieveShares (StorageLocations locs) sis updateprogress = do
 	let (is, sis') = nextShareIdents sis
 	let want = zip [1..] (S.toList is)
 	(shares, usedlocs, _unusedlocs) <- go locs [] want []
 	_ <- mapM_ obscureShares usedlocs
-	return (S.fromList shares, sis')
+	let usedservers = mapMaybe getServer usedlocs
+	return (S.fromList shares, sis', usedservers)
   where
 	go unusedlocs usedlocs [] shares = return (shares, usedlocs, unusedlocs)
 	go [] usedlocs _ shares = return (shares, usedlocs, [])
diff --git a/Tests.hs b/Tests.hs
index d18628e..09a7356 100644
--- a/Tests.hs
+++ b/Tests.hs
@@ -98,7 +98,7 @@ backupRestoreTest testdesc secretkey =
 
 	restore storagelocations = do
 		let sis = shareIdents tunables name secretkeysource
-		(shares, sis') <- retrieveShares storagelocations sis (return ())
+		(shares, sis', _) <- retrieveShares storagelocations sis (return ())
 		let candidatekeys = candidateKeyEncryptionKeys tunables name password
 		case combineShares tunables [shares] of
 			Left e -> testFailed e
@@ -112,7 +112,7 @@ backupRestoreTest testdesc secretkey =
 				then testSuccess
 				else testFailed "restore yielded different value than was backed up"
 		DecryptIncomplete kek -> do
-			(nextshares, sis') <- retrieveShares storagelocations sis (return ())
+			(nextshares, sis', _) <- retrieveShares storagelocations sis (return ())
 			let shares = firstshares ++ [nextshares]
 			case combineShares tunables shares of
 				Left e -> testFailed e
diff --git a/Types/Server.hs b/Types/Server.hs
index e1b4191..a6d1ad9 100644
--- a/Types/Server.hs
+++ b/Types/Server.hs
@@ -17,12 +17,12 @@ type HostName = String
 -- hostnames. Using tor is highly recommended, to avoid correlation
 -- attacks.
 data ServerAddress = ServerAddress HostName Port
-	deriving (Show)
+	deriving (Show, Eq, Ord)
 
 -- | Name used in queuing uploads to the server. Should remain stable
 -- across keysafe versions.
 newtype ServerName = ServerName String
-	deriving (Show, Generic)
+	deriving (Show, Eq, Ord, Generic)
 
 instance ToJSON ServerName
 instance FromJSON ServerName
@@ -32,4 +32,4 @@ data Server = Server
 	, serverAddress :: [ServerAddress]
 	-- ^ A server may have multiple addresses, or no current address.
 	}
-	deriving (Show)
+	deriving (Show, Eq, Ord)
diff --git a/keysafe.hs b/keysafe.hs
index 7fe27cf..a6db8ca 100644
--- a/keysafe.hs
+++ b/keysafe.hs
@@ -19,6 +19,7 @@ import Cost
 import SecretKey
 import Share
 import Storage
+import Types.Server
 import BackupLog
 import AutoStart
 import HTTP.Server
@@ -28,6 +29,7 @@ import Data.Maybe
 import Data.Time.Clock
 import Data.Time.Calendar
 import Data.Monoid
+import Data.List
 import Control.DeepSeq
 import qualified Data.ByteString as B
 import qualified Data.ByteString.UTF8 as BU8
@@ -135,9 +137,7 @@ backup cmdline storagelocations ui tunables secretkeysource secretkey = do
 		password <- fromMaybe (error "Aborting on no password") 
 			<$> promptPassword ui True "Enter password" passworddesc
 		kek <- genKeyEncryptionKey tunables name password
-		username <- userName
-		let badwords = concatMap namewords [name, username]
-		let passwordentropy = calcPasswordEntropy password badwords
+		passwordentropy <- getPasswordEntropy password name
 		let crackcost = estimateAttackCost spotAWS $
 			estimateBruteforceOf kek passwordentropy
 		let mincost = Dollars 100000
@@ -154,7 +154,6 @@ backup cmdline storagelocations ui tunables secretkeysource secretkey = do
 				if ok
 					then return (kek, passwordentropy)
 					else promptpassword name
-	namewords (Name nb) = words (BU8.toString nb)
 	keydesc = case secretkeysource of
 		GpgKey _ -> "gpg secret key"
 		KeyFile _ -> "secret key"
@@ -229,7 +228,7 @@ restore cmdline storagelocations ui possibletunables secretkeydest = do
 	r <- downloadInitialShares storagelocations ui mksis possibletunables
 	case r of
 		Nothing -> showError ui "No shares could be downloaded. Perhaps you entered the wrong name?"
-		Just (tunables, shares, sis) -> do
+		Just (tunables, shares, sis, usedservers) -> do
 			let candidatekeys = candidateKeyEncryptionKeys tunables name password
 			let cost = getCreationCost candidatekeys 
 				<> castCost (getDecryptionCost candidatekeys)
@@ -238,26 +237,33 @@ restore cmdline storagelocations ui possibletunables secretkeydest = do
 				Right esk -> do
 					final <- withProgress ui "Decrypting"
 						(decryptdesc cost cores) $ \setpercent ->
-							go tunables [shares] sis setpercent $
+							go tunables [shares] usedservers sis setpercent $
 								tryDecrypt candidatekeys esk
-					final
+					final =<< getPasswordEntropy password name
   where
-	go tunables firstshares sis setpercent r = case r of
-		DecryptFailed -> return $
+	go tunables firstshares firstusedservers sis setpercent r = case r of
+		DecryptFailed -> return $ \_ ->
 			showError ui "Decryption failed! Probably you entered the wrong password."
 		DecryptSuccess secretkey -> do
 			_ <- setpercent 100
 			writeSecretKey secretkeydest secretkey
-			return $
+			return $ \passwordentropy -> do
 				showInfo ui "Success" "Your secret key was successfully restored!"
+				-- Since the key was restored, we know it's
+				-- backed up; log that.
+				backuplog <- mkBackupLog $ 
+					backupMade firstusedservers secretkeydest passwordentropy
+				storeBackupLog backuplog
 		DecryptIncomplete kek -> do
 			-- Download shares for another chunk.
-			(nextshares, sis') <- retrieveShares storagelocations sis (return ())
+			(nextshares, sis', nextusedservers) 
+				<- retrieveShares storagelocations sis (return ())
 			let shares = firstshares ++ [nextshares]
+			let usedservers = nub (firstusedservers ++ nextusedservers)
 			case combineShares tunables shares of
-				Left e -> return $ showError ui e
+				Left e -> return $ \_ -> showError ui e
 				Right esk -> 
-					go tunables shares sis' setpercent $
+					go tunables shares usedservers sis' setpercent $
 						decrypt kek esk
 	namedesc = unlines
 		[ "When you backed up your secret key, you entered some information."
@@ -291,7 +297,7 @@ downloadInitialShares
 	-> UI
 	-> (Tunables -> ShareIdents)
 	-> [Tunables]
-	-> IO (Maybe (Tunables, S.Set Share, ShareIdents))
+	-> IO (Maybe (Tunables, S.Set Share, ShareIdents, [Server]))
 downloadInitialShares storagelocations ui mksis possibletunables = do
 	cores <- fromMaybe 1 <$> getNumCores
 	withProgressIncremental ui "Downloading encrypted data" (message cores) $ \addpercent -> do
@@ -305,10 +311,10 @@ downloadInitialShares storagelocations ui mksis possibletunables = do
 		addpercent 50
 		let m = totalObjects (shareParams tunables)
 		let step = 50 `div` m
-		(shares, sis') <- retrieveShares storagelocations sis (addpercent step)
+		(shares, sis', usedservers) <- retrieveShares storagelocations sis (addpercent step)
 		if S.null shares
 			then go othertunables addpercent
-			else return $ Just (tunables, shares, sis')
+			else return $ Just (tunables, shares, sis', usedservers)
 
 	possiblesis = map mksis possibletunables
 	message cores = unlines
@@ -331,6 +337,14 @@ userName = do
 	u <- getUserEntryForID =<< getEffectiveUserID
 	return $ Name $ BU8.fromString $ takeWhile (/= ',') (userGecos u)
 
+getPasswordEntropy :: Password -> Name -> IO (Entropy UnknownPassword)
+getPasswordEntropy password name = do
+	username <- userName
+	let badwords = concatMap namewords [name, username]
+	return $ calcPasswordEntropy password badwords
+  where
+	namewords (Name nb) = words (BU8.toString nb)
+
 uploadQueued :: UI -> Maybe LocalStorageDirectory -> IO ()
 uploadQueued ui d = do
 	problems <- tryUploadQueued d