transfer canceling

Should work (untested) for transfers being run by other processes.

Not yet by transfers being run by the assistant. killThread does not
kill processes forked off by a thread. To fix this, will probably
need to make `git annex getkey` and `git annex sendkey` commands that
operate on keys, and write their own transfer info. Then the assistant
can run them, and kill them, as needed.
This commit is contained in:
Joey Hess 2012-08-08 17:55:56 -04:00
parent 09449792fa
commit 20203b45b9
3 changed files with 34 additions and 5 deletions

View file

@ -13,7 +13,8 @@ module Assistant.TransferQueue (
queueTransfers,
queueTransfer,
queueTransferAt,
getNextTransfer
getNextTransfer,
dequeueTransfer,
) where
import Common.Annex
@ -30,7 +31,7 @@ import qualified Data.Map as M
- in parallel to allow for reading. -}
data TransferQueue = TransferQueue
{ queue :: TChan (Transfer, TransferInfo)
, queuesize :: TVar Integer
, queuesize :: TVar Int
, queuelist :: TVar [(Transfer, TransferInfo)]
}
@ -104,7 +105,7 @@ queueTransfer schedule q dstatus f t remote =
{- Blocks until the queue is no larger than a given size, and then adds a
- transfer to the queue. -}
queueTransferAt :: Integer -> Schedule -> TransferQueue -> DaemonStatusHandle -> AssociatedFile -> Transfer -> Remote -> IO ()
queueTransferAt :: Int -> Schedule -> TransferQueue -> DaemonStatusHandle -> AssociatedFile -> Transfer -> Remote -> IO ()
queueTransferAt wantsz schedule q dstatus f t remote = do
atomically $ do
sz <- readTVar (queuesize q)
@ -132,3 +133,12 @@ getNextTransfer q dstatus acceptable = atomically $ do
M.insertWith' const t info
return $ Just r
else return Nothing
{- Removes a transfer from the queue, if present, and returns True if it
- was present. -}
dequeueTransfer :: TransferQueue -> Transfer -> IO Bool
dequeueTransfer q t = atomically $ do
(l, removed) <- partition (\i -> fst i /= t) <$> readTVar (queuelist q)
void $ writeTVar (queuesize q) (length l)
void $ writeTVar (queuelist q) l
return $ not $ null removed