diff options
author | Joey Hess <joeyh@joeyh.name> | 2016-10-24 14:15:32 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2016-10-24 14:15:32 -0400 |
commit | 28ec99cd1848b859937250e1d7175dec27b006e7 (patch) | |
tree | b16d0aace012ad11f10be6db2c4addfbf674afff /keysafe.hs | |
parent | 9da16176d3e29445f0e2c0db3232c4254c8ad181 (diff) | |
download | keysafe-28ec99cd1848b859937250e1d7175dec27b006e7.tar.gz |
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.
Diffstat (limited to 'keysafe.hs')
-rw-r--r-- | keysafe.hs | 34 |
1 files changed, 28 insertions, 6 deletions
@@ -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 |