This commit is contained in:
Joey Hess 2012-09-17 14:58:43 -04:00
parent 1e37c0c5fc
commit 7a86dc9443
2 changed files with 17 additions and 18 deletions

View file

@ -65,35 +65,25 @@ transferScannerThread st dstatus scanremotes transferqueue = thread $ do
{- This is a cheap scan for failed transfers involving a remote. -} {- This is a cheap scan for failed transfers involving a remote. -}
failedTransferScan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO () failedTransferScan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO ()
failedTransferScan st dstatus transferqueue r = do failedTransferScan st dstatus transferqueue r = do
ts <- runThreadState st $ failed <- runThreadState st $ getFailedTransfers (Remote.uuid r)
getFailedTransfers $ Remote.uuid r runThreadState st $ mapM_ removeFailedTransfer $ map fst failed
go ts mapM_ retry failed
where where
go [] = noop retry (t, info)
go ((t, info):ts)
| transferDirection t == Download = do | transferDirection t == Download = do
{- Check if the remote still has the key. {- Check if the remote still has the key.
- If not, relies on the expensiveScan to - If not, relies on the expensiveScan to
- get it queued from some other remote. -} - get it queued from some other remote. -}
ifM (runThreadState st $ remoteHas r $ transferKey t) whenM (runThreadState st $ remoteHas r $ transferKey t) $
( requeue t info requeue t info
, dequeue t
)
go ts
| otherwise = do | otherwise = do
{- The Transferrer checks when uploading {- The Transferrer checks when uploading
- that the remote doesn't already have the - that the remote doesn't already have the
- key, so it's not redundantly checked - key, so it's not redundantly checked
- here. -} - here. -}
requeue t info requeue t info
go ts requeue t info = queueTransferWhenSmall
transferqueue dstatus (associatedFile info) t r
requeue t info = do
queueTransferWhenSmall
transferqueue dstatus (associatedFile info) t r
dequeue t
dequeue t = void $ runThreadState st $ inRepo $
liftIO . tryIO . removeFile . failedTransferFile t
{- This is a expensive scan through the full git work tree, finding {- This is a expensive scan through the full git work tree, finding
- files to download from or upload to any of the remotes. - files to download from or upload to any of the remotes.

View file

@ -10,6 +10,7 @@ module Logs.Transfer where
import Common.Annex import Common.Annex
import Annex.Perms import Annex.Perms
import Annex.Exception import Annex.Exception
import Annex.UUID
import qualified Git import qualified Git
import Types.Remote import Types.Remote
import Types.Key import Types.Key
@ -48,6 +49,9 @@ data TransferInfo = TransferInfo
} }
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
stubTransferInfo :: TransferInfo
stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing Nothing False
data Direction = Upload | Download data Direction = Upload | Download
deriving (Eq, Ord, Read, Show) deriving (Eq, Ord, Read, Show)
@ -164,6 +168,11 @@ getFailedTransfers u = catMaybes <$> (liftIO . getpairs =<< concat <$> findfiles
=<< mapM (fromRepo . failedTransferDir u) =<< mapM (fromRepo . failedTransferDir u)
[Download, Upload] [Download, Upload]
removeFailedTransfer :: Transfer -> Annex ()
removeFailedTransfer t = do
f <- fromRepo $ failedTransferFile t
liftIO $ void $ tryIO $ removeFile f
{- The transfer information file to use for a given Transfer. -} {- The transfer information file to use for a given Transfer. -}
transferFile :: Transfer -> Git.Repo -> FilePath transferFile :: Transfer -> Git.Repo -> FilePath
transferFile (Transfer direction u key) r = transferDir direction r transferFile (Transfer direction u key) r = transferDir direction r