From 8d32d54320d148e965f26d87d33694d7e8df5171 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 29 Aug 2012 16:30:40 -0400 Subject: make start button work on queued transfers When multiple downloads of a key are queued, it starts the first, but leaves the other downloads in the queue. This ensures that we don't lose a queued download if the one that got started failed. --- Assistant/Threads/Transferrer.hs | 76 +++++++++++++++++++--------------------- Assistant/TransferQueue.hs | 29 ++++++++++----- Assistant/WebApp/DashBoard.hs | 12 +++++-- 3 files changed, 66 insertions(+), 51 deletions(-) diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index db147ee10..525b02637 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -34,49 +34,26 @@ transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Transf transfererThread st dstatus transferqueue slots = go =<< readProgramFile where 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 - ) + maybe (return Nothing) (uncurry $ startTransfer st dstatus program) + =<< getNextTransfer transferqueue dstatus notrunning {- Skip transfers that are already running. -} notrunning i = startedTime i == Nothing -{- Checks if the file to download is already present, or the remote - - being uploaded to isn't known to have the file. -} -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 - key = transferKey t - -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) -> transferprocess remote file +{- By the time this is called, the daemonstatis's transfer map should + - already have been updated to include the transfer. -} +startTransfer :: ThreadState -> DaemonStatusHandle -> FilePath -> Transfer -> TransferInfo -> TransferGenerator +startTransfer st dstatus program t info = case (transferRemote info, associatedFile info) of + (Just remote, Just file) -> ifM (runThreadState st $ shouldTransfer t info) + ( do + debug thisThread [ "Transferring:" , show t ] + notifyTransfer dstatus + return $ Just (t, info, transferprocess remote file) + , do + debug thisThread [ "Skipping unnecessary transfer:" , show t ] + void $ removeTransfer dstatus t + return Nothing + ) + _ -> return Nothing where direction = transferDirection t isdownload = direction == Download @@ -101,3 +78,22 @@ doTransfer dstatus t info program = case (transferRemote info, associatedFile in , Param "--file" , File file ] + +{- Checks if the file to download is already present, or the remote + - being uploaded to isn't known to have the file. -} +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 + key = transferKey t diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs index ff202d11a..7d13406a6 100644 --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -15,6 +15,7 @@ module Assistant.TransferQueue ( queueTransferAt, queueTransferWhenSmall, getNextTransfer, + getMatchingTransfers, dequeueTransfers, ) where @@ -140,20 +141,32 @@ getNextTransfer q dstatus acceptable = atomically $ do return $ Just r else return Nothing +{- Moves transfers matching a condition from the queue, to the + - currentTransfers map. -} +getMatchingTransfers :: TransferQueue -> DaemonStatusHandle -> (Transfer -> Bool) -> IO [(Transfer, TransferInfo)] +getMatchingTransfers q dstatus c = atomically $ do + ts <- dequeueTransfersSTM q c + unless (null ts) $ + adjustTransfersSTM dstatus $ \m -> M.union m $ M.fromList ts + return ts + {- Removes transfers matching a condition from the queue, and returns the - removed transfers. -} dequeueTransfers :: TransferQueue -> DaemonStatusHandle -> (Transfer -> Bool) -> IO [(Transfer, TransferInfo)] dequeueTransfers q dstatus c = do - removed <- atomically $ do - (removed, ls) <- partition (c . fst) - <$> readTVar (queuelist q) - void $ writeTVar (queuesize q) (length ls) - void $ writeTVar (queuelist q) ls - drain - forM_ ls $ unGetTChan (queue q) - return removed + removed <- atomically $ dequeueTransfersSTM q c unless (null removed) $ notifyTransfer dstatus return removed + +dequeueTransfersSTM :: TransferQueue -> (Transfer -> Bool) -> STM [(Transfer, TransferInfo)] +dequeueTransfersSTM q c = do + (removed, ts) <- partition (c . fst) + <$> readTVar (queuelist q) + void $ writeTVar (queuesize q) (length ts) + void $ writeTVar (queuelist q) ts + drain + forM_ ts $ unGetTChan (queue q) + return removed where drain = maybe noop (const drain) =<< tryReadTChan (queue q) diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index 10a6deb5f..ffe967111 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -209,8 +209,14 @@ cancelTransfer pause t = do startTransfer :: Transfer -> Handler () startTransfer t = do m <- getCurrentTransfers + webapp <- getYesod + let dstatus = daemonStatus webapp + let q = transferQueue webapp + {- resume a paused transfer -} maybe noop go (M.lookup t m) - -- TODO: handle starting a queued transfer + {- start a queued transfer -} + is <- liftIO $ map snd <$> getMatchingTransfers q dstatus (== t) + maybe noop start $ headMaybe is where go info = maybe (start info) (resume info) $ transferTid info resume info tid = do @@ -222,6 +228,7 @@ startTransfer t = do throwTo tid ResumeTransfer start info = do webapp <- getYesod + let st = fromJust $ threadState webapp let dstatus = daemonStatus webapp let slots = transferSlots webapp {- This transfer was being run by another process, @@ -230,8 +237,7 @@ startTransfer t = do { transferPid = Nothing, transferPaused = False } liftIO $ inImmediateTransferSlot dstatus slots $ do program <- readProgramFile - let a = Transferrer.doTransfer dstatus t info program - return $ Just (t, info, a) + Transferrer.startTransfer st dstatus program t info getCurrentTransfers :: Handler TransferMap getCurrentTransfers = currentTransfers -- cgit v1.2.3