diff options
author | 2011-06-21 14:09:06 -0400 | |
---|---|---|
committer | 2011-06-21 14:09:06 -0400 | |
commit | e735d459b531246798622994718eaccfcf0086ab (patch) | |
tree | 4c63e9142a51e4c176f7379c4a41ed5b6fcf9cd2 /GitUnionMerge.hs | |
parent | 9f9e17aa0f4898063a58c88661bca01465b126a9 (diff) |
moved to library
Diffstat (limited to 'GitUnionMerge.hs')
-rw-r--r-- | GitUnionMerge.hs | 115 |
1 files changed, 115 insertions, 0 deletions
diff --git a/GitUnionMerge.hs b/GitUnionMerge.hs new file mode 100644 index 000000000..dde4b7a04 --- /dev/null +++ b/GitUnionMerge.hs @@ -0,0 +1,115 @@ +{- git-union-merge library + - + - Copyright 2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module GitUnionMerge ( + unionMerge +) where + +import System.FilePath +import System.Directory +import System.Cmd.Utils +import System.Posix.Env (setEnv, unsetEnv) +import Control.Monad (when) +import Data.List +import Data.Maybe +import Data.String.Utils + +import qualified GitRepo as Git +import Utility + +unionMerge :: Git.Repo -> String -> String -> String -> IO () +unionMerge g aref bref newref = do + setup g + stage g aref bref + commit g aref bref newref + cleanup g + +tmpIndex :: Git.Repo -> FilePath +tmpIndex g = Git.workTree g </> Git.gitDir g </> "index.git-union-merge" + +{- Configures git to use a temporary index file. -} +setup :: Git.Repo -> IO () +setup g = do + cleanup g -- idempotency + setEnv "GIT_INDEX_FILE" (tmpIndex g) True + +cleanup :: Git.Repo -> IO () +cleanup g = do + unsetEnv "GIT_INDEX_FILE" + e' <- doesFileExist (tmpIndex g) + when e' $ removeFile (tmpIndex g) + +{- Stages the content of both refs into the index. -} +stage :: Git.Repo -> String -> String -> IO () +stage g aref bref = do + -- Get the contents of aref, as a starting point. + ls <- fromgit + ["ls-tree", "-z", "-r", "--full-tree", aref] + -- Identify files that are different between aref and bref, and + -- inject merged versions into git. + diff <- fromgit + ["diff-tree", "--raw", "-z", "-r", "--no-renames", "-l0", aref, bref] + ls' <- mapM mergefile (pairs diff) + -- Populate the index file. Later lines override earlier ones. + togit ["update-index", "-z", "--index-info"] + (join "\0" $ ls++catMaybes ls') + where + fromgit l = Git.pipeNullSplit g (map Param l) + togit l content = Git.pipeWrite g (map Param l) content + >>= forceSuccess + tofromgit l content = do + (h, s) <- Git.pipeWriteRead g (map Param l) content + length s `seq` do + forceSuccess h + Git.reap + return ((), s) + + pairs [] = [] + pairs (_:[]) = error "parse error" + pairs (a:b:rest) = (a,b):pairs rest + + nullsha = take shaSize $ repeat '0' + ls_tree_line sha file = "100644 blob " ++ sha ++ "\t" ++ file + unionmerge = unlines . nub . lines + + mergefile (info, file) = do + let [_colonamode, _bmode, asha, bsha, _status] = words info + if bsha == nullsha + then return Nothing -- already staged from aref + else mergefile' file asha bsha + mergefile' file asha bsha = do + let shas = filter (/= nullsha) [asha, bsha] + content <- Git.pipeRead g $ map Param ("show":shas) + sha <- getSha "hash-object" $ + tofromgit ["hash-object", "-w", "--stdin"] $ + unionmerge content + return $ Just $ ls_tree_line sha file + +{- Commits the index into the specified branch. -} +commit :: Git.Repo -> String -> String -> String -> IO () +commit g aref bref newref = do + tree <- getSha "write-tree" $ + pipeFrom "git" ["write-tree"] + sha <- getSha "commit-tree" $ + pipeBoth "git" ["commit-tree", tree, "-p", aref, "-p", bref] + "union merge" + Git.run g "update-ref" [Param newref, Param sha] + +{- Runs an action that causes a git subcommand to emit a sha, and strips + any trailing newline, returning the sha. -} +getSha :: String -> IO (a, String) -> IO String +getSha subcommand a = do + (_, t) <- a + let t' = if last t == '\n' + then take (length t - 1) t + else t + when (length t' /= shaSize) $ + error $ "failed to read sha from git " ++ subcommand ++ " (" ++ t' ++ ")" + return t' + +shaSize :: Int +shaSize = 40 |