fix transferrer thread's use of transfer slots and transfer info files
Check first if a transfer needs to be done, using the location log only (for speed), and avoid occupying a slot if not. Always write a transfer info file, and keep it open throughout the tranfer process. Now transfers to remotes seem reliable.
This commit is contained in:
parent
cc6f660752
commit
cd168c6cba
1 changed files with 49 additions and 28 deletions
|
@ -13,9 +13,10 @@ import Assistant.DaemonStatus
|
|||
import Assistant.TransferQueue
|
||||
import Assistant.TransferSlots
|
||||
import Logs.Transfer
|
||||
import Logs.Presence
|
||||
import Logs.Location
|
||||
import Annex.Content
|
||||
import Command
|
||||
import qualified Command.Move
|
||||
import qualified Remote
|
||||
|
||||
import Data.Time.Clock
|
||||
import qualified Data.Map as M
|
||||
|
@ -31,8 +32,7 @@ transfererThread st dstatus transferqueue slots = go
|
|||
go = do
|
||||
(t, info) <- getNextTransfer transferqueue
|
||||
whenM (runThreadState st $ shouldTransfer dstatus t) $
|
||||
void $ inTransferSlot slots $
|
||||
runTransfer st dstatus t info
|
||||
runTransfer st dstatus slots t info
|
||||
go
|
||||
|
||||
{- Checks if the requested transfer is already running, or
|
||||
|
@ -49,33 +49,54 @@ shouldTransfer dstatus t = go =<< currentTransfers <$> getDaemonStatus dstatus
|
|||
{- A transfer is run in a separate process, with a *copy* of the Annex
|
||||
- state. This is necessary to avoid blocking the rest of the assistant
|
||||
- on the transfer completing, and also to allow multiple transfers to run
|
||||
- at once.
|
||||
- at once.
|
||||
-
|
||||
- However, it means that the transfer processes are responsible
|
||||
- for doing any necessary shutdown cleanups, and that the parent
|
||||
- thread's cache must be invalidated once a transfer completes, as
|
||||
- changes may have been made to the git-annex branch.
|
||||
-
|
||||
- Currently a minimal shutdown is done; the transfer processes are
|
||||
- effectively running in oneshot mode, without committing changes to the
|
||||
- git-annex branch, and transfers should never queue git commands to run.
|
||||
- changes may have been made to the git-annex branch.
|
||||
-}
|
||||
runTransfer :: ThreadState -> DaemonStatusHandle -> Transfer -> TransferInfo -> IO ()
|
||||
runTransfer st dstatus t info
|
||||
| transferDirection t == Download = go Command.Move.fromStart
|
||||
| otherwise = go Command.Move.toStart
|
||||
runTransfer :: ThreadState -> DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> IO ()
|
||||
runTransfer st dstatus slots t info = case (transferRemote info, associatedFile info) of
|
||||
(Nothing, _) -> noop
|
||||
(_, Nothing) -> noop
|
||||
(Just remote, Just file) -> whenM (shouldtransfer remote) $ do
|
||||
pid <- inTransferSlot slots $
|
||||
unsafeForkProcessThreadState st $
|
||||
transferprocess remote file
|
||||
now <- getCurrentTime
|
||||
runThreadState st $ adjustTransfers dstatus $
|
||||
M.insertWith' const t info
|
||||
{ startedTime = Just now
|
||||
, transferPid = Just pid
|
||||
, shouldWait = True
|
||||
}
|
||||
where
|
||||
go cmd = case (transferRemote info, associatedFile info) of
|
||||
(Nothing, _) -> noop
|
||||
(_, Nothing) -> noop
|
||||
(Just remote, Just file) -> do
|
||||
now <- getCurrentTime
|
||||
pid <- unsafeForkProcessThreadState st $
|
||||
doCommand $ cmd remote False file (transferKey t)
|
||||
runThreadState st $
|
||||
adjustTransfers dstatus $
|
||||
M.insertWith' const t info
|
||||
{ startedTime = Just now
|
||||
, transferPid = Just pid
|
||||
, shouldWait = True
|
||||
}
|
||||
isdownload = transferDirection t == Download
|
||||
tofrom
|
||||
| isdownload = "from"
|
||||
| otherwise = "to"
|
||||
key = transferKey t
|
||||
|
||||
shouldtransfer remote
|
||||
| isdownload = return True
|
||||
| otherwise = runThreadState st $
|
||||
{- Trust the location log to check if the
|
||||
- remote already has the key. This avoids
|
||||
- a roundtrip to the remote. -}
|
||||
notElem (Remote.uuid remote)
|
||||
<$> loggedLocations key
|
||||
|
||||
transferprocess remote file = do
|
||||
showStart "copy" file
|
||||
showAction $ tofrom ++ " " ++ Remote.name remote
|
||||
ok <- transfer t (Just file) $
|
||||
if isdownload
|
||||
then getViaTmp key $
|
||||
Remote.retrieveKeyFile remote key (Just file)
|
||||
else do
|
||||
ok <- Remote.storeKey remote key $ Just file
|
||||
when ok $
|
||||
Remote.logStatus remote key InfoPresent
|
||||
return ok
|
||||
showEndResult ok
|
||||
|
|
Loading…
Add table
Reference in a new issue