diff options
-rw-r--r-- | Annex/Content.hs | 5 | ||||
-rw-r--r-- | Annex/NumCopies.hs | 2 | ||||
-rw-r--r-- | Assistant/TransferSlots.hs | 2 | ||||
-rw-r--r-- | Command/Drop.hs | 5 | ||||
-rw-r--r-- | Command/Import.hs | 2 | ||||
-rw-r--r-- | Types/NumCopies.hs | 74 | ||||
-rw-r--r-- | Types/Remote.hs | 3 | ||||
-rw-r--r-- | Types/UUID.hs | 3 |
8 files changed, 73 insertions, 23 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs index e45d9ea05..d0596644e 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -183,7 +183,10 @@ contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key) lockContentShared :: Key -> (VerifiedCopy -> Annex a) -> Annex a lockContentShared key a = lockContentUsing lock key $ do u <- getUUID - a (VerifiedCopyLock u (return ())) + bracketIO + (invalidatableVerifiedCopy VerifiedCopyLock u) + invalidateVerifiedCopy + a where #ifndef mingw32_HOST_OS lock contentfile Nothing = liftIO $ tryLockShared Nothing contentfile diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs index 549c72207..6b534591e 100644 --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -113,7 +113,7 @@ verifyEnoughCopies nolocmsg key need skip preverified tocheck = | otherwise = do haskey <- Remote.hasKey r key case haskey of - Right True -> helper bad missing (VerifiedCopy u:have) rs + Right True -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy u : have) rs Left _ -> helper (r:bad) missing have rs Right False -> helper bad (u:missing) have rs where diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index 232d1d6e1..2ea09c419 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -161,7 +161,7 @@ genTransfer t info = case transferRemote info of ("object uploaded to " ++ show remote) True (transferKey t) (associatedFile info) - [VerifiedCopy (Remote.uuid remote)] + [mkVerifiedCopy RecentlyVerifiedCopy remote] void recordCommit , whenM (liftAnnex $ isNothing <$> checkTransfer t) $ void $ removeTransfer t diff --git a/Command/Drop.hs b/Command/Drop.hs index 49e4bea85..26872c6c0 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -95,7 +95,7 @@ startRemote afile numcopies key remote = do performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform performLocal key afile numcopies preverified = lockContentExclusive key $ \contentlock -> do (remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key - let preverified' = preverified ++ map TrustedCopy trusteduuids + let preverified' = preverified ++ map (mkVerifiedCopy TrustedCopy) trusteduuids untrusteduuids <- trustGet UnTrusted let tocheck = Remote.remotesWithoutUUID remotes (map toUUID preverified'++untrusteduuids) u <- getUUID @@ -117,10 +117,11 @@ performRemote key afile numcopies remote = do -- as long as the local repo is not untrusted. (remotes, trusteduuids) <- knownCopies key let trusted = filter (/= uuid) trusteduuids + let preverified = map (mkVerifiedCopy TrustedCopy) trusted untrusteduuids <- trustGet UnTrusted let tocheck = filter (/= remote) $ Remote.remotesWithoutUUID remotes (trusted++untrusteduuids) - stopUnless (canDrop uuid key afile numcopies [uuid] (map TrustedCopy trusted) tocheck) $ do + stopUnless (canDrop uuid key afile numcopies [uuid] preverified tocheck) $ do ok <- Remote.removeKey remote key next $ cleanupRemote key remote ok where diff --git a/Command/Import.hs b/Command/Import.hs index fbce4c55a..3206ad48b 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 [] (map TrustedCopy trusteduuids) tocheck + verifyEnoughCopies [] key need [] (map (mkVerifiedCopy TrustedCopy) trusteduuids) tocheck diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs index 732c928d2..0acb7cc3b 100644 --- a/Types/NumCopies.hs +++ b/Types/NumCopies.hs @@ -5,11 +5,22 @@ - 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, +) where import Types.UUID import qualified Data.Map as M +import Control.Concurrent.MVar newtype NumCopies = NumCopies Int deriving (Ord, Eq) @@ -17,38 +28,67 @@ newtype NumCopies = NumCopies Int fromNumCopies :: NumCopies -> Int fromNumCopies (NumCopies n) = n +-- A verification that a copy of a key exists in a repository. 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 + - a trusted repository, which is on record as containing a key + - and is presumably not going to lose its copy. + - This is the weakest level of verification. -} + = TrustedCopy V {- Represents a recent verification that a copy of an - object exists in a repository with the given UUID. -} - | VerifiedCopy UUID + | RecentlyVerifiedCopy 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 dropped by any git-annex process. -} - | VerifiedCopyLock UUID (IO ()) + | VerifiedCopyLock V + deriving (Show) instance ToUUID VerifiedCopy where - toUUID (VerifiedCopy u) = u - toUUID (VerifiedCopyLock u _) = u - toUUID (TrustedCopy u) = u + toUUID = _getUUID . toV + +toV :: VerifiedCopy -> V +toV (TrustedCopy v) = v +toV (RecentlyVerifiedCopy v) = v +toV (VerifiedCopyLock v) = v -instance Show VerifiedCopy where - show (TrustedCopy u) = "TrustedCopy " ++ show u - show (VerifiedCopy u) = "VerifiedCopy " ++ show u - show (VerifiedCopyLock u _) = "VerifiedCopyLock " ++ show u +-- Checks that it's still valid. +checkVerifiedCopy :: VerifiedCopy -> IO Bool +checkVerifiedCopy = _checkVerifiedCopy . toV + +invalidateVerifiedCopy :: VerifiedCopy -> IO () +invalidateVerifiedCopy = _invalidateVerifiedCopy . toV + +data V = V + { _getUUID :: UUID + , _checkVerifiedCopy :: IO Bool + , _invalidateVerifiedCopy :: IO () + } + +instance Show V where + show v = show (_getUUID v) strongestVerifiedCopy :: VerifiedCopy -> VerifiedCopy -> VerifiedCopy -strongestVerifiedCopy a@(VerifiedCopyLock _ _) _ = a -strongestVerifiedCopy _ b@(VerifiedCopyLock _ _) = b -strongestVerifiedCopy a@(VerifiedCopy _) _ = a -strongestVerifiedCopy _ b@(VerifiedCopy _) = b +strongestVerifiedCopy a@(VerifiedCopyLock _) _ = a +strongestVerifiedCopy _ b@(VerifiedCopyLock _) = b +strongestVerifiedCopy a@(RecentlyVerifiedCopy _) _ = a +strongestVerifiedCopy _ b@(RecentlyVerifiedCopy _) = 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) + +mkVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> VerifiedCopy +mkVerifiedCopy mk u = mk $ V (toUUID u) (return True) (return ()) + +invalidatableVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> IO VerifiedCopy +invalidatableVerifiedCopy mk u = do + v <- newEmptyMVar + let invalidate = do + _ <- tryPutMVar v () + return () + let check = isEmptyMVar v + return $ mk $ V (toUUID u) check invalidate diff --git a/Types/Remote.hs b/Types/Remote.hs index 1bf79a81e..9e5f9f735 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -131,6 +131,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 diff --git a/Types/UUID.hs b/Types/UUID.hs index 27d82b86c..4212eaa7f 100644 --- a/Types/UUID.hs +++ b/Types/UUID.hs @@ -24,6 +24,9 @@ fromUUID NoUUID = "" class ToUUID a where toUUID :: a -> UUID +instance ToUUID UUID where + toUUID = id + instance ToUUID String where toUUID [] = NoUUID toUUID s = UUID s |