Randomize the server list.

May help avoid some correlations. Once there are many servers, will spread
the load out amoung them.

This commit was sponsored by Ethan Aubin.

7 files changed, 35 insertions, 23 deletions

diff --git a/CHANGELOG b/CHANGELOG
index dffd5eb..2e5e37e 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -4,6 +4,7 @@ keysafe (0.20160923) UNRELEASED; urgency=medium
   * Added --chaff-max-delay option for slower chaffing.
   * Fix embedded copy of Argon2 to not use Word64, fixing build on 32 bit
     systems.
+  * Randomize the server list.
 
  -- Joey Hess <id@joeyh.name>  Fri, 23 Sep 2016 10:40:55 -0400
 
diff --git a/Servers.hs b/Servers.hs
index d12fc56..7edc7af 100644
--- a/Servers.hs
+++ b/Servers.hs
@@ -7,6 +7,7 @@ module Servers where
 
 import Types.Server
 import Servant.Client
+import System.Random.Shuffle
 
 serverUrls :: Server -> [BaseUrl]
 serverUrls srv = map go (serverAddress srv)
@@ -17,15 +18,22 @@ networkServers :: [Server]
 networkServers =
 	[ Server (ServerName "keysafe.joeyh.name") Alternate
 		[ServerAddress "vzgrspuxbtnlrtup.onion" 4242]
+		"Provided by Joey Hess. Digital Ocean VPS, located in Indonesia"
 
-	-- Purism server is not yet deployed, but planned.
 	, Server (ServerName "keysafe.puri.sm") Alternate
 		[]
+		"Purism server is not yet deployed, but planned."
 
-	-- Unknown yet who will provide this server, but allocate it now
-	-- so keysafe can start queuing uploads to it.
-	, Server (ServerName "thirdserver") Recommended
-		[]
-	--	[ServerAddress "eqi7glyxe5ravak5.onion" 4242]
-	--	-- ^ still being vetted
+	-- Provided by https://faelix.net/
+	-- Marek Isalski 
+	, Server (ServerName "thirdserver") Alternate -- still being vetted
+		[ServerAddress "eqi7glyxe5ravak5.onion" 4242]
+		"Provided by Marek Isalski at Faelix. Currently located in UK, but planned move to CH"
 	]
+
+-- | Shuffles the server list, keeping Recommended first, then
+-- Alternate, and finally Untrusted.
+shuffleServers :: [Server] -> IO [Server]
+shuffleServers l = concat <$> mapM shuf [minBound..maxBound]
+  where
+	shuf sl = shuffleM (filter (\s -> serverLevel s == sl) l)
diff --git a/Storage.hs b/Storage.hs
index b40a84a..c082c38 100644
--- a/Storage.hs
+++ b/Storage.hs
@@ -29,9 +29,9 @@ import Control.Concurrent.Async
 import qualified Data.Set as S
 import Network.Wai.Handler.Warp (Port)
 
-networkStorageLocations :: Maybe LocalStorageDirectory -> StorageLocations
-networkStorageLocations d = StorageLocations $ 
-	map (networkStorage d) networkServers
+networkStorageLocations :: Maybe LocalStorageDirectory -> IO StorageLocations
+networkStorageLocations d = StorageLocations . map (networkStorage d)
+	<$> shuffleServers networkServers
 
 localStorageLocations :: Maybe LocalStorageDirectory -> StorageLocations
 localStorageLocations d = StorageLocations $
@@ -125,12 +125,12 @@ retrieveShares (StorageLocations locs) sis updateprogress = do
 -- | Returns descriptions of any failures.
 tryUploadQueued :: Maybe LocalStorageDirectory -> IO [String]
 tryUploadQueued d = do
+	StorageLocations locs <- networkStorageLocations d
 	results <- forM locs $ \loc -> case uploadQueue loc of
 		Nothing -> return []
 		Just q -> moveShares q loc
 	return $ processresults (concat results) []
   where
-	StorageLocations locs = networkStorageLocations d
 	processresults [] c = nub c
 	processresults (StoreSuccess:rs) c = processresults rs c
 	processresults (StoreFailure e:rs) c = processresults rs (e:c)
@@ -152,7 +152,7 @@ storeChaff hn port delayseconds = forever $ do
 		[1..totalObjects (shareParams testModeTunables)]
   where
 	server = networkStorage Nothing $ 
-		Server (ServerName hn) Untrusted [ServerAddress hn port]
+		Server (ServerName hn) Untrusted [ServerAddress hn port] "chaff server"
 	objsize = objectSize defaultTunables * shareOverhead defaultTunables
 	maxmsdelay = ceiling $ 1000000 * fromMaybe 0 delayseconds
 	go sis rng n = do
diff --git a/TODO b/TODO
index d0a2932..4601942 100644
--- a/TODO
+++ b/TODO
@@ -7,7 +7,6 @@ Later:
 * The attack cost display can lead to a false sense of security if the user
   takes it as gospel. It needs to be clear that it's an estimate. This and
   other parts of the keysafe UI need usability testing.
