Merge branch 'dropproof'
This commit is contained in:
commit
22691478cf
50 changed files with 785 additions and 224 deletions
8
Annex.hs
8
Annex.hs
|
@ -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
|
||||
|
|
121
Annex/Content.hs
121
Annex/Content.hs
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
100
Command/Drop.hs
100
Command/Drop.hs
|
@ -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 =
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
46
Command/LockContent.hs
Normal 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."
|
|
@ -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
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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
|
||||
)
|
||||
|
|
33
Remote.hs
33
Remote.hs
|
@ -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 ()
|
||||
|
|
|
@ -58,6 +58,7 @@ gen r _ c gc =
|
|||
, retrieveKeyFile = downloadKey
|
||||
, retrieveKeyFileCheap = downloadKeyCheap
|
||||
, removeKey = dropKey
|
||||
, lockContent = Nothing
|
||||
, checkPresent = checkKey
|
||||
, checkPresentCheap = False
|
||||
, whereisKey = Nothing
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -81,6 +81,7 @@ gen r u c gc
|
|||
, retrieveKeyFile = retreiveKeyFileDummy
|
||||
, retrieveKeyFileCheap = \_ _ _ -> return False
|
||||
, removeKey = removeKeyDummy
|
||||
, lockContent = Nothing
|
||||
, checkPresent = checkPresentDummy
|
||||
, checkPresentCheap = False
|
||||
, whereisKey = towhereis
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 $
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -52,6 +52,7 @@ gen r _ c gc =
|
|||
, retrieveKeyFile = downloadKey
|
||||
, retrieveKeyFileCheap = downloadKeyCheap
|
||||
, removeKey = dropKey
|
||||
, lockContent = Nothing
|
||||
, checkPresent = checkKey
|
||||
, checkPresentCheap = False
|
||||
, whereisKey = Nothing
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -6,6 +6,7 @@
|
|||
-}
|
||||
|
||||
module Utility.LockPool.Windows (
|
||||
P.LockFile,
|
||||
LockHandle,
|
||||
lockShared,
|
||||
lockExclusive,
|
||||
|
|
16
debian/changelog
vendored
16
debian/changelog
vendored
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue