diff options
author | Joey Hess <joeyh@joeyh.name> | 2016-08-18 16:37:23 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2016-08-18 16:37:23 -0400 |
commit | 845289fdd8fbbed2cbc7eaf7a3d31efe5a8aa80d (patch) | |
tree | 9c0690078b462efc855d7fd42bc0db4e586a6f05 /Storage.hs | |
parent | 4e53adca698bde2430f30a6b1bd10bf7cdd52e1e (diff) | |
download | keysafe-845289fdd8fbbed2cbc7eaf7a3d31efe5a8aa80d.tar.gz |
untested moving of upload queues on to servers
There needs to be a 1:1 mapping between upload queues and servers,
otherwise using the upload queue risks two shards for the same object
being uploaded to the same server.
Also, fixed storeShards to give up on StoreAlreadyExists, rather than
trying another storage location. Otherwise, on a name collision,
the shards would be rejected by the servers, and be stored to their upload
queues.
Diffstat (limited to 'Storage.hs')
-rw-r--r-- | Storage.hs | 25 |
1 files changed, 13 insertions, 12 deletions
@@ -10,23 +10,16 @@ import Types.Storage import Shard import Storage.Local import Storage.Network -import System.FilePath import Data.Monoid import Data.Maybe +import System.FilePath +import Control.Monad allStorageLocations :: IO StorageLocations allStorageLocations = do servers <- networkServers - return $ servers <> uploadQueueLocations servers - --- | Objects queued for upload to servers. There are a number of queues, --- but no 1:1 mapping from queues to a particular server. --- It's important that when flushing the upload queue, the objects in each --- separate queue are sent to a separate server. -uploadQueueLocations :: StorageLocations -> StorageLocations -uploadQueueLocations (StorageLocations servers) = StorageLocations $ - map (localStorage . ("uploadqueue" </>) . show) - [1..length servers] + return $ StorageLocations $ + map networkStorage servers <> map uploadQueue servers localStorageLocations :: StorageLocations localStorageLocations = StorageLocations $ @@ -52,7 +45,10 @@ storeShards (StorageLocations locs) sis shards = do StoreSuccess -> do _ <- showprogress go otherlocs (loc:usedlocs) Nothing rest - _ -> go otherlocs usedlocs (Just r) tostore + StoreFailure _ -> go otherlocs usedlocs (Just r) tostore + -- Give up if any location complains a shard + -- already exists, because we have a name conflict. + StoreAlreadyExists -> return (StoreAlreadyExists, usedlocs) -- | Retrieves shards from among the storage locations, and returns all -- the shards it can find, which may not be all that were requested. @@ -84,3 +80,8 @@ retrieveShards (StorageLocations locs) l = do -- all shards and so learn the idents of -- all of them. go (unusedlocs++[loc]) usedlocs' rest shards' + +uploadQueued :: IO () +uploadQueued = do + servers <- networkServers + forM_ servers $ \s -> moveShards (uploadQueue s) (networkStorage s) |