From 31a0c07ee91af9e3bf434f416a4d711d841aa223 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 12 Dec 2011 21:12:51 -0400 Subject: broke out Git/Branch.hs and reorganized --- Annex/Branch.hs | 337 ++++++++++++++++++++++++-------------------------------- 1 file changed, 147 insertions(+), 190 deletions(-) (limited to 'Annex') diff --git a/Annex/Branch.hs b/Annex/Branch.hs index c8a538acd..42940f4ff 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -6,15 +6,15 @@ -} module Annex.Branch ( + name, + hasOrigin, + hasSibling, create, update, get, change, commit, files, - name, - hasOrigin, - hasSibling, ) where import System.Exit @@ -27,6 +27,7 @@ import Annex.Journal import qualified Git import qualified Git.UnionMerge import qualified Git.Ref +import qualified Git.Branch import Annex.CatFile {- Name of the branch that is used to store git-annex's information. -} @@ -41,110 +42,18 @@ fullname = Git.Ref $ "refs/heads/" ++ show name originname :: Git.Ref originname = Git.Ref $ "origin/" ++ show name -{- Populates the branch's index file with the current branch contents. - - - - This is only done when the index doesn't yet exist, and the index - - is used to build up changes to be commited to the branch, and merge - - in changes from other branches. - -} -genIndex :: Git.Repo -> IO () -genIndex g = Git.UnionMerge.stream_update_index g - [Git.UnionMerge.ls_tree fullname g] - -{- Merges the specified branches into the index. - - Any changes staged in the index will be preserved. -} -mergeIndex :: [Git.Ref] -> Annex () -mergeIndex branches = do - h <- catFileHandle - inRepo $ \g -> Git.UnionMerge.merge_index h g branches - -{- Runs an action using the branch's index file. -} -withIndex :: Annex a -> Annex a -withIndex = withIndex' False -withIndex' :: Bool -> Annex a -> Annex a -withIndex' bootstrapping a = do - f <- fromRepo gitAnnexIndex - bracketIO (Git.useIndex f) id $ do - unlessM (liftIO $ doesFileExist f) $ do - unless bootstrapping create - liftIO $ createDirectoryIfMissing True $ takeDirectory f - unless bootstrapping $ inRepo genIndex - a - -{- Updates the branch's index to reflect the current contents of the branch. - - Any changes staged in the index will be preserved. - - - - Compares the ref stored in the lock file with the current - - ref of the branch to see if an update is needed. - -} -updateIndex :: Git.Ref -> Annex () -updateIndex branchref = do - lock <- fromRepo gitAnnexIndexLock - lockref <- Git.Ref . firstLine <$> - liftIO (catchDefaultIO (readFileStrict lock) "") - when (lockref /= branchref) $ do - withIndex $ mergeIndex [fullname] - setIndexSha branchref - -{- Record that the branch's index has been updated to correspond to a - - given ref of the branch. -} -setIndexSha :: Git.Ref -> Annex () -setIndexSha ref = do - lock <- fromRepo gitAnnexIndexLock - liftIO $ writeFile lock $ show ref ++ "\n" +{- Does origin/git-annex exist? -} +hasOrigin :: Annex Bool +hasOrigin = inRepo $ Git.Ref.exists originname -{- Commits the staged changes in the index to the branch. - - - - Ensures that the branch's index file is first updated to the state - - of the brannch at branchref, before running the commit action. This - - is needed because the branch may have had changes pushed to it, that - - are not yet reflected in the index. - - - - Also safely handles a race that can occur if a change is being pushed - - into the branch at the same time. When the race happens, the commit will - - be made on top of the newly pushed change, but without the index file - - being updated to include it. The result is that the newly pushed - - change is reverted. This race is detected and another commit made - - to fix it. - - - - The branchref value can have been obtained using getBranch at any - - previous point, though getting it a long time ago makes the race - - more likely to occur. - -} -commitBranch :: Git.Ref -> String -> [Git.Ref] -> Annex () -commitBranch branchref message parents = do - updateIndex branchref - committedref <- inRepo $ Git.commit message fullname parents - setIndexSha committedref - parentrefs <- commitparents <$> catObject committedref - when (racedetected branchref parentrefs) $ - fixrace committedref parentrefs - where - -- look for "parent ref" lines and return the refs - commitparents = map (Git.Ref . snd) . filter isparent . - map (toassoc . L.unpack) . L.lines - toassoc = separate (== ' ') - isparent (k,_) = k == "parent" - - {- The race can be detected by checking the commit's - - parent, which will be the newly pushed branch, - - instead of the expected ref that the index was updated to. -} - racedetected expectedref parentrefs - | expectedref `elem` parentrefs = False -- good parent - | otherwise = True -- race! - - {- To recover from the race, union merge the lost refs - - into the index, and recommit on top of the bad commit. -} - fixrace committedref lostrefs = do - mergeIndex lostrefs - commitBranch committedref racemessage [committedref] - - racemessage = message ++ " (recovery from race)" +{- Does the git-annex branch or a sibling foo/git-annex branch exist? -} +hasSibling :: Annex Bool +hasSibling = not . null <$> siblingBranches -{- Runs an action using the branch's index file, first making sure that - - the branch and index are up-to-date. -} -withIndexUpdate :: Annex a -> Annex a -withIndexUpdate a = update >> withIndex a +{- List of git-annex (refs, branches), including the main one and any + - from remotes. Duplicate refs are filtered out. -} +siblingBranches :: Annex [(Git.Ref, Git.Branch)] +siblingBranches = inRepo $ Git.Ref.matching name {- Creates the branch, if it does not already exist. -} create :: Annex () @@ -168,13 +77,6 @@ getBranch = maybe (hasOrigin >>= go >>= use) (return) =<< branchsha return sha branchsha = inRepo $ Git.Ref.sha fullname -{- Stages the journal, and commits staged changes to the branch. -} -commit :: String -> Annex () -commit message = whenM journalDirty $ lockJournal $ do - stageJournal - ref <- getBranch - withIndex $ commitBranch ref message [fullname] - {- Ensures that the branch and index are is up-to-date; should be - called before data is read from it. Runs only once per git-annex run. - @@ -194,8 +96,7 @@ update = runUpdateOnce $ do branchref <- getBranch -- check what needs updating before taking the lock dirty <- journalDirty - c <- filterM (changedBranch fullname . snd) =<< siblingBranches - let (refs, branches) = unzip c + (refs, branches) <- unzip <$> newerSiblings if (not dirty && null refs) then updateIndex branchref else withIndex $ lockJournal $ do @@ -208,88 +109,17 @@ update = runUpdateOnce $ do unless (null branches) $ do showSideAction merge_desc mergeIndex branches - ff <- if dirty then return False else tryFastForwardTo 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) invalidateCache - -{- Checks if the second branch has any commits not present on the first - - branch. -} -changedBranch :: Git.Branch -> Git.Branch -> Annex Bool -changedBranch origbranch newbranch - | origbranch == newbranch = return False - | otherwise = not . L.null <$> diffs - where - diffs = inRepo $ Git.pipeRead - [ Param "log" - , Param (show origbranch ++ ".." ++ show newbranch) - , Params "--oneline -n1" - ] - -{- Given a set of refs that are all known to have commits not - - on the git-annex branch, tries to update the branch by a - - fast-forward. - - - - In order for that to be possible, one of the refs must contain - - every commit present in all the other refs, as well as in the - - git-annex branch. - -} -tryFastForwardTo :: [Git.Ref] -> Annex Bool -tryFastForwardTo [] = return True -tryFastForwardTo (first:rest) = do - -- First, check that the git-annex branch does not contain any - -- new commits that are not in the first other branch. If it does, - -- cannot fast-forward. - diverged <- changedBranch first fullname - if diverged - then no_ff - else maybe no_ff do_ff =<< findbest first rest where - no_ff = return False - do_ff branch = do - inRepo $ Git.run "update-ref" - [Param $ show fullname, Param $ show branch] - return True - findbest c [] = return $ Just c - findbest c (r:rs) - | c == r = findbest c rs - | otherwise = do - better <- changedBranch c r - worse <- changedBranch r c - case (better, worse) of - (True, True) -> return Nothing -- divergent fail - (True, False) -> findbest r rs -- better - (False, True) -> findbest c rs -- worse - (False, False) -> findbest c rs -- same - -{- Does origin/git-annex exist? -} -hasOrigin :: Annex Bool -hasOrigin = inRepo $ Git.Ref.exists originname - -{- Does the git-annex branch or a sibling foo/git-annex branch exist? -} -hasSibling :: Annex Bool -hasSibling = not . null <$> siblingBranches - -{- List of git-annex (refs, branches), including the main one and any - - from remotes. Duplicate refs are filtered out. -} -siblingBranches :: Annex [(Git.Ref, Git.Branch)] -siblingBranches = inRepo $ Git.Ref.matching name - -{- Applies a function to modifiy the content of a file. - - - - Note that this does not cause the branch to be merged, it only - - modifes the current content of the file on the branch. - -} -change :: FilePath -> (String -> String) -> Annex () -change file a = lockJournal $ getStale file >>= return . a >>= set file - -{- Records new content of a file into the journal and cache. -} -set :: FilePath -> String -> Annex () -set file content = do - setJournalFile file content - setCache file content + newerSiblings = filterM isnewer =<< siblingBranches + isnewer (_, b) = inRepo $ Git.Branch.changed fullname b {- Gets the content of a file on the branch, or content from the journal, or - staged in the index. @@ -318,6 +148,75 @@ get' staleok file = fromcache =<< getCache file setCache file content return content +{- Applies a function to modifiy the content of a file. + - + - Note that this does not cause the branch to be merged, it only + - modifes the current content of the file on the branch. + -} +change :: FilePath -> (String -> String) -> Annex () +change file a = lockJournal $ getStale file >>= return . a >>= set file + +{- Records new content of a file into the journal and cache. -} +set :: FilePath -> String -> Annex () +set file content = do + setJournalFile file content + setCache file content + +{- Stages the journal, and commits staged changes to the branch. -} +commit :: String -> Annex () +commit message = whenM journalDirty $ lockJournal $ do + stageJournal + ref <- getBranch + withIndex $ commitBranch ref message [fullname] + +{- Commits the staged changes in the index to the branch. + - + - Ensures that the branch's index file is first updated to the state + - of the brannch at branchref, before running the commit action. This + - is needed because the branch may have had changes pushed to it, that + - are not yet reflected in the index. + - + - Also safely handles a race that can occur if a change is being pushed + - into the branch at the same time. When the race happens, the commit will + - be made on top of the newly pushed change, but without the index file + - being updated to include it. The result is that the newly pushed + - change is reverted. This race is detected and another commit made + - to fix it. + - + - The branchref value can have been obtained using getBranch at any + - previous point, though getting it a long time ago makes the race + - more likely to occur. + -} +commitBranch :: Git.Ref -> String -> [Git.Ref] -> Annex () +commitBranch branchref message parents = do + updateIndex branchref + committedref <- inRepo $ Git.commit message fullname parents + setIndexSha committedref + parentrefs <- commitparents <$> catObject committedref + when (racedetected branchref parentrefs) $ + fixrace committedref parentrefs + where + -- look for "parent ref" lines and return the refs + commitparents = map (Git.Ref . snd) . filter isparent . + map (toassoc . L.unpack) . L.lines + toassoc = separate (== ' ') + isparent (k,_) = k == "parent" + + {- The race can be detected by checking the commit's + - parent, which will be the newly pushed branch, + - instead of the expected ref that the index was updated to. -} + racedetected expectedref parentrefs + | expectedref `elem` parentrefs = False -- good parent + | otherwise = True -- race! + + {- To recover from the race, union merge the lost refs + - into the index, and recommit on top of the bad commit. -} + fixrace committedref lostrefs = do + mergeIndex lostrefs + commitBranch committedref racemessage [committedref] + + racemessage = message ++ " (recovery from race)" + {- Lists all files on the branch. There may be duplicates in the list. -} files :: Annex [FilePath] files = withIndexUpdate $ do @@ -326,6 +225,64 @@ files = withIndexUpdate $ do jfiles <- getJournalledFiles return $ jfiles ++ bfiles + +{- Populates the branch's index file with the current branch contents. + - + - This is only done when the index doesn't yet exist, and the index + - is used to build up changes to be commited to the branch, and merge + - in changes from other branches. + -} +genIndex :: Git.Repo -> IO () +genIndex g = Git.UnionMerge.stream_update_index g + [Git.UnionMerge.ls_tree fullname g] + +{- Merges the specified branches into the index. + - Any changes staged in the index will be preserved. -} +mergeIndex :: [Git.Ref] -> Annex () +mergeIndex branches = do + h <- catFileHandle + inRepo $ \g -> Git.UnionMerge.merge_index h g branches + +{- Runs an action using the branch's index file. -} +withIndex :: Annex a -> Annex a +withIndex = withIndex' False +withIndex' :: Bool -> Annex a -> Annex a +withIndex' bootstrapping a = do + f <- fromRepo gitAnnexIndex + bracketIO (Git.useIndex f) id $ do + unlessM (liftIO $ doesFileExist f) $ do + unless bootstrapping create + liftIO $ createDirectoryIfMissing True $ takeDirectory f + unless bootstrapping $ inRepo genIndex + a + +{- Runs an action using the branch's index file, first making sure that + - the branch and index are up-to-date. -} +withIndexUpdate :: Annex a -> Annex a +withIndexUpdate a = update >> withIndex a + +{- Updates the branch's index to reflect the current contents of the branch. + - Any changes staged in the index will be preserved. + - + - Compares the ref stored in the lock file with the current + - ref of the branch to see if an update is needed. + -} +updateIndex :: Git.Ref -> Annex () +updateIndex branchref = do + lock <- fromRepo gitAnnexIndexLock + lockref <- Git.Ref . firstLine <$> + liftIO (catchDefaultIO (readFileStrict lock) "") + when (lockref /= branchref) $ do + withIndex $ mergeIndex [fullname] + setIndexSha branchref + +{- Record that the branch's index has been updated to correspond to a + - given ref of the branch. -} +setIndexSha :: Git.Ref -> Annex () +setIndexSha ref = do + lock <- fromRepo gitAnnexIndexLock + liftIO $ writeFile lock $ show ref ++ "\n" + {- Stages the journal into the index. -} stageJournal :: Annex () stageJournal = do -- cgit v1.2.3