add support for multiple storage locattions

also, server upload queues in ~/.keysafe

7 files changed, 161 insertions, 95 deletions

diff --git a/CmdLine.hs b/CmdLine.hs
index 1c0abd2..a55e985 100644
--- a/CmdLine.hs
+++ b/CmdLine.hs
@@ -11,14 +11,11 @@ import qualified Gpg
 import Options.Applicative
 import qualified Data.ByteString.UTF8 as BU8
 import System.Directory
-import Storage
-import Storage.Local
-import Storage.Network
 
 data CmdLine = CmdLine
 	{ mode :: Maybe Mode
 	, secretkeysource :: Maybe SecretKeySource
-	, storage :: Storage
+	, localstorage :: Bool
 	, gui :: Bool
 	, testMode :: Bool
 	, customShardParams :: Maybe ShardParams
@@ -31,7 +28,7 @@ parse :: Parser CmdLine
 parse = CmdLine
 	<$> optional (backup <|> restore <|> benchmark)
 	<*> optional (gpgswitch <|> fileswitch)
-	<*> localstorageflag
+	<*> localstorageswitch
 	<*> guiswitch
 	<*> testmodeswitch
 	<*> optional (ShardParams <$> totalobjects <*> neededobjects)
@@ -58,7 +55,7 @@ parse = CmdLine
 		<> metavar "FILE"
 		<> help "Specify secret key file to back up or restore. (The same filename must be used to restore a key as was used to back it up.)"
 		)
-	localstorageflag = flag networkStorage localStorage
+	localstorageswitch = switch
 		( long "store-local"
 		<> help "Store data locally, in ~/.keysafe/objects. (The default is to store data in the cloud.)"
 		)
diff --git a/Storage.hs b/Storage.hs
index d1a3ad8..c80935f 100644
--- a/Storage.hs
+++ b/Storage.hs
@@ -3,41 +3,82 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-module Storage where
+module Storage (module Storage, module Types.Storage) where
 
 import Types
+import Types.Storage
 import Shard
+import Storage.Local
+import Storage.Network
+import System.FilePath
+import Data.Monoid
+import Data.Maybe
 
-data Storage = Storage
-	{ storeShard :: StorableObjectIdent -> Shard -> IO StoreResult
-	, retrieveShard :: ShardNum -> StorableObjectIdent -> IO RetrieveResult
-	, obscureShards :: IO ObscureResult
-	-- ^ run after making some calls to storeShard/retrieveShard,
-	-- to avoid correlation attacks
-	, countShards :: IO CountResult
-	} -- Note that there is no interface to enumerate shards.
+allStorageLocations :: IO StorageLocations
+allStorageLocations = do
+	servers <- networkServers
+	return $ servers <> uploadQueueLocations
 
-data StoreResult = StoreSuccess | StoreAlreadyExists | StoreFailure String
-	deriving (Show)
+-- | Objects queued for upload to servers. There are a number of queues,
+-- but no 1:1 mapping from queues to a particular server. 
+-- It's important that when flushing the upload queue, the objects in each
+-- separate queue are sent to a separate server.
+uploadQueueLocations :: StorageLocations
+uploadQueueLocations = StorageLocations $
+	map (localStorage . ("uploadqueue" </>) . show) ([1..] :: [Integer])
 
-data RetrieveResult = RetrieveSuccess Shard | RetrieveFailure String
+localStorageLocations :: StorageLocations
+localStorageLocations = StorageLocations $
+	map (localStorage . ("local" </>) . show) ([1..] :: [Integer])
 
-data ObscureResult = ObscureSuccess | ObscureFailure String
-	deriving (Show)
+type UpdateProgress = IO ()
 
