3a0cffcfed
This ensures file propigate takes place in situations such as: Usb drive A is connected to B. A's master branch is already in sync with B, but it is being used to sneakernet some files around, so B downloads those. There is no master branch change, so C does not request these files. B needs to upload the files it just downloaded on to C, etc. My first try at this, I saw loops happen. B uploaded to C, which then tried to upload back to B (because it had not received the updated git-annex branch from B yet). B already had the file, but it still created a transfer info file from the incoming transfer, and its watcher saw that be removed, and tried to upload back to C. These loops should have been fixed by my previous commit. (They never affected ssh remotes, only local ones, it seemed.) While C might still try to upload to B, or to some other remote that already has the file, the extra work dies out there.
103 lines
3.3 KiB
Haskell
103 lines
3.3 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 Types.Key
|
|
import Locations.UserConfig
|
|
|
|
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 -> NamedThread
|
|
transfererThread st dstatus transferqueue slots = thread $ go =<< readProgramFile
|
|
where
|
|
thread = NamedThread thisThread
|
|
go program = forever $ inTransferSlot dstatus slots $
|
|
maybe (return Nothing) (uncurry $ startTransfer st dstatus program)
|
|
=<< getNextTransfer transferqueue dstatus notrunning
|
|
{- Skip transfers that are already running. -}
|
|
notrunning = isNothing . startedTime
|
|
|
|
{- By the time this is called, the daemonstatus's transfer map should
|
|
- already have been updated to include the transfer. -}
|
|
startTransfer :: ThreadState -> DaemonStatusHandle -> FilePath -> Transfer -> TransferInfo -> TransferGenerator
|
|
startTransfer st dstatus program t info = case (transferRemote info, associatedFile info) of
|
|
(Just remote, Just file) -> ifM (runThreadState st $ shouldTransfer t info)
|
|
( do
|
|
debug thisThread [ "Transferring:" , show t ]
|
|
notifyTransfer dstatus
|
|
return $ Just (t, info, transferprocess remote file)
|
|
, do
|
|
debug thisThread [ "Skipping unnecessary transfer:" , show t ]
|
|
void $ removeTransfer dstatus t
|
|
return Nothing
|
|
)
|
|
_ -> return Nothing
|
|
where
|
|
direction = transferDirection t
|
|
isdownload = direction == Download
|
|
|
|
transferprocess remote file = void $ do
|
|
(_, _, _, pid)
|
|
<- 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. -}
|
|
whenM ((==) ExitSuccess <$> waitForProcess pid) $ void $
|
|
addAlert dstatus $
|
|
makeAlertFiller True $
|
|
transferFileAlert direction True file
|
|
where
|
|
params =
|
|
[ Param "transferkey"
|
|
, Param $ key2file $ transferKey t
|
|
, Param $ if isdownload
|
|
then "--from"
|
|
else "--to"
|
|
, Param $ Remote.name remote
|
|
, Param "--file"
|
|
, File file
|
|
]
|
|
|
|
{- 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
|