diff options
Diffstat (limited to 'keysafe.hs')
| -rw-r--r-- | keysafe.hs | 58 |
1 files changed, 44 insertions, 14 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 () @@ -62,7 +65,7 @@ dispatch cmdline ui tunables possibletunables = do where go CmdLine.Backup (Just secretkeysource) = backup cmdline ui tunables (Distinguisher secretkeysource) - =<< getSecretKey secretkeysource + secretkeysource go CmdLine.Restore (Just secretkeydest) = restore cmdline ui possibletunables (Distinguisher secretkeydest) go CmdLine.Backup Nothing = @@ -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) _ = @@ -91,8 +97,8 @@ dispatch cmdline ui tunables possibletunables = do go CmdLine.Test _ = runTests -backup :: CmdLine.CmdLine -> UI -> Tunables -> Distinguisher -> (SecretKeySource, SecretKey) -> IO () -backup cmdline ui tunables distinguisher (secretkeysource, secretkey) = do +backup :: CmdLine.CmdLine -> UI -> Tunables -> Distinguisher -> SecretKeySource -> IO () +backup cmdline ui tunables distinguisher secretkeysource = do installAutoStartFile let m = totalObjects (shareParams tunables) @@ -116,9 +122,9 @@ backup cmdline ui tunables distinguisher (secretkeysource, secretkey) = do Nothing -> fromMaybe (error "Aborting on no username") <$> promptName ui "Enter your name" usernamedesc (Just username) validateName - go theirname locs + go theirname locs Nothing where - go theirname locs = do + go theirname locs msecretkey = do cores <- fromMaybe 1 <$> getNumCores Name othername <- case CmdLine.name cmdline of Just n -> pure n @@ -129,6 +135,9 @@ backup cmdline ui tunables distinguisher (secretkeysource, secretkey) = do (kek, passwordentropy) <- promptpassword name let sis = shareIdents tunables name distinguisher let cost = getCreationCost kek <> getCreationCost sis + secretkey <- case msecretkey of + Just sk -> pure sk + Nothing -> getSecretKey secretkeysource (r, queued, usedlocs) <- withProgressIncremental ui "Encrypting and storing data" (encryptdesc cost cores) $ \addpercent -> do let esk = encrypt tunables kek secretkey @@ -153,7 +162,7 @@ backup cmdline ui tunables distinguisher (secretkeysource, secretkey) = do [ "Another secret key is already being stored under the name you entered." , "Please try again with a different name." ] - go theirname locs + go theirname locs (Just secretkey) promptpassword name = do password <- fromMaybe (error "Aborting on no password") <$> promptPassword ui True "Enter password" passworddesc @@ -164,7 +173,12 @@ backup cmdline ui tunables distinguisher (secretkeysource, secretkey) = do let mincost = Dollars 100000 if crackcost < mincost then do - showError ui $ "Weak password! It would cost only " ++ show crackcost ++ " to crack the password. Please think of a better one. More words would be good.." + showError ui $ unlines + [ "Weak password! It would cost only " ++ show crackcost ++ " to crack the password." + , "Please think of a better one." + , "" + , "Suggestion: Pick 3 or 4 unrelated words for a strong password, like \"correct horse battery staple\"" + ] promptpassword name else do (thisyear, _, _) <- toGregorian . utctDay @@ -384,18 +398,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 @@ -414,10 +430,24 @@ autoStart cmdline tunables ui = do "Do you want to back up the gpg secret key now?" if ans then backup cmdline ui tunables AnyGpgKey - =<< getSecretKey (GpgKey kid) + (GpgKey kid) 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 |