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

avoid crashing threads that drop content if the drop crashes

Browse source
This commit is contained in:
Joey Hess 2012-12-05 12:28:50 -04:00
parent 55d15fa658
commit e5516fc68f
1 changed files with 4 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

5
Assistant/Drop.hs
View file

@ -16,6 +16,7 @@ import qualified Remote
import qualified Command.Drop import qualified Command.Drop
import Command import Command
import Annex.Wanted import Annex.Wanted
import Annex.Exception
import Config import Config
{- Drop from local and/or remote when allowed by the preferred content and {- Drop from local and/or remote when allowed by the preferred content and
@ -52,7 +53,7 @@ handleDropsFrom locs rs fromhere key (Just f) knownpresentremote
| otherwise = noop | otherwise = noop
checkdrop n@(_, numcopies) u a = ifM (wantDrop u (Just f)) checkdrop n@(_, numcopies) u a = ifM (wantDrop u (Just f))
( ifM (doCommand $ a (Just numcopies)) ( ifM (safely $ doCommand $ a (Just numcopies))
( return $ decrcopies n ( return $ decrcopies n
, return n , return n
) )
@ -64,3 +65,5 @@ handleDropsFrom locs rs fromhere key (Just f) knownpresentremote
dropr r n = checkdrop n (Just $ Remote.uuid r) $ \numcopies -> dropr r n = checkdrop n (Just $ Remote.uuid r) $ \numcopies ->
Command.Drop.startRemote f numcopies key r Command.Drop.startRemote f numcopies key r
safely a = either (const False) id <$> tryAnnex a