Merge branch 'dropproof'

This commit is contained in:
Joey Hess 2015-10-09 18:03:00 -04:00
commit 22691478cf
Failed to extract signature
50 changed files with 785 additions and 224 deletions

View file

@ -13,6 +13,7 @@ module Annex (
new,
run,
eval,
makeRunner,
getState,
changeState,
withState,
@ -203,6 +204,13 @@ eval s a = do
mvar <- newMVar s
runReaderT (runAnnex a) mvar
{- Makes a runner action, that allows diving into IO and from inside
- the IO action, running an Annex action. -}
makeRunner :: Annex (Annex a -> IO a)
makeRunner = do
mvar <- ask
return $ \a -> runReaderT (runAnnex a) mvar
getState :: (AnnexState -> v) -> Annex v
getState selector = do
mvar <- ask

View file

@ -12,7 +12,9 @@ module Annex.Content (
inAnnex',
inAnnexSafe,
inAnnexCheck,
lockContent,
lockContentShared,
lockContentForRemoval,
ContentRemovalLock,
getViaTmp,
getViaTmp',
checkDiskSpaceToGet,
@ -66,6 +68,8 @@ import Messages.Progress
import qualified Types.Remote
import qualified Types.Backend
import qualified Backend
import Types.NumCopies
import Annex.UUID
{- Checks if a given key's content is currently present. -}
inAnnex :: Key -> Annex Bool
@ -165,57 +169,102 @@ contentLockFile key = ifM isDirect
contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key)
#endif
newtype ContentLock = ContentLock Key
{- Content is exclusively locked while running an action that might remove
- it. (If the content is not present, no locking is done.)
{- Prevents the content from being removed while the action is running.
- Uses a shared lock.
-
- Does not actually check if the content is present. Use inAnnex for that.
- However, since the contentLockFile is the content file in indirect mode,
- if the content is not present, locking it will fail.
-
- If locking fails, throws an exception rather than running the action.
-
- Note that, in direct mode, nothing prevents the user from directly
- editing or removing the content, even while it's locked by this.
-}
lockContent :: Key -> (ContentLock -> Annex a) -> Annex a
lockContent key a = do
lockContentShared :: Key -> (VerifiedCopy -> Annex a) -> Annex a
lockContentShared key a = lockContentUsing lock key $ do
u <- getUUID
withVerifiedCopy LockedCopy u (return True) a
where
#ifndef mingw32_HOST_OS
lock contentfile Nothing = liftIO $ tryLockShared Nothing contentfile
lock _ (Just lockfile) = posixLocker tryLockShared lockfile
#else
lock = winLocker lockShared
#endif
{- Exclusively locks content, while performing an action that
- might remove it.
-}
lockContentForRemoval :: Key -> (ContentRemovalLock -> Annex a) -> Annex a
lockContentForRemoval key a = lockContentUsing lock key $
a (ContentRemovalLock key)
where
#ifndef mingw32_HOST_OS
{- Since content files are stored with the write bit disabled, have
- to fiddle with permissions to open for an exclusive lock. -}
lock contentfile Nothing = bracket_
(thawContent contentfile)
(freezeContent contentfile)
(liftIO $ tryLockExclusive Nothing contentfile)
lock _ (Just lockfile) = posixLocker tryLockExclusive lockfile
#else
lock = winLocker lockExclusive
#endif
{- Passed the object content file, and maybe a separate lock file to use,
- when the content file itself should not be locked. -}
type ContentLocker = FilePath -> Maybe LockFile -> Annex (Maybe LockHandle)
#ifndef mingw32_HOST_OS
posixLocker :: (Maybe FileMode -> LockFile -> IO (Maybe LockHandle)) -> LockFile -> Annex (Maybe LockHandle)
posixLocker takelock lockfile = do
mode <- annexFileMode
modifyContent lockfile $
liftIO $ takelock (Just mode) lockfile
#else
winLocker :: (LockFile -> IO (Maybe LockHandle)) -> ContentLocker
winLocker takelock _ (Just lockfile) = do
modifyContent lockfile $
void $ liftIO $ tryIO $
writeFile lockfile ""
liftIO $ takelock lockfile
-- never reached; windows always uses a separate lock file
winLocker _ _ Nothing = return Nothing
#endif
lockContentUsing :: ContentLocker -> Key -> Annex a -> Annex a
lockContentUsing locker key a = do
contentfile <- calcRepo $ gitAnnexLocation key
lockfile <- contentLockFile key
bracket
(lock contentfile lockfile)
(unlock lockfile)
(const $ a $ ContentLock key )
(const a)
where
alreadylocked = error "content is locked"
cleanuplockfile lockfile = modifyContent lockfile $
void $ liftIO $ tryIO $
nukeFile lockfile
#ifndef mingw32_HOST_OS
{- Since content files are stored with the write bit disabled, have
- to fiddle with permissions to open for an exclusive lock. -}
lock contentfile Nothing = trylock $ bracket_
(thawContent contentfile)
(freezeContent contentfile)
failedtolock e = error $ "failed to lock content: " ++ show e
lock contentfile lockfile =
(maybe alreadylocked return
=<< liftIO (tryLockExclusive Nothing contentfile))
lock _ (Just lockfile) = trylock $ do
mode <- annexFileMode
maybe alreadylocked return
=<< modifyContent lockfile
(liftIO $ tryLockExclusive (Just mode) lockfile)
=<< locker contentfile lockfile)
`catchIO` failedtolock
#ifndef mingw32_HOST_OS
unlock mlockfile lck = do
maybe noop cleanuplockfile mlockfile
liftIO $ dropLock lck
failedtolock e = error $ "failed to lock content: " ++ show e
trylock locker = locker `catchIO` failedtolock
#else
lock _ (Just lockfile) = do
modifyContent lockfile $
void $ liftIO $ tryIO $
writeFile lockfile ""
maybe alreadylocked (return . Just)
=<< liftIO (lockExclusive lockfile)
-- never reached; windows always uses a separate lock file
lock _ Nothing = return Nothing
unlock mlockfile mlockhandle = do
liftIO $ maybe noop dropLock mlockhandle
maybe noop cleanuplockfile mlockfile
#endif
cleanuplockfile lockfile = modifyContent lockfile $
void $ liftIO $ tryIO $
nukeFile lockfile
{- Runs an action, passing it the temp file to get,
- and if the action succeeds, verifies the file matches
- the key and moves the file into the annex as a key's content. -}
@ -497,8 +546,8 @@ cleanObjectLoc key cleaner = do
- In direct mode, deletes the associated files or files, and replaces
- them with symlinks.
-}
removeAnnex :: ContentLock -> Annex ()
removeAnnex (ContentLock key) = withObjectLoc key remove removedirect
removeAnnex :: ContentRemovalLock -> Annex ()
removeAnnex (ContentRemovalLock key) = withObjectLoc key remove removedirect
where
remove file = cleanObjectLoc key $ do
secureErase file

View file

@ -32,9 +32,8 @@ type Reason = String
- only ones that match the UUIDs will be dropped from.
- If allowed to drop fromhere, that drop will be tried first.
-
- A remote can be specified that is known to have the key. This can be
- used an an optimisation when eg, a key has just been uploaded to a
- remote.
- A VerifiedCopy can be provided as an optimisation when eg, a key
- has just been uploaded to a remote.
-
- In direct mode, all associated files are checked, and only if all
- of them are unwanted are they dropped.
@ -42,8 +41,8 @@ type Reason = String
- The runner is used to run commands, and so can be either callCommand
- or commandAction.
-}
handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> (CommandStart -> CommandCleanup) -> Annex ()
handleDropsFrom locs rs reason fromhere key afile knownpresentremote runner = do
handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> [VerifiedCopy] -> (CommandStart -> CommandCleanup) -> Annex ()
handleDropsFrom locs rs reason fromhere key afile preverified runner = do
fs <- ifM isDirect
( do
l <- associatedFilesRelative key
@ -112,7 +111,7 @@ handleDropsFrom locs rs reason fromhere key afile knownpresentremote runner = do
)
dropl fs n = checkdrop fs n Nothing $ \numcopies ->
Command.Drop.startLocal afile numcopies key knownpresentremote
Command.Drop.startLocal afile numcopies key preverified
dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies ->
Command.Drop.startRemote afile numcopies key r

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,
@ -15,8 +17,9 @@ module Annex.NumCopies (
defaultNumCopies,
numCopiesCheck,
numCopiesCheck',
verifyEnoughCopies,
knownCopies,
verifyEnoughCopiesToDrop,
verifiableCopies,
UnVerifiedCopy(..),
) where
import Common.Annex
@ -26,8 +29,13 @@ import Logs.NumCopies
import Logs.Trust
import Annex.CheckAttr
import qualified Remote
import Annex.UUID
import qualified Types.Remote as Remote
import Annex.Content
import Annex.UUID
import Control.Exception
import qualified Control.Monad.Catch as M
import Data.Typeable
defaultNumCopies :: NumCopies
defaultNumCopies = NumCopies 1
@ -77,7 +85,11 @@ getFileNumCopies' file = maybe getGlobalNumCopies (return . Just) =<< getattr
{- Checks if numcopies are satisfied for a file by running a comparison
- between the number of (not untrusted) copies that are
- belived to exist, and the configured value. -}
- belived to exist, and the configured value.
-
- This is good enough for everything except dropping the file, which
- requires active verification of the copies.
-}
numCopiesCheck :: FilePath -> Key -> (Int -> Int -> v) -> Annex v
numCopiesCheck file key vs = do
have <- trustExclude UnTrusted =<< Remote.keyLocations key
@ -88,60 +100,118 @@ numCopiesCheck' file vs have = do
NumCopies needed <- getFileNumCopies file
return $ length have `vs` needed
data UnVerifiedCopy = UnVerifiedRemote Remote | UnVerifiedHere
deriving (Ord, Eq)
{- Verifies that enough copies of a key exist amoung the listed remotes,
- priting an informative message if not.
- to safely drop it, running an action with a proof if so, and
- printing an informative message if not.
-}
verifyEnoughCopies
verifyEnoughCopiesToDrop
:: String -- message to print when there are no known locations
-> Key
-> Maybe ContentRemovalLock
-> NumCopies
-> [UUID] -- repos to skip considering (generally untrusted remotes)
-> [UUID] -- repos that are trusted or already verified to have it
-> [Remote] -- remotes to check to see if they have it
-> Annex Bool
verifyEnoughCopies nolocmsg key need skip trusted tocheck =
helper [] [] (nub trusted) (nub tocheck)
-> [VerifiedCopy] -- copies already verified to exist
-> [UnVerifiedCopy] -- places to check to see if they have copies
-> (SafeDropProof -> Annex a) -- action to perform the drop
-> Annex a -- action to perform when unable to drop
-> Annex a
verifyEnoughCopiesToDrop nolocmsg key removallock need skip preverified tocheck dropaction nodropaction =
helper [] [] preverified (nub tocheck)
where
helper bad missing have []
| NumCopies (length have) >= need = return True
| otherwise = do
notEnoughCopies key need have (skip++missing) bad nolocmsg
return False
helper bad missing have (r:rs)
| NumCopies (length have) >= need = return True
| otherwise = do
let u = Remote.uuid r
let duplicate = u `elem` have
haskey <- Remote.hasKey r key
case (duplicate, haskey) of
(False, Right True) -> helper bad missing (u:have) rs
(False, Left _) -> helper (r:bad) missing have rs
(False, Right False) -> helper bad (u:missing) have rs
_ -> helper bad missing have rs
helper bad missing have [] = do
p <- liftIO $ mkSafeDropProof need have removallock
case p of
Right proof -> dropaction proof
Left stillhave -> do
notEnoughCopies key need stillhave (skip++missing) bad nolocmsg
nodropaction
helper bad missing have (c:cs)
| isSafeDrop need have removallock = do
p <- liftIO $ mkSafeDropProof need have removallock
case p of
Right proof -> dropaction proof
Left stillhave -> helper bad missing stillhave (c:cs)
| otherwise = case c of
UnVerifiedHere -> lockContentShared key contverified
UnVerifiedRemote r -> checkremote r contverified $ do
haskey <- Remote.hasKey r key
case haskey of
Right True -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy r : have) cs
Left _ -> helper (r:bad) missing have cs
Right False -> helper bad (Remote.uuid r:missing) have cs
where
contverified vc = helper bad missing (vc : have) cs
notEnoughCopies :: Key -> NumCopies -> [UUID] -> [UUID] -> [Remote] -> String -> Annex ()
checkremote r cont fallback = case Remote.lockContent r of
Just lockcontent -> do
-- The remote's lockContent will throw an exception
-- when it is unable to lock, in which case the
-- fallback should be run.
--
-- On the other hand, the continuation could itself
-- throw an exception (ie, the eventual drop action
-- fails), and in this case we don't want to run 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 $ \v ->
cont v `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
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"
showLongNote $
"Could only verify the existence of " ++
show (length have) ++ " out of " ++ show (fromNumCopies need) ++
" necessary copies"
if length have < fromNumCopies need
then showLongNote $
"Could only verify the existence of " ++
show (length have) ++ " out of " ++ show (fromNumCopies need) ++
" necessary copies"
else do
showLongNote "Unable to lock down 1 copy of file that is required to safely drop it."
showLongNote "(This could have happened because of a concurrent drop, or because a remote has too old a version of git-annex-shell installed.)"
Remote.showTriedRemotes bad
Remote.showLocations True key (have++skip) nolocmsg
Remote.showLocations True key (map toUUID have++skip) nolocmsg
{- Cost ordered lists of remotes that the location log indicates
- may have a key.
{- Finds locations of a key that can be used to get VerifiedCopies,
- in order to allow dropping the key.
-
- Also returns a list of UUIDs that are trusted to have the key
- (some may not have configured remotes). If the current repository
- currently has the key, and is not untrusted, it is included in this list.
- Provide a list of UUIDs that the key is being dropped from.
- The returned lists will exclude any of those UUIDs.
-
- The return lists also exclude any repositories that are untrusted,
- since those should not be used for verification.
-
- The UnVerifiedCopy list is cost ordered.
- The VerifiedCopy list contains repositories that are trusted to
- contain the key.
-}
knownCopies :: Key -> Annex ([Remote], [UUID])
knownCopies key = do
(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
verifiableCopies :: Key -> [UUID] -> Annex ([UnVerifiedCopy], [VerifiedCopy])
verifiableCopies key exclude = do
locs <- Remote.keyLocations key
(remotes, trusteduuids) <- Remote.remoteLocations locs
=<< trustGet Trusted
untrusteduuids <- trustGet UnTrusted
let exclude' = exclude ++ untrusteduuids
let remotes' = Remote.remotesWithoutUUID remotes (exclude' ++ trusteduuids)
let verified = map (mkVerifiedCopy TrustedCopy) $
filter (`notElem` exclude') trusteduuids
u <- getUUID
trusteduuids' <- ifM (inAnnex key <&&> (<= SemiTrusted) <$> lookupTrust u)
( pure (u:trusteduuids)
, pure trusteduuids
)
return (remotes, trusteduuids')
let herec = if u `elem` locs && u `notElem` exclude'
then [UnVerifiedHere]
else []
return (herec ++ map UnVerifiedRemote remotes', verified)

View file

@ -24,8 +24,6 @@ import Git.SharedRepository
import qualified Annex
import Config
import System.Posix.Types
withShared :: (SharedRepository -> Annex a) -> Annex a
withShared a = a =<< coreSharedRepository <$> Annex.getGitConfig

View file

@ -15,11 +15,12 @@ import Assistant.DaemonStatus
import Annex.Drop (handleDropsFrom, Reason)
import Logs.Location
import CmdLine.Action
import Types.NumCopies
{- Drop from local and/or remote when allowed by the preferred content and
- numcopies settings. -}
handleDrops :: Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant ()
handleDrops reason fromhere key f knownpresentremote = do
handleDrops :: Reason -> Bool -> Key -> AssociatedFile -> [VerifiedCopy] -> Assistant ()
handleDrops reason fromhere key f preverified = do
syncrs <- syncDataRemotes <$> getDaemonStatus
locs <- liftAnnex $ loggedLocations key
liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f knownpresentremote callCommandAction
liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f preverified callCommandAction

View file

@ -479,7 +479,7 @@ checkChangeContent change@(Change { changeInfo = i }) =
void $ if present
then queueTransfers "new file created" Next k (Just f) Upload
else queueTransfers "new or renamed file wanted" Next k (Just f) Download
handleDrops "file renamed" present k (Just f) Nothing
handleDrops "file renamed" present k (Just f) []
where
f = changeFile change
checkChangeContent _ = noop

View file

@ -191,7 +191,7 @@ dailyCheck urlrenderer = do
void $ liftAnnex $ setUnusedKeys unused
forM_ unused $ \k -> do
unlessM (queueTransfers "unused" Later k Nothing Upload) $
handleDrops "unused" True k Nothing Nothing
handleDrops "unused" True k Nothing []
return True
where

View file

@ -157,7 +157,7 @@ expensiveScan urlrenderer rs = batch <~> do
present <- liftAnnex $ inAnnex key
liftAnnex $ handleDropsFrom locs syncrs
"expensive scan found too many copies of object"
present key (Just f) Nothing callCommandAction
present key (Just f) [] callCommandAction
liftAnnex $ do
let slocs = S.fromList locs
let use a = return $ mapMaybe (a key slocs) syncrs

View file

@ -30,6 +30,7 @@ import Annex.Content
import Annex.Wanted
import Annex.Path
import Utility.Batch
import Types.NumCopies
import qualified Data.Map as M
import qualified Control.Exception as E
@ -160,7 +161,7 @@ genTransfer t info = case transferRemote info of
("object uploaded to " ++ show remote)
True (transferKey t)
(associatedFile info)
(Just remote)
[mkVerifiedCopy RecentlyVerifiedCopy remote]
void recordCommit
, whenM (liftAnnex $ isNothing <$> checkTransfer t) $
void $ removeTransfer t
@ -225,7 +226,7 @@ finishedTransfer t (Just info)
where
dodrops fromhere = handleDrops
("drop wanted after " ++ describeTransfer t info)
fromhere (transferKey t) (associatedFile info) Nothing
fromhere (transferKey t) (associatedFile info) []
finishedTransfer _ _ = noop
{- Pause a running transfer. -}

View file

@ -77,7 +77,7 @@ expireUnused duration = do
forM_ oldkeys $ \k -> do
debug ["removing old unused key", key2file k]
liftAnnex $ do
lockContent k removeAnnex
lockContentForRemoval k removeAnnex
logStatus k InfoMissing
where
boundry = durationToPOSIXTime <$> duration

View file

@ -97,7 +97,7 @@ startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO ol
, transferKey = k
}
cleanup = liftAnnex $ do
lockContent k removeAnnex
lockContentForRemoval k removeAnnex
setUrlMissing webUUID k u
logStatus k InfoMissing

View file

@ -20,6 +20,7 @@ import Remote.GCrypt (getGCryptUUID)
import qualified Command.ConfigList
import qualified Command.InAnnex
import qualified Command.LockContent
import qualified Command.DropKey
import qualified Command.RecvKey
import qualified Command.SendKey
@ -32,6 +33,7 @@ cmds_readonly :: [Command]
cmds_readonly =
[ Command.ConfigList.cmd
, gitAnnexShellCheck Command.InAnnex.cmd
, gitAnnexShellCheck Command.LockContent.cmd
, gitAnnexShellCheck Command.SendKey.cmd
, gitAnnexShellCheck Command.TransferInfo.cmd
, gitAnnexShellCheck Command.NotifyChanges.cmd

View file

@ -20,6 +20,7 @@ import Annex.Content
import Annex.Wanted
import Annex.Notification
import System.Log.Logger (debugM)
import qualified Data.Set as S
cmd :: Command
@ -64,11 +65,11 @@ start' o key afile = do
checkDropAuto (autoMode o) from afile key $ \numcopies ->
stopUnless (want from) $
case from of
Nothing -> startLocal afile numcopies key Nothing
Nothing -> startLocal afile numcopies key []
Just remote -> do
u <- getUUID
if Remote.uuid remote == u
then startLocal afile numcopies key Nothing
then startLocal afile numcopies key []
else startRemote afile numcopies key remote
where
want from
@ -78,35 +79,31 @@ start' o key afile = do
startKeys :: DropOptions -> Key -> CommandStart
startKeys o key = start' o key Nothing
startLocal :: AssociatedFile -> NumCopies -> Key -> Maybe Remote -> CommandStart
startLocal afile numcopies key knownpresentremote = stopUnless (inAnnex key) $ do
startLocal :: AssociatedFile -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart
startLocal afile numcopies key preverified = stopUnless (inAnnex key) $ do
showStart' "drop" key afile
next $ performLocal key afile numcopies knownpresentremote
next $ performLocal key afile numcopies preverified
startRemote :: AssociatedFile -> NumCopies -> Key -> Remote -> CommandStart
startRemote afile numcopies key remote = do
showStart' ("drop " ++ Remote.name remote) key afile
next $ performRemote key afile numcopies remote
-- Note that lockContent is called before checking if the key is present
-- on enough remotes to allow removal. This avoids a scenario where two
-- or more remotes are trying to remove a key at the same time, and each
-- see the key is present on the other.
performLocal :: Key -> AssociatedFile -> NumCopies -> Maybe Remote -> CommandPerform
performLocal key afile numcopies knownpresentremote = lockContent key $ \contentlock -> do
(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
let trusteduuids' = case knownpresentremote of
Nothing -> trusteduuids
Just r -> Remote.uuid r:trusteduuids
untrusteduuids <- trustGet UnTrusted
let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids'++untrusteduuids)
performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform
performLocal key afile numcopies preverified = lockContentForRemoval key $ \contentlock -> do
u <- getUUID
ifM (canDrop u key afile numcopies trusteduuids' tocheck [])
( do
(tocheck, verified) <- verifiableCopies key [u]
doDrop u (Just contentlock) key afile numcopies [] (preverified ++ verified) tocheck
( \proof -> do
liftIO $ debugM "drop" $ unwords
[ "Dropping from here"
, "proof:"
, show proof
]
removeAnnex contentlock
notifyDrop afile True
next $ cleanupLocal key
, do
, do
notifyDrop afile False
stop
)
@ -117,14 +114,19 @@ performRemote key afile numcopies remote = do
-- places assumed to have the key, and places to check.
-- When the local repo has the key, that's one additional copy,
-- as long as the local repo is not untrusted.
(remotes, trusteduuids) <- knownCopies key
let have = filter (/= uuid) trusteduuids
untrusteduuids <- trustGet UnTrusted
let tocheck = filter (/= remote) $
Remote.remotesWithoutUUID remotes (have++untrusteduuids)
stopUnless (canDrop uuid key afile numcopies have tocheck [uuid]) $ do
ok <- Remote.removeKey remote key
next $ cleanupRemote key remote ok
(tocheck, verified) <- verifiableCopies key [uuid]
doDrop uuid Nothing key afile numcopies [uuid] verified tocheck
( \proof -> do
liftIO $ debugM "drop" $ unwords
[ "Dropping from remote"
, show remote
, "proof:"
, show proof
]
ok <- Remote.removeKey remote key
next $ cleanupRemote key remote ok
, stop
)
where
uuid = Remote.uuid remote
@ -139,30 +141,42 @@ cleanupRemote key remote ok = do
Remote.logStatus remote key InfoMissing
return ok
{- Checks specified remotes to verify that enough copies of a key exist to
- allow it to be safely removed (with no data loss). Can be provided with
- some locations where the key is known/assumed to be present.
{- Before running the dropaction, checks specified remotes to
- verify that enough copies of a key exist to allow it to be
- safely removed (with no data loss).
-
- Also checks if it's required content, and refuses to drop if so.
-
- --force overrides and always allows dropping.
-}
canDrop :: UUID -> Key -> AssociatedFile -> NumCopies -> [UUID] -> [Remote] -> [UUID] -> Annex Bool
canDrop dropfrom key afile numcopies have check skip =
doDrop
:: UUID
-> Maybe ContentRemovalLock
-> Key
-> AssociatedFile
-> NumCopies
-> [UUID]
-> [VerifiedCopy]
-> [UnVerifiedCopy]
-> (Maybe SafeDropProof -> CommandPerform, CommandPerform)
-> CommandPerform
doDrop dropfrom contentlock key afile numcopies skip preverified check (dropaction, nodropaction) =
ifM (Annex.getState Annex.force)
( return True
, ifM (checkRequiredContent dropfrom key afile
<&&> verifyEnoughCopies nolocmsg key numcopies skip have check
)
( return True
, do
hint
return False
)
( dropaction Nothing
, ifM (checkRequiredContent dropfrom key afile)
( verifyEnoughCopiesToDrop nolocmsg key
contentlock numcopies
skip preverified check
(dropaction . Just)
(forcehint nodropaction)
, stop
)
)
where
nolocmsg = "Rather than dropping this file, try using: git annex move"
hint = showLongNote "(Use --force to override this check, or adjust numcopies.)"
forcehint a = do
showLongNote "(Use --force to override this check, or adjust numcopies.)"
a
checkRequiredContent :: UUID -> Key -> AssociatedFile -> Annex Bool
checkRequiredContent u k afile =

View file

@ -31,7 +31,7 @@ start key = stopUnless (inAnnex key) $ do
next $ perform key
perform :: Key -> CommandPerform
perform key = lockContent key $ \contentlock -> do
perform key = lockContentForRemoval key $ \contentlock -> do
removeAnnex contentlock
next $ cleanup key

View file

@ -44,7 +44,7 @@ perform from numcopies key = case from of
Just r -> do
showAction $ "from " ++ Remote.name r
Command.Drop.performRemote key Nothing numcopies r
Nothing -> Command.Drop.performLocal key Nothing numcopies Nothing
Nothing -> Command.Drop.performLocal key Nothing numcopies []
performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform
performOther filespec key = do

View file

@ -19,8 +19,6 @@ import Types.KeySource
import Types.Key
import Annex.CheckIgnore
import Annex.NumCopies
import Types.TrustLevel
import Logs.Trust
cmd :: Command
cmd = withGlobalOptions fileMatchingOptions $ notBareRepo $
@ -83,7 +81,7 @@ start mode (srcfile, destfile) =
where
deletedup k = do
showNote $ "duplicate of " ++ key2file k
ifM (verifiedExisting k destfile)
verifyExisting k destfile
( do
liftIO $ removeFile srcfile
next $ return True
@ -134,13 +132,12 @@ start mode (srcfile, destfile) =
SkipDuplicates -> checkdup Nothing (Just importfile)
_ -> return (Just importfile)
verifiedExisting :: Key -> FilePath -> Annex Bool
verifiedExisting key destfile = do
verifyExisting :: Key -> FilePath -> (CommandPerform, CommandPerform) -> CommandPerform
verifyExisting key destfile (yes, no) = do
-- Look up the numcopies setting for the file that it would be
-- imported to, if it were imported.
need <- getFileNumCopies destfile
(remotes, trusteduuids) <- knownCopies key
untrusteduuids <- trustGet UnTrusted
let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids++untrusteduuids)
verifyEnoughCopies [] key need [] trusteduuids tocheck
(tocheck, preverified) <- verifiableCopies key []
verifyEnoughCopiesToDrop [] key Nothing need [] preverified tocheck
(const yes) no

46
Command/LockContent.hs Normal file
View file

@ -0,0 +1,46 @@
{- git-annex-shell command
-
- Copyright 2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Command.LockContent where
import Common.Annex
import Command
import Annex.Content
import Types.Key
import Remote.Helper.Ssh (contentLockedMarker)
cmd :: Command
cmd = noCommit $
command "lockcontent" SectionPlumbing
"locks key's content in the annex, preventing it being dropped"
paramKey
(withParams seek)
seek :: CmdParams -> CommandSeek
seek = withWords start
-- First, lock the content. Then, make sure the content is actually
-- present, and print out a "1". Wait for the caller to send a line before
-- dropping the lock.
start :: [String] -> CommandStart
start [ks] = do
ok <- lockContentShared k (const locksuccess)
`catchNonAsync` (const $ return False)
liftIO $ if ok
then exitSuccess
else exitFailure
where
k = fromMaybe (error "bad key") (file2key ks)
locksuccess = ifM (inAnnex k)
( liftIO $ do
putStrLn contentLockedMarker
hFlush stdout
_ <- getLine
return True
, return False
)
start _ = error "Specify exactly 1 key."

View file

@ -65,7 +65,7 @@ startKey o afile key = case fromToOptions o of
Right False -> ifM (inAnnex key)
( do
numcopies <- getnumcopies
Command.Drop.startLocal afile numcopies key Nothing
Command.Drop.startLocal afile numcopies key []
, stop
)
where

View file

@ -1,6 +1,6 @@
{- git-annex command
-
- Copyright 2010-2013 Joey Hess <id@joeyh.name>
- Copyright 2010-2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@ -16,6 +16,9 @@ import qualified Remote
import Annex.UUID
import Annex.Transfer
import Logs.Presence
import Annex.NumCopies
import System.Log.Logger (debugM)
cmd :: Command
cmd = withGlobalOptions (jobsOption : annexedMatchingOptions) $
@ -123,7 +126,7 @@ toPerform dest move key afile fastcheck isthere =
finish
where
finish
| move = lockContent key $ \contentlock -> do
| move = lockContentForRemoval key $ \contentlock -> do
removeAnnex contentlock
next $ Command.Drop.cleanupLocal key
| otherwise = next $ return True
@ -170,6 +173,18 @@ fromPerform src move key afile = ifM (inAnnex key)
Remote.retrieveKeyFile src key afile t p
dispatch _ False = stop -- failed
dispatch False True = next $ return True -- copy complete
dispatch True True = do -- finish moving
-- Finish by dropping from remote, taking care to verify that
-- the copy here has not been lost somehow.
-- (NumCopies is 1 since we're moving.)
dispatch True True = verifyEnoughCopiesToDrop "" key Nothing
(NumCopies 1) [] [] [UnVerifiedHere] dropremote faileddropremote
dropremote proof = do
liftIO $ debugM "drop" $ unwords
[ "Dropping from remote"
, show src
, "proof:"
, show proof
]
ok <- Remote.removeKey src key
next $ Command.Drop.cleanupRemote key src ok
faileddropremote = error "Unable to drop from remote."

View file

@ -460,8 +460,8 @@ syncFile ebloom rs af k = do
-- includeCommandAction for drops,
-- because a failure to drop does not mean
-- the sync failed.
handleDropsFrom locs' rs "unwanted" True k af
Nothing callCommandAction
handleDropsFrom locs' rs "unwanted" True k af []
callCommandAction
return (got || not (null putrs))
where

View file

@ -120,7 +120,7 @@ test st r k =
, check "storeKey when already present" store
, present True
, check "retrieveKeyFile" $ do
lockContent k removeAnnex
lockContentForRemoval k removeAnnex
get
, check "fsck downloaded object" fsck
, check "retrieveKeyFile resume from 33%" $ do
@ -130,20 +130,20 @@ test st r k =
sz <- hFileSize h
L.hGet h $ fromInteger $ sz `div` 3
liftIO $ L.writeFile tmp partial
lockContent k removeAnnex
lockContentForRemoval k removeAnnex
get
, check "fsck downloaded object" fsck
, check "retrieveKeyFile resume from 0" $ do
tmp <- prepTmp k
liftIO $ writeFile tmp ""
lockContent k removeAnnex
lockContentForRemoval k removeAnnex
get
, check "fsck downloaded object" fsck
, check "retrieveKeyFile resume from end" $ do
loc <- Annex.calcRepo (gitAnnexLocation k)
tmp <- prepTmp k
void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp
lockContent k removeAnnex
lockContentForRemoval k removeAnnex
get
, check "fsck downloaded object" fsck
, check "removeKey when present" remove
@ -189,7 +189,7 @@ testUnavailable st r k =
cleanup :: [Remote] -> [Key] -> Bool -> CommandCleanup
cleanup rs ks ok = do
forM_ rs $ \r -> forM_ ks (Remote.removeKey r)
forM_ ks $ \k -> lockContent k removeAnnex
forM_ ks $ \k -> lockContentForRemoval k removeAnnex
return ok
chunkSizes :: Int -> Bool -> [Int]

View file

@ -105,7 +105,7 @@ removeUnannexed = go []
go c [] = return c
go c (k:ks) = ifM (inAnnexCheck k $ liftIO . enoughlinks)
( do
lockContent k removeAnnex
lockContentForRemoval k removeAnnex
go c ks
, go (k:c) ks
)

View file

@ -40,7 +40,7 @@ module Remote (
remotesWithoutUUID,
keyLocations,
keyPossibilities,
keyPossibilitiesTrusted,
remoteLocations,
nameToUUID,
nameToUUID',
showTriedRemotes,
@ -260,33 +260,26 @@ keyLocations key = trustExclude DeadTrusted =<< loggedLocations key
- may have a key.
-}
keyPossibilities :: Key -> Annex [Remote]
keyPossibilities key = fst <$> keyPossibilities' key []
{- Cost ordered lists of remotes that the location log indicates
- may have a key.
-
- Also returns a list of UUIDs that are trusted to have the key
- (some may not have configured remotes).
-}
keyPossibilitiesTrusted :: Key -> Annex ([Remote], [UUID])
keyPossibilitiesTrusted key = keyPossibilities' key =<< trustGet Trusted
keyPossibilities' :: Key -> [UUID] -> Annex ([Remote], [UUID])
keyPossibilities' key trusted = do
keyPossibilities key = do
u <- getUUID
-- uuids of all remotes that are recorded to have the key
validuuids <- filter (/= u) <$> keyLocations key
locations <- filter (/= u) <$> keyLocations key
fst <$> remoteLocations locations []
-- note that validuuids is assumed to not have dups
let validtrusteduuids = validuuids `intersect` trusted
{- Given a list of locations of a key, and a list of all
- trusted repositories, generates a cost-ordered list of
- remotes that contain the key, and a list of trusted locations of the key.
-}
remoteLocations :: [UUID] -> [UUID] -> Annex ([Remote], [UUID])
remoteLocations locations trusted = do
let validtrustedlocations = nub locations `intersect` trusted
-- remotes that match uuids that have the key
allremotes <- filter (not . remoteAnnexIgnore . gitconfig)
<$> remoteList
let validremotes = remotesWithUUID allremotes validuuids
let validremotes = remotesWithUUID allremotes locations
return (sortBy (comparing cost) validremotes, validtrusteduuids)
return (sortBy (comparing cost) validremotes, validtrustedlocations)
{- Displays known locations of a key. -}
showLocations :: Bool -> Key -> [UUID] -> String -> Annex ()

View file

@ -58,6 +58,7 @@ gen r _ c gc =
, retrieveKeyFile = downloadKey
, retrieveKeyFileCheap = downloadKeyCheap
, removeKey = dropKey
, lockContent = Nothing
, checkPresent = checkKey
, checkPresentCheap = False
, whereisKey = Nothing

View file

@ -58,6 +58,7 @@ gen r u c gc = do
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap buprepo
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = bupLocal buprepo
, whereisKey = Nothing

View file

@ -57,6 +57,7 @@ gen r u c gc = do
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = ddarLocal ddarrepo
, whereisKey = Nothing

View file

@ -55,6 +55,7 @@ gen r u c gc = do
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap dir chunkconfig
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = True
, whereisKey = Nothing

View file

@ -81,6 +81,7 @@ gen r u c gc
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = \_ _ _ -> return False
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
, whereisKey = towhereis

View file

@ -111,6 +111,7 @@ gen' r u c gc = do
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = \_ _ _ -> return False
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = repoCheap r
, whereisKey = Nothing

View file

@ -53,9 +53,11 @@ import Annex.Path
import Creds
import Annex.CatFile
import Messages.Progress
import Types.NumCopies
import Control.Concurrent
import Control.Concurrent.MSampleVar
import Control.Concurrent.Async
import qualified Data.Map as M
import Network.URI
@ -142,6 +144,7 @@ gen r u c gc
, retrieveKeyFile = copyFromRemote new
, retrieveKeyFileCheap = copyFromRemoteCheap new
, removeKey = dropKey new
, lockContent = Just (lockKey new)
, checkPresent = inAnnex new
, checkPresentCheap = repoCheap r
, whereisKey = Nothing
@ -350,7 +353,7 @@ dropKey r key
commitOnCleanup r $ onLocal r $ do
ensureInitialized
whenM (Annex.Content.inAnnex key) $ do
Annex.Content.lockContent key
Annex.Content.lockContentForRemoval key
Annex.Content.removeAnnex
logStatus key InfoMissing
Annex.Content.saveState True
@ -358,6 +361,64 @@ dropKey r key
| Git.repoIsHttp (repo r) = error "dropping from http remote not supported"
| otherwise = commitOnCleanup r $ Ssh.dropKey (repo r) key
lockKey :: Remote -> Key -> (VerifiedCopy -> Annex r) -> Annex r
lockKey r key callback
| not $ Git.repoIsUrl (repo r) =
guardUsable (repo r) failedlock $ do
inorigrepo <- Annex.makeRunner
-- Lock content from perspective of remote,
-- and then run the callback in the original
-- annex monad, not the remote's.
onLocal r $
Annex.Content.lockContentShared key $ \vc ->
ifM (Annex.Content.inAnnex key)
( liftIO $ inorigrepo $ callback vc
, failedlock
)
| Git.repoIsSsh (repo r) = do
showLocking r
Just (cmd, params) <- Ssh.git_annex_shell (repo r) "lockcontent"
[Param $ key2file key] []
(Just hin, Just hout, Nothing, p) <- liftIO $
withFile devNull WriteMode $ \nullh ->
createProcess $
(proc cmd (toCommand params))
{ std_in = CreatePipe
, std_out = CreatePipe
, std_err = UseHandle nullh
}
-- Wait for either the process to exit, or for it to
-- indicate the content is locked.
v <- liftIO $ race
(waitForProcess p)
(hGetLine hout)
let signaldone = void $ tryNonAsync $ liftIO $ do
hPutStrLn hout ""
hFlush hout
hClose hin
hClose hout
void $ waitForProcess p
let checkexited = not . isJust <$> getProcessExitCode p
case v of
Left _exited -> do
showNote "lockcontent failed"
liftIO $ do
hClose hin
hClose hout
failedlock
Right l
| l == Ssh.contentLockedMarker -> bracket_
noop
signaldone
(withVerifiedCopy LockedCopy r checkexited callback)
| otherwise -> do
showNote "lockcontent failed"
signaldone
failedlock
| otherwise = failedlock
where
failedlock = error "can't lock content"
{- Tries to copy a key's content from a remote's annex to a file. -}
copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)
copyFromRemote r key file dest p = parallelMetered (Just p) key file $

View file

@ -55,6 +55,7 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap this
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
, whereisKey = Nothing

View file

@ -13,20 +13,23 @@ import Common.Annex
import qualified Git
import qualified Types.Remote as Remote
class Checkable a where
descCheckable :: a -> String
class Describable a where
describe :: a -> String
instance Checkable Git.Repo where
descCheckable = Git.repoDescribe
instance Describable Git.Repo where
describe = Git.repoDescribe
instance Checkable (Remote.RemoteA a) where
descCheckable = Remote.name
instance Describable (Remote.RemoteA a) where
describe = Remote.name
instance Checkable String where
descCheckable = id
instance Describable String where
describe = id
showChecking :: Checkable a => a -> Annex ()
showChecking v = showAction $ "checking " ++ descCheckable v
showChecking :: Describable a => a -> Annex ()
showChecking v = showAction $ "checking " ++ describe v
cantCheck :: Checkable a => a -> e
cantCheck v = error $ "unable to check " ++ descCheckable v
cantCheck :: Describable a => a -> e
cantCheck v = error $ "unable to check " ++ describe v
showLocking :: Describable a => a -> Annex ()
showLocking v = showAction $ "locking " ++ describe v

View file

@ -173,3 +173,8 @@ rsyncParams r direction = do
| direction == Download = remoteAnnexRsyncDownloadOptions gc
| otherwise = remoteAnnexRsyncUploadOptions gc
gc = gitconfig r
-- Used by git-annex-shell lockcontent to indicate the content is
-- successfully locked.
contentLockedMarker :: String
contentLockedMarker = "OK"

View file

@ -49,6 +49,7 @@ gen r u c gc = do
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap hooktype
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
, whereisKey = Nothing

View file

@ -70,6 +70,7 @@ gen r u c gc = do
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap o
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
, whereisKey = Nothing

View file

@ -81,6 +81,7 @@ gen r u c gc = do
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
, whereisKey = Just (getWebUrls info)

View file

@ -72,6 +72,7 @@ gen r u c gc = do
, retrieveKeyFile = retrieve u hdl
, retrieveKeyFileCheap = \_ _ _ -> return False
, removeKey = remove
, lockContent = Nothing
, checkPresent = checkKey u hdl
, checkPresentCheap = False
, whereisKey = Nothing

View file

@ -52,6 +52,7 @@ gen r _ c gc =
, retrieveKeyFile = downloadKey
, retrieveKeyFileCheap = downloadKeyCheap
, removeKey = dropKey
, lockContent = Nothing
, checkPresent = checkKey
, checkPresentCheap = False
, whereisKey = Nothing

View file

@ -60,6 +60,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
, whereisKey = Nothing

View file

@ -1,14 +1,178 @@
{- git-annex numcopies type
{- git-annex numcopies types
-
- Copyright 2014 Joey Hess <id@joeyh.name>
- Copyright 2014-2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Types.NumCopies where
module Types.NumCopies (
NumCopies(..),
fromNumCopies,
VerifiedCopy(..),
checkVerifiedCopy,
invalidateVerifiedCopy,
strongestVerifiedCopy,
deDupVerifiedCopies,
mkVerifiedCopy,
invalidatableVerifiedCopy,
withVerifiedCopy,
isSafeDrop,
SafeDropProof,
mkSafeDropProof,
ContentRemovalLock(..),
) where
import Types.UUID
import Types.Key
import Utility.Exception (bracketIO)
import Utility.Monad
import qualified Data.Map as M
import Control.Concurrent.MVar
import Control.Monad.Catch (MonadMask)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad
newtype NumCopies = NumCopies Int
deriving (Ord, Eq)
deriving (Ord, Eq, Show)
fromNumCopies :: NumCopies -> Int
fromNumCopies (NumCopies n) = n
-- Indicates that a key's content is exclusively
-- locked locally, pending removal.
newtype ContentRemovalLock = ContentRemovalLock Key
deriving (Show)
-- A verification that a copy of a key exists in a repository.
data VerifiedCopy
{- Represents a recent verification that a copy of an
- object exists in a repository with the given UUID. -}
= RecentlyVerifiedCopy V
{- Use when a repository cannot be accessed, but it's
- a trusted repository, which is on record as containing a key
- and is presumably not going to lose its copy. -}
| TrustedCopy V
{- The strongest proof of the existence of a copy.
- Until its associated action is called to unlock it,
- the copy is locked in the repository and is guaranteed
- not to be removed by any git-annex process. -}
| LockedCopy V
deriving (Show)
data V = V
{ _getUUID :: UUID
, _checkVerifiedCopy :: IO Bool
, _invalidateVerifiedCopy :: IO ()
}
instance Show V where
show v = show (_getUUID v)
instance ToUUID VerifiedCopy where
toUUID = _getUUID . toV
toV :: VerifiedCopy -> V
toV (TrustedCopy v) = v
toV (RecentlyVerifiedCopy v) = v
toV (LockedCopy v) = v
-- Checks that it's still valid.
checkVerifiedCopy :: VerifiedCopy -> IO Bool
checkVerifiedCopy = _checkVerifiedCopy . toV
invalidateVerifiedCopy :: VerifiedCopy -> IO ()
invalidateVerifiedCopy = _invalidateVerifiedCopy . toV
strongestVerifiedCopy :: VerifiedCopy -> VerifiedCopy -> VerifiedCopy
strongestVerifiedCopy a@(LockedCopy _) _ = a
strongestVerifiedCopy _ b@(LockedCopy _) = b
strongestVerifiedCopy a@(TrustedCopy _) _ = a
strongestVerifiedCopy _ b@(TrustedCopy _) = b
strongestVerifiedCopy a@(RecentlyVerifiedCopy _) _ = a
-- Retains stronger verifications over weaker for the same uuid.
deDupVerifiedCopies :: [VerifiedCopy] -> [VerifiedCopy]
deDupVerifiedCopies l = M.elems $
M.fromListWith strongestVerifiedCopy (zip (map toUUID l) l)
mkVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> VerifiedCopy
mkVerifiedCopy mk u = mk $ V (toUUID u) (return True) (return ())
invalidatableVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> IO Bool -> IO VerifiedCopy
invalidatableVerifiedCopy mk u check = do
v <- newEmptyMVar
let invalidate = do
_ <- tryPutMVar v ()
return ()
let check' = isEmptyMVar v <&&> check
return $ mk $ V (toUUID u) check' invalidate
-- Constructs a VerifiedCopy, and runs the action, ensuring that the
-- verified copy is invalidated when the action returns, or on error.
withVerifiedCopy
:: (Monad m, MonadMask m, MonadIO m, ToUUID u)
=> (V -> VerifiedCopy)
-> u
-> IO Bool
-> (VerifiedCopy -> m a)
-> m a
withVerifiedCopy mk u check = bracketIO setup cleanup
where
setup = invalidatableVerifiedCopy mk u check
cleanup = invalidateVerifiedCopy
{- Check whether enough verification has been done of copies to allow
- dropping content safely.
-
- This is carefully balanced to prevent data loss when there are races
- between concurrent drops of the same content in different repos,
- without requiring impractical amounts of locking.
-
- In particular, concurrent drop races may cause the number of copies
- to fall below NumCopies, but it will never fall below 1.
-}
isSafeDrop :: NumCopies -> [VerifiedCopy] -> Maybe ContentRemovalLock -> Bool
{- When a ContentRemovalLock is provided, the content is being
- dropped from the local repo. That lock will prevent other git repos
- that are concurrently dropping from using the local copy as a VerifiedCopy.
- So, no additional locking is needed; all we need is verifications
- of any kind of N other copies of the content. -}
isSafeDrop (NumCopies n) l (Just (ContentRemovalLock _)) =
length (deDupVerifiedCopies l) >= n
{- Dropping from a remote repo.
-
- Unless numcopies is 0, at least one LockedCopy or TrustedCopy is required.
- A LockedCopy prevents races between concurrent drops from
- dropping the last copy, no matter what.
-
- The other N-1 copies can be less strong verifications, like
- RecentlyVerifiedCopy. While those are subject to concurrent drop races,
- and so could be dropped all at once, causing numcopies to be violated,
- this is the best that can be done without requiring that
- all special remotes support locking.
-}
isSafeDrop (NumCopies n) l Nothing
| n == 0 = True
| otherwise = and
[ length (deDupVerifiedCopies l) >= n
, any fullVerification l
]
fullVerification :: VerifiedCopy -> Bool
fullVerification (LockedCopy _) = True
fullVerification (TrustedCopy _) = True
fullVerification (RecentlyVerifiedCopy _) = False
-- A proof that it's currently safe to drop an object.
data SafeDropProof = SafeDropProof NumCopies [VerifiedCopy] (Maybe ContentRemovalLock)
deriving (Show)
-- Make sure that none of the VerifiedCopies have become invalidated
-- before constructing proof.
mkSafeDropProof :: NumCopies -> [VerifiedCopy] -> Maybe ContentRemovalLock -> IO (Either [VerifiedCopy] SafeDropProof)
mkSafeDropProof need have removallock = do
stillhave <- filterM checkVerifiedCopy have
return $ if isSafeDrop need stillhave removallock
then Right (SafeDropProof need stillhave removallock)
else Left stillhave

View file

@ -7,6 +7,8 @@
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE RankNTypes #-}
module Types.Remote
( RemoteConfigKey
, RemoteConfig
@ -28,6 +30,7 @@ import Types.GitConfig
import Types.Availability
import Types.Creds
import Types.UrlContents
import Types.NumCopies
import Config.Cost
import Utility.Metered
import Git.Types
@ -72,8 +75,14 @@ data RemoteA a = Remote {
-- Retrieves a key's contents to a tmp file, if it can be done cheaply.
-- It's ok to create a symlink or hardlink.
retrieveKeyFileCheap :: Key -> AssociatedFile -> FilePath -> a Bool,
-- removes a key's contents (succeeds if the contents are not present)
-- Removes a key's contents (succeeds if the contents are not present)
removeKey :: Key -> a Bool,
-- Uses locking to prevent removal of a key's contents,
-- thus producing a VerifiedCopy, which is passed to the callback.
-- If unable to lock, does not run the callback, and throws an
-- error.
-- This is optional; remotes do not have to support locking.
lockContent :: forall r. Maybe (Key -> (VerifiedCopy -> a r) -> a r),
-- Checks if a key is present in the remote.
-- Throws an exception if the remote cannot be accessed.
checkPresent :: Key -> a Bool,
@ -125,6 +134,9 @@ instance Eq (RemoteA a) where
instance Ord (RemoteA a) where
compare = comparing uuid
instance ToUUID (RemoteA a) where
toUUID = uuid
-- Use Verified when the content of a key is verified as part of a
-- transfer, and so a separate verification step is not needed.
data Verification = UnVerified | Verified

View file

@ -5,6 +5,8 @@
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module Types.UUID where
import qualified Data.Map as M
@ -19,9 +21,15 @@ fromUUID :: UUID -> String
fromUUID (UUID u) = u
fromUUID NoUUID = ""
toUUID :: String -> UUID
toUUID [] = NoUUID
toUUID s = UUID s
class ToUUID a where
toUUID :: a -> UUID
instance ToUUID UUID where
toUUID = id
instance ToUUID String where
toUUID [] = NoUUID
toUUID s = UUID s
isUUID :: String -> Bool
isUUID = isJust . U.fromString

View file

@ -7,7 +7,32 @@
{-# LANGUAGE CPP #-}
module Utility.FileMode where
module Utility.FileMode (
FileMode,
modifyFileMode,
addModes,
removeModes,
writeModes,
readModes,
executeModes,
otherGroupModes,
preventWrite,
allowWrite,
allowRead,
groupSharedModes,
groupWriteRead,
checkMode,
isSymLink,
isExecutable,
noUmask,
withUmask,
combineModes,
isSticky,
stickyMode,
setSticky,
writeFileProtected,
writeFileProtected'
) where
import System.IO
import Control.Monad

View file

@ -9,6 +9,7 @@ module Utility.LockFile.Posix (
LockHandle,
lockShared,
lockExclusive,
tryLockShared,
tryLockExclusive,
checkLocked,
getLockStatus,
@ -36,31 +37,43 @@ lockShared = lock ReadLock
lockExclusive :: Maybe FileMode -> LockFile -> IO LockHandle
lockExclusive = lock WriteLock
-- Tries to take a shared lock, but does not block.
tryLockShared :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
tryLockShared = tryLock ReadLock
-- Tries to take an exclusive lock, but does not block.
tryLockExclusive :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
tryLockExclusive mode lockfile = do
l <- openLockFile mode lockfile
v <- tryIO $ setLock l (WriteLock, AbsoluteSeek, 0, 0)
tryLockExclusive = tryLock WriteLock
-- Setting the FileMode allows creation of a new lock file.
-- If it's Nothing then this only succeeds when the lock file already exists.
lock :: LockRequest -> Maybe FileMode -> LockFile -> IO LockHandle
lock lockreq mode lockfile = do
l <- openLockFile lockreq mode lockfile
waitToSetLock l (lockreq, AbsoluteSeek, 0, 0)
return (LockHandle l)
-- Tries to take an lock, but does not block.
tryLock :: LockRequest -> Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
tryLock lockreq mode lockfile = do
l <- openLockFile lockreq mode lockfile
v <- tryIO $ setLock l (lockreq, AbsoluteSeek, 0, 0)
case v of
Left _ -> do
closeFd l
return Nothing
Right _ -> return $ Just $ LockHandle l
-- Setting the FileMode allows creation of a new lock file.
-- If it's Nothing then this only succeeds when the lock file already exists.
lock :: LockRequest -> Maybe FileMode -> LockFile -> IO LockHandle
lock lockreq mode lockfile = do
l <- openLockFile mode lockfile
waitToSetLock l (lockreq, AbsoluteSeek, 0, 0)
return (LockHandle l)
-- Close on exec flag is set so child processes do not inherit the lock.
openLockFile :: Maybe FileMode -> LockFile -> IO Fd
openLockFile filemode lockfile = do
l <- openFd lockfile ReadWrite filemode defaultFileFlags
openLockFile :: LockRequest -> Maybe FileMode -> LockFile -> IO Fd
openLockFile lockreq filemode lockfile = do
l <- openFd lockfile openfor filemode defaultFileFlags
setFdOption l CloseOnExec True
return l
where
openfor = case lockreq of
ReadLock -> ReadOnly
_ -> ReadWrite
-- Returns Nothing when the file doesn't exist, for cases where
-- that is different from it not being locked.
@ -81,7 +94,7 @@ getLockStatus lockfile = do
getLockStatus' :: LockFile -> IO (Maybe (Maybe ProcessID))
getLockStatus' lockfile = go =<< catchMaybeIO open
where
open = openFd lockfile ReadOnly Nothing defaultFileFlags
open = openLockFile ReadLock Nothing lockfile
go Nothing = return Nothing
go (Just h) = do
v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)

View file

@ -6,9 +6,11 @@
-}
module Utility.LockPool.Posix (
P.LockFile,
LockHandle,
lockShared,
lockExclusive,
tryLockShared,
tryLockExclusive,
checkLocked,
getLockStatus,
@ -35,11 +37,19 @@ lockShared mode file = makeLockHandle
(P.waitTakeLock P.lockPool file LockShared)
(F.lockShared mode file)
-- Takes an exclusive lock, blocking until the lock is available.
lockExclusive :: Maybe FileMode -> LockFile -> IO LockHandle
lockExclusive mode file = makeLockHandle
(P.waitTakeLock P.lockPool file LockExclusive)
(F.lockExclusive mode file)
-- Tries to take a shared lock, but does not block.
tryLockShared :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
tryLockShared mode file = tryMakeLockHandle
(P.tryTakeLock P.lockPool file LockShared)
(F.tryLockShared mode file)
-- Tries to take an exclusive lock, but does not block.
tryLockExclusive :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)
tryLockExclusive mode file = tryMakeLockHandle
(P.tryTakeLock P.lockPool file LockExclusive)

View file

@ -6,6 +6,7 @@
-}
module Utility.LockPool.Windows (
P.LockFile,
LockHandle,
lockShared,
lockExclusive,

16
debian/changelog vendored
View file

@ -1,5 +1,19 @@
git-annex (5.20150931) UNRELEASED; urgency=medium
* Fix a longstanding bug, where dropping a file from a remote
could race with other drops of the same file, and result in
all copies of its content being lost.
* git-annex-shell: Added lockcontent command, to prevent dropping of
a key's content. This is necessary due to the above bugfix.
* In some cases, the above bugfix changes what git-annex allows to be dropped:
- When a file is present in several special remotes,
but not in any accessible git repositories, dropping it from one of
the special remotes will now fail. Instead, the file has to be
moved from one of the special remotes to the git repository, and can
then safely be dropped from the git repository.
- If a git remote has too old a version of git-annex-shell installed,
git-annex won't trust it to hold onto a copy of a file when dropping
that file from some other remote.
* Do verification of checksums of annex objects downloaded from remotes.
* When annex objects are received into git repositories from other git
repos, their checksums are verified then too.
@ -20,7 +34,7 @@ git-annex (5.20150931) UNRELEASED; urgency=medium
and stop recommending bittornado | bittorrent.
* Debian: Remove dependency on transformers library, as it is now
included in ghc.
-- Joey Hess <id@joeyh.name> Thu, 01 Oct 2015 12:42:56 -0400
git-annex (5.20150930) unstable; urgency=medium

View file

@ -2,6 +2,8 @@ Concurrent dropping of a file has problems when drop --from is
used. (Also when the assistant or sync --content decided to drop from a
remote.)
> Now [[fixed|done]] --[[Joey]]
[[!toc]]
# refresher
@ -73,6 +75,8 @@ as part of its check of numcopies, and keep it locked
while it's asking B to drop it. Then when B tells A to drop it,
it'll be locked and that'll fail (and vice-versa).
> Done, and verified the fix works in this situation.
# the bug part 2
<pre>
@ -116,6 +120,8 @@ Note that this is analgous to the fix above; in both cases
the change is from checking if content is in a location, to locking it in
that location while performing a drop from another location.
> Done, and verified the fix works in this situation.
# the bug part 3 (where it gets really nasty)
<pre>
@ -198,6 +204,9 @@ never entirely lost.
Dipping below desired numcopies in an unusual race condition, and then
doing extra work later to recover may be good enough.
> Implemented, and I've now verified this solves the case above.
> Indeed, neither drop succeeds, because no copy can be locked.
### to drop from local repo
When dropping an object from the local repo, lock it for drop,
@ -339,3 +348,22 @@ A drops B keeps C keeps
It can race other ways, but they all work out the same way essentially,
due to the locking.
</pre>
# the bug, with moves
`git annex move --from remote` is the same as a copy followed by drop --from,
so the same bug can occur then.
But, the implementation differs from Command.Drop, so will also
need some changes.
Command.Move.toPerform already locks local content for removal before
removing it, of course. So, that will interoperate fine with
concurrent drops/moves. Seems fine as-is.
Command.Move.fromPerform simply needs to lock the local content
in place before dropping it from the remote. This satisfies the need
for 1 locked copy when dropping from a remote, and so is sufficent to
fix the bug.
> done

View file

@ -43,6 +43,17 @@ first "/~/" or "/~user/" is expanded to the specified home directory.
Exits 100 if it's unable to tell (perhaps the key is in the process of
being removed from the annex).
* lockcontent directory key
This locks a key's content in place in the annex, preventing it from
being dropped.
Once the content is successfully locked, outputs "OK". Then the content
remains locked until a newline is received from the caller or the
connection is broken.
Exits nonzero if the content is not present, or could not be locked.
* dropkey directory [key ...]
This drops the annexed data for the specified keys.