maintain pools of running transferkeys processes (untested)

This commit is contained in:
Joey Hess 2013-03-19 18:46:29 -04:00
parent ef3221181d
commit b6d691aff7
7 changed files with 178 additions and 86 deletions

View file

@ -14,25 +14,23 @@ import Assistant.TransferSlots
import Assistant.Alert
import Assistant.Commits
import Assistant.Drop
import Assistant.TransferrerPool
import Logs.Transfer
import Logs.Location
import Annex.Content
import qualified Remote
import qualified Types.Remote as Remote
import qualified Git
import Types.Key
import Locations.UserConfig
import Assistant.Threads.TransferWatcher
import Annex.Wanted
import System.Process (create_group)
{- Dispatches transfers from the queue. -}
transfererThread :: NamedThread
transfererThread = namedThread "Transferrer" $ do
program <- liftIO readProgramFile
forever $ inTransferSlot $
maybe (return Nothing) (uncurry $ startTransfer program)
forever $ inTransferSlot program $
maybe (return Nothing) (uncurry $ genTransfer)
=<< getNextTransfer notrunning
where
{- Skip transfers that are already running. -}
@ -40,12 +38,8 @@ transfererThread = namedThread "Transferrer" $ do
{- By the time this is called, the daemonstatus's currentTransfers map should
- already have been updated to include the transfer. -}
startTransfer
:: FilePath
-> Transfer
-> TransferInfo
-> Assistant (Maybe (Transfer, TransferInfo, Assistant ()))
startTransfer program t info = case (transferRemote info, associatedFile info) of
genTransfer :: Transfer -> TransferInfo -> TransferGenerator
genTransfer t info = case (transferRemote info, associatedFile info) of
(Just remote, Just file)
| Git.repoIsLocalUnknown (Remote.repo remote) -> do
-- optimisation for removable drives not plugged in
@ -56,7 +50,7 @@ startTransfer program t info = case (transferRemote info, associatedFile info) o
( do
debug [ "Transferring:" , describeTransfer t info ]
notifyTransfer
return $ Just (t, info, transferprocess remote file)
return $ Just (t, info, go remote file)
, do
debug [ "Skipping unnecessary transfer:",
describeTransfer t info ]
@ -69,57 +63,40 @@ startTransfer program t info = case (transferRemote info, associatedFile info) o
direction = transferDirection t
isdownload = direction == Download
transferprocess remote file = void $ do
(_, _, _, pid)
<- liftIO $ createProcess
(proc program $ toCommand params)
{ create_group = True }
{- Alerts are only shown for successful transfers.
- Transfers can temporarily fail for many reasons,
- so there's no point in bothering the user about
- those. The assistant should recover.
-
- After a successful upload, handle dropping it from
- here, if desired. In this case, the remote it was
- uploaded to is known to have it.
-
- Also, after a successful transfer, the location
- log has changed. Indicate that a commit has been
- made, in order to queue a push of the git-annex
- branch out to remotes that did not participate
- in the transfer.
-
- If the process failed, it could have crashed,
- so remove the transfer from the list of current
- transfers, just in case it didn't stop
- in a way that lets the TransferWatcher do its
- usual cleanup.
-}
ifM (liftIO $ (==) ExitSuccess <$> waitForProcess pid)
( do
void $ addAlert $ makeAlertFiller True $
transferFileAlert direction True file
unless isdownload $
handleDrops
("object uploaded to " ++ show remote)
True (transferKey t)
(associatedFile info)
(Just remote)
recordCommit
, void $ removeTransfer t
)
where
params =
[ Param "transferkey"
, Param "--quiet"
, Param $ key2file $ transferKey t
, Param $ if isdownload
then "--from"
else "--to"
, Param $ Remote.name remote
, Param "--file"
, File file
]
{- Alerts are only shown for successful transfers.
- Transfers can temporarily fail for many reasons,
- so there's no point in bothering the user about
- those. The assistant should recover.
-
- After a successful upload, handle dropping it from
- here, if desired. In this case, the remote it was
- uploaded to is known to have it.
-
- Also, after a successful transfer, the location
- log has changed. Indicate that a commit has been
- made, in order to queue a push of the git-annex
- branch out to remotes that did not participate
- in the transfer.
-
- If the process failed, it could have crashed,
- so remove the transfer from the list of current
- transfers, just in case it didn't stop
- in a way that lets the TransferWatcher do its
- usual cleanup.
-}
go remote file transferrer = ifM (liftIO $ performTransfer transferrer t $ associatedFile info)
( do
void $ addAlert $ makeAlertFiller True $
transferFileAlert direction True file
unless isdownload $
handleDrops
("object uploaded to " ++ show remote)
True (transferKey t)
(associatedFile info)
(Just remote)
void $ recordCommit
, void $ removeTransfer t
)
{- Called right before a transfer begins, this is a last chance to avoid
- unnecessary transfers.