diff options
| -rw-r--r-- | CHANGELOG | 1 | ||||
| -rw-r--r-- | Storage.hs | 16 | ||||
| -rw-r--r-- | Storage/Local.hs | 51 | ||||
| -rw-r--r-- | Storage/Network.hs | 2 | ||||
| -rw-r--r-- | Types/Storage.hs | 2 | ||||
| -rw-r--r-- | keysafe.hs | 7 |
6 files changed, 56 insertions, 23 deletions
@@ -9,6 +9,7 @@ keysafe (0.20160832) UNRELEASED; urgency=medium * Several new dependencies. * Another fix to gpg secret key list parser. * Warn when uploads fail and are put in the upload queue. + * Warn when --uploadqueued fails to upload to servers. -- Joey Hess <id@joeyh.name> Thu, 01 Sep 2016 11:42:27 -0400 @@ -12,6 +12,7 @@ import Storage.Local import Storage.Network import Servers import Data.Maybe +import Data.List import System.FilePath import Control.Monad import qualified Data.Set as S @@ -109,9 +110,18 @@ retrieveShares (StorageLocations locs) sis updateprogress = do -- all of them. go (unusedlocs++[loc]) usedlocs' rest shares' -uploadQueued :: Maybe LocalStorageDirectory -> IO () +-- | Returns descriptions of any failures. +uploadQueued :: Maybe LocalStorageDirectory -> IO [String] uploadQueued d = do StorageLocations locs <- allStorageLocations d - forM_ locs $ \loc -> case uploadQueue loc of - Nothing -> return () + results <- forM locs $ \loc -> case uploadQueue loc of + Nothing -> return [] Just q -> moveShares q loc + return $ processresults (concat results) [] + where + processresults [] c = nub c + processresults (StoreSuccess:rs) c = processresults rs c + processresults (StoreFailure e:rs) c = processresults rs (e:c) + processresults (StoreAlreadyExists:rs) c = + processresults rs ("Unable to upload a share to a server due to a name conflict.":c) + diff --git a/Storage/Local.hs b/Storage/Local.hs index 20d0922..efda2bc 100644 --- a/Storage/Local.hs +++ b/Storage/Local.hs @@ -17,6 +17,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as U8 import Data.Monoid import Data.List +import Data.Maybe import System.Posix.User import System.IO import System.Directory @@ -93,25 +94,43 @@ count section getsharedir = onError (CountFailure . show) $ do CountResult . genericLength . filter isShareFile <$> getDirectoryContents dir -move :: Section -> GetShareDir -> Storage -> IO () +move :: Section -> GetShareDir -> Storage -> IO [StoreResult] move section getsharedir storage = do dir <- getsharedir section fs <- getDirectoryContents dir - forM_ fs $ \f -> case fromShareFile f of - Nothing -> return () - Just i -> do - -- Use a dummy share number of 0; it doesn't - -- matter because we're not going to be - -- recombining the share, just sending its contents - -- on the the server. - r <- retrieve section getsharedir 0 i - case r of - RetrieveFailure _ -> return () - RetrieveSuccess share -> do - s <- storeShare storage i share - case s of - StoreFailure _ -> return () - _ -> removeFile f + rs <- forM fs $ \f -> case fromShareFile f of + Nothing -> return Nothing + Just i -> Just <$> go f i + return (catMaybes rs) + where + -- Use a dummy share number of 0; it doesn't + -- matter because we're not going to be + -- recombining the share here. + sharenum = 0 + + go f i = do + r <- retrieve section getsharedir sharenum i + case r of + RetrieveFailure e -> return (StoreFailure e) + RetrieveSuccess share -> do + s <- storeShare storage i share + case s of + StoreSuccess -> movesuccess f + StoreAlreadyExists -> alreadyexists share i f + StoreFailure e -> return (StoreFailure e) + + movesuccess f = do + removeFile f + return StoreSuccess + + -- Detect case where the same data is already + -- stored on the other storage. + alreadyexists share i f = do + check <- retrieveShare storage sharenum i + case check of + RetrieveSuccess share' + | share' == share -> movesuccess f + _ -> return StoreAlreadyExists onError :: (IOException -> a) -> IO a -> IO a onError f a = do diff --git a/Storage/Network.hs b/Storage/Network.hs index 9b586b3..ff33e3f 100644 --- a/Storage/Network.hs +++ b/Storage/Network.hs @@ -47,5 +47,5 @@ count :: Server -> IO CountResult count srv = serverRequest srv CountFailure id NoPOWIdent countObjects -- | Not needed for servers. -move :: Server -> Storage -> IO () +move :: Server -> Storage -> IO [StoreResult] move _ _ = error "move is not implemented for servers" diff --git a/Types/Storage.hs b/Types/Storage.hs index d6e4edf..2dabcac 100644 --- a/Types/Storage.hs +++ b/Types/Storage.hs @@ -31,7 +31,7 @@ data Storage = Storage -- ^ Run after making some calls to storeShare/retrieveShare, -- to avoid correlation attacks. , countShares :: IO CountResult - , moveShares :: Storage -> IO () + , moveShares :: Storage -> IO [StoreResult] -- ^ Tries to move all shares from this storage to another one. , uploadQueue :: Maybe Storage } @@ -62,8 +62,11 @@ dispatch cmdline ui storagelocations tunables possibletunables = do =<< Gpg.getKeyToBackup ui go CmdLine.Restore Nothing = restore cmdline storagelocations ui possibletunables Gpg.anyKey - go CmdLine.UploadQueued _ = - uploadQueued (CmdLine.localstoragedirectory cmdline) + go CmdLine.UploadQueued _ = do + problems <- uploadQueued (CmdLine.localstoragedirectory cmdline) + 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.") go (CmdLine.Server) _ = runServer (CmdLine.localstoragedirectory cmdline) |