diff --git a/Annex/Branch.hs b/Annex/Branch.hs index a8443b7767..fbfe2e4a1d 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -1,6 +1,6 @@ {- management of the git-annex branch - - - Copyright 2011-2018 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -63,6 +63,7 @@ import Logs import Logs.Transitions import Logs.File import Logs.Trust.Pure +import Logs.Remote.Pure import Logs.Difference.Pure import qualified Annex.Queue import Annex.Branch.Transitions @@ -574,13 +575,16 @@ performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do run [] = noop run changers = do trustmap <- calcTrustMap <$> getStaged trustLog + remoteconfigmap <- calcRemoteConfigMap <$> getStaged remoteLog + -- partially apply, improves performance + let changers' = map (\c -> c trustmap remoteconfigmap) changers fs <- branchFiles forM_ fs $ \f -> do content <- getStaged f - apply changers f content trustmap - apply [] _ _ _ = return () - apply (changer:rest) file content trustmap = - case changer file content trustmap of + apply changers' f content + apply [] _ _ = return () + apply (changer:rest) file content = + case changer file content of RemoveFile -> do Annex.Queue.addUpdateIndex =<< inRepo (Git.UpdateIndex.unstageFile file) @@ -592,9 +596,9 @@ performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do sha <- hashBlob content' Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $ Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath file) - apply rest file content' trustmap + apply rest file content' PreserveFile -> - apply rest file content trustmap + apply rest file content checkBranchDifferences :: Git.Ref -> Annex () checkBranchDifferences ref = do diff --git a/Annex/Branch/Transitions.hs b/Annex/Branch/Transitions.hs index d86dd1a14b..7961dcf1cc 100644 --- a/Annex/Branch/Transitions.hs +++ b/Annex/Branch/Transitions.hs @@ -20,6 +20,8 @@ import qualified Logs.MetaData.Pure as MetaData import Types.TrustLevel import Types.UUID import Types.MetaData +import Types.Remote +import Annex.SpecialRemote.Config import qualified Data.Map as M import qualified Data.Set as S @@ -32,42 +34,63 @@ data FileTransition | RemoveFile | PreserveFile -type TransitionCalculator = FilePath -> L.ByteString -> TrustMap -> FileTransition +type TransitionCalculator = TrustMap -> M.Map UUID RemoteConfig -> FilePath -> L.ByteString -> FileTransition getTransitionCalculator :: Transition -> Maybe TransitionCalculator getTransitionCalculator ForgetGitHistory = Nothing getTransitionCalculator ForgetDeadRemotes = Just dropDead -dropDead :: FilePath -> L.ByteString -> TrustMap -> FileTransition -dropDead f content trustmap = case getLogVariety f of +-- Removes data about all dead repos. +-- +-- The trust log is not changed, because other, unmerged clones +-- may contain other data about the dead repos. So we need to rememebr +-- which are dead to later remove that. +-- +-- When the remote log contains a sameas-uuid pointing to a dead uuid, +-- the uuid of that remote configuration is also effectively dead, +-- though not in the trust log. There may be per-remote state stored using +-- the latter uuid, that also needs to be removed. That configuration +-- is not removed from the remote log, for the same reason the trust log +-- is not changed. +dropDead :: TransitionCalculator +dropDead trustmap remoteconfigmap f content = case getLogVariety f of Just OldUUIDBasedLog - -- Don't remove the dead repo from the trust log, - -- because git remotes may still exist, and they need - -- to still know it's dead. | f == trustLog -> PreserveFile - | otherwise -> ChangeFile $ - UUIDBased.buildLogOld byteString $ - dropDeadFromMapLog trustmap id $ - UUIDBased.parseLogOld A.takeByteString content + | otherwise -> + let go tm = ChangeFile $ + UUIDBased.buildLogOld byteString $ + dropDeadFromMapLog tm id $ + UUIDBased.parseLogOld A.takeByteString content + in if f == remoteLog + then go trustmap + else go trustmap' Just NewUUIDBasedLog -> ChangeFile $ UUIDBased.buildLogNew byteString $ - dropDeadFromMapLog trustmap id $ + dropDeadFromMapLog trustmap' id $ UUIDBased.parseLogNew A.takeByteString content Just (ChunkLog _) -> ChangeFile $ - Chunk.buildLog $ dropDeadFromMapLog trustmap fst $ Chunk.parseLog content + Chunk.buildLog $ dropDeadFromMapLog trustmap' fst $ Chunk.parseLog content Just (PresenceLog _) -> let newlog = Presence.compactLog $ - dropDeadFromPresenceLog trustmap $ Presence.parseLog content + dropDeadFromPresenceLog trustmap' $ Presence.parseLog content in if null newlog then RemoveFile else ChangeFile $ Presence.buildLog newlog Just RemoteMetaDataLog -> - let newlog = dropDeadFromRemoteMetaDataLog trustmap $ MetaData.simplifyLog $ MetaData.parseLog content + let newlog = dropDeadFromRemoteMetaDataLog trustmap' $ + MetaData.simplifyLog $ MetaData.parseLog content in if S.null newlog then RemoveFile else ChangeFile $ MetaData.buildLog newlog Just OtherLog -> PreserveFile Nothing -> PreserveFile + where + trustmap' = trustmap `M.union` + M.map (const DeadTrusted) (M.filter sameasdead remoteconfigmap) + sameasdead cm = + case toUUID <$> M.lookup sameasUUIDField cm of + Nothing -> False + Just u' -> M.lookup u' trustmap == Just DeadTrusted dropDeadFromMapLog :: TrustMap -> (k -> UUID) -> M.Map k v -> M.Map k v dropDeadFromMapLog trustmap getuuid = diff --git a/Logs/Remote.hs b/Logs/Remote.hs index 2b767c2f4a..02350dbb83 100644 --- a/Logs/Remote.hs +++ b/Logs/Remote.hs @@ -22,11 +22,10 @@ import qualified Annex.Branch import Types.Remote import Logs import Logs.UUIDBased +import Logs.Remote.Pure import Annex.SpecialRemote.Config import qualified Data.Map as M -import Data.Char -import qualified Data.Attoparsec.ByteString.Lazy as A import Data.ByteString.Builder {- Adds or updates a remote's config in the log. -} @@ -40,71 +39,5 @@ configSet u cfg = do {- Map of remotes by uuid containing key/value config maps. -} readRemoteLog :: Annex (M.Map UUID RemoteConfig) -readRemoteLog = (\m -> M.map (addSameasInherited m) m) - . simpleMap - . parseLogOld remoteConfigParser +readRemoteLog = calcRemoteConfigMap <$> Annex.Branch.get remoteLog - -remoteConfigParser :: A.Parser RemoteConfig -remoteConfigParser = keyValToConfig . words . decodeBS <$> A.takeByteString - -showConfig :: RemoteConfig -> String -showConfig = unwords . configToKeyVal - -{- Given Strings like "key=value", generates a RemoteConfig. -} -keyValToConfig :: [String] -> RemoteConfig -keyValToConfig ws = M.fromList $ map (/=/) ws - where - (/=/) s = (k, v) - where - k = takeWhile (/= '=') s - v = configUnEscape $ drop (1 + length k) s - -configToKeyVal :: M.Map String String -> [String] -configToKeyVal m = map toword $ sort $ M.toList m - where - toword (k, v) = k ++ "=" ++ configEscape v - -configEscape :: String -> String -configEscape = concatMap escape - where - escape c - | isSpace c || c `elem` "&" = "&" ++ show (ord c) ++ ";" - | otherwise = [c] - -configUnEscape :: String -> String -configUnEscape = unescape - where - unescape [] = [] - unescape (c:rest) - | c == '&' = entity rest - | otherwise = c : unescape rest - entity s - | not (null num) && ";" `isPrefixOf` r = - chr (Prelude.read num) : unescape rest - | otherwise = - '&' : unescape s - where - num = takeWhile isNumber s - r = drop (length num) s - rest = drop 1 r - -{- for quickcheck -} -prop_isomorphic_configEscape :: String -> Bool -prop_isomorphic_configEscape s = s == (configUnEscape . configEscape) s - -prop_parse_show_Config :: RemoteConfig -> Bool -prop_parse_show_Config c - -- whitespace and '=' are not supported in config keys - | any (\k -> any isSpace k || elem '=' k) (M.keys c) = True - | any (any excluded) (M.keys c) = True - | any (any excluded) (M.elems c) = True - | otherwise = A.parseOnly remoteConfigParser (encodeBS $ showConfig c) ~~ Right c - where - normalize v = sort . M.toList <$> v - a ~~ b = normalize a == normalize b - -- limit to ascii alphanumerics for simplicity; characters not - -- allowed by the current character set in the config may not - -- round-trip in an identical representation due to the use of the - -- filesystem encoding. - excluded ch = not (isAlphaNum ch) || not (isAscii ch) diff --git a/git-annex.cabal b/git-annex.cabal index 134640f277..4ddc4444be 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -897,6 +897,7 @@ Executable git-annex Logs.Presence Logs.Presence.Pure Logs.Remote + Logs.Remote.Pure Logs.RemoteState Logs.Schedule Logs.SingleValue