From 3eb522469e641e31d02fa060a1b48b93edbf7d84 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 22 Sep 2016 14:08:36 -0400 Subject: record already-existing backup in log after restoring a secret key This will prevent --autostart from prompting to get the newly restored key backed up again. This commit was sponsored by Remy van Elst on Patreon. --- Storage.hs | 5 +++-- Tests.hs | 4 ++-- Types/Server.hs | 6 +++--- keysafe.hs | 46 ++++++++++++++++++++++++++++++---------------- 4 files changed, 38 insertions(+), 23 deletions(-) diff --git a/Storage.hs b/Storage.hs index aa52d7c..fcd2f7e 100644 --- a/Storage.hs +++ b/Storage.hs @@ -90,13 +90,14 @@ storeShares (StorageLocations locs) allsis shares updateprogress = do -- Assumes that each location only contains one share. So, once a -- share has been found on a location, can avoid asking that location -- for any other shares. -retrieveShares :: StorageLocations -> ShareIdents -> UpdateProgress -> IO (S.Set Share, ShareIdents) +retrieveShares :: StorageLocations -> ShareIdents -> UpdateProgress -> IO (S.Set Share, ShareIdents, [Server]) retrieveShares (StorageLocations locs) sis updateprogress = do let (is, sis') = nextShareIdents sis let want = zip [1..] (S.toList is) (shares, usedlocs, _unusedlocs) <- go locs [] want [] _ <- mapM_ obscureShares usedlocs - return (S.fromList shares, sis') + let usedservers = mapMaybe getServer usedlocs + return (S.fromList shares, sis', usedservers) where go unusedlocs usedlocs [] shares = return (shares, usedlocs, unusedlocs) go [] usedlocs _ shares = return (shares, usedlocs, []) diff --git a/Tests.hs b/Tests.hs index d18628e..09a7356 100644 --- a/Tests.hs +++ b/Tests.hs @@ -98,7 +98,7 @@ backupRestoreTest testdesc secretkey = restore storagelocations = do let sis = shareIdents tunables name secretkeysource - (shares, sis') <- retrieveShares storagelocations sis (return ()) + (shares, sis', _) <- retrieveShares storagelocations sis (return ()) let candidatekeys = candidateKeyEncryptionKeys tunables name password case combineShares tunables [shares] of Left e -> testFailed e @@ -112,7 +112,7 @@ backupRestoreTest testdesc secretkey = then testSuccess else testFailed "restore yielded different value than was backed up" DecryptIncomplete kek -> do - (nextshares, sis') <- retrieveShares storagelocations sis (return ()) + (nextshares, sis', _) <- retrieveShares storagelocations sis (return ()) let shares = firstshares ++ [nextshares] case combineShares tunables shares of Left e -> testFailed e diff --git a/Types/Server.hs b/Types/Server.hs index e1b4191..a6d1ad9 100644 --- a/Types/Server.hs +++ b/Types/Server.hs @@ -17,12 +17,12 @@ type HostName = String -- hostnames. Using tor is highly recommended, to avoid correlation -- attacks. data ServerAddress = ServerAddress HostName Port - deriving (Show) + deriving (Show, Eq, Ord) -- | Name used in queuing uploads to the server. Should remain stable -- across keysafe versions. newtype ServerName = ServerName String - deriving (Show, Generic) + deriving (Show, Eq, Ord, Generic) instance ToJSON ServerName instance FromJSON ServerName @@ -32,4 +32,4 @@ data Server = Server , serverAddress :: [ServerAddress] -- ^ A server may have multiple addresses, or no current address. } - deriving (Show) + deriving (Show, Eq, Ord) diff --git a/keysafe.hs b/keysafe.hs index 7fe27cf..a6db8ca 100644 --- a/keysafe.hs +++ b/keysafe.hs @@ -19,6 +19,7 @@ import Cost import SecretKey import Share import Storage +import Types.Server import BackupLog import AutoStart import HTTP.Server @@ -28,6 +29,7 @@ import Data.Maybe import Data.Time.Clock import Data.Time.Calendar import Data.Monoid +import Data.List import Control.DeepSeq import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BU8 @@ -135,9 +137,7 @@ backup cmdline storagelocations ui tunables secretkeysource secretkey = do password <- fromMaybe (error "Aborting on no password") <$> promptPassword ui True "Enter password" passworddesc kek <- genKeyEncryptionKey tunables name password - username <- userName - let badwords = concatMap namewords [name, username] - let passwordentropy = calcPasswordEntropy password badwords + passwordentropy <- getPasswordEntropy password name let crackcost = estimateAttackCost spotAWS $ estimateBruteforceOf kek passwordentropy let mincost = Dollars 100000 @@ -154,7 +154,6 @@ backup cmdline storagelocations ui tunables secretkeysource secretkey = do if ok then return (kek, passwordentropy) else promptpassword name - namewords (Name nb) = words (BU8.toString nb) keydesc = case secretkeysource of GpgKey _ -> "gpg secret key" KeyFile _ -> "secret key" @@ -229,7 +228,7 @@ restore cmdline storagelocations ui possibletunables secretkeydest = do r <- downloadInitialShares storagelocations ui mksis possibletunables case r of Nothing -> showError ui "No shares could be downloaded. Perhaps you entered the wrong name?" - Just (tunables, shares, sis) -> do + Just (tunables, shares, sis, usedservers) -> do let candidatekeys = candidateKeyEncryptionKeys tunables name password let cost = getCreationCost candidatekeys <> castCost (getDecryptionCost candidatekeys) @@ -238,26 +237,33 @@ restore cmdline storagelocations ui possibletunables secretkeydest = do Right esk -> do final <- withProgress ui "Decrypting" (decryptdesc cost cores) $ \setpercent -> - go tunables [shares] sis setpercent $ + go tunables [shares] usedservers sis setpercent $ tryDecrypt candidatekeys esk - final + final =<< getPasswordEntropy password name where - go tunables firstshares sis setpercent r = case r of - DecryptFailed -> return $ + go tunables firstshares firstusedservers sis setpercent r = case r of + DecryptFailed -> return $ \_ -> showError ui "Decryption failed! Probably you entered the wrong password." DecryptSuccess secretkey -> do _ <- setpercent 100 writeSecretKey secretkeydest secretkey - return $ + return $ \passwordentropy -> do showInfo ui "Success" "Your secret key was successfully restored!" + -- Since the key was restored, we know it's + -- backed up; log that. + backuplog <- mkBackupLog $ + backupMade firstusedservers secretkeydest passwordentropy + storeBackupLog backuplog DecryptIncomplete kek -> do -- Download shares for another chunk. - (nextshares, sis') <- retrieveShares storagelocations sis (return ()) + (nextshares, sis', nextusedservers) + <- retrieveShares storagelocations sis (return ()) let shares = firstshares ++ [nextshares] + let usedservers = nub (firstusedservers ++ nextusedservers) case combineShares tunables shares of - Left e -> return $ showError ui e + Left e -> return $ \_ -> showError ui e Right esk -> - go tunables shares sis' setpercent $ + go tunables shares usedservers sis' setpercent $ decrypt kek esk namedesc = unlines [ "When you backed up your secret key, you entered some information." @@ -291,7 +297,7 @@ downloadInitialShares -> UI -> (Tunables -> ShareIdents) -> [Tunables] - -> IO (Maybe (Tunables, S.Set Share, ShareIdents)) + -> IO (Maybe (Tunables, S.Set Share, ShareIdents, [Server])) downloadInitialShares storagelocations ui mksis possibletunables = do cores <- fromMaybe 1 <$> getNumCores withProgressIncremental ui "Downloading encrypted data" (message cores) $ \addpercent -> do @@ -305,10 +311,10 @@ downloadInitialShares storagelocations ui mksis possibletunables = do addpercent 50 let m = totalObjects (shareParams tunables) let step = 50 `div` m - (shares, sis') <- retrieveShares storagelocations sis (addpercent step) + (shares, sis', usedservers) <- retrieveShares storagelocations sis (addpercent step) if S.null shares then go othertunables addpercent - else return $ Just (tunables, shares, sis') + else return $ Just (tunables, shares, sis', usedservers) possiblesis = map mksis possibletunables message cores = unlines @@ -331,6 +337,14 @@ userName = do u <- getUserEntryForID =<< getEffectiveUserID return $ Name $ BU8.fromString $ takeWhile (/= ',') (userGecos u) +getPasswordEntropy :: Password -> Name -> IO (Entropy UnknownPassword) +getPasswordEntropy password name = do + username <- userName + let badwords = concatMap namewords [name, username] + return $ calcPasswordEntropy password badwords + where + namewords (Name nb) = words (BU8.toString nb) + uploadQueued :: UI -> Maybe LocalStorageDirectory -> IO () uploadQueued ui d = do problems <- tryUploadQueued d -- cgit v1.2.3