fixed close-together transfer race

The issue involved forking and they trying to read from a MVar. Reading the
MVar 1st fixed it.

2 files changed, 18 insertions, 15 deletions

diff --git a/Assistant/ThreadedMonad.hs b/Assistant/ThreadedMonad.hs
index 4e871ab67..16f3a9dd9 100644
--- a/Assistant/ThreadedMonad.hs
+++ b/Assistant/ThreadedMonad.hs
@@ -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
diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs
index 09c0aa036..f40218c08 100644
--- a/Assistant/Threads/Transferrer.hs
+++ b/Assistant/Threads/Transferrer.hs
@@ -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 $