Warn when uploads fail and are put in the upload queue.

6 files changed, 45 insertions, 30 deletions

diff --git a/CHANGELOG b/CHANGELOG
index b3c7f06..01609cb 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -8,6 +8,7 @@ keysafe (0.20160832) UNRELEASED; urgency=medium
   * server: Added --months-to-fill-half-disk option, defaulting to 12.
   * Several new dependencies.
   * Another fix to gpg secret key list parser.
+  * Warn when uploads fail and are put in the upload queue.
 
  -- Joey Hess <id@joeyh.name>  Thu, 01 Sep 2016 11:42:27 -0400
 
diff --git a/Storage.hs b/Storage.hs
index 8f67ea9..b8aace7 100644
--- a/Storage.hs
+++ b/Storage.hs
@@ -11,7 +11,6 @@ import Share
 import Storage.Local
 import Storage.Network
 import Servers
-import Data.Monoid
 import Data.Maybe
 import System.FilePath
 import Control.Monad
@@ -20,8 +19,7 @@ import qualified Data.Set as S
 allStorageLocations :: Maybe LocalStorageDirectory -> IO StorageLocations
 allStorageLocations d = do
 	servers <- networkServers
-	return $ StorageLocations $
-		map networkStorage servers <> map (uploadQueue d) servers
+	return $ StorageLocations $ map (networkStorage d) servers
 
 localStorageLocations :: Maybe LocalStorageDirectory -> StorageLocations
 localStorageLocations d = StorageLocations $
@@ -33,37 +31,48 @@ type UpdateProgress = IO ()
 -- | Stores the shares amoung the storage locations. Each location
 -- gets at most one share from each set.
 --
+-- If a server is not currently accessible, it will be queued locally.
+-- If this happens at all, returns True.
+--
 -- TODO: Add shuffling and queueing/chaffing to prevent
 -- correlation of related shares.
-storeShares :: StorageLocations -> ShareIdents -> [S.Set Share] -> UpdateProgress -> IO StoreResult
+storeShares :: StorageLocations -> ShareIdents -> [S.Set Share] -> UpdateProgress -> IO (StoreResult, Bool)
 storeShares (StorageLocations locs) allsis shares updateprogress = do
-	(r, usedlocs) <- go allsis shares []
+	(r, usedlocs) <- go allsis shares [] False
 	_ <- mapM_ obscureShares usedlocs
 	return r
   where
