diff options
author | Joey Hess <joey@kitenet.net> | 2012-08-28 17:17:09 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-08-28 17:17:09 -0400 |
commit | 0dd786039395637ad702f48c84eb8dcd323527f1 (patch) | |
tree | 984ef1af37824aafe6d4e1d57991a826ec702e81 /Assistant/Threads | |
parent | 19e8f1ca0e0b55910bf85fbbae72997618e4d2be (diff) |
fix a transfers display glitch
Run code that pops off the next queued transfer and adds it to the active
transfer map within an allocated transfer slot, rather than before
allocating a slot. Fixes the transfers display, which had been displaying
the next transfer as a running transfer, while the previous transfer was
still running.
Diffstat (limited to 'Assistant/Threads')
-rw-r--r-- | Assistant/Threads/Transferrer.hs | 51 |
1 files changed, 20 insertions, 31 deletions
diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index 9a772d628..d4c00afd8 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -33,21 +33,23 @@ maxTransfers = 1 transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> TransferSlots -> IO () transfererThread st dstatus transferqueue slots = go =<< readProgramFile where - go program = getNextTransfer transferqueue dstatus notrunning >>= handle program - handle program Nothing = go program - handle program (Just (t, info)) = do - ifM (runThreadState st $ shouldTransfer t info) - ( do - debug thisThread [ "Transferring:" , show t ] - notifyTransfer dstatus - transferThread dstatus slots t info inTransferSlot program - , do - debug thisThread [ "Skipping unnecessary transfer:" , show t ] - -- getNextTransfer added t to the - -- daemonstatus's transfer map. - void $ removeTransfer dstatus t - ) - go program + go program = forever $ inTransferSlot dstatus slots $ + getNextTransfer transferqueue dstatus notrunning + >>= handle program + handle _ Nothing = return Nothing + handle program (Just (t, info)) = ifM (runThreadState st $ shouldTransfer t info) + ( do + debug thisThread [ "Transferring:" , show t ] + notifyTransfer dstatus + let a = doTransfer dstatus t info program + return $ Just (t, info, a) + , do + debug thisThread [ "Skipping unnecessary transfer:" , show t ] + -- getNextTransfer added t to the + -- daemonstatus's transfer map. + void $ removeTransfer dstatus t + return Nothing + ) {- Skip transfers that are already running. -} notrunning i = startedTime i == Nothing @@ -70,24 +72,11 @@ shouldTransfer t info where key = transferKey t -{- A sepeate git-annex process is forked off to run a transfer, - - running in its own process group. This allows killing it and all its - - children if the user decides to cancel the transfer. - - - - A thread is forked off to run the process, and the thread - - occupies one of the transfer slots. If all slots are in use, this will - - block until one becomes available. The thread's id is also recorded in - - the transfer info; the thread will also be killed when a transfer is - - stopped, to avoid it displaying any alert about the transfer having - - failed. -} -transferThread :: DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> TransferSlotRunner -> FilePath -> IO () -transferThread dstatus slots t info runner program = case (transferRemote info, associatedFile info) of +doTransfer :: DaemonStatusHandle -> Transfer -> TransferInfo -> FilePath -> IO () +doTransfer dstatus t info program = case (transferRemote info, associatedFile info) of (Nothing, _) -> noop (_, Nothing) -> noop - (Just remote, Just file) -> do - tid <- runner slots $ - transferprocess remote file - updateTransferInfo dstatus t $ info { transferTid = Just tid } + (Just remote, Just file) -> transferprocess remote file where direction = transferDirection t isdownload = direction == Download |