This commit is contained in:
Joey Hess 2013-03-13 13:05:30 -04:00
parent f39dc54644
commit 60760cb430
2 changed files with 15 additions and 8 deletions

View file

@ -35,9 +35,13 @@ transfererThread = namedThread "Transferrer" $ do
{- Skip transfers that are already running. -} {- Skip transfers that are already running. -}
notrunning = isNothing . startedTime notrunning = isNothing . startedTime
{- By the time this is called, the daemonstatus's transfer map should {- By the time this is called, the daemonstatus's currentTransfers map should
- already have been updated to include the transfer. -} - already have been updated to include the transfer. -}
startTransfer :: FilePath -> Transfer -> TransferInfo -> Assistant (Maybe (Transfer, TransferInfo, Assistant ())) startTransfer
:: FilePath
-> Transfer
-> TransferInfo
-> Assistant (Maybe (Transfer, TransferInfo, Assistant ()))
startTransfer program t info = case (transferRemote info, associatedFile info) of startTransfer program t info = case (transferRemote info, associatedFile info) of
(Just remote, Just file) -> ifM (liftAnnex $ shouldTransfer t info) (Just remote, Just file) -> ifM (liftAnnex $ shouldTransfer t info)
( do ( do
@ -45,7 +49,8 @@ startTransfer program t info = case (transferRemote info, associatedFile info) o
notifyTransfer notifyTransfer
return $ Just (t, info, transferprocess remote file) return $ Just (t, info, transferprocess remote file)
, do , do
debug [ "Skipping unnecessary transfer:" , describeTransfer t info ] debug [ "Skipping unnecessary transfer:",
describeTransfer t info ]
void $ removeTransfer t void $ removeTransfer t
finishedTransfer t (Just info) finishedTransfer t (Just info)
return Nothing return Nothing
@ -57,7 +62,8 @@ startTransfer program t info = case (transferRemote info, associatedFile info) o
transferprocess remote file = void $ do transferprocess remote file = void $ do
(_, _, _, pid) (_, _, _, pid)
<- liftIO $ createProcess (proc program $ toCommand params) <- liftIO $ createProcess
(proc program $ toCommand params)
{ create_group = True } { create_group = True }
{- Alerts are only shown for successful transfers. {- Alerts are only shown for successful transfers.
- Transfers can temporarily fail for many reasons, - Transfers can temporarily fail for many reasons,

View file

@ -58,14 +58,14 @@ queueTransfersMatching matching reason schedule k f direction
| otherwise = go | otherwise = go
where where
go = do go = do
rs <- liftAnnex . sufficientremotes rs <- liftAnnex . selectremotes
=<< syncDataRemotes <$> getDaemonStatus =<< syncDataRemotes <$> getDaemonStatus
let matchingrs = filter (matching . Remote.uuid) rs let matchingrs = filter (matching . Remote.uuid) rs
if null matchingrs if null matchingrs
then defer then defer
else forM_ matchingrs $ \r -> else forM_ matchingrs $ \r ->
enqueue reason schedule (gentransfer r) (stubInfo f r) enqueue reason schedule (gentransfer r) (stubInfo f r)
sufficientremotes rs selectremotes rs
{- Queue downloads from all remotes that {- Queue downloads from all remotes that
- have the key, with the cheapest ones first. - have the key, with the cheapest ones first.
- More expensive ones will only be tried if - More expensive ones will only be tried if
@ -107,7 +107,8 @@ queueDeferredDownloads reason schedule = do
let sources = filter (\r -> uuid r `elem` uuids) rs let sources = filter (\r -> uuid r `elem` uuids) rs
unless (null sources) $ unless (null sources) $
forM_ sources $ \r -> forM_ sources $ \r ->
enqueue reason schedule (gentransfer r) (stubInfo f r) enqueue reason schedule
(gentransfer r) (stubInfo f r)
return $ null sources return $ null sources
where where
gentransfer r = Transfer gentransfer r = Transfer