mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

TransferSlots: Use SafeSemaphore's MSemN instead of QSemN from base

Browse source 
As described in the documentation, QSemN is unsafe for a variety of
reasons.
This commit is contained in:
Ben Gamari 2012-10-05 17:02:51 -04:00
parent 6c9964de4e
commit cff451b37c
2 changed files with 10 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
Assistant/TransferSlots.hs
View file

@ -16,9 +16,10 @@ import Logs.Transfer
import qualified Control.Exception as E import qualified Control.Exception as E
import Control.Concurrent import Control.Concurrent
import qualified Control.Concurrent.MSemN as MSemN
import Data.Typeable import Data.Typeable
type TransferSlots = QSemN type TransferSlots = MSemN.MSemN Int
{- A special exception that can be thrown to pause or resume a transfer, while {- A special exception that can be thrown to pause or resume a transfer, while
- keeping its slot in use. -} - keeping its slot in use. -}
@ -39,21 +40,21 @@ numSlots :: Int
numSlots = 1 numSlots = 1
newTransferSlots :: IO TransferSlots newTransferSlots :: IO TransferSlots
newTransferSlots = newQSemN numSlots newTransferSlots = MSemN.new numSlots
{- Waits until a transfer slot becomes available, then runs a {- Waits until a transfer slot becomes available, then runs a
- TransferGenerator, and then runs the transfer action in its own thread. - TransferGenerator, and then runs the transfer action in its own thread.
-} -}
inTransferSlot :: TransferSlotRunner inTransferSlot :: TransferSlotRunner
inTransferSlot dstatus s gen = do inTransferSlot dstatus s gen = do
waitQSemN s 1 MSemN.wait s 1
runTransferThread dstatus s =<< gen runTransferThread dstatus s =<< gen
{- Runs a TransferGenerator, and its transfer action, {- Runs a TransferGenerator, and its transfer action,
- without waiting for a slot to become available. -} - without waiting for a slot to become available. -}
inImmediateTransferSlot :: TransferSlotRunner inImmediateTransferSlot :: TransferSlotRunner
inImmediateTransferSlot dstatus s gen = do inImmediateTransferSlot dstatus s gen = do
signalQSemN s (-1) MSemN.signal s (-1)
runTransferThread dstatus s =<< gen runTransferThread dstatus s =<< gen
{- Runs a transfer action, in an already allocated transfer slot. {- Runs a transfer action, in an already allocated transfer slot.
@ -67,7 +68,7 @@ inImmediateTransferSlot dstatus s gen = do
- then rerunning the action. - then rerunning the action.
-} -}
runTransferThread :: DaemonStatusHandle -> TransferSlots -> Maybe (Transfer, TransferInfo, IO ()) -> IO () runTransferThread :: DaemonStatusHandle -> TransferSlots -> Maybe (Transfer, TransferInfo, IO ()) -> IO ()
runTransferThread _ s Nothing = signalQSemN s 1 runTransferThread _ s Nothing = MSemN.signal s 1
runTransferThread dstatus s (Just (t, info, a)) = do runTransferThread dstatus s (Just (t, info, a)) = do
tid <- forkIO go tid <- forkIO go
updateTransferInfo dstatus t $ info { transferTid = Just tid } updateTransferInfo dstatus t $ info { transferTid = Just tid }
@ -86,4 +87,4 @@ runTransferThread dstatus s (Just (t, info, a)) = do
Just ResumeTransfer -> go Just ResumeTransfer -> go
_ -> done _ -> done
_ -> done _ -> done
done = signalQSemN s 1 done = MSemN.signal s 1

5
git-annex.cabal
View file

@ -1,5 +1,5 @@
Name: git-annex Name: git-annex
Version: 3.20121001 Version: 3.20121002
Cabal-Version: >= 1.8 Cabal-Version: >= 1.8
License: GPL License: GPL
Maintainer: Joey Hess <joey@kitenet.net> Maintainer: Joey Hess <joey@kitenet.net>
@ -49,7 +49,8 @@ Executable git-annex
unix, containers, utf8-string, network, mtl, bytestring, old-locale, time, unix, containers, utf8-string, network, mtl, bytestring, old-locale, time,
pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP, pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP,
base >= 4.5 && < 4.7, monad-control, transformers-base, lifted-base, base >= 4.5 && < 4.7, monad-control, transformers-base, lifted-base,
IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process,
SafeSemaphore
-- Need to list these because they're generated from .hsc files. -- Need to list these because they're generated from .hsc files.
Other-Modules: Utility.Touch Utility.Mounts Other-Modules: Utility.Touch Utility.Mounts
Include-Dirs: Utility Include-Dirs: Utility