fixed close-together transfer race

The issue involved forking and they trying to read from a MVar. Reading the
MVar 1st fixed it.
This commit is contained in:
Joey Hess 2012-07-06 18:48:51 -06:00
parent d6f65aed16
commit d954a0ce59
2 changed files with 18 additions and 15 deletions

View file

@ -12,6 +12,7 @@ import qualified Annex
import Control.Concurrent
import Data.Tuple
import System.Posix.Types
{- The Annex state is stored in a MVar, so that threaded actions can access
- it. -}
@ -37,14 +38,14 @@ withThreadState a = do
runThreadState :: ThreadState -> Annex a -> IO a
runThreadState mvar a = modifyMVar mvar $ \state -> swap <$> Annex.run state a
{- Runs an Annex action, using a copy of the state from the MVar.
{- Runs an Annex action in a separate process, using a copy of the state
- from the MVar.
-
- The state modified by the action is thrown away, so it's up to the
- action to perform any necessary shutdown tasks in order for state to not
- be lost. And it's up to the caller to resynchronise with any changes
- the action makes to eg, the git-annex branch.
- It's up to the action to perform any necessary shutdown tasks in order
- for state to not be lost. And it's up to the caller to resynchronise
- with any changes the action makes to eg, the git-annex branch.
-}
unsafeRunThreadState :: ThreadState -> Annex a -> IO a
unsafeRunThreadState mvar a = do
unsafeForkProcessThreadState :: ThreadState -> Annex a -> IO ProcessID
unsafeForkProcessThreadState mvar a = do
state <- readMVar mvar
Annex.eval state a
forkProcess $ void $ Annex.eval state a

View file

@ -14,7 +14,6 @@ import Assistant.TransferQueue
import Assistant.TransferSlots
import Logs.Transfer
import Annex.Content
import Utility.ThreadScheduler
import Command
import qualified Command.Move
@ -27,11 +26,14 @@ maxTransfers = 1
{- Dispatches transfers from the queue. -}
transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> TransferSlots -> IO ()
transfererThread st dstatus transferqueue slots = runEvery (Seconds 1) $ do
(t, info) <- getNextTransfer transferqueue
whenM (runThreadState st $ shouldTransfer dstatus t) $
void $ inTransferSlot slots $
runTransfer st dstatus t info
transfererThread st dstatus transferqueue slots = go
where
go = do
(t, info) <- getNextTransfer transferqueue
whenM (runThreadState st $ shouldTransfer dstatus t) $
void $ inTransferSlot slots $
runTransfer st dstatus t info
go
{- Checks if the requested transfer is already running, or
- the file to download is already present. -}
@ -68,7 +70,7 @@ runTransfer st dstatus t info
(_, Nothing) -> noop
(Just remote, Just file) -> do
now <- getCurrentTime
pid <- forkProcess $ unsafeRunThreadState st $ void $
pid <- unsafeForkProcessThreadState st $
doCommand $ cmd remote False file (transferKey t)
runThreadState st $
adjustTransfers dstatus $