diff options
| -rw-r--r-- | Assistant.hs | 3 | ||||
| -rw-r--r-- | Assistant/Threads/Transferrer.hs | 11 | ||||
| -rw-r--r-- | Assistant/TransferSlots.hs | 30 |
3 files changed, 39 insertions, 5 deletions
diff --git a/Assistant.hs b/Assistant.hs index 38ed539a1..06484b086 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -84,6 +84,7 @@ import Assistant.Changes import Assistant.Commits import Assistant.Pushes import Assistant.TransferQueue +import Assistant.TransferSlots import Assistant.Threads.Watcher import Assistant.Threads.Committer import Assistant.Threads.Pusher @@ -122,7 +123,7 @@ startDaemon assistant foreground , pushThread st dstatus commitchan pushmap , pushRetryThread st pushmap , mergeThread st - , transferWatcherThread st dstatus transferslots + , transferWatcherThread st dstatus , transfererThread st dstatus transferqueue transferslots , daemonStatusThread st dstatus , sanityCheckerThread st dstatus transferqueue changechan diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index 0d0bc6f6d..3e417e7ff 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -11,6 +11,7 @@ import Common.Annex import Assistant.ThreadedMonad import Assistant.DaemonStatus import Assistant.TransferQueue +import Assistant.TransferSlots import Logs.Transfer import Annex.Content import Utility.ThreadScheduler @@ -25,14 +26,16 @@ maxTransfers :: Int maxTransfers = 1 {- Dispatches transfers from the queue. -} -transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> IO () -transfererThread st dstatus transferqueue = runEvery (Seconds 1) $ do +transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> TransferSlots -> IO () +transfererThread st dstatus transferqueue slots = runEvery (Seconds 1) $ do (t, info) <- getNextTransfer transferqueue c <- runThreadState st $ shouldTransfer dstatus t + let run = void $ inTransferSlot slots $ + runTransfer st dstatus t info case c of - Yes -> void $ runTransfer st dstatus t info + Yes -> run Skip -> noop - TooMany -> void $ waitTransfer >> runTransfer st dstatus t info + TooMany -> waitTransfer >> run data ShouldTransfer = Yes | Skip | TooMany diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs new file mode 100644 index 000000000..0e2bb98b0 --- /dev/null +++ b/Assistant/TransferSlots.hs @@ -0,0 +1,30 @@ +{- git-annex assistant transfer slots + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.TransferSlots where + +import Control.Exception +import Control.Concurrent + +type TransferSlots = QSemN + +{- Number of concurrent transfers allowed to be run from the assistant. + - + - Transfers launched by other means, including by remote assistants, + - do not currently take up slots. + -} +numSlots :: Int +numSlots = 1 + +newTransferSlots :: IO TransferSlots +newTransferSlots = newQSemN numSlots + +{- Waits until a transfer slot becomes available, and runs a transfer + - action in the slot. + -} +inTransferSlot :: TransferSlots -> IO a -> IO a +inTransferSlot s = bracket_ (waitQSemN s 1) (signalQSemN s 1) |