summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2011-12-12 21:12:51 -0400
committerGravatar Joey Hess <joey@kitenet.net>2011-12-12 21:12:51 -0400
commit31a0c07ee91af9e3bf434f416a4d711d841aa223 (patch)
treef45a90aea7a22aa564ef4af9232d81db77108e9b
parent543d0d250104c1f5908e1b7b258d36d95488a029 (diff)
broke out Git/Branch.hs and reorganized
-rw-r--r--Annex/Branch.hs337
-rw-r--r--Git/Branch.hs60
2 files changed, 207 insertions, 190 deletions
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
diff --git a/Git/Branch.hs b/Git/Branch.hs
new file mode 100644
index 000000000..e69e96f28
--- /dev/null
+++ b/Git/Branch.hs
@@ -0,0 +1,60 @@
+{- git branch stuff
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Branch where
+
+import qualified Data.ByteString.Lazy.Char8 as L
+
+import Common
+import Git
+
+{- Checks if the second branch has any commits not present on the first
+ - branch. -}
+changed :: Branch -> Branch -> Repo -> IO Bool
+changed origbranch newbranch repo
+ | origbranch == newbranch = return False
+ | otherwise = not . L.null <$> diffs
+ where
+ diffs = Git.pipeRead
+ [ Param "log"
+ , Param (show origbranch ++ ".." ++ show newbranch)
+ , Params "--oneline -n1"
+ ] repo
+
+{- Given a set of refs that are all known to have commits not
+ - on the 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.
+ -}
+fastForward :: Branch -> [Ref] -> Repo -> IO Bool
+fastForward _ [] _ = return True
+fastForward branch (first:rest) repo = do
+ -- First, check that the branch does not contain any
+ -- new commits that are not in the first ref. If it does,
+ -- cannot fast-forward.
+ diverged <- changed first branch repo
+ if diverged
+ then no_ff
+ else maybe no_ff do_ff =<< findbest first rest
+ where
+ no_ff = return False
+ do_ff to = do
+ Git.run "update-ref"
+ [Param $ show branch, Param $ show to] repo
+ return True
+ findbest c [] = return $ Just c
+ findbest c (r:rs)
+ | c == r = findbest c rs
+ | otherwise = do
+ better <- changed c r repo
+ worse <- changed r c repo
+ 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