a76078a78e
This seems to work pretty well. Handled the process groups like this: - git-annex processes started by the assistant for transfers are run in their own process groups. - otherwise, rely on the shell to allocate a process group for git-annex There is potentially a problem if some other program runs git-annex directly (not using sh -c) The program and git-annex would then be in the same process group. If that git-annex starts a transfer and it's canceled, the program would also get killed. May or may not be a desired result. Also, the new updateTransferInfo probably closes a race where it was possible for the thread id to not be recorded in the transfer info, if the transfer info file from the transfer process is read first.
111 lines
3.5 KiB
Haskell
111 lines
3.5 KiB
Haskell
{- git-annex assistant data transferrer thread
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Assistant.Threads.Transferrer where
|
|
|
|
import Assistant.Common
|
|
import Assistant.ThreadedMonad
|
|
import Assistant.DaemonStatus
|
|
import Assistant.TransferQueue
|
|
import Assistant.TransferSlots
|
|
import Assistant.Alert
|
|
import Logs.Transfer
|
|
import Logs.Location
|
|
import Annex.Content
|
|
import qualified Remote
|
|
|
|
import System.Process (create_group)
|
|
|
|
thisThread :: ThreadName
|
|
thisThread = "Transferrer"
|
|
|
|
{- For now only one transfer is run at a time. -}
|
|
maxTransfers :: Int
|
|
maxTransfers = 1
|
|
|
|
{- Dispatches transfers from the queue. -}
|
|
transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> TransferSlots -> IO ()
|
|
transfererThread st dstatus transferqueue slots = go
|
|
where
|
|
go = getNextTransfer transferqueue dstatus notrunning >>= handle
|
|
handle Nothing = go
|
|
handle (Just (t, info)) = do
|
|
ifM (runThreadState st $ shouldTransfer t info)
|
|
( do
|
|
debug thisThread [ "Transferring:" , show t ]
|
|
notifyTransfer dstatus
|
|
transferThread dstatus slots t info
|
|
, do
|
|
debug thisThread [ "Skipping unnecessary transfer:" , show t ]
|
|
-- getNextTransfer added t to the
|
|
-- daemonstatus's transfer map.
|
|
void $ removeTransfer dstatus t
|
|
)
|
|
go
|
|
{- 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
|
|
|
|
{- A sepeate git-annex process is forked off to run a transfer,
|
|
- running in its own process group. This allows killing it and all its
|
|
- children if the user decides to cancel the transfer.
|
|
-
|
|
- A thread is forked off to run the process, and the thread
|
|
- occupies one of the transfer slots. If all slots are in use, this will
|
|
- block until one becomes available. The thread's id is also recorded in
|
|
- the transfer info; the thread will also be killed when a transfer is
|
|
- stopped, to avoid it displaying any alert about the transfer having
|
|
- failed. -}
|
|
transferThread :: DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> IO ()
|
|
transferThread dstatus slots t info = case (transferRemote info, associatedFile info) of
|
|
(Nothing, _) -> noop
|
|
(_, Nothing) -> noop
|
|
(Just remote, Just file) -> do
|
|
tid <- inTransferSlot slots $
|
|
transferprocess remote file
|
|
updateTransferInfo dstatus t $ info { transferTid = Just tid }
|
|
where
|
|
direction = transferDirection t
|
|
isdownload = direction == Download
|
|
|
|
transferprocess remote file = void $ do
|
|
(_, _, _, pid)
|
|
<- createProcess (proc command $ toCommand params)
|
|
{ create_group = True }
|
|
status <- waitForProcess pid
|
|
addAlert dstatus $
|
|
makeAlertFiller (status == ExitSuccess) $
|
|
transferFileAlert direction file
|
|
where
|
|
command = "git-annex"
|
|
params =
|
|
[ Param "copy"
|
|
, Param "--fast"
|
|
, Param $ if isdownload
|
|
then "--from"
|
|
else "--to"
|
|
, Param $ Remote.name remote
|
|
, File file
|
|
]
|