untested transition detection on merging, and transition running code
This commit is contained in:
parent
511cf77b6d
commit
fcd5c167ef
4 changed files with 142 additions and 23 deletions
112
Annex/Branch.hs
112
Annex/Branch.hs
|
@ -1,6 +1,6 @@
|
|||
{- management of the git-annex branch
|
||||
-
|
||||
- Copyright 2011-2012 Joey Hess <joey@kitenet.net>
|
||||
- Copyright 2011-2013 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
@ -22,9 +22,12 @@ module Annex.Branch (
|
|||
commit,
|
||||
files,
|
||||
withIndex,
|
||||
performTransitions,
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Lazy.Char8 as L
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Map as M
|
||||
|
||||
import Common.Annex
|
||||
import Annex.BranchState
|
||||
|
@ -32,6 +35,7 @@ import Annex.Journal
|
|||
import qualified Git
|
||||
import qualified Git.Command
|
||||
import qualified Git.Ref
|
||||
import qualified Git.Sha
|
||||
import qualified Git.Branch
|
||||
import qualified Git.UnionMerge
|
||||
import qualified Git.UpdateIndex
|
||||
|
@ -42,6 +46,8 @@ import Annex.CatFile
|
|||
import Annex.Perms
|
||||
import qualified Annex
|
||||
import Utility.Env
|
||||
import Logs.Transitions
|
||||
import Annex.ReplaceFile
|
||||
|
||||
{- Name of the branch that is used to store git-annex's information. -}
|
||||
name :: Git.Ref
|
||||
|
@ -110,6 +116,9 @@ forceUpdate = updateTo =<< siblingBranches
|
|||
- later get staged, and might overwrite changes made during the merge.
|
||||
- This is only done if some of the Refs do need to be merged.
|
||||
-
|
||||
- Also handles performing any Transitions that have not yet been
|
||||
- performed, in either the local branch, or the Refs.
|
||||
-
|
||||
- Returns True if any refs were merged in, False otherwise.
|
||||
-}
|
||||
updateTo :: [(Git.Ref, Git.Branch)] -> Annex Bool
|
||||
|
@ -117,7 +126,8 @@ updateTo pairs = do
|
|||
-- ensure branch exists, and get its current ref
|
||||
branchref <- getBranch
|
||||
dirty <- journalDirty
|
||||
(refs, branches) <- unzip <$> filterM isnewer pairs
|
||||
ignoredrefs <- getIgnoredRefs
|
||||
(refs, branches) <- unzip <$> filterM (isnewer ignoredrefs) pairs
|
||||
if null refs
|
||||
{- Even when no refs need to be merged, the index
|
||||
- may still be updated if the branch has gotten ahead
|
||||
|
@ -132,7 +142,9 @@ updateTo pairs = do
|
|||
else lockJournal $ go branchref dirty refs branches
|
||||
return $ not $ null refs
|
||||
where
|
||||
isnewer (r, _) = inRepo $ Git.Branch.changed fullname r
|
||||
isnewer ignoredrefs (r, _)
|
||||
| S.member r ignoredrefs = return False
|
||||
| otherwise = inRepo $ Git.Branch.changed fullname r
|
||||
go branchref dirty refs branches = withIndex $ do
|
||||
cleanjournal <- if dirty then stageJournal else return noop
|
||||
let merge_desc = if null branches
|
||||
|
@ -140,16 +152,23 @@ updateTo pairs = do
|
|||
else "merging " ++
|
||||
unwords (map Git.Ref.describe branches) ++
|
||||
" into " ++ show name
|
||||
localtransitions <- parseTransitionsStrictly "local"
|
||||
<$> getStale transitionsLog
|
||||
unless (null branches) $ do
|
||||
showSideAction merge_desc
|
||||
mergeIndex refs
|
||||
ff <- if dirty
|
||||
then return False
|
||||
else inRepo $ Git.Branch.fastForward fullname refs
|
||||
if ff
|
||||
then updateIndex branchref
|
||||
else commitBranch branchref merge_desc
|
||||
(nub $ fullname:refs)
|
||||
let commitrefs = nub $ fullname:refs
|
||||
transitioned <- handleTransitions localtransitions commitrefs
|
||||
case transitioned of
|
||||
Nothing -> do
|
||||
ff <- if dirty
|
||||
then return False
|
||||
else inRepo $ Git.Branch.fastForward fullname refs
|
||||
if ff
|
||||
then updateIndex branchref
|
||||
else commitBranch branchref merge_desc commitrefs
|
||||
Just (branchref', commitrefs') ->
|
||||
commitBranch branchref' merge_desc commitrefs'
|
||||
liftIO cleanjournal
|
||||
|
||||
{- Gets the content of a file, which may be in the journal, or in the index
|
||||
|
@ -361,3 +380,76 @@ stageJournal = withIndex $ do
|
|||
sha <- hashFile h path
|
||||
streamer $ Git.UpdateIndex.updateIndexLine
|
||||
sha FileBlob (asTopFilePath $ fileJournal file)
|
||||
|
||||
{- This is run after the refs have been merged into the index,
|
||||
- but before the result is committed to the branch.
|
||||
- Which is why it's passed the contents of the local branches's
|
||||
- transition log before that merge took place.
|
||||
-
|
||||
- When the refs contain transitions that have not yet been done locally,
|
||||
- the transitions are performed on the index, and a new branch
|
||||
- is created from the result, and returned.
|
||||
-
|
||||
- When there are transitions recorded locally that have not been done
|
||||
- to the remote refs, the transitions are performed in the index,
|
||||
- and the existing branch is returned. In this case, the untransitioned
|
||||
- remote refs cannot be merged into the branch (since transitions
|
||||
- throw away history), so none of them are included in the returned
|
||||
- list of refs, and they are added to the list of refs to ignore,
|
||||
- to avoid re-merging content from them again.
|
||||
-}
|
||||
handleTransitions :: Transitions -> [Git.Ref] -> Annex (Maybe (Git.Branch, [Git.Ref]))
|
||||
handleTransitions localts refs = do
|
||||
m <- M.fromList <$> mapM getreftransition refs
|
||||
let remotets = M.elems m
|
||||
if all (localts ==) remotets
|
||||
then return Nothing
|
||||
else do
|
||||
let allts = combineTransitions (localts:remotets)
|
||||
let (transitionedrefs, untransitionedrefs) =
|
||||
partition (\r -> M.lookup r m == Just allts) refs
|
||||
transitionedbranch <- performTransitions allts (localts /= allts)
|
||||
ignoreRefs untransitionedrefs
|
||||
return $ Just (transitionedbranch, transitionedrefs)
|
||||
where
|
||||
getreftransition ref = do
|
||||
ts <- parseTransitionsStrictly "remote" . L.unpack
|
||||
<$> catFile ref transitionsLog
|
||||
return (ref, ts)
|
||||
|
||||
ignoreRefs :: [Git.Ref] -> Annex ()
|
||||
ignoreRefs rs = do
|
||||
old <- getIgnoredRefs
|
||||
let s = S.unions [old, S.fromList rs]
|
||||
f <- fromRepo gitAnnexIgnoredRefs
|
||||
replaceFile f $ \tmp -> liftIO $ writeFile tmp $
|
||||
unlines $ map show $ S.elems s
|
||||
|
||||
getIgnoredRefs :: Annex (S.Set Git.Ref)
|
||||
getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . lines <$> content
|
||||
where
|
||||
content = do
|
||||
f <- fromRepo gitAnnexIgnoredRefs
|
||||
liftIO $ catchDefaultIO "" $ readFile f
|
||||
|
||||
{- Performs the specified transitions on the contents of the index file,
|
||||
- commits it to the branch, or creates a new branch, and returns
|
||||
- the branch's ref. -}
|
||||
performTransitions :: Transitions -> Bool -> Annex Git.Ref
|
||||
performTransitions ts neednewbranch = withIndex $ do
|
||||
when (inTransitions ForgetDeadRemotes ts) $
|
||||
error "TODO ForgetDeadRemotes transition"
|
||||
if neednewbranch
|
||||
then do
|
||||
committedref <- inRepo $ Git.Branch.commit message fullname []
|
||||
setIndexSha committedref
|
||||
return committedref
|
||||
else do
|
||||
ref <- getBranch
|
||||
commitBranch ref message [fullname]
|
||||
getBranch
|
||||
where
|
||||
message
|
||||
| neednewbranch = "new branch for transition " ++ tdesc
|
||||
| otherwise = "continuing transition " ++ tdesc
|
||||
tdesc = show $ map describeTransition $ transitionList ts
|
||||
|
|
|
@ -35,6 +35,7 @@ module Locations (
|
|||
gitAnnexJournalLock,
|
||||
gitAnnexIndex,
|
||||
gitAnnexIndexLock,
|
||||
gitAnnexIgnoredRefs,
|
||||
gitAnnexPidFile,
|
||||
gitAnnexDaemonStatusFile,
|
||||
gitAnnexLogFile,
|
||||
|
@ -225,6 +226,10 @@ gitAnnexIndex r = gitAnnexDir r </> "index"
|
|||
gitAnnexIndexLock :: Git.Repo -> FilePath
|
||||
gitAnnexIndexLock r = gitAnnexDir r </> "index.lck"
|
||||
|
||||
{- List of refs that should not be merged into the git-annex branch. -}
|
||||
gitAnnexIgnoredRefs :: Git.Repo -> FilePath
|
||||
gitAnnexIgnoredRefs r = gitAnnexDir r </> "ignoredrefs"
|
||||
|
||||
{- Pid file for daemon mode. -}
|
||||
gitAnnexPidFile :: Git.Repo -> FilePath
|
||||
gitAnnexPidFile r = gitAnnexDir r </> "daemon.pid"
|
||||
|
|
|
@ -46,6 +46,10 @@ data TransitionLine = TransitionLine
|
|||
|
||||
type Transitions = S.Set TransitionLine
|
||||
|
||||
describeTransition :: Transition -> String
|
||||
describeTransition ForgetGitHistory = "forget git history"
|
||||
describeTransition ForgetDeadRemotes = "forget dead remotes"
|
||||
|
||||
addTransition :: POSIXTime -> Transition -> Transitions -> Transitions
|
||||
addTransition ts t = S.insert $ TransitionLine ts t
|
||||
|
||||
|
@ -60,6 +64,11 @@ parseTransitions = check . map parseTransitionLine . lines
|
|||
| all isJust l = Just $ S.fromList $ catMaybes l
|
||||
| otherwise = Nothing
|
||||
|
||||
parseTransitionsStrictly :: String -> String -> Transitions
|
||||
parseTransitionsStrictly source = fromMaybe badsource . parseTransitions
|
||||
where
|
||||
badsource = error $ "unknown transitions listed in " ++ source ++ "; upgrade git-annex!"
|
||||
|
||||
showTransitionLine :: TransitionLine -> String
|
||||
showTransitionLine (TransitionLine ts t) = unwords [show t, show ts]
|
||||
|
||||
|
@ -71,17 +80,14 @@ parseTransitionLine s = TransitionLine <$> pdate ds <*> readish ts
|
|||
ds = unwords $ Prelude.tail ws
|
||||
pdate = parseTime defaultTimeLocale "%s%Qs" >=*> utcTimeToPOSIXSeconds
|
||||
|
||||
{- Compares two sets of transitions, and returns a list of any transitions
|
||||
- from the second set that have not yet been perfomed in the first,
|
||||
- and a list of any transitions from the first set that have not yet been
|
||||
- performed in the second. -}
|
||||
diffTransitions :: Transitions -> Transitions -> ([Transition], [Transition])
|
||||
diffTransitions a b = (b `diff` a, a `diff` b)
|
||||
where
|
||||
diff x y = map transition $ S.elems $ S.difference x y
|
||||
combineTransitions :: [Transitions] -> Transitions
|
||||
combineTransitions = S.unions
|
||||
|
||||
sameTransitions :: Transitions -> Transitions -> Bool
|
||||
sameTransitions a b = let (x, y) = diffTransitions a b in null x && null y
|
||||
inTransitions :: Transition -> Transitions -> Bool
|
||||
inTransitions t = not . S.null . S.filter (\l -> transition l == t)
|
||||
|
||||
transitionList :: Transitions -> [Transition]
|
||||
transitionList = map transition . S.elems
|
||||
|
||||
{- Typically ran with Annex.Branch.change, but we can't import Annex.Branch
|
||||
- here since it depends on this module. -}
|
||||
|
@ -89,6 +95,4 @@ recordTransition :: (FilePath -> (String -> String) -> Annex ()) -> Transition -
|
|||
recordTransition changer o = do
|
||||
t <- liftIO getPOSIXTime
|
||||
changer transitionsLog $
|
||||
showTransitions . addTransition t o . fromMaybe badlog . parseTransitions
|
||||
where
|
||||
badlog = error $ "unknown transitions exist in " ++ transitionsLog
|
||||
showTransitions . addTransition t o . parseTransitionsStrictly "local"
|
||||
|
|
|
@ -479,6 +479,24 @@ subdirectories).
|
|||
|
||||
Upgrades the repository to current layout.
|
||||
|
||||
* forget
|
||||
|
||||
Causes the git-annex branch to be rewritten, throwing away historical
|
||||
data about past locations of files, files that are no longer present on
|
||||
any remote, etc. The resulting branch will use less space, but for
|
||||
example `git annex log` will not be able to show where files used to
|
||||
be located.
|
||||
|
||||
To also prune references to remotes that have been marked as dead,
|
||||
specify --forget-dead.
|
||||
|
||||
When this rewritten branch is merged into other clones of
|
||||
the repository, git-annex will automatically perform the same rewriting
|
||||
to their local git-annex branch. So the forgetfulness will automatically
|
||||
propigate out from its starting point until all repositories running
|
||||
git-annex have forgotten their old history. (You may need to force
|
||||
git to push the branch to any git repositories not running git-annex.
|
||||
|
||||
# QUERY COMMANDS
|
||||
|
||||
* version
|
||||
|
|
Loading…
Reference in a new issue