move level from Server to Storage

This allows local storage locations to have levels too, and also get
shuffled nicely.

This commit was sponsored by Ethan Aubin.

10 files changed, 51 insertions, 56 deletions

diff --git a/HTTP/Client.hs b/HTTP/Client.hs
index 50c5906..8415b2f 100644
--- a/HTTP/Client.hs
+++ b/HTTP/Client.hs
@@ -9,7 +9,6 @@ import HTTP
 import HTTP.ProofOfWork
 import Types
 import Types.Server
-import Servers
 import Types.Storage
 import Types.Cost
 import Servant.API
@@ -111,3 +110,8 @@ socketConnection socket chunksize = makeConnection
 	(recv socket chunksize)
 	(sendAll socket)
 	(Network.Socket.close socket)
+
+serverUrls :: Server -> [BaseUrl]
+serverUrls srv = map go (serverAddress srv)
+  where
+	go (ServerAddress addr port) = BaseUrl Http addr port ""
diff --git a/HTTP/Server.hs b/HTTP/Server.hs
index 886fe6f..6fd570d 100644
--- a/HTTP/Server.hs
+++ b/HTTP/Server.hs
@@ -56,7 +56,7 @@ runServer d cfg = do
 	host = fromString (serverAddress cfg)
 
 serverStorage :: Maybe LocalStorageDirectory -> Storage
-serverStorage d = localStorage (storageDir d) "server"
+serverStorage d = localStorage LocallyPreferred (storageDir d) "server"
 
 app :: ServerState -> Application
 app st = serve userAPI (server st)
diff --git a/Servers.hs b/Servers.hs
index 08789ce..ab31838 100644
--- a/Servers.hs
+++ b/Servers.hs
@@ -6,8 +6,8 @@
 module Servers where
 
 import Types.Server
-import Servant.Client
-import System.Random.Shuffle
+import Types.Storage
+import Storage.Network
 
 -- | Keysafe's server list.
 --
@@ -17,29 +17,20 @@ import System.Random.Shuffle
 --
 -- Also, avoid changing the ServerName of any server, as that will
 -- cause any uploads queued under that name to not go through.
-networkServers :: [Server]
-networkServers =
-	[ Server (ServerName "keysafe.joeyh.name") Alternate
+serverList :: Maybe LocalStorageDirectory -> [Storage]
+serverList d =
+	[ mk Alternate $ Server (ServerName "keysafe.joeyh.name")
 		[ServerAddress "vzgrspuxbtnlrtup.onion" 4242]
 		"Provided by Joey Hess. Digital Ocean VPS, located in Indonesia"
 
-	, Server (ServerName "keysafe.puri.sm") Alternate
+	, mk Alternate $ Server (ServerName "keysafe.puri.sm")
 		[]
 		"Purism server is not yet deployed, but planned."
 
-	, Server (ServerName "thirdserver") Alternate -- still being vetted
+	-- still being vetted
+	, mk Alternate $ Server (ServerName "thirdserver")
 		[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)
-
-serverUrls :: Server -> [BaseUrl]
-serverUrls srv = map go (serverAddress srv)
   where
-	go (ServerAddress addr port) = BaseUrl Http addr port ""
+	mk l s = networkStorage l d s
diff --git a/Storage.hs b/Storage.hs
index 10e6bfe..de6eab3 100644
--- a/Storage.hs
+++ b/Storage.hs
@@ -13,14 +13,12 @@ import Types.Server
 import Types.Cost
 import Output
 import Share
-import Storage.Local
 import Storage.Network
 import Servers
 import Tunables
 import Data.Maybe
 import Data.List
 import Data.Monoid
-import System.FilePath
 import Control.Monad
 import Crypto.Random
 import System.Random
@@ -28,15 +26,11 @@ import Control.Concurrent.Thread.Delay
 import Control.Concurrent.Async
 import qualified Data.Set as S
 import Network.Wai.Handler.Warp (Port)
+import System.Random.Shuffle
 
 networkStorageLocations :: Maybe LocalStorageDirectory -> IO StorageLocations
-networkStorageLocations d = StorageLocations . map (networkStorage d)
-	<$> shuffleServers networkServers
-
-localStorageLocations :: Maybe LocalStorageDirectory -> StorageLocations
-localStorageLocations d = StorageLocations $
-	map (localStorage (storageDir d) . ("local" </>) . show)
-		[1..100 :: Int]
+networkStorageLocations = shuffleStorageLocations 
+	. StorageLocations . serverList
 
 type UpdateProgress = IO ()
 
@@ -67,12 +61,11 @@ problemStoringIn (StorageLocations locs) tunables
 		, "If you continue, some of the following less secure"
 		, "servers will be used:"
 		, ""
-		] ++ map descserver alternates
+		] ++ map descserver (mapMaybe getServer alternates)
 	| otherwise = Nothing
   where
 	ps = shareParams tunables
