diff options
| -rw-r--r-- | GitUnionMerge.hs | 115 | ||||
| -rw-r--r-- | git-union-merge.hs | 107 |
2 files changed, 120 insertions, 102 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 diff --git a/git-union-merge.hs b/git-union-merge.hs index e11f93701..62a79a4c2 100644 --- a/git-union-merge.hs +++ b/git-union-merge.hs @@ -6,17 +6,9 @@ -} import System.Environment -import System.FilePath -import System.Directory -import System.Cmd.Utils -import System.Posix.Env (setEnv) -import Control.Monad (when) -import Data.List -import Data.Maybe -import Data.String.Utils +import GitUnionMerge import qualified GitRepo as Git -import Utility header :: String header = "Usage: git-union-merge ref ref newref" @@ -24,14 +16,6 @@ header = "Usage: git-union-merge ref ref newref" usage :: IO a usage = error $ "bad parameters\n\n" ++ header -main :: IO () -main = do - [aref, bref, newref] <- parseArgs - g <- setup - stage g aref bref - commit g aref bref newref - cleanup g - parseArgs :: IO [String] parseArgs = do args <- getArgs @@ -39,89 +23,8 @@ parseArgs = do then usage else return args -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 :: IO Git.Repo -setup = do +main :: IO () +main = do + [aref, bref, newref] <- parseArgs g <- Git.configRead =<< Git.repoFromCwd - cleanup g -- idempotency - setEnv "GIT_INDEX_FILE" (tmpIndex g) True - return g - -cleanup :: Git.Repo -> IO () -cleanup g = do - 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 + unionMerge g aref bref newref |