From 0a3eb9be07a7514f5544384bc914f22ea88c24a8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 14 Sep 2016 14:02:29 -0400 Subject: Warn when uploads fail and are put in the upload queue. --- CHANGELOG | 1 + Storage.hs | 53 ++++++++++++++++++++++++++++++++--------------------- Storage/Local.hs | 6 +----- Storage/Network.hs | 8 ++++++-- Types/Storage.hs | 1 + keysafe.hs | 6 ++++-- 6 files changed, 45 insertions(+), 30 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index b3c7f06..01609cb 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -8,6 +8,7 @@ keysafe (0.20160832) UNRELEASED; urgency=medium * server: Added --months-to-fill-half-disk option, defaulting to 12. * Several new dependencies. * Another fix to gpg secret key list parser. + * Warn when uploads fail and are put in the upload queue. -- Joey Hess Thu, 01 Sep 2016 11:42:27 -0400 diff --git a/Storage.hs b/Storage.hs index 8f67ea9..b8aace7 100644 --- a/Storage.hs +++ b/Storage.hs @@ -11,7 +11,6 @@ import Share import Storage.Local import Storage.Network import Servers -import Data.Monoid import Data.Maybe import System.FilePath import Control.Monad @@ -20,8 +19,7 @@ import qualified Data.Set as S allStorageLocations :: Maybe LocalStorageDirectory -> IO StorageLocations allStorageLocations d = do servers <- networkServers - return $ StorageLocations $ - map networkStorage servers <> map (uploadQueue d) servers + return $ StorageLocations $ map (networkStorage d) servers localStorageLocations :: Maybe LocalStorageDirectory -> StorageLocations localStorageLocations d = StorageLocations $ @@ -33,37 +31,48 @@ type UpdateProgress = IO () -- | Stores the shares amoung the storage locations. Each location -- gets at most one share from each set. -- +-- If a server is not currently accessible, it will be queued locally. +-- If this happens at all, returns True. +-- -- TODO: Add shuffling and queueing/chaffing to prevent -- correlation of related shares. -storeShares :: StorageLocations -> ShareIdents -> [S.Set Share] -> UpdateProgress -> IO StoreResult +storeShares :: StorageLocations -> ShareIdents -> [S.Set Share] -> UpdateProgress -> IO (StoreResult, Bool) storeShares (StorageLocations locs) allsis shares updateprogress = do - (r, usedlocs) <- go allsis shares [] + (r, usedlocs) <- go allsis shares [] False _ <- mapM_ obscureShares usedlocs return r where - go sis (s:rest) usedlocs = do + go sis (s:rest) usedlocs anyqueued = do let (is, sis') = nextShareIdents sis - (r, usedlocs') <- storeset locs [] Nothing (zip (S.toList is) (S.toList s)) + (r, usedlocs', queued) <- storeset locs [] Nothing (zip (S.toList is) (S.toList s)) False case r of - StoreSuccess -> go sis' rest (usedlocs ++ usedlocs') - _ -> return (r, usedlocs ++ usedlocs') - go _ [] usedlocs = return (StoreSuccess, usedlocs) + StoreSuccess -> go sis' rest (usedlocs ++ usedlocs') (anyqueued || queued) + _ -> return ((r, anyqueued || queued), usedlocs ++ usedlocs') + go _ [] usedlocs anyqueued = return ((StoreSuccess, anyqueued), usedlocs) - storeset _ usedlocs _ [] = return (StoreSuccess, usedlocs) - storeset [] usedlocs lasterr _ = - return (fromMaybe (StoreFailure "no storage locations") lasterr, usedlocs) - storeset (loc:otherlocs) usedlocs _ ((i, s):rest) = do + storeset _ usedlocs _ [] queued = return (StoreSuccess, usedlocs, queued) + storeset [] usedlocs lasterr _ queued = + return (fromMaybe (StoreFailure "no storage locations") lasterr, usedlocs, queued) + storeset (loc:otherlocs) usedlocs _ ((i, s):rest) queued = do r <- storeShare loc i s case r of StoreSuccess -> do _ <- updateprogress - storeset otherlocs (loc:usedlocs) Nothing rest + storeset otherlocs (loc:usedlocs) Nothing rest queued -- Give up if any location complains a share -- already exists, because we have a name conflict. - StoreAlreadyExists -> return (StoreAlreadyExists, usedlocs) - -- Try storing it somewhere else on failure. - StoreFailure _ -> - storeset otherlocs usedlocs (Just r) ((i, s):rest) + StoreAlreadyExists -> return (StoreAlreadyExists, usedlocs, queued) + -- Queue or try storing it somewhere else on failure. + StoreFailure _ -> case uploadQueue loc of + Just q -> do + r' <- storeShare q i s + case r' of + StoreSuccess -> do + _ <- updateprogress + storeset otherlocs (loc:usedlocs) Nothing rest True + StoreAlreadyExists -> return (StoreAlreadyExists, usedlocs, queued) + StoreFailure _ -> storeset otherlocs usedlocs (Just r) ((i, s):rest) queued + Nothing -> storeset otherlocs usedlocs (Just r) ((i, s):rest) queued -- | Retrieves one set of shares from the storage locations. -- Returns all the shares it can find, which may not be enough, @@ -102,5 +111,7 @@ retrieveShares (StorageLocations locs) sis updateprogress = do uploadQueued :: Maybe LocalStorageDirectory -> IO () uploadQueued d = do - servers <- networkServers - forM_ servers $ \s -> moveShares (uploadQueue d s) (networkStorage s) + StorageLocations locs <- allStorageLocations d + forM_ locs $ \loc -> case uploadQueue loc of + Nothing -> return () + Just q -> moveShares q loc diff --git a/Storage/Local.hs b/Storage/Local.hs index 71d5aa7..20d0922 100644 --- a/Storage/Local.hs +++ b/Storage/Local.hs @@ -7,13 +7,11 @@ module Storage.Local ( localStorage , storageDir , testStorageDir - , uploadQueue , localDiskUsage ) where import Types import Types.Storage -import Servers import Serialization () import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as U8 @@ -41,13 +39,11 @@ localStorage getsharedir n = Storage , obscureShares = obscure section getsharedir , countShares = count section getsharedir , moveShares = move section getsharedir + , uploadQueue = Nothing } where section = Section n -uploadQueue :: Maybe LocalStorageDirectory -> Server -> Storage -uploadQueue d s = localStorage (storageDir d) ("uploadqueue" serverName s) - store :: Section -> GetShareDir -> StorableObjectIdent -> Share -> IO StoreResult store section getsharedir i s = onError (StoreFailure . show) $ do dir <- getsharedir section diff --git a/Storage/Network.hs b/Storage/Network.hs index 21909d4..9b586b3 100644 --- a/Storage/Network.hs +++ b/Storage/Network.hs @@ -11,17 +11,21 @@ module Storage.Network ( import Types import Types.Storage +import Storage.Local import Servers import HTTP.Client import HTTP.ProofOfWork +import System.FilePath -networkStorage :: Server -> Storage -networkStorage server = Storage +networkStorage :: Maybe LocalStorageDirectory -> Server -> Storage +networkStorage localdir server = Storage { storeShare = store server , retrieveShare = retrieve server , obscureShares = obscure server , countShares = count server , moveShares = move server + , uploadQueue = Just $ localStorage (storageDir localdir) + ("uploadqueue" serverName server) } store :: Server -> StorableObjectIdent -> Share -> IO StoreResult diff --git a/Types/Storage.hs b/Types/Storage.hs index bc186e7..d6e4edf 100644 --- a/Types/Storage.hs +++ b/Types/Storage.hs @@ -33,6 +33,7 @@ data Storage = Storage , countShares :: IO CountResult , moveShares :: Storage -> IO () -- ^ Tries to move all shares from this storage to another one. + , uploadQueue :: Maybe Storage } data StoreResult = StoreSuccess | StoreAlreadyExists | StoreFailure String diff --git a/keysafe.hs b/keysafe.hs index e2b112c..33ea1a2 100644 --- a/keysafe.hs +++ b/keysafe.hs @@ -94,7 +94,7 @@ backup cmdline storagelocations ui tunables secretkeysource secretkey = do kek <- promptkek name let sis = shareIdents tunables name secretkeysource let cost = getCreationCost kek <> getCreationCost sis - r <- withProgressIncremental ui "Encrypting and storing data" + (r, queued) <- withProgressIncremental ui "Encrypting and storing data" (encryptdesc cost cores) $ \addpercent -> do let esk = encrypt tunables kek secretkey shares <- genShares esk tunables @@ -103,7 +103,9 @@ backup cmdline storagelocations ui tunables secretkeysource secretkey = do let step = 50 `div` sum (map S.size shares) storeShares storagelocations sis shares (addpercent step) case r of - StoreSuccess -> showInfo ui "Success" "Your secret key was successfully encrypted and backed up." + StoreSuccess + | queued -> showInfo ui "Backup queued" "Some data was not sucessfully uploaded to servers, and has been queued for later upload. Run keysafe --uploadqueued at a later point to finish the backup." + | otherwise -> showInfo ui "Backup success" "Your secret key was successfully encrypted and backed up." StoreFailure s -> showError ui ("There was a problem storing your encrypted secret key: " ++ s) StoreAlreadyExists -> do showError ui $ unlines -- cgit v1.2.3