Branch module complete

Refactored some code that it needs into GitRepo.

Branch.hs

@@ -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

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]

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

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