From 28ec99cd1848b859937250e1d7175dec27b006e7 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Mon, 24 Oct 2016 14:15:32 -0400
Subject: improved queue upload

* --upload-queued: Exit nonzero if unable to upload all queued objects.
* --autostart: If unable to upload all queued objects initially,
  delay between 1 and 2 hours and try again.

  This way, if tor takes some time to start after login, it will retry
  later, when tor is hopefully running.
---
 keysafe.hs | 34 ++++++++++++++++++++++++++++------
 1 file changed, 28 insertions(+), 6 deletions(-)

(limited to 'keysafe.hs')

diff --git a/keysafe.hs b/keysafe.hs
index 996c0a7..738274f 100644
--- a/keysafe.hs
+++ b/keysafe.hs
@@ -40,6 +40,9 @@ import qualified Data.Text as T
 import qualified Data.ByteString as B
 import qualified Data.ByteString.UTF8 as BU8
 import qualified Data.Set as S
+import Control.Concurrent.Thread.Delay
+import System.Random
+import System.Exit
 import System.Posix.User (userGecos, getUserEntryForID, getEffectiveUserID)
 
 main :: IO ()
@@ -70,8 +73,11 @@ dispatch cmdline ui tunables possibletunables = do
 			=<< Gpg.getKeyToBackup ui
 	go CmdLine.Restore Nothing =
 		restore cmdline ui possibletunables AnyGpgKey
-	go CmdLine.UploadQueued _ =
-		uploadQueued ui (CmdLine.localstoragedirectory cmdline)
+	go CmdLine.UploadQueued _ = do
+		ok <- uploadQueued ui (CmdLine.localstoragedirectory cmdline)
+		if ok
+			then exitSuccess
+			else exitFailure
 	go CmdLine.AutoStart _ =
 		autoStart cmdline tunables ui
 	go (CmdLine.Server) _ =
@@ -384,18 +390,20 @@ getPasswordEntropy password name = do
   where
 	namewords (Name nb) = words (BU8.toString nb)
 
-uploadQueued :: UI -> Maybe LocalStorageDirectory -> IO ()
+uploadQueued :: UI -> Maybe LocalStorageDirectory -> IO Bool
 uploadQueued ui d = do
 	problems <- tryUploadQueued d
 	if null problems
-		then return ()
-		else showError ui ("Problem uploading queued data to servers:\n\n" ++ unlines problems ++ "\n\nYour secret keys have not yet been backed up.")
+		then return True
+		else do
+			showError ui ("Problem uploading queued data to servers:\n\n" ++ unlines problems ++ "\n\nYour secret keys have not yet been backed up.")
+			return False
 
 autoStart :: CmdLine.CmdLine -> Tunables -> UI -> IO ()
 autoStart cmdline tunables ui = do
 	-- Upload queued first, before making any more backups that might
 	-- queue more.
-	uploadQueued ui (CmdLine.localstoragedirectory cmdline)
+	queueok <- uploadQueued ui (CmdLine.localstoragedirectory cmdline)
 
 	-- Ask about backing up any gpg secret key that has not been backed up
 	-- or asked about before. If there are multiple secret keys, only
@@ -418,6 +426,20 @@ autoStart cmdline tunables ui = do
 				else storeBackupLog
 					=<< mkBackupLog (BackupSkipped (GpgKey kid))
 
+	if queueok
+		then return ()
+		else retryqueue
+  where
+	-- Delay for between 1 and 2 hours, and retry queued uploads.
+	retryqueue = do
+		let hourdelay = 1000000 * 60*60
+		msdelay <- getStdRandom (randomR (hourdelay, hourdelay*2))
+		delay msdelay
+		problems <- tryUploadQueued (CmdLine.localstoragedirectory cmdline)
+		if null problems
+			then return ()
+			else retryqueue
+
 checkServers :: CmdLine.CmdLine -> IO ()
 checkServers cmdline = do
 	StorageLocations sls <- cmdLineStorageLocations cmdline
-- 
cgit v1.2.3