diff options
author | Joey Hess <joey@kitenet.net> | 2011-06-21 17:39:45 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2011-06-21 17:52:39 -0400 |
commit | 40ec8a9726586f24357a5ae2057a092a971c1046 (patch) | |
tree | 3da8a6b99fe58f3405fcfb117050b5821fbc0041 | |
parent | 7e7428f173ba1b72b4de69fd482f44161ee84420 (diff) |
Branch module complete
Refactored some code that it needs into GitRepo.
-rw-r--r-- | Branch.hs | 76 | ||||
-rw-r--r-- | GitRepo.hs | 50 | ||||
-rw-r--r-- | GitUnionMerge.hs | 60 | ||||
-rw-r--r-- | git-union-merge.hs | 8 |
4 files changed, 135 insertions, 59 deletions
@@ -12,26 +12,63 @@ module Branch ( import Control.Monad (unless) import Control.Monad.State (liftIO) +import System.FilePath +import System.Directory +import Data.String.Utils +import System.Cmd.Utils import GitUnionMerge -import GitRepo as Git +import qualified GitRepo as Git import qualified Annex import Utility import Types import Messages +{- Name of the branch that is used to store git-annex's information. -} name :: String name = "git-annex" +{- Fully qualified name of the branch. -} fullname :: String fullname = "refs/heads/" ++ name +{- A separate index file for the branch. -} +index :: Git.Repo -> FilePath +index g = Git.workTree g </> Git.gitDir g </> "index." ++ name + +{- Populates the branch's index file with the current branch contents. + - + - Usually, 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. + -} +genIndex :: FilePath -> Git.Repo -> IO () +genIndex f g = do + ls <- Git.pipeNullSplit g $ + map Param ["ls-tree", "-z", "-r", "--full-tree", fullname] + forceSuccess =<< Git.pipeWrite g + (map Param ["update-index", "-z", "--index-info"]) + (join "\0" ls) + +{- Runs an action using the branch's index file. -} +withIndex :: Annex a -> Annex a +withIndex a = do + g <- Annex.gitRepo + let f = index g + liftIO $ Git.useIndex f + + e <- liftIO $ doesFileExist f + unless e $ liftIO $ genIndex f g + + r <- a + liftIO $ Git.useDefaultIndex + return r + {- Ensures that the branch is up-to-date; should be called before - data is read from it. Runs only once per git-annex run. -} update :: Annex () update = do updated <- Annex.getState Annex.updated - unless updated $ do + unless updated $ withIndex $ do g <- Annex.gitRepo refs <- liftIO $ Git.pipeRead g [Param "show-ref", Param name] mapM_ updateRef $ map (last . words) (lines refs) @@ -49,12 +86,37 @@ updateRef ref Params "--oneline -n1" ] unless (null diffs) $ do - showSideAction "merging " ++ ref ++ " into " ++ name ++ "..." - liftIO $ unionMerge g fullname ref fullname + showSideAction $ "merging " ++ ref ++ " into " ++ name ++ "..." + liftIO $ unionMerge g fullname ref fullname True -{- Stages the content of a file to be committed to the branch. -} +{- Stages the content of a file into the branch's index. -} change :: FilePath -> String -> Annex () -change file content = do - update +change file content = update >> do + g <- Annex.gitRepo + sha <- liftIO $ Git.hashObject g content + withIndex $ liftIO $ Git.run g "update-index" + [ Params "--add --cacheinfo 100644 ", + Param sha, File file] {- Commits staged changes to the branch. -} +commit :: String -> Annex () +commit message = withIndex $ do + g <- Annex.gitRepo + -- It would be expensive to check if anything needs to be + -- committed, so --allow-empty is used. + liftIO $ Git.run g "commit" + [Param "--allow-empty", Param "-m", Param message] + +{- Gets the content of a file on the branch, or content staged in the index + - if it's newer. Returns an empty string if the file didn't exist yet. -} +get :: FilePath -> Annex String +get file = withIndex $ do + g <- Annex.gitRepo + liftIO $ catch (cat g) (const $ return "") + where + -- To avoid stderr from cat-file when file does not exist, + -- first run it with -e to check that it exists. + cat g = do + Git.run g "cat-file" [Param "-e", catfile] + Git.pipeRead g [Param "cat-file", Param "blob", catfile] + catfile = Param $ ':':file diff --git a/GitRepo.hs b/GitRepo.hs index 11511f77d..91ddf6dca 100644 --- a/GitRepo.hs +++ b/GitRepo.hs @@ -58,12 +58,16 @@ module GitRepo ( typeChangedStagedFiles, repoAbsPath, reap, - withIndex, + useIndex, + useDefaultIndex, + hashObject, + getSha, + shaSize, prop_idempotent_deencode ) where -import Control.Monad (unless) +import Control.Monad (unless, when) import System.Directory import System.FilePath import System.Posix.Directory @@ -381,13 +385,41 @@ reap = do r <- catch (getAnyProcessStatus False True) (\_ -> return Nothing) maybe (return ()) (const reap) r -{- Runs an action using a specified index file. -} -withIndex :: FilePath -> IO a -> IO a -withIndex index a = do - setEnv "GIT_INDEX_FILE" index True - r <- a - unsetEnv "GIT_INDEX_FILE" - return r +{- Forces git to use the specified index file. -} +useIndex :: FilePath -> IO () +useIndex index = setEnv "GIT_INDEX_FILE" index True + +{- Undoes useIndex -} +useDefaultIndex :: IO () +useDefaultIndex = unsetEnv "GIT_INDEX_FILE" + +{- Injects some content into git, returning its hash. -} +hashObject :: Repo -> String -> IO String +hashObject repo content = getSha subcmd $ do + (h, s) <- pipeWriteRead repo (map Param params) content + length s `seq` do + forceSuccess h + reap -- XXX unsure why this is needed + return s + where + subcmd = "hash-object" + params = [subcmd, "-w", "--stdin"] + +{- Runs an action that causes a git subcommand to emit a sha, and strips + any trailing newline, returning the sha. -} +getSha :: String -> IO 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' + +{- Size of a git sha. -} +shaSize :: Int +shaSize = 40 {- Scans for files that are checked into git at the specified locations. -} inRepo :: Repo -> [FilePath] -> IO [FilePath] diff --git a/GitUnionMerge.hs b/GitUnionMerge.hs index 8aa04f53a..ba9ea79e4 100644 --- a/GitUnionMerge.hs +++ b/GitUnionMerge.hs @@ -9,10 +9,7 @@ module GitUnionMerge ( unionMerge ) where -import System.FilePath -import System.Directory import System.Cmd.Utils -import Control.Monad (when) import Data.List import Data.Maybe import Data.String.Utils @@ -21,18 +18,24 @@ import qualified GitRepo as Git import Utility {- Performs a union merge. Should be run with a temporary index file - - configured by Git.withIndex. -} -unionMerge :: Git.Repo -> String -> String -> String -> IO () -unionMerge g aref bref newref = do - stage g aref bref + - configured by Git.useIndex. + - + - Use indexpopulated only if the index file already contains exactly the + - contents of aref. + -} +unionMerge :: Git.Repo -> String -> String -> String -> Bool -> IO () +unionMerge g aref bref newref indexpopulated = do + stage g aref bref indexpopulated commit g aref bref newref {- 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] +stage :: Git.Repo -> String -> String -> Bool -> IO () +stage g aref bref indexpopulated = do + -- Get the contents of aref, as a starting point, unless + -- the index is already populated with it. + ls <- if indexpopulated + then return [] + else 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 @@ -45,18 +48,12 @@ stage g aref bref = do 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' + nullsha = take Git.shaSize $ repeat '0' ls_tree_line sha file = "100644 blob " ++ sha ++ "\t" ++ file unionmerge = unlines . nub . lines @@ -68,32 +65,17 @@ stage g aref bref = do 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 + sha <- Git.hashObject g $ unionmerge content return $ Just $ ls_tree_line sha file {- Commits the index into the specified branch, as a merge commit. -} commit :: Git.Repo -> String -> String -> String -> IO () commit g aref bref newref = do - tree <- getSha "write-tree" $ + tree <- Git.getSha "write-tree" $ ignorehandle $ pipeFrom "git" ["write-tree"] - sha <- getSha "commit-tree" $ + sha <- Git.getSha "commit-tree" $ ignorehandle $ 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 + where + ignorehandle a = return . snd =<< a diff --git a/git-union-merge.hs b/git-union-merge.hs index 12f49adc6..e8ac0a0c5 100644 --- a/git-union-merge.hs +++ b/git-union-merge.hs @@ -42,7 +42,7 @@ main :: IO () main = do [aref, bref, newref] <- parseArgs g <- Git.configRead =<< Git.repoFromCwd - Git.withIndex (tmpIndex g) $ do - setup g - unionMerge g aref bref newref - cleanup g + Git.useIndex (tmpIndex g) + setup g + unionMerge g aref bref newref False + cleanup g |