mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

avoid queuing transfers that are currently running

Browse source
This commit is contained in:
Joey Hess 2013-04-02 16:17:06 -04:00
parent 1f4fe92f61
commit 69a80a9a4d
2 changed files with 17 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

5
Assistant/DaemonStatus.hs
View file

@ -151,6 +151,11 @@ adjustTransfersSTM dstatus a = do
s <- takeTMVar dstatus s <- takeTMVar dstatus
putTMVar dstatus $ s { currentTransfers = a (currentTransfers s) } putTMVar dstatus $ s { currentTransfers = a (currentTransfers s) }
{- Checks if a transfer is currently running. -}
checkRunningTransferSTM :: DaemonStatusHandle -> Transfer -> STM Bool
checkRunningTransferSTM dstatus t = M.member t . currentTransfers
<$> readTMVar dstatus
{- Alters a transfer's info, if the transfer is in the map. -} {- Alters a transfer's info, if the transfer is in the map. -}
alterTransferInfo :: Transfer -> (TransferInfo -> TransferInfo) -> Assistant () alterTransferInfo :: Transfer -> (TransferInfo -> TransferInfo) -> Assistant ()
alterTransferInfo t a = updateTransferInfo' $ M.adjust a t alterTransferInfo t a = updateTransferInfo' $ M.adjust a t

6
Assistant/TransferQueue.hs
View file

@ -136,7 +136,10 @@ enqueue reason schedule t info
notifyTransfer notifyTransfer
add modlist = do add modlist = do
q <- getAssistant transferQueue q <- getAssistant transferQueue
liftIO $ atomically $ do dstatus <- getAssistant daemonStatusHandle
liftIO $ atomically $ ifM (checkRunningTransferSTM dstatus t)
( return False
, do
l <- readTVar (queuelist q) l <- readTVar (queuelist q)
if (t `notElem` map fst l) if (t `notElem` map fst l)
then do then do
@ -144,6 +147,7 @@ enqueue reason schedule t info
void $ modifyTVar' (queuelist q) modlist void $ modifyTVar' (queuelist q) modlist
return True return True
else return False else return False
)
{- Adds a transfer to the queue. -} {- Adds a transfer to the queue. -}
queueTransfer :: Reason -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant () queueTransfer :: Reason -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()