-data CountResult = CountResult Integer | CountFailure String
-	deriving (Show)
-
-storeShards :: Storage -> ShardIdents -> [(IO (), Shard)] -> IO StoreResult
-storeShards storage sis shards = do
-	r <- go (zip (getIdents sis) shards)
-	_ <- obscureShards storage
+-- | Stores the shards amoung the storage locations. Each location
+-- gets at most one shard.
+storeShards :: StorageLocations -> ShardIdents -> [(UpdateProgress, Shard)] -> IO StoreResult
+storeShards (StorageLocations locs) sis shards = do
+	(r, usedlocs) <- go locs [] Nothing (zip (getIdents sis) shards)
+	_ <- mapM_ obscureShards usedlocs
 	return r
   where
-	go [] = return StoreSuccess
-	go ((i,(showprogress, s)):rest) = do
-		r <- storeShard storage i s
-		_ <- showprogress
+	go _ usedlocs _ [] = return (StoreSuccess, usedlocs)
+	go [] usedlocs lasterr _ =
+		return (fromMaybe (StoreFailure "no storage locations") lasterr, usedlocs)
+	go (loc:otherlocs) usedlocs _ tostore@((i,(showprogress, s)):rest) = do
+		r <- storeShard loc i s
+		case r of
+			StoreSuccess -> do
+				_ <- showprogress
+				go otherlocs (loc:usedlocs) Nothing rest
+			_ -> go otherlocs usedlocs (Just r) tostore
+
+-- | Retrieves shards from among the storage locations, and returns all
+-- the shards it can find, which may not be all that were requested.
+--
+-- Assumes that each location only contains one shard. So, once a
+-- shard has been found on a location, can avoid asking that location
+-- for any other shards.
+retrieveShards :: StorageLocations -> [(UpdateProgress, (ShardNum, StorableObjectIdent))] -> IO [Shard]
+retrieveShards (StorageLocations locs) l = do
+	(shards, usedlocs, _unusedlocs) <- go locs [] l []
+	_ <- mapM_ obscureShards usedlocs
+	return shards
+  where
+	go unusedlocs usedlocs [] shards = return (shards, usedlocs, unusedlocs)
+	go [] usedlocs _ shards = return (shards, usedlocs, [])
+	go (loc:otherlocs) usedlocs toretrieve@((updateprogress, (n, i)):rest) shards = do
+		r <- retrieveShard loc n i
 		case r of
-			StoreSuccess -> go rest
-			_ -> return r
+			RetrieveSuccess s -> do
+				_ <- updateprogress
+				go otherlocs (loc:usedlocs) rest (s:shards)
+			RetrieveFailure _ -> do
+				(shards', usedlocs', unusedlocs) <-
+					go otherlocs usedlocs toretrieve shards
+				-- May need to ask the location that didn't
+				-- have the shard for a later shard, but
+				-- ask it last. This way, the first
+				-- location on the list can't deny having
+				-- all shards and so learn the idents of
+				-- all of them.
+				go (unusedlocs++[loc]) usedlocs' toretrieve shards'
diff --git a/Storage/Local.hs b/Storage/Local.hs
index 82a7fd0..a13fcae 100644
--- a/Storage/Local.hs
+++ b/Storage/Local.hs
@@ -8,7 +8,7 @@
 module Storage.Local (localStorage) where
 
 import Types
-import Storage
+import Types.Storage
 import Serialization ()
 import qualified Data.ByteString as B
 import qualified Data.ByteString.UTF8 as U8
@@ -23,17 +23,21 @@ import Raaz.Core.Encode
 import Control.DeepSeq
 import Control.Exception
 
