diff options
| -rw-r--r-- | Assistant/Threads/Transferrer.hs | 43 | ||||
| -rw-r--r-- | Assistant/TransferQueue.hs | 26 |
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 |