-	getlevel sl = filter (\s -> serverLevel s == sl) $
-		mapMaybe getServer locs
+	getlevel sl = filter (\s -> storageLevel s == sl) locs
 	alternates = getlevel Alternate
 	descserver (Server { serverName = ServerName n, serverDesc = d}) = 
 		"* " ++ n ++ " -- " ++ d
@@ -188,8 +181,8 @@ storeChaff hn port delayseconds = forever $ do
 	mapConcurrently (go sis rng')
 		[1..totalObjects (shareParams testModeTunables)]
   where
-	server = networkStorage Nothing $ 
-		Server (ServerName hn) Untrusted [ServerAddress hn port] "chaff server"
+	server = networkStorage Untrusted Nothing $ 
+		Server (ServerName hn) [ServerAddress hn port] "chaff server"
 	objsize = objectSize defaultTunables * shareOverhead defaultTunables
 	maxmsdelay = ceiling $ 1000000 * fromMaybe 0 delayseconds
 	go sis rng n = do
@@ -205,3 +198,11 @@ storeChaff hn port delayseconds = forever $ do
 			StoreSuccess -> progress "+"
 			_ -> progress "!"
 		go sis' rng' n
+
+-- | Shuffles the list, keeping Recommended first, then
+-- Alternate, and finally Untrusted.
+shuffleStorageLocations :: StorageLocations -> IO StorageLocations
+shuffleStorageLocations (StorageLocations l) = 
+	StorageLocations . concat <$> mapM shuf [minBound..maxBound]
+  where
+	shuf sl = shuffleM (filter (\s -> storageLevel s == sl) l)
diff --git a/Storage/Local.hs b/Storage/Local.hs
index e061831..6dcaaae 100644
--- a/Storage/Local.hs
+++ b/Storage/Local.hs
@@ -35,13 +35,14 @@ type GetShareDir = Section -> IO FilePath
 
 newtype Section = Section String
 
-localStorage :: GetShareDir -> String -> Storage
-localStorage getsharedir n = Storage
+localStorage :: StorageLevel -> GetShareDir -> String -> Storage
+localStorage storagelevel getsharedir n = Storage
 	{ storeShare = store section getsharedir
 	, retrieveShare = retrieve section getsharedir
 	, obscureShares = obscure section getsharedir
 	, countShares = count section getsharedir
 	, moveShares = move section getsharedir
+	, storageLevel = storagelevel
 	, uploadQueue = Nothing
 	, getServer = Nothing
 	}
diff --git a/Storage/Network.hs b/Storage/Network.hs
index f8169c9..e2004cc 100644
--- a/Storage/Network.hs
+++ b/Storage/Network.hs
@@ -17,15 +17,16 @@ import HTTP.Client
 import HTTP.ProofOfWork
 import System.FilePath
 
-networkStorage :: Maybe LocalStorageDirectory -> Server -> Storage
-networkStorage localdir server = Storage
+networkStorage :: StorageLevel -> Maybe LocalStorageDirectory -> Server -> Storage
+networkStorage storagelevel localdir server = Storage
 	{ storeShare = store server
 	, retrieveShare = retrieve server
 	, obscureShares = obscure server
 	, countShares = count server
 	, moveShares = move server
-	, uploadQueue = Just $ localStorage (storageDir localdir)
+	, uploadQueue = Just $ localStorage storagelevel (storageDir localdir)
 		("uploadqueue" </> name)
+	, storageLevel = storagelevel
 	, getServer = Just server
 	}
   where
diff --git a/Tests.hs b/Tests.hs
index 7955c7f..7294cfb 100644
--- a/Tests.hs
+++ b/Tests.hs
@@ -75,7 +75,7 @@ withTestStorageLocations a = bracket setup cleanup go
 	setup = mkdtemp "keysafe-test"
 	cleanup = removeDirectoryRecursive
 	go tmpdir = a $ StorageLocations $
-		map (localStorage (testStorageDir tmpdir) . show)
+		map (localStorage LocallyPreferred (testStorageDir tmpdir) . show)
 			[1..100 :: Int]
 
 -- | Test of backup and restore of a SecretKey.
diff --git a/Types/Server.hs b/Types/Server.hs
index 5caf9db..9a2017d 100644
--- a/Types/Server.hs
+++ b/Types/Server.hs
@@ -27,12 +27,8 @@ newtype ServerName = ServerName { fromServerName :: String }
 instance ToJSON ServerName
 instance FromJSON ServerName
 
-data ServerLevel = Recommended | Alternate | Untrusted
-	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
diff --git a/Types/Storage.hs b/Types/Storage.hs
index d9db853..c83593a 100644
--- a/Types/Storage.hs
+++ b/Types/Storage.hs
@@ -20,6 +20,9 @@ newtype StorageLocations = StorageLocations [Storage]
 
 newtype LocalStorageDirectory = LocalStorageDirectory FilePath
 
+data StorageLevel = LocallyPreferred | Recommended | Alternate | Untrusted
+	deriving (Show, Eq, Ord, Bounded, Enum)
+
 -- | Storage interface. This can be used both for local storage,
 -- an upload queue, or a remote server.
 --
@@ -35,6 +38,7 @@ data Storage = Storage
 	, moveShares :: Storage -> IO [StoreResult]
 	-- ^ Tries to move all shares from this storage to another one.
 	, uploadQueue :: Maybe Storage
+	, storageLevel :: StorageLevel
 	, getServer :: Maybe Server
 	}
 
