add support for staging other types of blobs, like symlinks, into the index

Also added a utility TopFilePath type, which could stand to be used more
widely.

4 files changed, 53 insertions, 7 deletions

diff --git a/Git/FilePath.hs b/Git/FilePath.hs
new file mode 100644
index 000000000..6344353d6
--- /dev/null
+++ b/Git/FilePath.hs
@@ -0,0 +1,34 @@
+{- git FilePath library
+ -
+ - Different git commands use different types of FilePaths to refer to
+ - files in the repository. Some commands use paths relative to the
+ - top of the repository even when run in a subdirectory. Adding some
+ - types helps keep that straight.
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.FilePath (
+	TopFilePath,
+	getTopFilePath,
+	toTopFilePath,
+	asTopFilePath,
+) where
+
+import Common
+import Git
+
+{- A FilePath, relative to the top of the git repository. -}
+newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }
+
+{- The input FilePath can be absolute, or relative to the CWD. -}
+toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath
+toTopFilePath file repo = TopFilePath <$>
+	relPathDirToFile (repoPath repo) <$> absPath file
+
+{- The input FilePath must already be relative to the top of the git
+ - repository -}
+asTopFilePath :: FilePath -> TopFilePath
+asTopFilePath file = TopFilePath file
diff --git a/Git/Types.hs b/Git/Types.hs
index 64d418a04..1df6e343b 100644
--- a/Git/Types.hs
+++ b/Git/Types.hs
@@ -63,3 +63,11 @@ readObjectType "commit" = Just CommitObject
 readObjectType "tree" = Just TreeObject
 readObjectType _ = Nothing
 
+{- Types of blobs. -}
+data BlobType = FileBlob | ExecutableBlob | SymlinkBlob
+
+{- Git uses magic numbers to denote the type of a blob. -}
+instance Show BlobType where
+	show FileBlob = "100644"
+	show ExecutableBlob = "100755"
+	show SymlinkBlob = "120000"
diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs
index 822e6abbf..f65b59c53 100644
--- a/Git/UnionMerge.hs
+++ b/Git/UnionMerge.hs
@@ -22,6 +22,7 @@ import Git.Command
 import Git.UpdateIndex
 import Git.HashObject
 import Git.Types
+import Git.FilePath
 
 {- Performs a union merge between two branches, staging it in the index.
  - Any previously staged changes in the index will be lost.
@@ -79,7 +80,7 @@ mergeFile info file h repo = case filter (/= nullSha) [Ref asha, Ref bsha] of
 		[_colonmode, _bmode, asha, bsha, _status] = words info
 		getcontents s = map L.unpack . L.lines .
 			L.decodeUtf8 <$> catObject h s
-		use sha = return $ Just $ update_index_line sha file
+		use sha = return $ Just $ update_index_line sha FileBlob $ asTopFilePath file
 
 {- Calculates a union merge between a list of refs, with contents.
  -
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index 04bc4da5b..8c003dd13 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -8,15 +8,17 @@
 module Git.UpdateIndex (
 	Streamer,
 	stream_update_index,
+	ls_tree,
 	update_index_line,
-	ls_tree
 ) where
 
 import System.Cmd.Utils
 
 import Common
 import Git
+import Git.Types
 import Git.Command
+import Git.FilePath
 
 {- Streamers are passed a callback and should feed it lines in the form
  - read by update-index, and generated by ls-tree. -}
@@ -37,13 +39,14 @@ stream_update_index repo as = do
 			hPutStr h s
 			hPutStr h "\0"
 
-{- Generates a line suitable to be fed into update-index, to add
- - a given file with a given sha. -}
-update_index_line :: Sha -> FilePath -> String
-update_index_line sha file = "100644 blob " ++ show sha ++ "\t" ++ file
-
 {- Gets the current tree for a ref. -}
 ls_tree :: Ref -> Repo -> Streamer
 ls_tree (Ref x) repo streamer = mapM_ streamer =<< pipeNullSplit params repo
 	where
 		params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
+
+{- Generates a line suitable to be fed into update-index, to add
+ - a given file with a given sha. -}
+update_index_line :: Sha -> BlobType -> TopFilePath -> String
+update_index_line sha filetype file =
+	show filetype ++ " blob " ++ show sha ++ "\t" ++ getTopFilePath file