diff options
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 |