From 987489c93fde496a6b8658e77752130068f36d18 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Mon, 26 Sep 2016 15:07:33 -0400
Subject: 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.
---
 keysafe.hs | 27 +++++++++++++++++++++------
 1 file changed, 21 insertions(+), 6 deletions(-)

(limited to 'keysafe.hs')

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
-- 
cgit v1.2.3