moved to library
This commit is contained in:
Joey Hess
parent
9f9e17aa0f
commit
e735d459b5
2 changed files with 120 additions and 102 deletions
115
GitUnionMerge.hs
Normal file
115
GitUnionMerge.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue