check server levels

Don't upload more than neededshares-1 shares to Alternate servers without
asking the user if they want to do this potentially dangerous action.

Never allow uploads to Untrusted servers.

This commit was sponsored by Ignacio on Patreon.

3 files changed, 61 insertions, 6 deletions

diff --git a/CHANGELOG b/CHANGELOG
index 2e5e37e..9785dfb 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -5,6 +5,9 @@ keysafe (0.20160923) UNRELEASED; urgency=medium
   * Fix embedded copy of Argon2 to not use Word64, fixing build on 32 bit
     systems.
   * Randomize the server list.
+  * Don't upload more than neededshares-1 shares to Alternate servers
+    without asking the user if they want to do this potentially dangerous
+    action.
 
  -- Joey Hess <id@joeyh.name>  Fri, 23 Sep 2016 10:40:55 -0400
 
diff --git a/Storage.hs b/Storage.hs
index 484df56..59da0d1 100644
--- a/Storage.hs
+++ b/Storage.hs
@@ -40,6 +40,43 @@ localStorageLocations d = StorageLocations $
 
 type UpdateProgress = IO ()
 
+data StorageProblem
+	= FatalProblem String
+	| OverridableProblem String
+	deriving (Show)
+
+-- | Check if there is a problem with storing shares amoung the provided
+-- storage locations, assuming that some random set of the storage
+-- locations will be used.
+--
+-- It's always a problem to store anything on an Untrusted server.
+--
+-- It should not be possible to reconstruct the encrypted
+-- secret key using only objects from Alternate servers, so
+-- fewer than neededObjects Alternate servers can be used.
+problemStoringIn :: StorageLocations -> Tunables -> Maybe StorageProblem
+problemStoringIn (StorageLocations locs) tunables
+	| not (null (getlevel Untrusted)) || length locs < totalObjects ps = 
+		Just $ FatalProblem
+			"Not enough servers are available to store your encrypted secret key."
+	| length alternates >= neededObjects ps = Just $ OverridableProblem $ unlines $
+		[ "Not enough keysafe servers are available that can store"
+		, "your encrypted secret key with a recommended level of"
+		, "security."
+		, "" 
+		, "If you continue, some of the following less secure"
+		, "servers will be used:"
+		, ""
+		] ++ map descserver alternates
+	| otherwise = Nothing
+  where
+	ps = shareParams tunables
+	getlevel sl = filter (\s -> serverLevel s == sl) $
+		mapMaybe getServer locs
+	alternates = getlevel Alternate
+	descserver (Server { serverName = ServerName n, serverDesc = d}) = 
+		"* " ++ n ++ " -- " ++ d
+
 -- | Stores the shares amoung the storage locations. Each location
 -- gets at most one share from each set.
 --
diff --git a/keysafe.hs b/keysafe.hs
index ed7b3c4..7306a29 100644
--- a/keysafe.hs
+++ b/keysafe.hs
@@ -88,15 +88,31 @@ dispatch cmdline ui tunables possibletunables = do
 backup :: CmdLine.CmdLine -> UI -> Tunables -> SecretKeySource -> SecretKey -> IO ()
 backup cmdline ui tunables secretkeysource secretkey = do
 	installAutoStartFile
+
+	let m = totalObjects (shareParams tunables)
+	StorageLocations allocs <- cmdLineStorageLocations cmdline
+	let locs =  StorageLocations (take m allocs)
+	case problemStoringIn locs tunables of
+		Nothing -> return ()
+		Just (FatalProblem p) -> do
+			showError ui p
+			error "aborting"
+		Just (OverridableProblem p) -> do
+			ok <- promptQuestion ui "Server problem"
+				p "Continue anyway?"
+			if ok
+				then return ()
+				else error "aborting"
+	
 	username <- userName
 	Name theirname <- case CmdLine.name cmdline of
 		Just n -> pure n
 		Nothing -> fromMaybe (error "Aborting on no username") 
 			<$> promptName ui "Enter your name"
 				usernamedesc (Just username) validateName
-	go theirname
+	go theirname locs
   where
-	go theirname = do
+	go theirname locs = do
 		cores <- fromMaybe 1 <$> getNumCores
 		Name othername <- case CmdLine.name cmdline of
 			Just n -> pure n
@@ -107,16 +123,15 @@ backup cmdline ui tunables secretkeysource secretkey = do
 		(kek, passwordentropy) <- promptpassword name
 		let sis = shareIdents tunables name secretkeysource
 		let cost = getCreationCost kek <> getCreationCost sis
-		(r, queued, locs) <- withProgressIncremental ui "Encrypting and storing data"
+		(r, queued, usedlocs) <- withProgressIncremental ui "Encrypting and storing data"
 			(encryptdesc cost cores) $ \addpercent -> do
 				let esk = encrypt tunables kek secretkey
 				shares <- genShares esk tunables
 				_ <- esk `deepseq` addpercent 25
 				_ <- sis `seq` addpercent 25
 				let step = 50 `div` sum (map S.size shares)
-				locs <- cmdLineStorageLocations cmdline
 				storeShares locs sis shares (addpercent step)
-		backuplog <- mkBackupLog $ backupMade (mapMaybe getServer locs) secretkeysource passwordentropy
+		backuplog <- mkBackupLog $ backupMade (mapMaybe getServer usedlocs) secretkeysource passwordentropy
 		case r of
 			StoreSuccess -> do
 				storeBackupLog backuplog
@@ -132,7 +147,7 @@ backup cmdline ui tunables secretkeysource secretkey = do
 					[ "Another secret key is already being stored under the name you entered."
 					, "Please try again with a different name."
 					]
-				go theirname
+				go theirname locs
 	promptpassword name = do
 		password <- fromMaybe (error "Aborting on no password") 
 			<$> promptPassword ui True "Enter password" passworddesc