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:
parent
d6f65aed16
commit
d954a0ce59
2 changed files with 18 additions and 15 deletions
|
@ -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
|
||||
|
|
|
@ -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 $
|
||||
|
|
Loading…
Add table
Reference in a new issue