summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Assistant/Threads/Transferrer.hs43
-rw-r--r--Assistant/TransferQueue.hs26
2 files changed, 37 insertions, 32 deletions
diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs
index a801556db..956e0fc9d 100644
--- a/Assistant/Threads/Transferrer.hs
+++ b/Assistant/Threads/Transferrer.hs
@@ -33,9 +33,10 @@ maxTransfers = 1
transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> TransferSlots -> IO ()
transfererThread st dstatus transferqueue slots = go
where
- go = do
- (t, info) <- getNextTransfer transferqueue dstatus
- ifM (runThreadState st $ shouldTransfer dstatus t info)
+ go = getNextTransfer transferqueue dstatus notrunning >>= handle
+ handle Nothing = go
+ handle (Just (t, info)) = do
+ ifM (runThreadState st $ shouldTransfer t info)
( do
debug thisThread [ "Transferring:" , show t ]
notifyTransfer dstatus
@@ -47,28 +48,26 @@ transfererThread st dstatus transferqueue slots = go
void $ removeTransfer dstatus t
)
go
+ {- Skip transfers that are already running. -}
+ notrunning i = startedTime i == Nothing
-{- Checks if the requested transfer is already running, or
- - the file to download is already present, or the remote
+{- Checks if the file to download is already present, or the remote
- being uploaded to isn't known to have the file. -}
-shouldTransfer :: DaemonStatusHandle -> Transfer -> TransferInfo -> Annex Bool
-shouldTransfer dstatus t info =
- go =<< currentTransfers <$> liftIO (getDaemonStatus dstatus)
+shouldTransfer :: Transfer -> TransferInfo -> Annex Bool
+shouldTransfer t info
+ | transferDirection t == Download =
+ not <$> inAnnex key
+ | transferDirection t == Upload =
+ {- Trust the location log to check if the
+ - remote already has the key. This avoids
+ - a roundtrip to the remote. -}
+ case transferRemote info of
+ Nothing -> return False
+ Just remote ->
+ notElem (Remote.uuid remote)
+ <$> loggedLocations key
+ | otherwise = return False
where
- go m
- | M.member t m = return False
- | transferDirection t == Download =
- not <$> inAnnex key
- | transferDirection t == Upload =
- {- Trust the location log to check if the
- - remote already has the key. This avoids
- - a roundtrip to the remote. -}
- case transferRemote info of
- Nothing -> return False
- Just remote ->
- notElem (Remote.uuid remote)
- <$> loggedLocations key
- | otherwise = return False
key = transferKey t
{- A transfer is run in a separate thread, with a *copy* of the Annex
diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs
index 01c159b08..40adc3520 100644
--- a/Assistant/TransferQueue.hs
+++ b/Assistant/TransferQueue.hs
@@ -113,16 +113,22 @@ queueTransferAt wantsz schedule q dstatus f t remote = do
else retry -- blocks until queuesize changes
enqueue schedule q dstatus t (stubInfo f remote)
-{- Blocks until a pending transfer is available from the queue.
- - The transfer is removed from the transfer queue, and added to
- - the daemon status currentTransfers map. This is done in a single STM
- - transaction, so there is no window where an observer sees an
- - inconsistent status. -}
-getNextTransfer :: TransferQueue -> DaemonStatusHandle -> IO (Transfer, TransferInfo)
-getNextTransfer q dstatus = atomically $ do
+{- Blocks until a pending transfer is available from the queue,
+ - and removes it.
+ -
+ - Checks that it's acceptable, before adding it to the
+ - the currentTransfers map. If it's not acceptable, it's discarded.
+ -
+ - This is done in a single STM transaction, so there is no window
+ - where an observer sees an inconsistent status. -}
+getNextTransfer :: TransferQueue -> DaemonStatusHandle -> (TransferInfo -> Bool) -> IO (Maybe (Transfer, TransferInfo))
+getNextTransfer q dstatus acceptable = atomically $ do
void $ modifyTVar' (queuesize q) pred
void $ modifyTVar' (queuelist q) (drop 1)
r@(t, info) <- readTChan (queue q)
- adjustTransfersSTM dstatus $
- M.insertWith' const t info
- return r
+ if acceptable info
+ then do
+ adjustTransfersSTM dstatus $
+ M.insertWith' const t info
+ return $ Just r
+ else return Nothing