-localStorage :: Storage
-localStorage = Storage
-	{ storeShard = store
-	, retrieveShard = retrieve
-	, obscureShards = obscure
-	, countShards = count
+newtype Section = Section String
+
+localStorage :: String -> Storage
+localStorage n = Storage
+	{ storeShard = store section
+	, retrieveShard = retrieve section
+	, obscureShards = obscure section
+	, countShards = count section
 	}
+  where
+	section = Section n
 
-store :: StorableObjectIdent -> Shard -> IO StoreResult
-store i s = onError (StoreFailure . show) $ do
-	dir <- shardDir
+store :: Section -> StorableObjectIdent -> Shard -> IO StoreResult
+store section i s = onError (StoreFailure . show) $ do
+	dir <- shardDir section
 	createDirectoryIfMissing True dir
 	let dest = dir </> shardFile i
 	exists <- doesFileExist dest
@@ -49,9 +53,9 @@ store i s = onError (StoreFailure . show) $ do
 			renameFile tmp dest
 			return StoreSuccess
 
-retrieve :: ShardNum -> StorableObjectIdent -> IO RetrieveResult
-retrieve n i = onError (RetrieveFailure . show) $ do
-	dir <- shardDir
+retrieve :: Section -> ShardNum -> StorableObjectIdent -> IO RetrieveResult
+retrieve section n i = onError (RetrieveFailure . show) $ do
+	dir <- shardDir section
 	fd <- openFd (dir </> shardFile i) ReadOnly Nothing defaultFileFlags
 	h <- fdToHandle fd
 	b <- B.hGetContents h
@@ -67,16 +71,16 @@ retrieve n i = onError (RetrieveFailure . show) $ do
 --
 -- Note that the contents of shards is never changed, so it's ok to set the
 -- mtime to the epoch; backup programs won't be confused.
-obscure :: IO ObscureResult
-obscure = onError (ObscureFailure . show) $ do
-	dir <- shardDir
+obscure :: Section -> IO ObscureResult
+obscure section = onError (ObscureFailure . show) $ do
+	dir <- shardDir section
 	fs <- filter isShardFile <$> getDirectoryContents dir
 	mapM_ (\f -> setFileTimes (dir </> f) 0 0) fs
 	return ObscureSuccess
 
-count :: IO CountResult
-count = onError (CountFailure . show) $ do
-	dir <- shardDir
+count :: Section -> IO CountResult
+count section = onError (CountFailure . show) $ do
+	dir <- shardDir section
 	CountResult . genericLength . filter isShardFile
 		<$> getDirectoryContents dir
 
@@ -87,10 +91,10 @@ onError f a = do
 		Left e -> f e
 		Right r -> r
 
-shardDir :: IO FilePath
-shardDir = do
+shardDir :: Section -> IO FilePath
+shardDir (Section section) = do
 	u <- getUserEntryForID =<< getEffectiveUserID
-	return $ homeDirectory u </> dotdir
+	return $ homeDirectory u </> dotdir </> section
 
 shardFile :: StorableObjectIdent -> String
 shardFile i = U8.toString (toByteString i) <> ext
diff --git a/Storage/Network.hs b/Storage/Network.hs
index 06b7545..7a461c7 100644
--- a/Storage/Network.hs
+++ b/Storage/Network.hs
@@ -5,10 +5,13 @@
 
 {-# LANGUAGE OverloadedStrings #-}
 
-module Storage.Network (networkStorage) where
+module Storage.Network (networkServers, networkStorage) where
 
 import Types
-import Storage
+import Types.Storage
+
+networkServers :: IO StorageLocations
+networkServers = return $ StorageLocations [] -- none yet
 
 networkStorage :: Storage
 networkStorage = Storage
diff --git a/Types/Storage.hs b/Types/Storage.hs
new file mode 100644
index 0000000..bc11b55
--- /dev/null
+++ b/Types/Storage.hs
@@ -0,0 +1,35 @@
+{- Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Types.Storage where
+
+import Types
+
+-- | All known locations where shards can be stored, ordered with
+-- preferred locations first.
+newtype StorageLocations = StorageLocations [Storage]
+	deriving (Monoid)
+
+data Storage = Storage
+	{ storeShard :: StorableObjectIdent -> Shard -> IO StoreResult
+	, retrieveShard :: ShardNum -> StorableObjectIdent -> IO RetrieveResult
+	, obscureShards :: IO ObscureResult
+	-- ^ run after making some calls to storeShard/retrieveShard,
+	-- to avoid correlation attacks
+	, countShards :: IO CountResult
+	} -- Note that there is no interface to enumerate shards.
+
+data StoreResult = StoreSuccess | StoreAlreadyExists | StoreFailure String
+	deriving (Show)
+
+data RetrieveResult = RetrieveSuccess Shard | RetrieveFailure String
+
+data ObscureResult = ObscureSuccess | ObscureFailure String
+	deriving (Show)
+
+data CountResult = CountResult Integer | CountFailure String
+	deriving (Show)
diff --git a/keysafe.cabal b/keysafe.cabal
index 2488c0b..0cd9bc7 100644
--- a/keysafe.cabal
+++ b/keysafe.cabal
@@ -74,6 +74,7 @@ Executable keysafe
     Tunables
     Types
     Types.Cost
+    Types.Storage
     Types.UI
     UI
     UI.Readline
diff --git a/keysafe.hs b/keysafe.hs
index 2ac765f..c1ed35a 100644
--- a/keysafe.hs
+++ b/keysafe.hs
@@ -23,10 +23,7 @@ import Data.Maybe
 import Data.Time.Clock
 import Data.Time.Calendar
 import Data.Monoid
-import Control.Monad
 import Control.DeepSeq
-import Control.Exception
-import System.IO
 import qualified Data.ByteString as B
 import qualified Data.ByteString.UTF8 as BU8
 import System.Posix.User (userGecos, getUserEntryForID, getEffectiveUserID)
@@ -42,29 +39,31 @@ main = do
 				"Keysafe is running in test mode. This is not secure, and should not be used with real secret keys!"
 			return (mkt testModeTunables, [mkt testModeTunables])
 		else return (mkt defaultTunables, map (mkt . snd) knownTunings)
-	dispatch cmdline ui tunables possibletunables
+	storagelocations <- if CmdLine.localstorage cmdline
+		then return localStorageLocations
+		else allStorageLocations
+	dispatch cmdline ui storagelocations tunables possibletunables
 
-dispatch :: CmdLine.CmdLine -> UI -> Tunables -> [Tunables] -> IO ()
-dispatch cmdline ui tunables possibletunables = do
+dispatch :: CmdLine.CmdLine -> UI -> StorageLocations -> Tunables -> [Tunables] -> IO ()
+dispatch cmdline ui storagelocations tunables possibletunables = do
 	mode <- CmdLine.selectMode cmdline
 	go mode (CmdLine.secretkeysource cmdline)
   where
-	storage = CmdLine.storage cmdline
 	go CmdLine.Backup (Just secretkeysource) =
-		backup storage ui tunables secretkeysource
+		backup storagelocations ui tunables secretkeysource
 			=<< getSecretKey secretkeysource
 	go CmdLine.Restore (Just secretkeydest) =
-		restore storage ui possibletunables secretkeydest
+		restore storagelocations ui possibletunables secretkeydest
 	go CmdLine.Backup Nothing =
-		backup storage ui tunables Gpg.anyKey
+		backup storagelocations ui tunables Gpg.anyKey
 			=<< Gpg.getKeyToBackup ui
 	go CmdLine.Restore Nothing =
-		restore storage ui possibletunables Gpg.anyKey
+		restore storagelocations ui possibletunables Gpg.anyKey
 	go CmdLine.Benchmark _ =
 		benchmarkTunables tunables
 
-backup :: Storage -> UI -> Tunables -> SecretKeySource -> SecretKey -> IO ()
-backup storage ui tunables secretkeysource secretkey = do
+backup :: StorageLocations -> UI -> Tunables -> SecretKeySource -> SecretKey -> IO ()
+backup storagelocations ui tunables secretkeysource secretkey = do
 	username <- userName
 	Name theirname <- fromMaybe (error "Aborting on no username") 
 		<$> promptName ui "Enter your name"
@@ -84,7 +83,7 @@ backup storage ui tunables secretkeysource secretkey = do
 			_ <- sis `deepseq` setpercent 50
 			let step = 50 `div` length shards
 			let percentsteps = map setpercent [50+step, 50+step*2..100]
-			storeShards storage sis (zip percentsteps shards)
+			storeShards storagelocations sis (zip percentsteps shards)
 	case r of
 		StoreSuccess -> showInfo ui "Success" "Your secret key successfully encrypted and backed up."
 		StoreFailure s -> showError ui ("There was a problem storing your encrypted secret key: " ++ s)
@@ -93,7 +92,7 @@ backup storage ui tunables secretkeysource secretkey = do
 				[ "Another secret key is already being stored under the name you entered."
 				, "Please try again with a different name."
 				]
-			backup storage ui tunables secretkeysource secretkey
+			backup storagelocations ui tunables secretkeysource secretkey
   where
 	promptkek name = do
 		password <- fromMaybe (error "Aborting on no password") 
@@ -168,8 +167,8 @@ otherNameSuggestions = unlines $ map ("  * " ++)
 	, "Your college roomate."
 	]
 
-restore :: Storage -> UI -> [Tunables] -> SecretKeySource -> IO ()
-restore storage ui possibletunables secretkeydest = do
+restore :: StorageLocations -> UI -> [Tunables] -> SecretKeySource -> IO ()
+restore storagelocations ui possibletunables secretkeydest = do
 	username <- userName
 	Name theirname <- fromMaybe (error "Aborting on no username") 
 		<$> promptName ui "Enter your name"
@@ -182,7 +181,7 @@ restore storage ui possibletunables secretkeydest = do
 		<$> promptPassword ui True "Enter password" passworddesc
 	
 	let mksis tunables = shardIdents tunables name secretkeydest
-	(tunables, shards) <- downloadShards storage ui mksis possibletunables
+	(tunables, shards) <- downloadShards storagelocations ui mksis possibletunables
 
 	let candidatekeys = candidateKeyEncryptionKeys tunables name password
 	let cost = getCreationCost candidatekeys 
@@ -222,14 +221,11 @@ restore storage ui possibletunables secretkeydest = do
 		, "Please wait..."
 		]
 
-downloadShards :: Storage -> UI -> (Tunables -> ShardIdents) -> [Tunables] -> IO (Tunables, [Shard])
-downloadShards storage ui mksis possibletunables =
-	bracket_ setup cleanup download
+downloadShards :: StorageLocations -> UI -> (Tunables -> ShardIdents) -> [Tunables] -> IO (Tunables, [Shard])
+downloadShards storagelocations ui mksis possibletunables =
+	withProgress ui "Downloading encrypted data" message $
+		go possibletunables
   where
-	setup = return ()
-	download = withProgress ui "Downloading encrypted data" message (go possibletunables)
-	cleanup = obscureShards storage
-
 	go [] _ = return (defaultTunables, [])
 	go (tunables:othertunables) setpercent = do
 		let sis = mksis tunables
@@ -238,19 +234,8 @@ downloadShards storage ui mksis possibletunables =
 		-- most of the time.
 		_ <- l `deepseq` setpercent 50
 		let step = 50 `div` length l
-		let percentsteps = [50+step, 50+step*2..100]
-
-		mshards <- forM (zip percentsteps l) $ \(pct, (n, i)) -> do
-			r <- retrieveShard storage n i
-			case r of
-				RetrieveSuccess s -> do
-					_ <- setpercent pct
-					return (Just s)
-				RetrieveFailure f -> do
-					hPutStrLn stderr $
-						"warning: retrieval of shard " ++ show n ++ " failed: " ++ f
-					return Nothing
-		let shards = catMaybes mshards
+		let percentsteps = map setpercent [50+step, 50+step*2..100]
+		shards <- retrieveShards storagelocations (zip percentsteps l)
 		if null shards
 			then go othertunables setpercent
 			else return (tunables, shards)