when a Download finishes, queue Uploads
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.
This commit is contained in:
parent
e9238e9588
commit
3a0cffcfed
4 changed files with 66 additions and 46 deletions
|
@ -10,6 +10,7 @@ module Assistant.Threads.TransferWatcher where
|
|||
import Assistant.Common
|
||||
import Assistant.ThreadedMonad
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.TransferQueue
|
||||
import Logs.Transfer
|
||||
import Utility.DirWatcher
|
||||
import Utility.Types.DirWatcher
|
||||
|
@ -20,12 +21,12 @@ thisThread = "TransferWatcher"
|
|||
|
||||
{- This thread watches for changes to the gitAnnexTransferDir,
|
||||
- and updates the DaemonStatus's map of ongoing transfers. -}
|
||||
transferWatcherThread :: ThreadState -> DaemonStatusHandle -> NamedThread
|
||||
transferWatcherThread st dstatus = thread $ do
|
||||
transferWatcherThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> NamedThread
|
||||
transferWatcherThread st dstatus transferqueue = thread $ do
|
||||
g <- runThreadState st $ fromRepo id
|
||||
let dir = gitAnnexTransferDir g
|
||||
createDirectoryIfMissing True dir
|
||||
let hook a = Just $ runHandler st dstatus a
|
||||
let hook a = Just $ runHandler st dstatus transferqueue a
|
||||
let hooks = mkWatchHooks
|
||||
{ addHook = hook onAdd
|
||||
, delHook = hook onDel
|
||||
|
@ -36,25 +37,25 @@ transferWatcherThread st dstatus = thread $ do
|
|||
where
|
||||
thread = NamedThread thisThread
|
||||
|
||||
type Handler = ThreadState -> DaemonStatusHandle -> FilePath -> Maybe FileStatus -> IO ()
|
||||
type Handler = ThreadState -> DaemonStatusHandle -> TransferQueue -> FilePath -> Maybe FileStatus -> IO ()
|
||||
|
||||
{- Runs an action handler.
|
||||
-
|
||||
- Exceptions are ignored, otherwise a whole thread could be crashed.
|
||||
-}
|
||||
runHandler :: ThreadState -> DaemonStatusHandle -> Handler -> FilePath -> Maybe FileStatus -> IO ()
|
||||
runHandler st dstatus handler file filestatus = void $
|
||||
runHandler :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Handler -> FilePath -> Maybe FileStatus -> IO ()
|
||||
runHandler st dstatus transferqueue handler file filestatus = void $
|
||||
either print (const noop) =<< tryIO go
|
||||
where
|
||||
go = handler st dstatus file filestatus
|
||||
go = handler st dstatus transferqueue file filestatus
|
||||
|
||||
{- Called when there's an error with inotify. -}
|
||||
onErr :: Handler
|
||||
onErr _ _ msg _ = error msg
|
||||
onErr _ _ _ msg _ = error msg
|
||||
|
||||
{- Called when a new transfer information file is written. -}
|
||||
onAdd :: Handler
|
||||
onAdd st dstatus file _ = case parseTransferFile file of
|
||||
onAdd st dstatus _ file _ = case parseTransferFile file of
|
||||
Nothing -> noop
|
||||
Just t -> go t =<< runThreadState st (checkTransfer t)
|
||||
where
|
||||
|
@ -72,11 +73,22 @@ onAdd st dstatus file _ = case parseTransferFile file of
|
|||
|
||||
{- Called when a transfer information file is removed. -}
|
||||
onDel :: Handler
|
||||
onDel _ dstatus file _ = case parseTransferFile file of
|
||||
onDel st dstatus transferqueue file _ = case parseTransferFile file of
|
||||
Nothing -> noop
|
||||
Just t -> do
|
||||
debug thisThread
|
||||
[ "transfer finishing:"
|
||||
, show t
|
||||
]
|
||||
void $ removeTransfer dstatus t
|
||||
minfo <- removeTransfer dstatus t
|
||||
|
||||
{- Queue uploads of files we successfully downloaded,
|
||||
- spreading them out to other reachable remotes. -}
|
||||
case (minfo, transferDirection t) of
|
||||
(Just info, Download) -> runThreadState st $
|
||||
queueTransfers Later transferqueue dstatus
|
||||
(transferKey t)
|
||||
(associatedFile info)
|
||||
Upload
|
||||
_ -> noop
|
||||
|
||||
|
|
|
@ -63,6 +63,10 @@ startTransfer st dstatus program t info = case (transferRemote info, associatedF
|
|||
(_, _, _, 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 $
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue