avoid queueing uploads to remotes that already have the content

diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs
index 5974c70d180ff2ee403f7b2c01beb06cd21a9625..5f68ba6284a858632cd98e3eee23cded9b4efbc0 100644 (file)
--- a/Assistant/TransferQueue.hs
+++ b/Assistant/TransferQueue.hs
@@ -32,6 +32,7 @@ import Annex.Wanted
 
 import Control.Concurrent.STM
 import qualified Data.Map as M
+import qualified Data.Set as S
 
 type Reason = String
 
@@ -58,6 +59,7 @@ queueTransfersMatching matching reason schedule k f direction
        | otherwise = go
   where
        go = do
+               
                rs <- liftAnnex . selectremotes
                        =<< syncDataRemotes <$> getDaemonStatus
                let matchingrs = filter (matching . Remote.uuid) rs
@@ -67,15 +69,21 @@ queueTransfersMatching matching reason schedule k f direction
                                enqueue reason schedule (gentransfer r) (stubInfo f r)
        selectremotes rs
                {- Queue downloads from all remotes that
-                - have the key, with the cheapest ones first.
-                - More expensive ones will only be tried if
-                - downloading from a cheap one fails. -}
+                - have the key. The list of remotes is ordered with
+                - cheapest first. More expensive ones will only be tried
+                - if downloading from a cheap one fails. -}
                | direction == Download = do
-                       uuids <- Remote.keyLocations k
-                       return $ filter (\r -> uuid r `elem` uuids) rs
-               {- Upload to all remotes that want the content. -}
-               | otherwise = filterM (wantSend True f . Remote.uuid) $
-                       filter (not . Remote.readonly) rs
+                       s <- locs
+                       return $ filter (inset s) rs
+               {- Upload to all remotes that want the content and don't
+                - already have it. -}
+               | otherwise = do
+                       s <- locs
+                       filterM (wantSend True f . Remote.uuid) $
+                               filter (\r -> not (inset s r || Remote.readonly r)) rs
+         where
+               locs = S.fromList <$> Remote.keyLocations k
+               inset s r = S.member (Remote.uuid r) s
        gentransfer r = Transfer
                { transferDirection = direction
                , transferKey = k

diff --git a/debian/changelog b/debian/changelog
index 2e29c2cee338fe40175b65b1e36b84595e2dac39..62c5ac62be8c9a7aada0c3932979bd9a3ebdcdef 100644 (file)
--- a/debian/changelog
+++ b/debian/changelog
@@ -27,6 +27,7 @@ git-annex (4.20130324) UNRELEASED; urgency=low
   * assistant: Fix bug that could cause direct mode files to be unstaged
     from git.
   * Update working tree files fully atomically.
+  * webapp: Improved transfer queue management.
 
  -- Joey Hess <joeyh@debian.org>  Mon, 25 Mar 2013 10:21:46 -0400