From 845289fdd8fbbed2cbc7eaf7a3d31efe5a8aa80d Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 18 Aug 2016 16:37:23 -0400
Subject: 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.
---
 Storage.hs | 25 +++++++++++++------------
 1 file changed, 13 insertions(+), 12 deletions(-)

(limited to 'Storage.hs')

diff --git a/Storage.hs b/Storage.hs
index 6f39cde..ff96a3d 100644
--- a/Storage.hs
+++ b/Storage.hs
@@ -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)
-- 
cgit v1.2.3