content locking during drop working for local git remotes

Only ssh remotes lack locking now
This commit is contained in:
Joey Hess 2015-10-09 13:07:03 -04:00
parent ceb5819538
commit 4c6095b6f5
Failed to extract signature
4 changed files with 52 additions and 8 deletions

View file

@ -5,6 +5,8 @@
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
module Annex.NumCopies (
module Types.NumCopies,
module Logs.NumCopies,
@ -30,6 +32,10 @@ import qualified Types.Remote as Remote
import Annex.UUID
import Annex.Content
import Control.Exception
import qualified Control.Monad.Catch as M
import Data.Typeable
defaultNumCopies :: NumCopies
defaultNumCopies = NumCopies 1
@ -124,10 +130,31 @@ verifyEnoughCopiesToDrop nolocmsg key need skip preverified tocheck dropaction n
Right proof -> dropaction proof
Left stillhave -> helper bad missing stillhave (r:rs)
| otherwise = case Remote.lockContent r of
Just lockcontent -> do
-- The remote's lockContent will throw
-- an exception if it is unable to lock,
-- in which case the fallback should be
-- run.
--
-- On the other hand, the callback passed
-- to the lockContent could itself throw an
-- exception (ie, the eventual drop
-- action fails), and in this case we don't
-- want to use the fallback since part
-- of the drop action may have already been
-- performed.
--
-- Differentiate between these two sorts
-- of exceptions by using DropException.
let a = lockcontent key $ \vc ->
helper bad missing (vc : have) rs
`catchNonAsync` (throw . DropException)
a `M.catches`
[ M.Handler (\ (e :: AsyncException) -> throwM e)
, M.Handler (\ (DropException e') -> throwM e')
, M.Handler (\ (_e :: SomeException) -> fallback)
]
Nothing -> fallback
Just lockcontent -> lockcontent key $ \v -> case v of
Nothing -> fallback
Just vc -> helper bad missing (vc : have) rs
where
fallback = do
haskey <- Remote.hasKey r key
@ -136,6 +163,11 @@ verifyEnoughCopiesToDrop nolocmsg key need skip preverified tocheck dropaction n
Left _ -> helper (r:bad) missing have rs
Right False -> helper bad (Remote.uuid r:missing) have rs
data DropException = DropException SomeException
deriving (Typeable, Show)
instance Exception DropException
notEnoughCopies :: Key -> NumCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> Annex ()
notEnoughCopies key need have skip bad nolocmsg = do
showNote "unsafe"