-* Implement the different categories of servers in the server list.
 * improve restore progress bar points (update after every hash try)
 * If we retrieved enough shares successfully, but decrypt failed, must
   be a wrong password, so prompt for re-entry and retry with those shares.
diff --git a/Types/Server.hs b/Types/Server.hs
index 7be29ce..785dd24 100644
--- a/Types/Server.hs
+++ b/Types/Server.hs
@@ -28,12 +28,13 @@ instance ToJSON ServerName
 instance FromJSON ServerName
 
 data ServerLevel = Recommended | Alternate | Untrusted
-	deriving (Show, Eq, Ord)
+	deriving (Show, Eq, Ord, Bounded, Enum)
 
 data Server = Server
 	{ serverName :: ServerName
 	, serverLevel :: ServerLevel
 	, serverAddress :: [ServerAddress]
 	-- ^ A server may have multiple addresses, or no current address.
+	, serverDesc :: String
 	}
 	deriving (Show, Eq, Ord)
diff --git a/keysafe.cabal b/keysafe.cabal
index 10061ed..538a694 100644
--- a/keysafe.cabal
+++ b/keysafe.cabal
@@ -72,6 +72,8 @@ Executable keysafe
     , async == 2.1.*
     , unix-compat == 0.4.*
     , exceptions == 0.8.*
+    , random-shuffle == 0.0.*
+    , MonadRandom == 0.4.*
     -- Temporarily inlined due to FTBFS bug
     -- https://github.com/ocharles/argon2/issues/2
     -- argon2 == 1.1.*
diff --git a/keysafe.hs b/keysafe.hs
index f4ee878..ed7b3c4 100644
--- a/keysafe.hs
+++ b/keysafe.hs
@@ -114,7 +114,8 @@ backup cmdline ui tunables secretkeysource secretkey = do
 				_ <- esk `deepseq` addpercent 25
 				_ <- sis `seq` addpercent 25
 				let step = 50 `div` sum (map S.size shares)
-				storeShares (cmdLineStorageLocations cmdline) sis shares (addpercent step)
+				locs <- cmdLineStorageLocations cmdline
+				storeShares locs sis shares (addpercent step)
 		backuplog <- mkBackupLog $ backupMade (mapMaybe getServer locs) secretkeysource passwordentropy
 		case r of
 			StoreSuccess -> do
@@ -224,7 +225,8 @@ restore cmdline ui possibletunables secretkeydest = do
 		<$> promptPassword ui True "Enter password" passworddesc
 	
 	let mksis tunables = shareIdents tunables name secretkeydest
-	r <- downloadInitialShares storagelocations ui mksis possibletunables
+	locs <- cmdLineStorageLocations cmdline
+	r <- downloadInitialShares locs ui mksis possibletunables
 	case r of
 		Nothing -> showError ui "No shares could be downloaded. Perhaps you entered the wrong name?"
 		Just (tunables, shares, sis, usedservers) -> do
@@ -236,12 +238,11 @@ restore cmdline ui possibletunables secretkeydest = do
 				Right esk -> do
 					final <- withProgress ui "Decrypting"
 						(decryptdesc cost cores) $ \setpercent ->
-							go tunables [shares] usedservers sis setpercent $
+							go locs tunables [shares] usedservers sis setpercent $
 								tryDecrypt candidatekeys esk
 					final =<< getPasswordEntropy password name
   where
-	storagelocations = cmdLineStorageLocations cmdline
-	go tunables firstshares firstusedservers sis setpercent r = case r of
+	go locs tunables firstshares firstusedservers sis setpercent r = case r of
 		DecryptFailed -> return $ \_ ->
 			showError ui "Decryption failed! Probably you entered the wrong password."
 		DecryptSuccess secretkey -> do
@@ -257,13 +258,13 @@ restore cmdline ui possibletunables secretkeydest = do
 		DecryptIncomplete kek -> do
 			-- Download shares for another chunk.
 			(nextshares, sis', nextusedservers) 
-				<- retrieveShares storagelocations sis (return ())
+				<- retrieveShares locs sis (return ())
 			let shares = firstshares ++ [nextshares]
 			let usedservers = nub (firstusedservers ++ nextusedservers)
 			case combineShares tunables shares of
 				Left e -> return $ \_ -> showError ui e
 				Right esk -> 
-					go tunables shares usedservers sis' setpercent $
+					go locs tunables shares usedservers sis' setpercent $
 						decrypt kek esk
 	namedesc = unlines
 		[ "When you backed up your secret key, you entered some information."
@@ -337,9 +338,9 @@ userName = do
 	u <- getUserEntryForID =<< getEffectiveUserID
 	return $ Name $ BU8.fromString $ takeWhile (/= ',') (userGecos u)
 
-cmdLineStorageLocations :: CmdLine.CmdLine -> StorageLocations
+cmdLineStorageLocations :: CmdLine.CmdLine -> IO StorageLocations
 cmdLineStorageLocations cmdline
-	| CmdLine.localstorage cmdline = localStorageLocations lsd
+	| CmdLine.localstorage cmdline = return (localStorageLocations lsd)
 	| otherwise = networkStorageLocations lsd
   where
 	lsd = CmdLine.localstoragedirectory cmdline