-	go sis (s:rest) usedlocs = do
+	go sis (s:rest) usedlocs anyqueued = do
 		let (is, sis') = nextShareIdents sis
-		(r, usedlocs') <- storeset locs [] Nothing (zip (S.toList is) (S.toList s))
+		(r, usedlocs', queued) <- storeset locs [] Nothing (zip (S.toList is) (S.toList s)) False
 		case r of
-			StoreSuccess -> go sis' rest (usedlocs ++ usedlocs')
-			_ -> return (r, usedlocs ++ usedlocs')
-	go _ [] usedlocs = return (StoreSuccess, usedlocs)
+			StoreSuccess -> go sis' rest (usedlocs ++ usedlocs') (anyqueued || queued)
+			_ -> return ((r, anyqueued || queued), usedlocs ++ usedlocs')
+	go _ [] usedlocs anyqueued = return ((StoreSuccess, anyqueued), usedlocs)
 
-	storeset _ usedlocs _ [] = return (StoreSuccess, usedlocs)
-	storeset [] usedlocs lasterr _ =
-		return (fromMaybe (StoreFailure "no storage locations") lasterr, usedlocs)
-	storeset (loc:otherlocs) usedlocs _ ((i, s):rest) = do
+	storeset _ usedlocs _ [] queued = return (StoreSuccess, usedlocs, queued)
+	storeset [] usedlocs lasterr _ queued =
+		return (fromMaybe (StoreFailure "no storage locations") lasterr, usedlocs, queued)
+	storeset (loc:otherlocs) usedlocs _ ((i, s):rest) queued = do
 		r <- storeShare loc i s
 		case r of
 			StoreSuccess -> do
 				_ <- updateprogress
-				storeset otherlocs (loc:usedlocs) Nothing rest
+				storeset otherlocs (loc:usedlocs) Nothing rest queued
 			-- Give up if any location complains a share
 			-- already exists, because we have a name conflict.
-			StoreAlreadyExists -> return (StoreAlreadyExists, usedlocs)
-			-- Try storing it somewhere else on failure.
-			StoreFailure _ ->
-				storeset otherlocs usedlocs (Just r) ((i, s):rest)
+			StoreAlreadyExists -> return (StoreAlreadyExists, usedlocs, queued)
+			-- Queue or try storing it somewhere else on failure.
+			StoreFailure _ -> case uploadQueue loc of
+				Just q -> do
+					r' <- storeShare q i s
+					case r' of
+						StoreSuccess -> do
+							_ <- updateprogress
+							storeset otherlocs (loc:usedlocs) Nothing rest True
+						StoreAlreadyExists -> return (StoreAlreadyExists, usedlocs, queued)
+						StoreFailure _ -> storeset otherlocs usedlocs (Just r) ((i, s):rest) queued
+				Nothing -> storeset otherlocs usedlocs (Just r) ((i, s):rest) queued
 
 -- | Retrieves one set of shares from the storage locations.
 -- Returns all the shares it can find, which may not be enough,
@@ -102,5 +111,7 @@ retrieveShares (StorageLocations locs) sis updateprogress = do
 
 uploadQueued :: Maybe LocalStorageDirectory -> IO ()
 uploadQueued d = do
-	servers <- networkServers
-	forM_ servers $ \s -> moveShares (uploadQueue d s) (networkStorage s)
+	StorageLocations locs <- allStorageLocations d
+	forM_ locs $ \loc -> case uploadQueue loc of
+		Nothing -> return ()
+		Just q -> moveShares q loc
diff --git a/Storage/Local.hs b/Storage/Local.hs
index 71d5aa7..20d0922 100644
--- a/Storage/Local.hs
+++ b/Storage/Local.hs
@@ -7,13 +7,11 @@ module Storage.Local
 	( localStorage
 	, storageDir
 	, testStorageDir
-	, uploadQueue
 	, localDiskUsage
 	) where
 
 import Types
 import Types.Storage
-import Servers
 import Serialization ()
 import qualified Data.ByteString as B
 import qualified Data.ByteString.UTF8 as U8
@@ -41,13 +39,11 @@ localStorage getsharedir n = Storage
 	, obscureShares = obscure section getsharedir
 	, countShares = count section getsharedir
 	, moveShares = move section getsharedir
+	, uploadQueue = Nothing
 	}
   where
 	section = Section n
 
-uploadQueue :: Maybe LocalStorageDirectory -> Server -> Storage
-uploadQueue d s = localStorage (storageDir d) ("uploadqueue" </> serverName s)
-
 store :: Section -> GetShareDir -> StorableObjectIdent -> Share -> IO StoreResult
 store section getsharedir i s = onError (StoreFailure . show) $ do
 	dir <- getsharedir section
diff --git a/Storage/Network.hs b/Storage/Network.hs
index 21909d4..9b586b3 100644
--- a/Storage/Network.hs
+++ b/Storage/Network.hs
@@ -11,17 +11,21 @@ module Storage.Network (
 
 import Types
 import Types.Storage
+import Storage.Local
 import Servers
 import HTTP.Client
 import HTTP.ProofOfWork
+import System.FilePath
 
-networkStorage :: Server -> Storage
-networkStorage server = Storage
+networkStorage :: Maybe LocalStorageDirectory -> Server -> Storage
+networkStorage localdir server = Storage
 	{ storeShare = store server
 	, retrieveShare = retrieve server
 	, obscureShares = obscure server
 	, countShares = count server
 	, moveShares = move server
+	, uploadQueue = Just $ localStorage (storageDir localdir)
+		("uploadqueue" </> serverName server)
 	}
 
 store :: Server -> StorableObjectIdent -> Share -> IO StoreResult
diff --git a/Types/Storage.hs b/Types/Storage.hs
index bc186e7..d6e4edf 100644
--- a/Types/Storage.hs
+++ b/Types/Storage.hs
@@ -33,6 +33,7 @@ data Storage = Storage
 	, countShares :: IO CountResult
 	, moveShares :: Storage -> IO ()
 	-- ^ Tries to move all shares from this storage to another one.
+	, uploadQueue :: Maybe Storage
 	}
 
 data StoreResult = StoreSuccess | StoreAlreadyExists | StoreFailure String
diff --git a/keysafe.hs b/keysafe.hs
index e2b112c..33ea1a2 100644
--- a/keysafe.hs
+++ b/keysafe.hs
@@ -94,7 +94,7 @@ backup cmdline storagelocations ui tunables secretkeysource secretkey = do
 		kek <- promptkek name
 		let sis = shareIdents tunables name secretkeysource
 		let cost = getCreationCost kek <> getCreationCost sis
-		r <- withProgressIncremental ui "Encrypting and storing data"
+		(r, queued) <- withProgressIncremental ui "Encrypting and storing data"
 			(encryptdesc cost cores) $ \addpercent -> do
 				let esk = encrypt tunables kek secretkey
 				shares <- genShares esk tunables
@@ -103,7 +103,9 @@ backup cmdline storagelocations ui tunables secretkeysource secretkey = do
 				let step = 50 `div` sum (map S.size shares)
 				storeShares storagelocations sis shares (addpercent step)
 		case r of
-			StoreSuccess -> showInfo ui "Success" "Your secret key was successfully encrypted and backed up."
+			StoreSuccess
+				| queued -> showInfo ui "Backup queued" "Some data was not sucessfully uploaded to servers, and has been queued for later upload. Run keysafe --uploadqueued at a later point to finish the backup."
+				| otherwise -> showInfo ui "Backup success" "Your secret key was successfully encrypted and backed up."
 			StoreFailure s -> showError ui ("There was a problem storing your encrypted secret key: " ++ s)
 			StoreAlreadyExists -> do
 				showError ui $ unlines