allow servers to have multiple or no addresses

This allows the server list to contain 3 servers although only 1 is running
so far; uploads to the others will be queued.

It also allows a server to be spread amoung multiple addresses, which may
be useful later for scaling.

This changes BackupRecord serialization, but it's not been in a keysafe
release yet, so that's not a problem.

This commit was sponsored by Boyd Stephen Smith Jr. on Patreon.

6 files changed, 55 insertions, 25 deletions

diff --git a/BackupRecord.hs b/BackupRecord.hs
index 6d150e1..0a90de2 100644
--- a/BackupRecord.hs
+++ b/BackupRecord.hs
@@ -33,7 +33,7 @@ import qualified Data.ByteString.Lazy as B
 -- this should only half the password crack time at worst.
 data BackupRecord = BackupRecord
 	{ backupDate :: POSIXTime
-	, backupServers :: [HostName]
+	, backupServers :: [ServerName]
 	, secretKeySource :: SecretKeySource
 	, passwordEntropy :: Int
 	} deriving (Show, Generic)
diff --git a/HTTP/Client.hs b/HTTP/Client.hs
index 48a430c..f13620e 100644
--- a/HTTP/Client.hs
+++ b/HTTP/Client.hs
@@ -64,23 +64,25 @@ serverRequest srv onerr onsuccess p a = do
 					(Just $ genProofOfWork req p)
 					(Seconds timeleft - generationTime req)
 
+-- A new Manager is allocated for each request, rather than reusing
+-- any connection. This is a feature; it makes correlation attacks
+-- harder because the server can't tell if two connections
+-- accessing different objects came from the same user, except by
+-- comparing IP addresses (which are masked somewhat by using tor).
 serverRequest'
 	:: Server
 	-> (Manager -> BaseUrl -> ExceptT ServantError IO r)
 	-> IO (Either String r)
-serverRequest' srv a = do
-	-- A new Manager is allocated for each request, rather than reusing
-	-- any connection. This is a feature; it makes correlation attacks
-	-- harder because the server can't tell if two connections
-	-- accessing different objects came from the same user, except by
-	-- comparing IP addresses (which are masked somewhat by using tor).
-	manager <- torableManager
-	res <- runExceptT $ a manager url
-	return $ case res of
-		Left err -> Left $ "server failure: " ++ show err
-		Right r -> Right r
+serverRequest' srv a = go Nothing (serverUrls srv)
   where
-	url = serverUrl srv
+	go lasterr [] = return $ Left $
+		maybe "no available servers" (\err -> "server failure: " ++ show err) lasterr
+	go _ (url:urls) = do
+		manager <- torableManager
+		res <- runExceptT $ a manager url
+		case res of
+			Left err -> go (Just err) urls
+			Right r -> return (Right r)
 
 -- | HTTP Manager supporting tor .onion and regular hosts
 torableManager :: IO Manager
@@ -94,7 +96,7 @@ torableManager = newManager $ defaultManagerSettings
 			regular <- managerRawConnection defaultManagerSettings
 			regular addr host port
 
-torConnection :: HostName -> Port -> IO Connection
+torConnection :: String -> Port -> IO Connection
 torConnection onionaddress p = do
 	(socket, _) <- socksConnect torsockconf socksaddr
 	socketConnection socket 8192
diff --git a/Servers.hs b/Servers.hs
index 0a1e246..8b99fe0 100644
--- a/Servers.hs
+++ b/Servers.hs
@@ -8,14 +8,20 @@ module Servers where
 import Types.Server
 import Servant.Client
 
-serverUrl :: Server -> BaseUrl
-serverUrl srv = BaseUrl Http (serverName srv) (serverPort srv) ""
+serverUrls :: Server -> [BaseUrl]
+serverUrls srv = map go (serverAddress srv)
+  where
+	go (ServerAddress addr port) = BaseUrl Http addr port ""
 
--- | These can be either tor .onion addresses, or regular hostnames.
--- Using tor is highly recommended, to avoid correlation attacks.
 networkServers :: IO [Server]
 networkServers = return 
-	[ Server "vzgrspuxbtnlrtup.onion" 4242 -- keysafe.joeyh.name
-	, Server "localhost" 4242
-	, Server "localhost" 4242
+	[ Server (ServerName "keysafe.joeyh.name")
+		[ServerAddress "vzgrspuxbtnlrtup.onion" 4242]
+	-- Purism server is not yet deployed, but planned.
+	, Server (ServerName "keysafe.puri.sm")
+		[]
+	-- Unknown yet who will provide this server, but allocate it now
+	-- so keysafe can start queuing uploads to it.
+	, Server (ServerName "thirdserver")
+		[]
 	]
diff --git a/Storage.hs b/Storage.hs
index ded4bbf..3e2c418 100644
--- a/Storage.hs
+++ b/Storage.hs
@@ -148,7 +148,8 @@ storeChaff hn port = forever $ do
 	mapConcurrently (go sis rng')
 		[1..totalObjects (shareParams testModeTunables)]
   where
-	server = networkStorage Nothing $ Server hn port
+	server = networkStorage Nothing $ Server (ServerName hn) 
+		[ServerAddress hn port]
 	objsize = objectSize defaultTunables * shareOverhead defaultTunables
 	go sis rng n = do
 		let (b, rng') = cprgGenerate objsize rng
diff --git a/Storage/Network.hs b/Storage/Network.hs
index dec6d57..f8169c9 100644
--- a/Storage/Network.hs
+++ b/Storage/Network.hs
@@ -25,9 +25,11 @@ networkStorage localdir server = Storage
 	, countShares = count server
 	, moveShares = move server
 	, uploadQueue = Just $ localStorage (storageDir localdir)
-		("uploadqueue" </> serverName server)
+		("uploadqueue" </> name)
 	, getServer = Just server
 	}
+  where
+	ServerName name = serverName server
 
 store :: Server -> StorableObjectIdent -> Share -> IO StoreResult
 store srv i (Share _n o) = 
diff --git a/Types/Server.hs b/Types/Server.hs
index dd06909..e1b4191 100644
--- a/Types/Server.hs
+++ b/Types/Server.hs
@@ -3,14 +3,33 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE DeriveGeneric #-}
+
 module Types.Server where
 
+import Data.Aeson
+import GHC.Generics
 import Network.Wai.Handler.Warp (Port)
 
 type HostName = String
 
+-- | Server address can use either tor .onion addresses, or regular
+-- hostnames. Using tor is highly recommended, to avoid correlation
+-- attacks.
+data ServerAddress = ServerAddress HostName Port
+	deriving (Show)
+
+-- | Name used in queuing uploads to the server. Should remain stable
+-- across keysafe versions.
+newtype ServerName = ServerName String
+	deriving (Show, Generic)
+
+instance ToJSON ServerName
+instance FromJSON ServerName
+	
 data Server = Server
-	{ serverName :: HostName
-	, serverPort :: Port
+	{ serverName :: ServerName
+	, serverAddress :: [ServerAddress]
+	-- ^ A server may have multiple addresses, or no current address.
 	}
 	deriving (Show)