From 07afb8fc1eb3a850b13f7aa09cc0ca3b0b495a2c Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 18 Aug 2016 15:48:45 -0400
Subject: fix behavior on retrieve failure

---
 Storage.hs | 18 ++++++++++--------
 1 file changed, 10 insertions(+), 8 deletions(-)

(limited to 'Storage.hs')

diff --git a/Storage.hs b/Storage.hs
index c80935f..6f39cde 100644
--- a/Storage.hs
+++ b/Storage.hs
@@ -17,19 +17,21 @@ import Data.Maybe
 allStorageLocations :: IO StorageLocations
 allStorageLocations = do
 	servers <- networkServers
-	return $ servers <> uploadQueueLocations
+	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
-uploadQueueLocations = StorageLocations $
-	map (localStorage . ("uploadqueue" </>) . show) ([1..] :: [Integer])
+uploadQueueLocations :: StorageLocations -> StorageLocations
+uploadQueueLocations (StorageLocations servers) = StorageLocations $
+	map (localStorage . ("uploadqueue" </>) . show)
+		[1..length servers]
 
 localStorageLocations :: StorageLocations
 localStorageLocations = StorageLocations $
-	map (localStorage . ("local" </>) . show) ([1..] :: [Integer])
+	map (localStorage . ("local" </>) . show)
+		[1..100 :: Int]
 
 type UpdateProgress = IO ()
 
@@ -66,7 +68,7 @@ retrieveShards (StorageLocations locs) l = do
   where
 	go unusedlocs usedlocs [] shards = return (shards, usedlocs, unusedlocs)
 	go [] usedlocs _ shards = return (shards, usedlocs, [])
-	go (loc:otherlocs) usedlocs toretrieve@((updateprogress, (n, i)):rest) shards = do
+	go (loc:otherlocs) usedlocs (toretrieve@(updateprogress, (n, i)):rest) shards = do
 		r <- retrieveShard loc n i
 		case r of
 			RetrieveSuccess s -> do
@@ -74,11 +76,11 @@ retrieveShards (StorageLocations locs) l = do
 				go otherlocs (loc:usedlocs) rest (s:shards)
 			RetrieveFailure _ -> do
 				(shards', usedlocs', unusedlocs) <-
-					go otherlocs usedlocs toretrieve shards
+					go otherlocs usedlocs [toretrieve] shards
 				-- May need to ask the location that didn't
 				-- have the shard for a later shard, but
 				-- ask it last. This way, the first
 				-- location on the list can't deny having
 				-- all shards and so learn the idents of
 				-- all of them.
-				go (unusedlocs++[loc]) usedlocs' toretrieve shards'
+				go (unusedlocs++[loc]) usedlocs' rest shards'
-- 
cgit v1.2.3