2012-07-06 20:39:07 +00:00
|
|
|
{- git-annex assistant transfer slots
|
|
|
|
-
|
2020-12-07 17:08:59 +00:00
|
|
|
- Copyright 2012-2020 Joey Hess <id@joeyh.name>
|
2012-07-06 20:39:07 +00:00
|
|
|
-
|
2019-03-13 19:48:14 +00:00
|
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
2012-07-06 20:39:07 +00:00
|
|
|
-}
|
|
|
|
|
2013-11-12 18:54:02 +00:00
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
|
2012-07-06 20:39:07 +00:00
|
|
|
module Assistant.TransferSlots where
|
|
|
|
|
2020-12-07 17:08:59 +00:00
|
|
|
import Control.Concurrent.STM
|
|
|
|
|
2012-10-30 18:34:48 +00:00
|
|
|
import Assistant.Common
|
2012-08-28 21:17:09 +00:00
|
|
|
import Utility.ThreadScheduler
|
2020-12-07 17:08:59 +00:00
|
|
|
import Utility.NotificationBroadcaster
|
2012-10-30 18:34:48 +00:00
|
|
|
import Assistant.Types.TransferSlots
|
2012-08-28 21:17:09 +00:00
|
|
|
import Assistant.DaemonStatus
|
2020-12-07 16:50:48 +00:00
|
|
|
import Annex.TransferrerPool
|
2020-12-07 17:08:59 +00:00
|
|
|
import Types.TransferrerPool
|
2013-10-26 20:54:49 +00:00
|
|
|
import Assistant.Types.TransferQueue
|
|
|
|
import Assistant.TransferQueue
|
|
|
|
import Assistant.Alert
|
|
|
|
import Assistant.Alert.Utility
|
|
|
|
import Assistant.Commits
|
|
|
|
import Assistant.Drop
|
2016-08-03 16:37:12 +00:00
|
|
|
import Types.Transfer
|
2012-08-28 21:17:09 +00:00
|
|
|
import Logs.Transfer
|
2013-10-26 20:54:49 +00:00
|
|
|
import Logs.Location
|
|
|
|
import qualified Git
|
2020-12-07 17:08:59 +00:00
|
|
|
import qualified Annex
|
2013-10-26 20:54:49 +00:00
|
|
|
import qualified Remote
|
|
|
|
import qualified Types.Remote as Remote
|
|
|
|
import Annex.Content
|
|
|
|
import Annex.Wanted
|
2024-01-19 19:14:26 +00:00
|
|
|
import Annex.StallDetection
|
2013-12-01 19:37:51 +00:00
|
|
|
import Utility.Batch
|
2015-10-08 20:55:11 +00:00
|
|
|
import Types.NumCopies
|
2012-08-28 21:17:09 +00:00
|
|
|
|
2020-12-08 19:22:18 +00:00
|
|
|
import Data.Either
|
2013-10-26 20:54:49 +00:00
|
|
|
import qualified Data.Map as M
|
2012-08-10 22:42:44 +00:00
|
|
|
import qualified Control.Exception as E
|
2012-07-06 20:39:07 +00:00
|
|
|
import Control.Concurrent
|
2012-10-05 21:02:51 +00:00
|
|
|
import qualified Control.Concurrent.MSemN as MSemN
|
2013-11-12 18:54:02 +00:00
|
|
|
#ifndef mingw32_HOST_OS
|
2013-10-26 20:54:49 +00:00
|
|
|
import System.Posix.Process (getProcessGroupIDOf)
|
2013-11-12 18:54:02 +00:00
|
|
|
import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
|
2013-12-11 03:19:18 +00:00
|
|
|
#else
|
2017-10-25 23:46:28 +00:00
|
|
|
import System.Win32.Process (terminateProcessById)
|
2013-11-12 18:54:02 +00:00
|
|
|
#endif
|
2012-07-06 20:39:07 +00:00
|
|
|
|
2013-03-19 22:46:29 +00:00
|
|
|
type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()))
|
2012-10-30 19:39:15 +00:00
|
|
|
|
2012-08-28 21:17:09 +00:00
|
|
|
{- Waits until a transfer slot becomes available, then runs a
|
|
|
|
- TransferGenerator, and then runs the transfer action in its own thread.
|
2012-08-12 16:36:08 +00:00
|
|
|
-}
|
propagate git-annex -c on to transferrer child process
git -c was already propagated via environment, but need this for
consistency.
Also, notice it does not use gitAnnexChildProcess to run the
transferrer. So nothing is done about avoid it taking the
pid lock. It's possible that the caller is already doing something that
took the pid lock, and if so, the transferrer will certianly fail,
since it needs to take the pid lock too. This may prevent combining
annex.stalldetection with annex.pidlock, but I have not verified it's
really a problem. If it was, it seems git-annex would have to take
the pid lock when starting a transferrer, and hold it until shutdown,
or would need to take pid lock when starting to use a transferrer,
and hold it until done with a transfer and then drop it. The latter
would require starting the transferrer with pid locking disabled for the
child process, so assumes that the transferrer does not do anyting that
needs locking when not running a transfer.
2020-12-15 15:36:25 +00:00
|
|
|
inTransferSlot :: RunTransferrer -> TransferGenerator -> Assistant ()
|
|
|
|
inTransferSlot rt gen = do
|
2012-10-30 19:39:15 +00:00
|
|
|
flip MSemN.wait 1 <<~ transferSlots
|
propagate git-annex -c on to transferrer child process
git -c was already propagated via environment, but need this for
consistency.
Also, notice it does not use gitAnnexChildProcess to run the
transferrer. So nothing is done about avoid it taking the
pid lock. It's possible that the caller is already doing something that
took the pid lock, and if so, the transferrer will certianly fail,
since it needs to take the pid lock too. This may prevent combining
annex.stalldetection with annex.pidlock, but I have not verified it's
really a problem. If it was, it seems git-annex would have to take
the pid lock when starting a transferrer, and hold it until shutdown,
or would need to take pid lock when starting to use a transferrer,
and hold it until done with a transfer and then drop it. The latter
would require starting the transferrer with pid locking disabled for the
child process, so assumes that the transferrer does not do anyting that
needs locking when not running a transfer.
2020-12-15 15:36:25 +00:00
|
|
|
runTransferThread rt =<< gen
|
2012-08-12 16:36:08 +00:00
|
|
|
|
2012-08-28 21:17:09 +00:00
|
|
|
{- Runs a TransferGenerator, and its transfer action,
|
|
|
|
- without waiting for a slot to become available. -}
|
propagate git-annex -c on to transferrer child process
git -c was already propagated via environment, but need this for
consistency.
Also, notice it does not use gitAnnexChildProcess to run the
transferrer. So nothing is done about avoid it taking the
pid lock. It's possible that the caller is already doing something that
took the pid lock, and if so, the transferrer will certianly fail,
since it needs to take the pid lock too. This may prevent combining
annex.stalldetection with annex.pidlock, but I have not verified it's
really a problem. If it was, it seems git-annex would have to take
the pid lock when starting a transferrer, and hold it until shutdown,
or would need to take pid lock when starting to use a transferrer,
and hold it until done with a transfer and then drop it. The latter
would require starting the transferrer with pid locking disabled for the
child process, so assumes that the transferrer does not do anyting that
needs locking when not running a transfer.
2020-12-15 15:36:25 +00:00
|
|
|
inImmediateTransferSlot :: RunTransferrer -> TransferGenerator -> Assistant ()
|
|
|
|
inImmediateTransferSlot rt gen = do
|
2012-10-30 19:39:15 +00:00
|
|
|
flip MSemN.signal (-1) <<~ transferSlots
|
propagate git-annex -c on to transferrer child process
git -c was already propagated via environment, but need this for
consistency.
Also, notice it does not use gitAnnexChildProcess to run the
transferrer. So nothing is done about avoid it taking the
pid lock. It's possible that the caller is already doing something that
took the pid lock, and if so, the transferrer will certianly fail,
since it needs to take the pid lock too. This may prevent combining
annex.stalldetection with annex.pidlock, but I have not verified it's
really a problem. If it was, it seems git-annex would have to take
the pid lock when starting a transferrer, and hold it until shutdown,
or would need to take pid lock when starting to use a transferrer,
and hold it until done with a transfer and then drop it. The latter
would require starting the transferrer with pid locking disabled for the
child process, so assumes that the transferrer does not do anyting that
needs locking when not running a transfer.
2020-12-15 15:36:25 +00:00
|
|
|
runTransferThread rt =<< gen
|
2012-08-12 16:36:08 +00:00
|
|
|
|
2012-08-28 21:17:09 +00:00
|
|
|
{- Runs a transfer action, in an already allocated transfer slot.
|
|
|
|
- Once it finishes, frees the transfer slot.
|
|
|
|
-
|
|
|
|
- Note that the action is subject to being killed when the transfer
|
2012-08-10 22:42:44 +00:00
|
|
|
- is canceled or paused.
|
|
|
|
-
|
|
|
|
- A PauseTransfer exception is handled by letting the action be killed,
|
|
|
|
- then pausing the thread until a ResumeTransfer exception is raised,
|
|
|
|
- then rerunning the action.
|
|
|
|
-}
|
propagate git-annex -c on to transferrer child process
git -c was already propagated via environment, but need this for
consistency.
Also, notice it does not use gitAnnexChildProcess to run the
transferrer. So nothing is done about avoid it taking the
pid lock. It's possible that the caller is already doing something that
took the pid lock, and if so, the transferrer will certianly fail,
since it needs to take the pid lock too. This may prevent combining
annex.stalldetection with annex.pidlock, but I have not verified it's
really a problem. If it was, it seems git-annex would have to take
the pid lock when starting a transferrer, and hold it until shutdown,
or would need to take pid lock when starting to use a transferrer,
and hold it until done with a transfer and then drop it. The latter
would require starting the transferrer with pid locking disabled for the
child process, so assumes that the transferrer does not do anyting that
needs locking when not running a transfer.
2020-12-15 15:36:25 +00:00
|
|
|
runTransferThread :: RunTransferrer -> Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()) -> Assistant ()
|
|
|
|
runTransferThread _ Nothing = flip MSemN.signal 1 <<~ transferSlots
|
|
|
|
runTransferThread rt (Just (t, info, a)) = do
|
2012-10-30 19:39:15 +00:00
|
|
|
d <- getAssistant id
|
2020-12-07 17:08:59 +00:00
|
|
|
mkcheck <- checkNetworkConnections
|
|
|
|
<$> getAssistant daemonStatusHandle
|
2013-03-19 22:46:29 +00:00
|
|
|
aio <- asIO1 a
|
propagate git-annex -c on to transferrer child process
git -c was already propagated via environment, but need this for
consistency.
Also, notice it does not use gitAnnexChildProcess to run the
transferrer. So nothing is done about avoid it taking the
pid lock. It's possible that the caller is already doing something that
took the pid lock, and if so, the transferrer will certianly fail,
since it needs to take the pid lock too. This may prevent combining
annex.stalldetection with annex.pidlock, but I have not verified it's
really a problem. If it was, it seems git-annex would have to take
the pid lock when starting a transferrer, and hold it until shutdown,
or would need to take pid lock when starting to use a transferrer,
and hold it until done with a transfer and then drop it. The latter
would require starting the transferrer with pid locking disabled for the
child process, so assumes that the transferrer does not do anyting that
needs locking when not running a transfer.
2020-12-15 15:36:25 +00:00
|
|
|
tid <- liftIO $ forkIO $ runTransferThread' mkcheck rt d aio
|
2012-10-30 19:39:15 +00:00
|
|
|
updateTransferInfo t $ info { transferTid = Just tid }
|
2012-10-30 21:14:26 +00:00
|
|
|
|
propagate git-annex -c on to transferrer child process
git -c was already propagated via environment, but need this for
consistency.
Also, notice it does not use gitAnnexChildProcess to run the
transferrer. So nothing is done about avoid it taking the
pid lock. It's possible that the caller is already doing something that
took the pid lock, and if so, the transferrer will certianly fail,
since it needs to take the pid lock too. This may prevent combining
annex.stalldetection with annex.pidlock, but I have not verified it's
really a problem. If it was, it seems git-annex would have to take
the pid lock when starting a transferrer, and hold it until shutdown,
or would need to take pid lock when starting to use a transferrer,
and hold it until done with a transfer and then drop it. The latter
would require starting the transferrer with pid locking disabled for the
child process, so assumes that the transferrer does not do anyting that
needs locking when not running a transfer.
2020-12-15 15:36:25 +00:00
|
|
|
runTransferThread' :: MkCheckTransferrer -> RunTransferrer -> AssistantData -> (Transferrer -> IO ()) -> IO ()
|
|
|
|
runTransferThread' mkcheck rt d run = go
|
2012-10-31 06:34:03 +00:00
|
|
|
where
|
2020-12-07 17:08:59 +00:00
|
|
|
go = catchPauseResume $ do
|
|
|
|
p <- runAssistant d $ liftAnnex $
|
2021-04-02 19:26:21 +00:00
|
|
|
Annex.getRead Annex.transferrerpool
|
2020-12-11 19:28:58 +00:00
|
|
|
signalactonsvar <- runAssistant d $ liftAnnex $
|
2021-04-02 19:26:21 +00:00
|
|
|
Annex.getRead Annex.signalactions
|
propagate git-annex -c on to transferrer child process
git -c was already propagated via environment, but need this for
consistency.
Also, notice it does not use gitAnnexChildProcess to run the
transferrer. So nothing is done about avoid it taking the
pid lock. It's possible that the caller is already doing something that
took the pid lock, and if so, the transferrer will certianly fail,
since it needs to take the pid lock too. This may prevent combining
annex.stalldetection with annex.pidlock, but I have not verified it's
really a problem. If it was, it seems git-annex would have to take
the pid lock when starting a transferrer, and hold it until shutdown,
or would need to take pid lock when starting to use a transferrer,
and hold it until done with a transfer and then drop it. The latter
would require starting the transferrer with pid locking disabled for the
child process, so assumes that the transferrer does not do anyting that
needs locking when not running a transfer.
2020-12-15 15:36:25 +00:00
|
|
|
withTransferrer' True signalactonsvar mkcheck rt p run
|
2013-03-19 22:46:29 +00:00
|
|
|
pause = catchPauseResume $
|
|
|
|
runEvery (Seconds 86400) noop
|
2012-10-31 06:34:03 +00:00
|
|
|
{- Note: This must use E.try, rather than E.catch.
|
|
|
|
- When E.catch is used, and has called go in its exception
|
|
|
|
- handler, Control.Concurrent.throwTo will block sometimes
|
|
|
|
- when signaling. Using E.try avoids the problem. -}
|
|
|
|
catchPauseResume a' = do
|
|
|
|
r <- E.try a' :: IO (Either E.SomeException ())
|
|
|
|
case r of
|
|
|
|
Left e -> case E.fromException e of
|
|
|
|
Just PauseTransfer -> pause
|
|
|
|
Just ResumeTransfer -> go
|
2012-10-30 21:14:26 +00:00
|
|
|
_ -> done
|
2012-10-31 06:34:03 +00:00
|
|
|
_ -> done
|
2012-11-05 23:39:08 +00:00
|
|
|
done = runAssistant d $
|
2012-10-31 06:34:03 +00:00
|
|
|
flip MSemN.signal 1 <<~ transferSlots
|
2013-10-26 20:54:49 +00:00
|
|
|
|
|
|
|
{- By the time this is called, the daemonstatus's currentTransfers map should
|
|
|
|
- already have been updated to include the transfer. -}
|
|
|
|
genTransfer :: Transfer -> TransferInfo -> TransferGenerator
|
2014-01-23 20:37:08 +00:00
|
|
|
genTransfer t info = case transferRemote info of
|
2018-06-04 18:31:55 +00:00
|
|
|
Just remote -> ifM (unpluggedremovabledrive remote)
|
|
|
|
( do
|
|
|
|
-- optimisation, since the transfer would fail
|
2013-10-26 20:54:49 +00:00
|
|
|
liftAnnex $ recordFailedTransfer t info
|
|
|
|
void $ removeTransfer t
|
|
|
|
return Nothing
|
2018-06-04 18:31:55 +00:00
|
|
|
, ifM (liftAnnex $ shouldTransfer t info)
|
2013-10-26 20:54:49 +00:00
|
|
|
( do
|
git style filename quoting controlled by core.quotePath
This is by no means complete, but escaping filenames in actionItemDesc does
cover most commands.
Note that for ActionItemBranchFilePath, the value is branch:file, and I
choose to only quote the file part (if necessary). I considered quoting the
whole thing. But, branch names cannot contain control characters, and while
they can contain unicode, git coes not quote unicode when displaying branch
names. So, it would be surprising for git-annex to quote unicode in a
branch name.
The find command is the most obvious command that still needs to be
dealt with. There are probably other places that filenames also get
displayed, eg embedded in error messages.
Some other commands use ActionItemOther with a filename, I think that
ActionItemOther should either be pre-sanitized, or should explicitly not
be used for filenames, so that needs more work.
When --json is used, unicode does not get escaped, but control
characters were already escaped in json.
(Key escaping may turn out to be needed, but I'm ignoring that for now.)
Sponsored-by: unqueued on Patreon
2023-04-08 18:20:02 +00:00
|
|
|
qp <- liftAnnex $ coreQuotePath <$> Annex.getGitConfig
|
|
|
|
debug [ "Transferring:" , describeTransfer qp t info ]
|
2013-10-26 20:54:49 +00:00
|
|
|
notifyTransfer
|
2024-01-19 19:14:26 +00:00
|
|
|
let sd = getStallDetection (transferDirection t) remote
|
2020-12-08 19:22:18 +00:00
|
|
|
return $ Just (t, info, go remote sd)
|
2013-10-26 20:54:49 +00:00
|
|
|
, do
|
git style filename quoting controlled by core.quotePath
This is by no means complete, but escaping filenames in actionItemDesc does
cover most commands.
Note that for ActionItemBranchFilePath, the value is branch:file, and I
choose to only quote the file part (if necessary). I considered quoting the
whole thing. But, branch names cannot contain control characters, and while
they can contain unicode, git coes not quote unicode when displaying branch
names. So, it would be surprising for git-annex to quote unicode in a
branch name.
The find command is the most obvious command that still needs to be
dealt with. There are probably other places that filenames also get
displayed, eg embedded in error messages.
Some other commands use ActionItemOther with a filename, I think that
ActionItemOther should either be pre-sanitized, or should explicitly not
be used for filenames, so that needs more work.
When --json is used, unicode does not get escaped, but control
characters were already escaped in json.
(Key escaping may turn out to be needed, but I'm ignoring that for now.)
Sponsored-by: unqueued on Patreon
2023-04-08 18:20:02 +00:00
|
|
|
qp <- liftAnnex $ coreQuotePath <$> Annex.getGitConfig
|
2013-10-26 20:54:49 +00:00
|
|
|
debug [ "Skipping unnecessary transfer:",
|
git style filename quoting controlled by core.quotePath
This is by no means complete, but escaping filenames in actionItemDesc does
cover most commands.
Note that for ActionItemBranchFilePath, the value is branch:file, and I
choose to only quote the file part (if necessary). I considered quoting the
whole thing. But, branch names cannot contain control characters, and while
they can contain unicode, git coes not quote unicode when displaying branch
names. So, it would be surprising for git-annex to quote unicode in a
branch name.
The find command is the most obvious command that still needs to be
dealt with. There are probably other places that filenames also get
displayed, eg embedded in error messages.
Some other commands use ActionItemOther with a filename, I think that
ActionItemOther should either be pre-sanitized, or should explicitly not
be used for filenames, so that needs more work.
When --json is used, unicode does not get escaped, but control
characters were already escaped in json.
(Key escaping may turn out to be needed, but I'm ignoring that for now.)
Sponsored-by: unqueued on Patreon
2023-04-08 18:20:02 +00:00
|
|
|
describeTransfer qp t info ]
|
2013-10-26 20:54:49 +00:00
|
|
|
void $ removeTransfer t
|
|
|
|
finishedTransfer t (Just info)
|
|
|
|
return Nothing
|
|
|
|
)
|
2018-06-04 18:31:55 +00:00
|
|
|
)
|
2013-10-26 20:54:49 +00:00
|
|
|
_ -> return Nothing
|
|
|
|
where
|
|
|
|
direction = transferDirection t
|
|
|
|
isdownload = direction == Download
|
|
|
|
|
2018-06-04 18:31:55 +00:00
|
|
|
unpluggedremovabledrive remote = Git.repoIsLocalUnknown
|
|
|
|
<$> liftAnnex (Remote.getRepo remote)
|
|
|
|
|
2013-10-26 20:54:49 +00:00
|
|
|
{- 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. However, first check if something else is
|
|
|
|
- running the transfer, to avoid removing active transfers.
|
|
|
|
-}
|
2020-12-08 19:22:18 +00:00
|
|
|
go remote sd transferrer = ifM (isRight <$> performTransfer sd AssistantLevel liftAnnex (transferRemote info) t info transferrer)
|
2013-10-26 20:54:49 +00:00
|
|
|
( do
|
2017-03-10 17:12:24 +00:00
|
|
|
case associatedFile info of
|
|
|
|
AssociatedFile Nothing -> noop
|
|
|
|
AssociatedFile (Just af) -> void $
|
|
|
|
addAlert $ makeAlertFiller True $
|
2019-12-05 19:10:23 +00:00
|
|
|
transferFileAlert direction True (fromRawFilePath af)
|
2013-10-26 20:54:49 +00:00
|
|
|
unless isdownload $
|
|
|
|
handleDrops
|
|
|
|
("object uploaded to " ++ show remote)
|
|
|
|
True (transferKey t)
|
|
|
|
(associatedFile info)
|
2015-10-08 21:58:32 +00:00
|
|
|
[mkVerifiedCopy RecentlyVerifiedCopy remote]
|
2013-10-26 20:54:49 +00:00
|
|
|
void recordCommit
|
|
|
|
, whenM (liftAnnex $ isNothing <$> checkTransfer t) $
|
|
|
|
void $ removeTransfer t
|
|
|
|
)
|
|
|
|
|
|
|
|
{- Called right before a transfer begins, this is a last chance to avoid
|
|
|
|
- unnecessary transfers.
|
|
|
|
-
|
|
|
|
- For downloads, we obviously don't need to download if the already
|
|
|
|
- have the object.
|
|
|
|
-
|
|
|
|
- Smilarly, for uploads, check if the remote is known to already have
|
|
|
|
- the object.
|
|
|
|
-
|
|
|
|
- Also, uploads get queued to all remotes, in order of cost.
|
|
|
|
- This may mean, for example, that an object is uploaded over the LAN
|
|
|
|
- to a locally paired client, and once that upload is done, a more
|
|
|
|
- expensive transfer remote no longer wants the object. (Since
|
|
|
|
- all the clients have it already.) So do one last check if this is still
|
|
|
|
- preferred content.
|
|
|
|
-
|
|
|
|
- We'll also do one last preferred content check for downloads. An
|
|
|
|
- example of a case where this could be needed is if a download is queued
|
|
|
|
- for a file that gets moved out of an archive directory -- but before
|
|
|
|
- that download can happen, the file is put back in the archive.
|
|
|
|
-}
|
|
|
|
shouldTransfer :: Transfer -> TransferInfo -> Annex Bool
|
|
|
|
shouldTransfer t info
|
|
|
|
| transferDirection t == Download =
|
2024-08-23 20:35:12 +00:00
|
|
|
(not <$> inAnnex key) <&&> wantGet NoLiveUpdate True (Just key) file
|
2013-10-26 20:54:49 +00:00
|
|
|
| transferDirection t == Upload = case transferRemote info of
|
|
|
|
Nothing -> return False
|
|
|
|
Just r -> notinremote r
|
2024-08-23 20:35:12 +00:00
|
|
|
<&&> wantGetBy NoLiveUpdate True (Just key) file (Remote.uuid r)
|
2013-10-26 20:54:49 +00:00
|
|
|
| otherwise = return False
|
|
|
|
where
|
|
|
|
key = transferKey t
|
|
|
|
file = associatedFile info
|
|
|
|
|
|
|
|
{- Trust the location log to check if the remote already has
|
|
|
|
- the key. This avoids a roundtrip to the remote. -}
|
|
|
|
notinremote r = notElem (Remote.uuid r) <$> loggedLocations key
|
|
|
|
|
|
|
|
{- Queue uploads of files downloaded to us, spreading them
|
|
|
|
- out to other reachable remotes.
|
|
|
|
-
|
|
|
|
- Downloading a file may have caused a remote to not want it;
|
|
|
|
- so check for drops from remotes.
|
|
|
|
-
|
|
|
|
- Uploading a file may cause the local repo, or some other remote to not
|
|
|
|
- want it; handle that too.
|
|
|
|
-}
|
|
|
|
finishedTransfer :: Transfer -> Maybe TransferInfo -> Assistant ()
|
|
|
|
finishedTransfer t (Just info)
|
|
|
|
| transferDirection t == Download =
|
|
|
|
whenM (liftAnnex $ inAnnex $ transferKey t) $ do
|
|
|
|
dodrops False
|
2014-01-23 20:51:16 +00:00
|
|
|
void $ queueTransfersMatching (/= transferUUID t)
|
2013-10-26 20:54:49 +00:00
|
|
|
"newly received object"
|
|
|
|
Later (transferKey t) (associatedFile info) Upload
|
|
|
|
| otherwise = dodrops True
|
|
|
|
where
|
git style filename quoting controlled by core.quotePath
This is by no means complete, but escaping filenames in actionItemDesc does
cover most commands.
Note that for ActionItemBranchFilePath, the value is branch:file, and I
choose to only quote the file part (if necessary). I considered quoting the
whole thing. But, branch names cannot contain control characters, and while
they can contain unicode, git coes not quote unicode when displaying branch
names. So, it would be surprising for git-annex to quote unicode in a
branch name.
The find command is the most obvious command that still needs to be
dealt with. There are probably other places that filenames also get
displayed, eg embedded in error messages.
Some other commands use ActionItemOther with a filename, I think that
ActionItemOther should either be pre-sanitized, or should explicitly not
be used for filenames, so that needs more work.
When --json is used, unicode does not get escaped, but control
characters were already escaped in json.
(Key escaping may turn out to be needed, but I'm ignoring that for now.)
Sponsored-by: unqueued on Patreon
2023-04-08 18:20:02 +00:00
|
|
|
dodrops fromhere = do
|
|
|
|
qp <- liftAnnex $ coreQuotePath <$> Annex.getGitConfig
|
|
|
|
handleDrops
|
|
|
|
("drop wanted after " ++ describeTransfer qp t info)
|
|
|
|
fromhere (transferKey t) (associatedFile info) []
|
2013-10-26 20:54:49 +00:00
|
|
|
finishedTransfer _ _ = noop
|
|
|
|
|
|
|
|
{- Pause a running transfer. -}
|
|
|
|
pauseTransfer :: Transfer -> Assistant ()
|
|
|
|
pauseTransfer = cancelTransfer True
|
|
|
|
|
|
|
|
{- Cancel a running transfer. -}
|
|
|
|
cancelTransfer :: Bool -> Transfer -> Assistant ()
|
|
|
|
cancelTransfer pause t = do
|
|
|
|
m <- getCurrentTransfers
|
|
|
|
unless pause $
|
|
|
|
{- remove queued transfer -}
|
|
|
|
void $ dequeueTransfers $ equivilantTransfer t
|
|
|
|
{- stop running transfer -}
|
|
|
|
maybe noop stop (M.lookup t m)
|
|
|
|
where
|
|
|
|
stop info = do
|
|
|
|
{- When there's a thread associated with the
|
|
|
|
- transfer, it's signaled first, to avoid it
|
|
|
|
- displaying any alert about the transfer having
|
|
|
|
- failed when the transfer process is killed. -}
|
|
|
|
liftIO $ maybe noop signalthread $ transferTid info
|
|
|
|
liftIO $ maybe noop killproc $ transferPid info
|
|
|
|
if pause
|
|
|
|
then void $ alterTransferInfo t $
|
|
|
|
\i -> i { transferPaused = True }
|
|
|
|
else void $ removeTransfer t
|
|
|
|
signalthread tid
|
|
|
|
| pause = throwTo tid PauseTransfer
|
|
|
|
| otherwise = killThread tid
|
|
|
|
killproc pid = void $ tryIO $ do
|
2013-11-12 18:54:02 +00:00
|
|
|
#ifndef mingw32_HOST_OS
|
2014-02-13 18:00:15 +00:00
|
|
|
{- In order to stop helper processes like rsync,
|
|
|
|
- kill the whole process group of the process
|
|
|
|
- running the transfer. -}
|
2013-10-26 20:54:49 +00:00
|
|
|
g <- getProcessGroupIDOf pid
|
2013-12-11 03:32:10 +00:00
|
|
|
let signal sig = void $ tryIO $ signalProcessGroup sig g
|
|
|
|
signal sigTERM
|
2014-02-13 18:00:15 +00:00
|
|
|
threadDelay 50000 -- 0.05 second grace period
|
2013-12-11 03:32:10 +00:00
|
|
|
signal sigKILL
|
2013-11-12 18:54:02 +00:00
|
|
|
#else
|
2017-10-25 23:46:28 +00:00
|
|
|
terminateProcessById pid
|
2013-11-12 18:54:02 +00:00
|
|
|
#endif
|
2013-10-26 20:54:49 +00:00
|
|
|
|
|
|
|
{- Start or resume a transfer. -}
|
|
|
|
startTransfer :: Transfer -> Assistant ()
|
|
|
|
startTransfer t = do
|
|
|
|
m <- getCurrentTransfers
|
|
|
|
maybe startqueued go (M.lookup t m)
|
|
|
|
where
|
|
|
|
go info = maybe (start info) resume $ transferTid info
|
|
|
|
startqueued = do
|
|
|
|
is <- map snd <$> getMatchingTransfers (== t)
|
|
|
|
maybe noop start $ headMaybe is
|
|
|
|
resume tid = do
|
|
|
|
alterTransferInfo t $ \i -> i { transferPaused = False }
|
|
|
|
liftIO $ throwTo tid ResumeTransfer
|
|
|
|
start info = do
|
propagate git-annex -c on to transferrer child process
git -c was already propagated via environment, but need this for
consistency.
Also, notice it does not use gitAnnexChildProcess to run the
transferrer. So nothing is done about avoid it taking the
pid lock. It's possible that the caller is already doing something that
took the pid lock, and if so, the transferrer will certianly fail,
since it needs to take the pid lock too. This may prevent combining
annex.stalldetection with annex.pidlock, but I have not verified it's
really a problem. If it was, it seems git-annex would have to take
the pid lock when starting a transferrer, and hold it until shutdown,
or would need to take pid lock when starting to use a transferrer,
and hold it until done with a transfer and then drop it. The latter
would require starting the transferrer with pid locking disabled for the
child process, so assumes that the transferrer does not do anyting that
needs locking when not running a transfer.
2020-12-15 15:36:25 +00:00
|
|
|
rt <- liftAnnex . mkRunTransferrer
|
|
|
|
=<< liftIO getBatchCommandMaker
|
|
|
|
inImmediateTransferSlot rt $
|
2013-10-26 20:54:49 +00:00
|
|
|
genTransfer t info
|
|
|
|
|
|
|
|
getCurrentTransfers :: Assistant TransferMap
|
|
|
|
getCurrentTransfers = currentTransfers <$> getDaemonStatus
|
2020-12-07 17:08:59 +00:00
|
|
|
|
|
|
|
checkNetworkConnections :: DaemonStatusHandle -> MkCheckTransferrer
|
|
|
|
checkNetworkConnections dstatushandle = do
|
|
|
|
dstatus <- atomically $ readTVar dstatushandle
|
|
|
|
h <- newNotificationHandle False (networkConnectedNotifier dstatus)
|
|
|
|
return $ not <$> checkNotification h
|