summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Annex/Content.hs12
-rw-r--r--Annex/Drop.hs11
-rw-r--r--Annex/NumCopies.hs24
-rw-r--r--Assistant/Drop.hs7
-rw-r--r--Assistant/Threads/Committer.hs2
-rw-r--r--Assistant/Threads/SanityChecker.hs2
-rw-r--r--Assistant/Threads/TransferScanner.hs2
-rw-r--r--Assistant/TransferSlots.hs5
-rw-r--r--Command/Drop.hs37
-rw-r--r--Command/DropUnused.hs2
-rw-r--r--Command/Import.hs2
-rw-r--r--Command/LockContent.hs2
-rw-r--r--Command/Mirror.hs2
-rw-r--r--Command/Sync.hs4
-rw-r--r--Types/NumCopies.hs42
-rw-r--r--Types/UUID.hs11
16 files changed, 107 insertions, 60 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs
index 8fbb49ce6..e45d9ea05 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -67,6 +67,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
@@ -178,8 +180,10 @@ contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key)
- Note that, in direct mode, nothing prevents the user from directly
- editing or removing the content, even while it's locked by this.
-}
-lockContentShared :: Key -> Annex a -> Annex a
-lockContentShared = lockContentUsing lock
+lockContentShared :: Key -> (VerifiedCopy -> Annex a) -> Annex a
+lockContentShared key a = lockContentUsing lock key $ do
+ u <- getUUID
+ a (VerifiedCopyLock u (return ()))
where
#ifndef mingw32_HOST_OS
lock contentfile Nothing = liftIO $ tryLockShared Nothing contentfile
@@ -195,7 +199,7 @@ newtype ContentLockExclusive = ContentLockExclusive Key
-}
lockContentExclusive :: Key -> (ContentLockExclusive -> Annex a) -> Annex a
lockContentExclusive key a = lockContentUsing lock key $
- a $ ContentLockExclusive key
+ a (ContentLockExclusive key)
where
#ifndef mingw32_HOST_OS
{- Since content files are stored with the write bit disabled, have
@@ -238,7 +242,7 @@ lockContentUsing locker key a = do
bracket
(lock contentfile lockfile)
(unlock lockfile)
- (const $ a)
+ (const a)
where
alreadylocked = error "content is locked"
failedtolock e = error $ "failed to lock content: " ++ show e
diff --git a/Annex/Drop.hs b/Annex/Drop.hs
index 973e51348..791273d8e 100644
--- a/Annex/Drop.hs
+++ b/Annex/Drop.hs
@@ -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
diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs
index 3f078b8f0..549c72207 100644
--- a/Annex/NumCopies.hs
+++ b/Annex/NumCopies.hs
@@ -96,11 +96,11 @@ verifyEnoughCopies
-> Key
-> NumCopies
-> [UUID] -- repos to skip considering (generally untrusted remotes)
- -> [UUID] -- repos that are trusted or already verified to have it
+ -> [VerifiedCopy] -- already known verifications
-> [Remote] -- remotes to check to see if they have it
-> Annex Bool
-verifyEnoughCopies nolocmsg key need skip trusted tocheck =
- helper [] [] (nub trusted) (nub tocheck)
+verifyEnoughCopies nolocmsg key need skip preverified tocheck =
+ helper [] [] (deDupVerifiedCopies preverified) (nub tocheck)
where
helper bad missing have []
| NumCopies (length have) >= need = return True
@@ -109,17 +109,17 @@ verifyEnoughCopies nolocmsg key need skip trusted tocheck =
return False
helper bad missing have (r:rs)
| NumCopies (length have) >= need = return True
+ | any (== u) (map toUUID have) = helper bad missing have rs
| 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
+ case haskey of
+ Right True -> helper bad missing (VerifiedCopy u:have) rs
+ Left _ -> helper (r:bad) missing have rs
+ Right False -> helper bad (u:missing) have rs
+ where
+ u = Remote.uuid r
-notEnoughCopies :: Key -> NumCopies -> [UUID] -> [UUID] -> [Remote] -> String -> Annex ()
+notEnoughCopies :: Key -> NumCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> Annex ()
notEnoughCopies key need have skip bad nolocmsg = do
showNote "unsafe"
showLongNote $
@@ -127,7 +127,7 @@ notEnoughCopies key need have skip bad nolocmsg = do
show (length have) ++ " out of " ++ show (fromNumCopies need) ++
" necessary copies"
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.
diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs
index 57eef8f3a..5653b7795 100644
--- a/Assistant/Drop.hs
+++ b/Assistant/Drop.hs
@@ -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
diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs
index f4af93285..59ca69e88 100644
--- a/Assistant/Threads/Committer.hs
+++ b/Assistant/Threads/Committer.hs
@@ -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
diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs
index 0f2c1245a..f42462e52 100644
--- a/Assistant/Threads/SanityChecker.hs
+++ b/Assistant/Threads/SanityChecker.hs
@@ -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
diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs
index 3cbaadf19..f35c1f1f5 100644
--- a/Assistant/Threads/TransferScanner.hs
+++ b/Assistant/Threads/TransferScanner.hs
@@ -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
diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs
index 7490ede39..232d1d6e1 100644
--- a/Assistant/TransferSlots.hs
+++ b/Assistant/TransferSlots.hs
@@ -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)
+ [VerifiedCopy (Remote.uuid 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. -}
diff --git a/Command/Drop.hs b/Command/Drop.hs
index 8b361ed56..49e4bea85 100644
--- a/Command/Drop.hs
+++ b/Command/Drop.hs
@@ -64,11 +64,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,10 +78,10 @@ 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
@@ -92,16 +92,14 @@ startRemote afile numcopies key remote = do
-- 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
-- sees the key is present on the other.
-performLocal :: Key -> AssociatedFile -> NumCopies -> Maybe Remote -> CommandPerform
-performLocal key afile numcopies knownpresentremote = lockContentExclusive key $ \contentlock -> do
+performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform
+performLocal key afile numcopies preverified = lockContentExclusive key $ \contentlock -> do
(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
- let trusteduuids' = case knownpresentremote of
- Nothing -> trusteduuids
- Just r -> Remote.uuid r:trusteduuids
+ let preverified' = preverified ++ map TrustedCopy trusteduuids
untrusteduuids <- trustGet UnTrusted
- let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids'++untrusteduuids)
+ let tocheck = Remote.remotesWithoutUUID remotes (map toUUID preverified'++untrusteduuids)
u <- getUUID
- ifM (canDrop u key afile numcopies trusteduuids' tocheck [])
+ ifM (canDrop u key afile numcopies [] preverified' tocheck)
( do
removeAnnex contentlock
notifyDrop afile True
@@ -118,11 +116,11 @@ performRemote key afile numcopies remote = do
-- 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
+ let trusted = 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
+ Remote.remotesWithoutUUID remotes (trusted++untrusteduuids)
+ stopUnless (canDrop uuid key afile numcopies [uuid] (map TrustedCopy trusted) tocheck) $ do
ok <- Remote.removeKey remote key
next $ cleanupRemote key remote ok
where
@@ -140,19 +138,18 @@ cleanupRemote key remote ok = do
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.
+ - 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 =
+canDrop :: UUID -> Key -> AssociatedFile -> NumCopies -> [UUID] -> [VerifiedCopy] -> [Remote] -> Annex Bool
+canDrop dropfrom key afile numcopies skip preverified check =
ifM (Annex.getState Annex.force)
( return True
, ifM (checkRequiredContent dropfrom key afile
- <&&> verifyEnoughCopies nolocmsg key numcopies skip have check
+ <&&> verifyEnoughCopies nolocmsg key numcopies skip preverified check
)
( return True
, do
diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs
index 98fcef6ea..9c2ae972a 100644
--- a/Command/DropUnused.hs
+++ b/Command/DropUnused.hs
@@ -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
diff --git a/Command/Import.hs b/Command/Import.hs
index e84618173..fbce4c55a 100644
--- a/Command/Import.hs
+++ b/Command/Import.hs
@@ -143,4 +143,4 @@ verifiedExisting key destfile = do
(remotes, trusteduuids) <- knownCopies key
untrusteduuids <- trustGet UnTrusted
let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids++untrusteduuids)
- verifyEnoughCopies [] key need [] trusteduuids tocheck
+ verifyEnoughCopies [] key need [] (map TrustedCopy trusteduuids) tocheck
diff --git a/Command/LockContent.hs b/Command/LockContent.hs
index bab5c9276..e37d4cca5 100644
--- a/Command/LockContent.hs
+++ b/Command/LockContent.hs
@@ -27,7 +27,7 @@ seek = withWords start
-- dropping the lock.
start :: [String] -> CommandStart
start [ks] = do
- ok <- lockContentShared k locksuccess
+ ok <- lockContentShared k (const locksuccess)
`catchNonAsync` (const $ return False)
liftIO $ if ok
then exitSuccess
diff --git a/Command/Mirror.hs b/Command/Mirror.hs
index 0555d025c..a8caf9da7 100644
--- a/Command/Mirror.hs
+++ b/Command/Mirror.hs
@@ -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
diff --git a/Command/Sync.hs b/Command/Sync.hs
index 964b45dc2..49dfe811e 100644
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@@ -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
diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs
index d8ea31e69..732c928d2 100644
--- a/Types/NumCopies.hs
+++ b/Types/NumCopies.hs
@@ -1,4 +1,4 @@
-{- git-annex numcopies type
+{- git-annex numcopies types
-
- Copyright 2014 Joey Hess <id@joeyh.name>
-
@@ -7,8 +7,48 @@
module Types.NumCopies where
+import Types.UUID
+
+import qualified Data.Map as M
+
newtype NumCopies = NumCopies Int
deriving (Ord, Eq)
fromNumCopies :: NumCopies -> Int
fromNumCopies (NumCopies n) = n
+
+data VerifiedCopy
+ {- Use when a repository cannot be accessed, but it's
+ - a trusted repository, which is presumably not going to
+ - lose a copy. This is the weakest level of verification. -}
+ = TrustedCopy UUID
+ {- Represents a recent verification that a copy of an
+ - object exists in a repository with the given UUID. -}
+ | VerifiedCopy UUID
+ {- 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 dropped by any git-annex process. -}
+ | VerifiedCopyLock UUID (IO ())
+
+instance ToUUID VerifiedCopy where
+ toUUID (VerifiedCopy u) = u
+ toUUID (VerifiedCopyLock u _) = u
+ toUUID (TrustedCopy u) = u
+
+instance Show VerifiedCopy where
+ show (TrustedCopy u) = "TrustedCopy " ++ show u
+ show (VerifiedCopy u) = "VerifiedCopy " ++ show u
+ show (VerifiedCopyLock u _) = "VerifiedCopyLock " ++ show u
+
+strongestVerifiedCopy :: VerifiedCopy -> VerifiedCopy -> VerifiedCopy
+strongestVerifiedCopy a@(VerifiedCopyLock _ _) _ = a
+strongestVerifiedCopy _ b@(VerifiedCopyLock _ _) = b
+strongestVerifiedCopy a@(VerifiedCopy _) _ = a
+strongestVerifiedCopy _ b@(VerifiedCopy _) = b
+strongestVerifiedCopy a@(TrustedCopy _) _ = 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)
diff --git a/Types/UUID.hs b/Types/UUID.hs
index de7ddd65d..27d82b86c 100644
--- a/Types/UUID.hs
+++ b/Types/UUID.hs
@@ -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,12 @@ 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 String where
+ toUUID [] = NoUUID
+ toUUID s = UUID s
isUUID :: String -> Bool
isUUID = isJust . U.fromString
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-23 18:40:14 +0000