diff --git a/keysafe.hs b/keysafe.hs
index bd63ff1..11f52dc 100644
--- a/keysafe.hs
+++ b/keysafe.hs
@@ -20,7 +20,6 @@ import Cost
 import SecretKey
 import Share
 import Storage
-import Servers
 import Types.Server
 import BackupLog
 import AutoStart
@@ -86,7 +85,7 @@ dispatch cmdline ui tunables possibletunables = do
 	go (CmdLine.Chaff hn) _ = storeChaff hn
 		(CmdLine.serverPort (CmdLine.serverConfig cmdline))
 		(CmdLine.chaffMaxDelay cmdline)
-	go CmdLine.CheckServers _ = checkServers
+	go CmdLine.CheckServers _ = checkServers cmdline
 	go CmdLine.Benchmark _ =
 		benchmarkTunables tunables
 	go CmdLine.Test _ =
@@ -361,11 +360,7 @@ userName = do
 	return $ Name $ BU8.fromString $ takeWhile (/= ',') (userGecos u)
 
 cmdLineStorageLocations :: CmdLine.CmdLine -> IO StorageLocations
-cmdLineStorageLocations cmdline
-	| CmdLine.localstorage cmdline = return (localStorageLocations lsd)
-	| otherwise = networkStorageLocations lsd
-  where
-	lsd = CmdLine.localstoragedirectory cmdline
+cmdLineStorageLocations = networkStorageLocations . CmdLine.localstoragedirectory
 
 getPasswordEntropy :: Password -> Name -> IO (Entropy UnknownPassword)
 getPasswordEntropy password name = do
@@ -409,15 +404,17 @@ autoStart cmdline tunables ui = do
 				else storeBackupLog
 					=<< mkBackupLog (BackupSkipped (GpgKey kid))
 
-checkServers :: IO ()
-checkServers = do
-	say $ "Checking " ++ show (length networkServers) ++ " servers concurrently; please wait..."
-	results <- mapConcurrently check networkServers
+checkServers :: CmdLine.CmdLine -> IO ()
+checkServers cmdline = do
+	StorageLocations sls <- cmdLineStorageLocations cmdline
+	let serverlist = mapMaybe getServer sls
+	say $ "Checking " ++ show (length serverlist) ++ " servers concurrently; please wait..."
+	results <- mapConcurrently check serverlist
 	mapM_ displayresult results
 	case filter failed results of
 		[] -> return ()
 		l
-			| length l == length networkServers ->
+			| length l == length serverlist ->
 				error "Failed to connect to any servers. Perhaps TOR is not running?"
 			| otherwise -> 
 				error $ "Failed to connect to some servers: "