From 0a3eb9be07a7514f5544384bc914f22ea88c24a8 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 14 Sep 2016 14:02:29 -0400
Subject: Warn when uploads fail and are put in the upload queue.

---
 Storage.hs | 53 ++++++++++++++++++++++++++++++++---------------------
 1 file changed, 32 insertions(+), 21 deletions(-)

(limited to 'Storage.hs')

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
-- 
cgit v1.2.3