code:
{- running git commands
 -
 - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Git.Command where

import Common
import Git
import Git.Types
import qualified Utility.CoProcess as CoProcess

{- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
gitCommandLine params r@(Repo { location = l@(Local _ _ ) }) =
	setdir : settree ++ gitGlobalOpts r ++ params
  where
	setdir = Param $ "--git-dir=" ++ gitdir l
	settree = case worktree l of
		Nothing -> []
		Just t -> [Param $ "--work-tree=" ++ t]
gitCommandLine _ repo = assertLocal repo $ error "internal"

{- Runs git in the specified repo. -}
runBool :: [CommandParam] -> Repo -> IO Bool
runBool params repo = assertLocal repo $
	boolSystemEnv "git" (gitCommandLine params repo) (gitEnv repo)

{- Runs git in the specified repo, throwing an error if it fails. -}
run :: [CommandParam] -> Repo -> IO ()
run params repo = assertLocal repo $
	unlessM (runBool params repo) $
		error $ "git " ++ show params ++ " failed"

{- Runs git and forces it to be quiet, throwing an error if it fails. -}
runQuiet :: [CommandParam] -> Repo -> IO ()
runQuiet params repo = withQuietOutput createProcessSuccess $
	(proc "git" $ toCommand $ gitCommandLine (params) repo)
		{ env = gitEnv repo }

{- Runs a git command and returns its output, lazily.
 -
 - Also returns an action that should be used when the output is all
 - read (or no more is needed), that will wait on the command, and
 - return True if it succeeded. Failure to wait will result in zombies.
 -}
pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool)
pipeReadLazy params repo = assertLocal repo $ do
	(_, Just h, _, pid) <- createProcess p { std_out = CreatePipe }
	fileEncoding h
	c <- hGetContents h
	return (c, checkSuccessProcess pid)
  where
	p  = gitCreateProcess params repo

{- Runs a git command, and returns its output, strictly.
 -
 - Nonzero exit status is ignored.
 -}
pipeReadStrict :: [CommandParam] -> Repo -> IO String
pipeReadStrict params repo = assertLocal repo $
	withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do
		fileEncoding h
		output <- hGetContentsStrict h
		hClose h
		return output
  where
	p  = gitCreateProcess params repo

{- Runs a git command, feeding it an input, and returning its output,
 - which is expected to be fairly small, since it's all read into memory
 - strictly. -}
pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO String
pipeWriteRead params writer repo = assertLocal repo $
	writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo)
		(gitEnv repo) writer (Just adjusthandle)
  where
  	adjusthandle h = do
		fileEncoding h
		hSetNewlineMode h noNewlineTranslation

{- Runs a git command, feeding it input on a handle with an action. -}
pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO ()
pipeWrite params repo = withHandle StdinHandle createProcessSuccess $
	gitCreateProcess params repo

{- Reads null terminated output of a git command (as enabled by the -z
 - parameter), and splits it. -}
pipeNullSplit :: [CommandParam] -> Repo -> IO ([String], IO Bool)
pipeNullSplit params repo = do
	(s, cleanup) <- pipeReadLazy params repo
	return (filter (not . null) $ split sep s, cleanup)
  where
	sep = "\0"

pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [String]
pipeNullSplitStrict params repo = do
	s <- pipeReadStrict params repo
	return $ filter (not . null) $ split sep s
  where
	sep = "\0"

pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String]
pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo

{- Doesn't run the cleanup action. A zombie results. -}
leaveZombie :: (a, IO Bool) -> a
leaveZombie = fst

{- Runs a git command as a coprocess. -}
gitCoProcessStart :: Bool -> [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle
gitCoProcessStart restartable params repo = CoProcess.start numrestarts "git"
	(toCommand $ gitCommandLine params repo)
	(gitEnv repo)
  where
  	{- If a long-running git command like cat-file --batch
	 - crashes, it will likely start up again ok. If it keeps crashing
	 - 10 times, something is badly wrong. -}
	numrestarts = if restartable then 10 else 0

gitCreateProcess :: [CommandParam] -> Repo -> CreateProcess
gitCreateProcess params repo =
	(proc "git" $ toCommand $ gitCommandLine params repo)
			{ env = gitEnv repo }


code:
{- running batch git commands
 -
 - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.Command.Batch where

import Common
import Git
import Git.Command
import Utility.Batch

{- Runs git in batch mode. -}
run :: BatchCommandMaker -> [CommandParam] -> Repo -> IO Bool
run batchmaker params repo = assertLocal repo $ do
	let (cmd, params') = batchmaker ("git", gitCommandLine params repo)
	boolSystemEnv cmd params' (gitEnv repo)

repo_name: kakafarm/git

license: unknown


code:
{- git repository configuration handling
 -
 - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.Config where

import qualified Data.Map as M
import Data.Char
import Control.Exception.Extensible

import Common
import Git
import Git.Types
import qualified Git.Construct
import Utility.UserInfo

{- Returns a single git config setting, or a default value if not set. -}
get :: String -> String -> Repo -> String
get key defaultValue repo = M.findWithDefault defaultValue key (config repo)

{- Returns a list with each line of a multiline config setting. -}
getList :: String -> Repo -> [String]
getList key repo = M.findWithDefault [] key (fullconfig repo)

{- Returns a single git config setting, if set. -}
getMaybe :: String -> Repo -> Maybe String
getMaybe key repo = M.lookup key (config repo)

{- Runs git config and populates a repo with its config.
 - Avoids re-reading config when run repeatedly. -}
read :: Repo -> IO Repo
read repo@(Repo { config = c })
	| c == M.empty = read' repo
	| otherwise = return repo

{- Reads config even if it was read before. -}
reRead :: Repo -> IO Repo
reRead r = read' $ r
	{ config = M.empty
	, fullconfig = M.empty
	}

{- Cannot use pipeRead because it relies on the config having been already
 - read. Instead, chdir to the repo and run git config.
 -}
read' :: Repo -> IO Repo
read' repo = go repo
  where
	go Repo { location = Local { gitdir = d } } = git_config d
	go Repo { location = LocalUnknown d } = git_config d
	go _ = assertLocal repo $ error "internal"
	git_config d = withHandle StdoutHandle createProcessSuccess p $
		hRead repo
	  where
		params = ["config", "--null", "--list"]
		p = (proc "git" params)
			{ cwd = Just d
			, env = gitEnv repo
			}

{- Gets the global git config, returning a dummy Repo containing it. -}
global :: IO (Maybe Repo)
global = do
	home <- myHomeDir
	ifM (doesFileExist $ home </> ".gitconfig")
		( do
			repo <- Git.Construct.fromUnknown
			repo' <- withHandle StdoutHandle createProcessSuccess p $
				hRead repo
			return $ Just repo'
		, return Nothing
		)
  where
	params = ["config", "--null", "--list", "--global"]
	p = (proc "git" params)

{- Reads git config from a handle and populates a repo with it. -}
hRead :: Repo -> Handle -> IO Repo
hRead repo h = do
	-- We use the FileSystemEncoding when reading from git-config,
	-- because it can contain arbitrary filepaths (and other strings)
	-- in any encoding.
	fileEncoding h
	val <- hGetContentsStrict h
	store val repo

{- Stores a git config into a Repo, returning the new version of the Repo.
 - The git config may be multiple lines, or a single line.
 - Config settings can be updated incrementally.
 -}
store :: String -> Repo -> IO Repo
store s repo = do
	let c = parse s
	repo' <- updateLocation $ repo
		{ config = (M.map Prelude.head c) `M.union` config repo
		, fullconfig = M.unionWith (++) c (fullconfig repo)
		}
	rs <- Git.Construct.fromRemotes repo'
	return $ repo' { remotes = rs }

{- Updates the location of a repo, based on its configuration.
 -
 - Git.Construct makes LocalUknown repos, of which only a directory is
 - known. Once the config is read, this can be fixed up to a Local repo,
 - based on the core.bare and core.worktree settings.
 -}
updateLocation :: Repo -> IO Repo
updateLocation r@(Repo { location = LocalUnknown d })
	| isBare r = ifM (doesDirectoryExist dotgit)
			( updateLocation' r $ Local dotgit Nothing
			, updateLocation' r $ Local d Nothing
			)
	| otherwise = updateLocation' r $ Local dotgit (Just d)
  where
	dotgit = (d </> ".git")
updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l
updateLocation r = return r

updateLocation' :: Repo -> RepoLocation -> IO Repo
updateLocation' r l = do
	l' <- case getMaybe "core.worktree" r of
		Nothing -> return l
		Just d -> do
			{- core.worktree is relative to the gitdir -}
			top <- absPath $ gitdir l
			return $ l { worktree = Just $ absPathFrom top d }
	return $ r { location = l' }

{- Parses git config --list or git config --null --list output into a
 - config map. -}
parse :: String -> M.Map String [String]
parse [] = M.empty
parse s
	-- --list output will have an = in the first line
	| all ('=' `elem`) (take 1 ls) = sep '=' ls
	-- --null --list output separates keys from values with newlines
	| otherwise = sep '\n' $ split "\0" s
  where
	ls = lines s
	sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .
		map (separate (== c))

{- Checks if a string from git config is a true value. -}
isTrue :: String -> Maybe Bool
isTrue s
	| s' == "true" = Just True
	| s' == "false" = Just False
	| otherwise = Nothing
  where
	s' = map toLower s

boolConfig :: Bool -> String
boolConfig True = "true"
boolConfig False = "false"

isBare :: Repo -> Bool
isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r

coreBare :: String
coreBare = "core.bare"

{- Runs a command to get the configuration of a repo,
 - and returns a repo populated with the configuration, as well as the raw
 - output of the command. -}
fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String))
fromPipe r cmd params = try $
	withHandle StdoutHandle createProcessSuccess p $ \h -> do
 		fileEncoding h
		val <- hGetContentsStrict h
		r' <- store val r
		return (r', val)
  where
	p = proc cmd $ toCommand params

{- Reads git config from a specified file and returns the repo populated
 - with the configuration. -}
fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String))
fromFile r f = fromPipe r "git"
	[ Param "config"
	, Param "--file"
	, File f
	, Param "--list"
	]

{- Changes a git config setting in the specified config file.
 - (Creates the file if it does not already exist.) -}
changeFile :: FilePath -> String -> String -> IO Bool
changeFile f k v = boolSystem "git"
	[ Param "config"
	, Param "--file"
	, File f
	, Param k
	, Param v
	]


code:
{- Construction of Git Repo objects
 -
 - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Git.Construct (
	fromCwd,
	fromAbsPath,
	fromPath,
	fromUrl,
	fromUnknown,
	localToUrl,
	remoteNamed,
	remoteNamedFromKey,
	fromRemotes,
	fromRemoteLocation,
	repoAbsPath,
	newFrom,
	checkForRepo,
) where

#ifndef mingw32_HOST_OS
import System.Posix.User
#endif
import qualified Data.Map as M hiding (map, split)
import Network.URI

import Common
import Git.Types
import Git
import Git.Remote
import Git.FilePath
import qualified Git.Url as Url
import Utility.UserInfo

{- Finds the git repository used for the cwd, which may be in a parent
 - directory. -}
fromCwd :: IO (Maybe Repo)
fromCwd = getCurrentDirectory >>= seekUp
  where
	seekUp dir = do
		r <- checkForRepo dir
		case r of
			Nothing -> case parentDir dir of
				"" -> return Nothing
				d -> seekUp d
			Just loc -> Just <$> newFrom loc

{- Local Repo constructor, accepts a relative or absolute path. -}
fromPath :: FilePath -> IO Repo
fromPath dir = fromAbsPath =<< absPath dir

{- Local Repo constructor, requires an absolute path to the repo be
 - specified. -}
fromAbsPath :: FilePath -> IO Repo
fromAbsPath dir
	| absoluteGitPath dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt )
	| otherwise =
		error $ "internal error, " ++ dir ++ " is not absolute"
  where
	ret = newFrom . LocalUnknown
	{- Git always looks for "dir.git" in preference to
	 - to "dir", even if dir ends in a "/". -}
	canondir = dropTrailingPathSeparator dir
	dir' = canondir ++ ".git"
	{- When dir == "foo/.git", git looks for "foo/.git/.git",
	 - and failing that, uses "foo" as the repository. -}
	hunt
		| (pathSeparator:".git") `isSuffixOf` canondir =
			ifM (doesDirectoryExist $ dir </> ".git")
				( ret dir
				, ret $ takeDirectory canondir
				)
		| otherwise = ret dir

{- Remote Repo constructor. Throws exception on invalid url.
 -
 - Git is somewhat forgiving about urls to repositories, allowing
 - eg spaces that are not normally allowed unescaped in urls.
 -}
fromUrl :: String -> IO Repo
fromUrl url
	| not (isURI url) = fromUrlStrict $ escapeURIString isUnescapedInURI url
	| otherwise = fromUrlStrict url

fromUrlStrict :: String -> IO Repo
fromUrlStrict url
	| startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u
	| otherwise = newFrom $ Url u
  where
	u = fromMaybe bad $ parseURI url
	bad = error $ "bad url " ++ url

{- Creates a repo that has an unknown location. -}
fromUnknown :: IO Repo
fromUnknown = newFrom Unknown

{- Converts a local Repo into a remote repo, using the reference repo
 - which is assumed to be on the same host. -}
localToUrl :: Repo -> Repo -> Repo
localToUrl reference r
	| not $ repoIsUrl reference = error "internal error; reference repo not url"
	| repoIsUrl r = r
	| otherwise = case Url.authority reference of
		Nothing -> r
		Just auth ->
			let absurl = concat
				[ Url.scheme reference
				, "//"
				, auth
				, repoPath r
				]
			in r { location = Url $ fromJust $ parseURI absurl }

{- Calculates a list of a repo's configured remotes, by parsing its config. -}
fromRemotes :: Repo -> IO [Repo]
fromRemotes repo = mapM construct remotepairs
  where
	filterconfig f = filter f $ M.toList $ config repo
	filterkeys f = filterconfig (\(k,_) -> f k)
	remotepairs = filterkeys isremote
	isremote k = startswith "remote." k && endswith ".url" k
	construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo

{- Sets the name of a remote when constructing the Repo to represent it. -}
remoteNamed :: String -> IO Repo -> IO Repo
remoteNamed n constructor = do
	r <- constructor
	return $ r { remoteName = Just n }

{- Sets the name of a remote based on the git config key, such as
 - "remote.foo.url". -}
remoteNamedFromKey :: String -> IO Repo -> IO Repo
remoteNamedFromKey k = remoteNamed basename
  where
	basename = intercalate "." $
		reverse $ drop 1 $ reverse $ drop 1 $ split "." k

{- Constructs a new Repo for one of a Repo's remotes using a given
 - location (ie, an url). -}
fromRemoteLocation :: String -> Repo -> IO Repo
fromRemoteLocation s repo = gen $ parseRemoteLocation s repo
  where
	gen (RemotePath p) = fromRemotePath p repo
	gen (RemoteUrl u) = fromUrl u

{- Constructs a Repo from the path specified in the git remotes of
 - another Repo. -}
fromRemotePath :: FilePath -> Repo -> IO Repo
fromRemotePath dir repo = do
	dir' <- expandTilde dir
	fromAbsPath $ repoPath repo </> dir'

{- Git remotes can have a directory that is specified relative
 - to the user's home directory, or that contains tilde expansions.
 - This converts such a directory to an absolute path.
 - Note that it has to run on the system where the remote is.
 -}
repoAbsPath :: FilePath -> IO FilePath
repoAbsPath d = do
	d' <- expandTilde d
	h <- myHomeDir
	return $ h </> d'

expandTilde :: FilePath -> IO FilePath
#ifdef mingw32_HOST_OS
expandTilde = return
#else
expandTilde = expandt True
  where
	expandt _ [] = return ""
	expandt _ ('/':cs) = do
		v <- expandt True cs
		return ('/':v)
	expandt True ('~':'/':cs) = do
		h <- myHomeDir
		return $ h </> cs
	expandt True ('~':cs) = do
		let (name, rest) = findname "" cs
		u <- getUserEntryForName name
		return $ homeDirectory u </> rest
	expandt _ (c:cs) = do
		v <- expandt False cs
		return (c:v)
	findname n [] = (n, "")
	findname n (c:cs)
		| c == '/' = (n, cs)
		| otherwise = findname (n++[c]) cs
#endif

{- Checks if a git repository exists in a directory. Does not find
 - git repositories in parent directories. -}
checkForRepo :: FilePath -> IO (Maybe RepoLocation)
checkForRepo dir =
	check isRepo $
		check gitDirFile $
			check isBareRepo $
				return Nothing
  where
	check test cont = maybe cont (return . Just) =<< test
	checkdir c = ifM c
		( return $ Just $ LocalUnknown dir
		, return Nothing
		)
	isRepo = checkdir $ gitSignature $ ".git" </> "config"
	isBareRepo = checkdir $ gitSignature "config"
		<&&> doesDirectoryExist (dir </> "objects")
	gitDirFile = do
		c <- firstLine <$>
			catchDefaultIO "" (readFile $ dir </> ".git")
		return $ if gitdirprefix `isPrefixOf` c
			then Just $ Local
				{ gitdir = absPathFrom dir $
					drop (length gitdirprefix) c
				, worktree = Just dir
				}
			else Nothing
	  where
		gitdirprefix = "gitdir: "
	gitSignature file = doesFileExist $ dir </> file

newFrom :: RepoLocation -> IO Repo
newFrom l = return Repo
	{ location = l
	, config = M.empty
	, fullconfig = M.empty
	, remotes = []
	, remoteName = Nothing
	, gitEnv = Nothing
	, gitGlobalOpts = []
	}


code:
{- The current git repository.
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Git.CurrentRepo where

import Common
import Git.Types
import Git.Construct
import qualified Git.Config
#ifndef mingw32_HOST_OS
import Utility.Env
#endif

{- Gets the current git repository.
 -
 - Honors GIT_DIR and GIT_WORK_TREE.
 - Both environment variables are unset, to avoid confusing other git
 - commands that also look at them. Instead, the Git module passes
 - --work-tree and --git-dir to git commands it runs.
 -
 - When GIT_WORK_TREE or core.worktree are set, changes the working
 - directory if necessary to ensure it is within the repository's work
 - tree. While not needed for git commands, this is useful for anything
 - else that looks for files in the worktree.
 -}
get :: IO Repo
get = do
	gd <- pathenv "GIT_DIR"
	r <- configure gd =<< fromCwd
	wt <- maybe (worktree $ location r) Just <$> pathenv "GIT_WORK_TREE"
	case wt of
		Nothing -> return r
		Just d -> do
			curr <- getCurrentDirectory
			unless (d `dirContains` curr) $
				setCurrentDirectory d
			return $ addworktree wt r
  where
#ifndef mingw32_HOST_OS
	pathenv s = do
		v <- getEnv s
		case v of
			Just d -> do
				void $ unsetEnv s
				Just <$> absPath d
			Nothing -> return Nothing
#else
	pathenv _ = return Nothing
#endif

	configure Nothing (Just r) = Git.Config.read r
	configure (Just d) _ = do
		absd <- absPath d
		curr <- getCurrentDirectory
		r <- newFrom $ Local { gitdir = absd, worktree = Just curr }
		Git.Config.read r
	configure Nothing Nothing = error "Not in a git repository."

	addworktree w r = changelocation r $
		Local { gitdir = gitdir (location r), worktree = w }
	changelocation r l = r { location = l }


code:
{- git diff-tree interface
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.DiffTree (
	DiffTreeItem(..),
	diffTree,
	diffTreeRecursive,
	diffIndex,
	diffWorkTree,
) where

import Numeric
import System.Posix.Types

import Common
import Git
import Git.Sha
import Git.Command
import Git.FilePath
import qualified Git.Filename
import qualified Git.Ref

data DiffTreeItem = DiffTreeItem
	{ srcmode :: FileMode
	, dstmode :: FileMode
	, srcsha :: Sha -- nullSha if file was added
	, dstsha :: Sha -- nullSha if file was deleted
	, status :: String
	, file :: TopFilePath
	} deriving Show

{- Diffs two tree Refs. -}
diffTree :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool)
diffTree src dst = getdiff (Param "diff-tree")
	[Param (fromRef src), Param (fromRef dst)]

{- Diffs two tree Refs, recursing into sub-trees -}
diffTreeRecursive :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool)
diffTreeRecursive src dst = getdiff (Param "diff-tree")
	[Param "-r", Param (fromRef src), Param (fromRef dst)]

{- Diffs between a tree and the index. Does nothing if there is not yet a
 - commit in the repository. -}
diffIndex :: Ref -> Repo -> IO ([DiffTreeItem], IO Bool)
diffIndex ref = diffIndex' ref [Param "--cached"]

{- Diffs between a tree and the working tree. Does nothing if there is not
 - yet a commit in the repository, or if the repository is bare. -}
diffWorkTree :: Ref -> Repo -> IO ([DiffTreeItem], IO Bool)
diffWorkTree ref repo =
	ifM (Git.Ref.headExists repo)
                ( diffIndex' ref [] repo
		, return ([], return True)
		)

diffIndex' :: Ref -> [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool)
diffIndex' ref params repo =
	ifM (Git.Ref.headExists repo)
		( getdiff (Param "diff-index")
			( params ++ [Param $ fromRef ref] )
			repo
		, return ([], return True)
		)

getdiff :: CommandParam -> [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool)
getdiff command params repo = do
	(diff, cleanup) <- pipeNullSplit ps repo
	return (parseDiffTree diff, cleanup)
  where
	ps = command : Params "-z --raw --no-renames -l0" : params

{- Parses diff-tree output. -}
parseDiffTree :: [String] -> [DiffTreeItem]
parseDiffTree l = go l []
  where
	go [] c = c
	go (info:f:rest) c = go rest (mk info f : c)
	go (s:[]) _ = error $ "diff-tree parse error " ++ s

	mk info f = DiffTreeItem
		{ srcmode = readmode srcm
		, dstmode = readmode dstm
		, srcsha = fromMaybe (error "bad srcsha") $ extractSha ssha
		, dstsha = fromMaybe (error "bad dstsha") $ extractSha dsha
		, status = s
		, file = asTopFilePath $ fromInternalGitPath $ Git.Filename.decode f
		}
	  where
		readmode = fst . Prelude.head . readOct

		-- info = :<srcmode> SP <dstmode> SP <srcsha> SP <dstsha> SP <status>
		-- All fields are fixed, so we can pull them out of
		-- specific positions in the line.
		(srcm, past_srcm) = splitAt 7 $ drop 1 info
		(dstm, past_dstm) = splitAt 7 past_srcm
		(ssha, past_ssha) = splitAt shaSize past_dstm
		(dsha, past_dsha) = splitAt shaSize $ drop 1 past_ssha
		s = drop 1 past_dsha


code:
{- git file modes
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Git.FileMode where

import Utility.FileMode

import System.PosixCompat.Types

symLinkMode :: FileMode
symLinkMode = 40960

{- Git uses a special file mode to indicate a symlink. This is the case
 - even on Windows, so we hard code the valuse here, rather than using
 - System.Posix.Files.symbolicLinkMode. -}
isSymLink :: FileMode -> Bool
isSymLink = checkMode symLinkMode


code:
{- 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-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Git.FilePath (
	TopFilePath,
	fromTopFilePath,
	getTopFilePath,
	toTopFilePath,
	asTopFilePath,
	InternalGitPath,
	toInternalGitPath,
	fromInternalGitPath,
	absoluteGitPath
) where

import Common
import Git

import qualified System.FilePath.Posix

{- A FilePath, relative to the top of the git repository. -}
newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }
	deriving (Show)

{- Returns an absolute FilePath. -}
fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath
fromTopFilePath p repo = absPathFrom (repoPath repo) (getTopFilePath p)

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

{- Git may use a different representation of a path when storing
 - it internally.
 -
 - On Windows, git uses '/' to separate paths stored in the repository,
 - despite Windows using '\'.
 -
 -}
type InternalGitPath = String

toInternalGitPath :: FilePath -> InternalGitPath
#ifndef mingw32_HOST_OS
toInternalGitPath = id
#else
toInternalGitPath = replace "\\" "/"
#endif

fromInternalGitPath :: InternalGitPath -> FilePath
#ifndef mingw32_HOST_OS
fromInternalGitPath = id
#else
fromInternalGitPath = replace "/" "\\"
#endif

{- isAbsolute on Windows does not think "/foo" or "\foo" is absolute,
 - so try posix paths.
 -}
absoluteGitPath :: FilePath -> Bool
absoluteGitPath p = isAbsolute p ||
	System.FilePath.Posix.isAbsolute (toInternalGitPath p)


code:
{- Some git commands output encoded filenames, in a rather annoyingly complex
 - C-style encoding.
 -
 - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.Filename where

import Utility.Format (decode_c, encode_c)

import Common

decode :: String -> FilePath
decode [] = []
decode f@(c:s)
	-- encoded strings will be inside double quotes
	| c == '"' && end s == ['"'] = decode_c $ beginning s
	| otherwise = f

{- Should not need to use this, except for testing decode. -}
encode :: FilePath -> String
encode s = "\"" ++ encode_c s ++ "\""

{- for quickcheck -}
prop_idempotent_deencode :: String -> Bool
prop_idempotent_deencode s = s == decode (encode s)


code:
{- git fsck interface
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.Fsck (
	FsckResults(..),
	MissingObjects,
	findBroken,
	foundBroken,
	findMissing,
	isMissing,
	knownMissing,
) where

import Common
import Git
import Git.Command
import Git.Sha
import Utility.Batch
import qualified Git.Version

import qualified Data.Set as S
import Control.Concurrent.Async

type MissingObjects = S.Set Sha

data FsckResults
	= FsckFoundMissing
		{ missingObjects :: MissingObjects
		, missingObjectsTruncated :: Bool
		}
	| FsckFailed
	deriving (Show)

{- Runs fsck to find some of the broken objects in the repository.
 - May not find all broken objects, if fsck fails on bad data in some of
 - the broken objects it does find.
 -
 - Strategy: Rather than parsing fsck's current specific output,
 - look for anything in its output (both stdout and stderr) that appears
 - to be a git sha. Not all such shas are of broken objects, so ask git
 - to try to cat the object, and see if it fails.
 -}
findBroken :: Bool -> Repo -> IO FsckResults
findBroken batchmode r = do
	supportsNoDangling <- (>= Git.Version.normalize "1.7.10")
		<$> Git.Version.installed
	let (command, params) = ("git", fsckParams supportsNoDangling r)
	(command', params') <- if batchmode
		then toBatchCommand (command, params)
		else return (command, params)

	p@(_, _, _, pid) <- createProcess $
		(proc command' (toCommand params'))
			{ std_out = CreatePipe
			, std_err = CreatePipe
			}
	(bad1, bad2) <- concurrently
		(readMissingObjs maxobjs r supportsNoDangling (stdoutHandle p))
		(readMissingObjs maxobjs r supportsNoDangling (stderrHandle p))
	fsckok <- checkSuccessProcess pid
	let truncated = S.size bad1 == maxobjs || S.size bad1 == maxobjs
	let badobjs = S.union bad1 bad2

	if S.null badobjs && not fsckok
		then return FsckFailed
		else return $ FsckFoundMissing badobjs truncated
  where
	maxobjs = 10000

foundBroken :: FsckResults -> Bool
foundBroken FsckFailed = True
foundBroken (FsckFoundMissing s _) = not (S.null s)

knownMissing :: FsckResults -> MissingObjects
knownMissing FsckFailed = S.empty
knownMissing (FsckFoundMissing s _) = s

{- Finds objects that are missing from the git repsitory, or are corrupt.
 -
 - This does not use git cat-file --batch, because catting a corrupt
 - object can cause it to crash, or to report incorrect size information.
 -}
findMissing :: [Sha] -> Repo -> IO MissingObjects
findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs

readMissingObjs :: Int -> Repo -> Bool -> Handle -> IO MissingObjects
readMissingObjs maxobjs r supportsNoDangling h = do
	objs <- take maxobjs . findShas supportsNoDangling <$> hGetContents h
	findMissing objs r

isMissing :: Sha -> Repo -> IO Bool
isMissing s r = either (const True) (const False) <$> tryIO dump
  where
	dump = runQuiet
		[ Param "show"
		, Param (fromRef s)
		] r

findShas :: Bool -> String -> [Sha]
findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted . lines
  where
	wanted l
		| supportsNoDangling = True
		| otherwise = not ("dangling " `isPrefixOf` l)

fsckParams :: Bool -> Repo -> [CommandParam]
fsckParams supportsNoDangling = gitCommandLine $ map Param $ catMaybes
	[ Just "fsck"
	, if supportsNoDangling
		then Just "--no-dangling"
		else Nothing
	, Just "--no-reflogs"
	]


code:
{- git-remote-gcrypt support
 -
 - https://github.com/blake2-ppc/git-remote-gcrypt
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.GCrypt where

import Common
import Git.Types
import Git.Construct
import qualified Git.Config as Config
import qualified Git.Command as Command
import Utility.Gpg

urlScheme :: String
urlScheme = "gcrypt:"

urlPrefix :: String
urlPrefix = urlScheme ++ ":"

isEncrypted :: Repo -> Bool
isEncrypted Repo { location = Url url } = urlPrefix `isPrefixOf` show url
isEncrypted _ = False

{- The first Repo is the git repository that has the second Repo
 - as one of its remotes.
 -
 - When the remote Repo uses gcrypt, returns the actual underlying
 - git repository that gcrypt is using to store its data.
 -
 - Throws an exception if an url is invalid or the repo does not use
 - gcrypt.
 -}
encryptedRemote :: Repo -> Repo -> IO Repo
encryptedRemote baserepo = go
  where
  	go Repo { location = Url url }
		| urlPrefix `isPrefixOf` u =
			fromRemoteLocation (drop plen u) baserepo
		| otherwise = notencrypted
	  where
  		u = show url
		plen = length urlPrefix
	go _ = notencrypted
	notencrypted = error "not a gcrypt encrypted repository"

data ProbeResult = Decryptable | NotDecryptable | NotEncrypted

{- Checks if the git repo at a location uses gcrypt.
 -
 - Rather expensive -- many need to fetch the entire repo contents.
 - (Which is fine if the repo is going to be added as a remote..)
 -}
probeRepo :: String -> Repo -> IO ProbeResult
probeRepo loc baserepo = do
	let p = proc "git" $ toCommand $ Command.gitCommandLine
		[ Param "remote-gcrypt"
		, Param "--check"
		, Param loc
		] baserepo
	(_, _, _, pid) <- createProcess p
	code <- waitForProcess pid
	return $ case code of
		ExitSuccess -> Decryptable
		ExitFailure 1 -> NotDecryptable
		ExitFailure _ -> NotEncrypted

type GCryptId = String

{- gcrypt gives each encrypted repository a uique gcrypt-id,
 - which is stored in the repository (in encrypted form)
 - and cached in a per-remote gcrypt-id configuration setting. -}
remoteRepoId :: Repo -> Maybe RemoteName -> Maybe GCryptId
remoteRepoId = getRemoteConfig "gcrypt-id"

getRemoteConfig :: String -> Repo -> Maybe RemoteName -> Maybe String
getRemoteConfig field repo remotename = do
	n <- remotename
	Config.getMaybe (remoteConfigKey field n) repo

{- Gpg keys that the remote is encrypted for.
 - If empty, gcrypt uses --default-recipient-self -}
getParticiantList :: Maybe Repo -> Repo -> Maybe RemoteName -> KeyIds
getParticiantList globalconfigrepo repo remotename = KeyIds $ parse $ firstJust
	[ getRemoteConfig "gcrypt-participants" repo remotename
	, Config.getMaybe defaultkey repo
	, Config.getMaybe defaultkey =<< globalconfigrepo
	]
  where
	defaultkey = "gcrypt.participants"
  	parse (Just "simple") = []
	parse (Just l) = words l
	parse Nothing = []

remoteParticipantConfigKey :: RemoteName -> String
remoteParticipantConfigKey = remoteConfigKey "gcrypt-participants"

remotePublishParticipantConfigKey :: RemoteName -> String
remotePublishParticipantConfigKey = remoteConfigKey "gcrypt-publish-participants"

remoteSigningKey :: RemoteName -> String
remoteSigningKey = remoteConfigKey "gcrypt-signingkey"

remoteConfigKey :: String -> RemoteName -> String
remoteConfigKey key remotename = "remote." ++ remotename ++ "." ++ key


code:
{- git hash-object interface
 -
 - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.HashObject where

import Common
import Git
import Git.Sha
import Git.Command
import Git.Types
import qualified Utility.CoProcess as CoProcess
import Utility.Tmp

type HashObjectHandle = CoProcess.CoProcessHandle

hashObjectStart :: Repo -> IO HashObjectHandle
hashObjectStart = CoProcess.rawMode <=< gitCoProcessStart True
	[ Param "hash-object"
	, Param "-w"
	, Param "--stdin-paths"
	, Param "--no-filters"
	]

hashObjectStop :: HashObjectHandle -> IO ()
hashObjectStop = CoProcess.stop

{- Injects a file into git, returning the Sha of the object. -}
hashFile :: HashObjectHandle -> FilePath -> IO Sha
hashFile h file = CoProcess.query h send receive
  where
	send to = hPutStrLn to file
	receive from = getSha "hash-object" $ hGetLine from

{- Injects a blob into git. Unfortunately, the current git-hash-object
 - interface does not allow batch hashing without using temp files. -}
hashBlob :: HashObjectHandle -> String -> IO Sha
hashBlob h s = withTmpFile "hash" $ \tmp tmph -> do
	hPutStr tmph s
	hClose tmph
	hashFile h tmp

{- Injects some content into git, returning its Sha.
 -
 - Avoids using a tmp file, but runs a new hash-object command each
 - time called. -}
hashObject :: ObjectType -> String -> Repo -> IO Sha
hashObject objtype content = hashObject' objtype (flip hPutStr content)

hashObject' :: ObjectType -> (Handle -> IO ()) -> Repo -> IO Sha
hashObject' objtype writer repo = getSha subcmd $
	pipeWriteRead (map Param params) (Just writer) repo
  where
	subcmd = "hash-object"
	params = [subcmd, "-t", show objtype, "-w", "--stdin", "--no-filters"]


code:
{- git hooks
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.Hook where

import Common
import Git
import Utility.Tmp

data Hook = Hook
	{ hookName :: FilePath
	, hookScript :: String
	}
	deriving (Ord)

instance Eq Hook where
	a == b = hookName a == hookName b

hookFile :: Hook -> Repo -> FilePath
hookFile h r = localGitDir r </> "hooks" </> hookName h

{- Writes a hook. Returns False if the hook already exists with a different
 - content. -}
hookWrite :: Hook -> Repo -> IO Bool
hookWrite h r = do
	let f = hookFile h r
	ifM (doesFileExist f)
		( expectedContent h r
		, do
			viaTmp writeFile f (hookScript h)
			p <- getPermissions f
			setPermissions f $ p {executable = True}
			return True
		)

{- Removes a hook. Returns False if the hook contained something else, and
 - could not be removed. -}
hookUnWrite :: Hook -> Repo -> IO Bool
hookUnWrite h r = do
	let f = hookFile h r
	ifM (doesFileExist f)
		( ifM (expectedContent h r)
			( do
				removeFile f
				return True
			, return False
			)
		, return True
		)

expectedContent :: Hook -> Repo -> IO Bool
expectedContent h r = do
	content <- readFile $ hookFile h r
	return $ content == hookScript h


code:
{- git index file stuff
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.Index where

import Common
import Git
import Utility.Env

{- Forces git to use the specified index file.
 -
 - Returns an action that will reset back to the default
 - index file.
 -
 - Warning: Not thread safe.
 -}
override :: FilePath -> IO (IO ())
override index = do
	res <- getEnv var
	void $ setEnv var index True
	return $ void $ reset res
  where
	var = "GIT_INDEX_FILE"
	reset (Just v) = setEnv var v True
	reset _ = unsetEnv var

indexFile :: Repo -> FilePath
indexFile r = localGitDir r </> "index"

{- Git locks the index by creating this file. -}
indexFileLock :: Repo -> FilePath
indexFileLock r = indexFile r ++ ".lock"


code:
{- git ls-files interface
 -
 - Copyright 2010,2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.LsFiles (
	inRepo,
	notInRepo,
	allFiles,
	deleted,
	modified,
	modifiedOthers,
	staged,
	stagedNotDeleted,
	stagedOthersDetails,
	stagedDetails,
	typeChanged,
	typeChangedStaged,
	Conflicting(..),
	Unmerged(..),
	unmerged,
	StagedDetails,
) where

import Common
import Git
import Git.Command
import Git.Types
import Git.Sha

import Numeric
import System.Posix.Types

{- Scans for files that are checked into git at the specified locations. -}
inRepo :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
inRepo l = pipeNullSplit $ Params "ls-files --cached -z --" : map File l

{- Scans for files at the specified locations that are not checked into git. -}
notInRepo :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
notInRepo include_ignored l repo = pipeNullSplit params repo
  where
	params = [Params "ls-files --others"] ++ exclude ++
		[Params "-z --"] ++ map File l
	exclude
		| include_ignored = []
		| otherwise = [Param "--exclude-standard"]

{- Finds all files in the specified locations, whether checked into git or
 - not. -}
allFiles :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
allFiles l = pipeNullSplit $ Params "ls-files --cached --others -z --" : map File l

{- Returns a list of files in the specified locations that have been
 - deleted. -}
deleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
deleted l repo = pipeNullSplit params repo
  where
	params = [Params "ls-files --deleted -z --"] ++ map File l

{- Returns a list of files in the specified locations that have been
 - modified. -}
modified :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
modified l repo = pipeNullSplit params repo
  where
	params = [Params "ls-files --modified -z --"] ++ map File l

{- Files that have been modified or are not checked into git (and are not
 - ignored). -}
modifiedOthers :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
modifiedOthers l repo = pipeNullSplit params repo
  where
	params = [Params "ls-files --modified --others --exclude-standard -z --"] ++ map File l

{- Returns a list of all files that are staged for commit. -}
staged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
staged = staged' []

{- Returns a list of the files, staged for commit, that are being added,
 - moved, or changed (but not deleted), from the specified locations. -}
stagedNotDeleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"]

staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix
  where
	prefix = [Params "diff --cached --name-only -z"]
	suffix = Param "--" : map File l

type StagedDetails = (FilePath, Maybe Sha, Maybe FileMode)

{- Returns details about files that are staged in the index,
 - as well as files not yet in git. Skips ignored files. -}
stagedOthersDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)
stagedOthersDetails = stagedDetails' [Params "--others --exclude-standard"]

{- Returns details about all files that are staged in the index. -}
stagedDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)
stagedDetails = stagedDetails' []

{- Gets details about staged files, including the Sha of their staged
 - contents. -}
stagedDetails' :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)
stagedDetails' ps l repo = do
	(ls, cleanup) <- pipeNullSplit params repo
	return (map parse ls, cleanup)
  where
	params = Params "ls-files --stage -z" : ps ++
		Param "--" : map File l
	parse s
		| null file = (s, Nothing, Nothing)
		| otherwise = (file, extractSha $ take shaSize rest, readmode mode)
	  where
		(metadata, file) = separate (== '\t') s
		(mode, rest) = separate (== ' ') metadata
		readmode = fst <$$> headMaybe . readOct

{- Returns a list of the files in the specified locations that are staged
 - for commit, and whose type has changed. -}
typeChangedStaged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
typeChangedStaged = typeChanged' [Param "--cached"]

{- Returns a list of the files in the specified locations whose type has
 - changed.  Files only staged for commit will not be included. -}
typeChanged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
typeChanged = typeChanged' []

typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
typeChanged' ps l repo = do
	(fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo
	-- git diff returns filenames relative to the top of the git repo;
	-- convert to filenames relative to the cwd, like git ls-files.
	let top = repoPath repo
	currdir <- getCurrentDirectory
	return (map (\f -> relPathDirToFile currdir $ top </> f) fs, cleanup)
  where
	prefix = [Params "diff --name-only --diff-filter=T -z"]
	suffix = Param "--" : (if null l then [File "."] else map File l)

{- A item in conflict has two possible values.
 - Either can be Nothing, when that side deleted the file. -}
data Conflicting v = Conflicting
	{ valUs :: Maybe v
	, valThem :: Maybe v
	} deriving (Show)

data Unmerged = Unmerged
	{ unmergedFile :: FilePath
	, unmergedBlobType :: Conflicting BlobType
	, unmergedSha :: Conflicting Sha
	} deriving (Show)

{- Returns a list of the files in the specified locations that have
 - unresolved merge conflicts.
 -
 - ls-files outputs multiple lines per conflicting file, each with its own
 - stage number:
 -   1 = old version, can be ignored
 -   2 = us
 -   3 = them
 - If a line is omitted, that side removed the file.
 -}
unmerged :: [FilePath] -> Repo -> IO ([Unmerged], IO Bool)
unmerged l repo = do
	(fs, cleanup) <- pipeNullSplit params repo
	return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup)
  where
	params = Params "ls-files --unmerged -z --" : map File l

data InternalUnmerged = InternalUnmerged
	{ isus :: Bool
	, ifile :: FilePath
	, iblobtype :: Maybe BlobType
	, isha :: Maybe Sha
	} deriving (Show)

parseUnmerged :: String -> Maybe InternalUnmerged
parseUnmerged s
	| null file = Nothing
	| otherwise = case words metadata of
		(rawblobtype:rawsha:rawstage:_) -> do
			stage <- readish rawstage :: Maybe Int
			unless (stage == 2 || stage == 3) $
				fail undefined -- skip stage 1
			blobtype <- readBlobType rawblobtype
			sha <- extractSha rawsha
			return $ InternalUnmerged (stage == 2) file
				(Just blobtype) (Just sha)
		_ -> Nothing
  where
	(metadata, file) = separate (== '\t') s

reduceUnmerged :: [Unmerged] -> [InternalUnmerged] -> [Unmerged]
reduceUnmerged c [] = c
reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest
  where
	(rest, sibi) = findsib i is
	(blobtypeA, blobtypeB, shaA, shaB)
		| isus i    = (iblobtype i, iblobtype sibi, isha i, isha sibi)
		| otherwise = (iblobtype sibi, iblobtype i, isha sibi, isha i)
	new = Unmerged
		{ unmergedFile = ifile i
		, unmergedBlobType = Conflicting blobtypeA blobtypeB
		, unmergedSha = Conflicting shaA shaB
		}
	findsib templatei [] = ([], removed templatei)
	findsib templatei (l:ls)
		| ifile l == ifile templatei = (ls, l)
		| otherwise = (l:ls, removed templatei)
	removed templatei = templatei
		{ isus = not (isus templatei)
		, iblobtype = Nothing
		, isha = Nothing
		}


code:
{- git ls-tree interface
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.LsTree (
	TreeItem(..),
	lsTree,
	lsTreeParams,
	lsTreeFiles,
	parseLsTree
) where

import Numeric
import Control.Applicative
import System.Posix.Types

import Common
import Git
import Git.Command
import Git.Sha
import Git.FilePath
import qualified Git.Filename

data TreeItem = TreeItem
	{ mode :: FileMode
	, typeobj :: String
	, sha :: String
	, file :: TopFilePath
	} deriving Show

{- Lists the complete contents of a tree, recursing into sub-trees,
 - with lazy output. -}
lsTree :: Ref -> Repo -> IO [TreeItem]
lsTree t repo = map parseLsTree
	<$> pipeNullSplitZombie (lsTreeParams t) repo

lsTreeParams :: Ref -> [CommandParam]
lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ fromRef t ]

{- Lists specified files in a tree. -}
lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem]
lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo
  where
  	ps = [Params "ls-tree --full-tree -z --", File $ fromRef t] ++ map File fs

{- Parses a line of ls-tree output.
 - (The --long format is not currently supported.) -}
parseLsTree :: String -> TreeItem
parseLsTree l = TreeItem
	{ mode = fst $ Prelude.head $ readOct m
	, typeobj = t
	, sha = s
	, file = asTopFilePath $ Git.Filename.decode f
	}
  where
	-- l = <mode> SP <type> SP <sha> TAB <file>
	-- All fields are fixed, so we can pull them out of
	-- specific positions in the line.
	(m, past_m) = splitAt 7 l
	(t, past_t) = splitAt 4 past_m
	(s, past_s) = splitAt shaSize $ Prelude.tail past_t
	f = Prelude.tail past_s


code:
{- git merging
 -
 - Copyright 2012, 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.Merge where

import Common
import Git
import Git.Command
import Git.BuildVersion
import Git.Branch (CommitMode(..))

{- Avoids recent git's interactive merge. -}
mergeNonInteractive :: Ref -> CommitMode -> Repo -> IO Bool
mergeNonInteractive branch commitmode
	| older "1.7.7.6" = merge [Param $ fromRef branch]
	| otherwise = merge $ [Param "--no-edit", Param $ fromRef branch]
  where
	merge ps = runBool $ cp ++ [Param "merge"] ++ ps
	cp
		| commitmode == AutomaticCommit =
			[Param "-c", Param "commit.gpgsign=false"]
		| otherwise = []

{- Stage the merge into the index, but do not commit it.-}
stageMerge :: Ref -> Repo -> IO Bool
stageMerge branch = runBool
	[ Param "merge"
	, Param "--quiet"
	, Param "--no-commit"
	-- Without this, a fast-forward merge is done, since it involves no
	-- commit.
	, Param "--no-ff"
	, Param $ fromRef branch
	]


code:
{- .git/objects
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.Objects where

import Common
import Git
import Git.Sha

objectsDir :: Repo -> FilePath
objectsDir r = localGitDir r </> "objects"

packDir :: Repo -> FilePath
packDir r = objectsDir r </> "pack"

packIdxFile :: FilePath -> FilePath
packIdxFile = flip replaceExtension "idx"

listPackFiles :: Repo -> IO [FilePath]
listPackFiles r = filter (".pack" `isSuffixOf`)
	<$> catchDefaultIO [] (dirContents $ packDir r)

listLooseObjectShas :: Repo -> IO [Sha]
listLooseObjectShas r = catchDefaultIO [] $
	mapMaybe (extractSha . concat . reverse . take 2 . reverse . splitDirectories)
		<$> dirContentsRecursiveSkipping (== "pack") True (objectsDir r)

looseObjectFile :: Repo -> Sha -> FilePath
looseObjectFile r sha = objectsDir r </> prefix </> rest
  where
	(prefix, rest) = splitAt 2 (fromRef sha)


code:
{- git repository command queue
 -
 - Copyright 2010,2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP, BangPatterns #-}

module Git.Queue (
	Queue,
	new,
	addCommand,
	addUpdateIndex,
	size,
	full,
	flush,
) where

import Utility.SafeCommand
import Common
import Git
import Git.Command
import qualified Git.UpdateIndex

import qualified Data.Map as M

{- Queable actions that can be performed in a git repository.
 -}
data Action
	{- Updating the index file, using a list of streamers that can
	 - be added to as the queue grows. -}
	= UpdateIndexAction
		{ getStreamers :: [Git.UpdateIndex.Streamer] -- in reverse order
		}
	{- A git command to run, on a list of files that can be added to
	 - as the queue grows. -}
	| CommandAction
		{ getSubcommand :: String
		, getParams :: [CommandParam]
		, getFiles :: [CommandParam]
		}

{- A key that can uniquely represent an action in a Map. -}
data ActionKey = UpdateIndexActionKey | CommandActionKey String
	deriving (Eq, Ord)

actionKey :: Action -> ActionKey
actionKey (UpdateIndexAction _) = UpdateIndexActionKey
actionKey CommandAction { getSubcommand = s } = CommandActionKey s

{- A queue of actions to perform (in any order) on a git repository,
 - with lists of files to perform them on. This allows coalescing
 - similar git commands. -}
data Queue = Queue
	{ size :: Int
	, _limit :: Int
	, items :: M.Map ActionKey Action
	}

{- A recommended maximum size for the queue, after which it should be
 - run.
 -
 - 10240 is semi-arbitrary. If we assume git filenames are between 10 and
 - 255 characters long, then the queue will build up between 100kb and
 - 2550kb long commands. The max command line length on linux is somewhere
 - above 20k, so this is a fairly good balance -- the queue will buffer
 - only a few megabytes of stuff and a minimal number of commands will be
 - run by xargs. -}
defaultLimit :: Int
defaultLimit = 10240

{- Constructor for empty queue. -}
new :: Maybe Int -> Queue
new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty

{- Adds an git command to the queue.
 -
 - Git commands with the same subcommand but different parameters are
 - assumed to be equivilant enough to perform in any order with the same
 - result.
 -}
addCommand :: String -> [CommandParam] -> [FilePath] -> Queue -> Repo -> IO Queue
addCommand subcommand params files q repo =
	updateQueue action different (length files) q repo
  where
	key = actionKey action
	action = CommandAction
		{ getSubcommand = subcommand
		, getParams = params
		, getFiles = allfiles
		}
	allfiles = map File files ++ maybe [] getFiles (M.lookup key $ items q)

	different (CommandAction { getSubcommand = s }) = s /= subcommand
	different _ = True

{- Adds an update-index streamer to the queue. -}
addUpdateIndex :: Git.UpdateIndex.Streamer -> Queue -> Repo -> IO Queue
addUpdateIndex streamer q repo =
	updateQueue action different 1 q repo
  where
	key = actionKey action
	-- the list is built in reverse order
	action = UpdateIndexAction $ streamer : streamers
	streamers = maybe [] getStreamers $ M.lookup key $ items q

	different (UpdateIndexAction _) = False
	different _ = True

{- Updates or adds an action in the queue. If the queue already contains a
 - different action, it will be flushed; this is to ensure that conflicting
 - actions, like add and rm, are run in the right order.-}
updateQueue :: Action -> (Action -> Bool) -> Int -> Queue -> Repo -> IO Queue
updateQueue !action different sizeincrease q repo
	| null (filter different (M.elems (items q))) = return $ go q
	| otherwise = go <$> flush q repo
  where
	go q' = newq
	  where
		!newq = q'
			{ size = newsize
			, items = newitems
			}
		!newsize = size q' + sizeincrease
		!newitems = M.insertWith' const (actionKey action) action (items q')

{- Is a queue large enough that it should be flushed? -}
full :: Queue -> Bool
full (Queue cur lim  _) = cur > lim

{- Runs a queue on a git repository. -}
flush :: Queue -> Repo -> IO Queue
flush (Queue _ lim m) repo = do
	forM_ (M.elems m) $ runAction repo
	return $ Queue 0 lim M.empty

{- Runs an Action on a list of files in a git repository.
 -
 - Complicated by commandline length limits.
 -
 - Intentionally runs the command even if the list of files is empty;
 - this allows queueing commands that do not need a list of files. -}
runAction :: Repo -> Action -> IO ()
runAction repo (UpdateIndexAction streamers) =
	-- list is stored in reverse order
	Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers
runAction repo action@(CommandAction {}) = do
#ifndef mingw32_HOST_OS
	let p = (proc "xargs" $ "-0":"git":toCommand gitparams) { env = gitEnv repo }
	withHandle StdinHandle createProcessSuccess p $ \h -> do
		fileEncoding h
		hPutStr h $ intercalate "\0" $ toCommand $ getFiles action
		hClose h
#else
	-- Using xargs on Windows is problimatic, so just run the command
	-- once per file (not as efficient.)
	if null (getFiles action)
		then void $ boolSystemEnv "git" gitparams (gitEnv repo)
		else forM_ (getFiles action) $ \f ->
			void $ boolSystemEnv "git" (gitparams ++ [f]) (gitEnv repo)
#endif
  where
	gitparams = gitCommandLine
		(Param (getSubcommand action):getParams action) repo


code:
{- git ref stuff
 -
 - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.Ref where

import Common
import Git
import Git.Command
import Git.Sha
import Git.Types

import Data.Char (chr)

headRef :: Ref
headRef = Ref "HEAD"

{- Converts a fully qualified git ref into a user-visible string. -}
describe :: Ref -> String
describe = fromRef . base

{- Often git refs are fully qualified (eg: refs/heads/master).
 - Converts such a fully qualified ref into a base ref (eg: master). -}
base :: Ref -> Ref
base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef
  where
	remove prefix s
		| prefix `isPrefixOf` s = drop (length prefix) s
		| otherwise = s

{- Given a directory and any ref, takes the basename of the ref and puts
 - it under the directory. -}
under :: String -> Ref -> Ref
under dir r = Ref $ dir ++ "/" ++
	(reverse $ takeWhile (/= '/') $ reverse $ fromRef r)

{- Given a directory such as "refs/remotes/origin", and a ref such as
 - refs/heads/master, yields a version of that ref under the directory,
 - such as refs/remotes/origin/master. -}
underBase :: String -> Ref -> Ref
underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r)

{- A Ref that can be used to refer to a file in the repository, as staged
 - in the index.
 -
 - Prefixing the file with ./ makes this work even if in a subdirectory
 - of a repo.
 -}
fileRef :: FilePath -> Ref
fileRef f = Ref $ ":./" ++ f

{- Converts a Ref to refer to the content of the Ref on a given date. -}
dateRef :: Ref -> RefDate -> Ref
dateRef (Ref r) (RefDate d) = Ref $ r ++ "@" ++ d

{- A Ref that can be used to refer to a file in the repository as it
 - appears in a given Ref. -}
fileFromRef :: Ref -> FilePath -> Ref
fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)

{- Checks if a ref exists. -}
exists :: Ref -> Repo -> IO Bool
exists ref = runBool
	[Param "show-ref", Param "--verify", Param "-q", Param $ fromRef ref]

{- The file used to record a ref. (Git also stores some refs in a
 - packed-refs file.) -}
file :: Ref -> Repo -> FilePath
file ref repo = localGitDir repo </> fromRef ref

{- Checks if HEAD exists. It generally will, except for in a repository
 - that was just created. -}
headExists :: Repo -> IO Bool
headExists repo = do
	ls <- lines <$> pipeReadStrict [Param "show-ref", Param "--head"] repo
	return $ any (" HEAD" `isSuffixOf`) ls

{- Get the sha of a fully qualified git ref, if it exists. -}
sha :: Branch -> Repo -> IO (Maybe Sha)
sha branch repo = process <$> showref repo
  where
	showref = pipeReadStrict [Param "show-ref",
		Param "--hash", -- get the hash
		Param $ fromRef branch]
	process [] = Nothing
	process s = Just $ Ref $ firstLine s

{- List of (shas, branches) matching a given ref or refs. -}
matching :: [Ref] -> Repo -> IO [(Sha, Branch)]
matching refs repo =  matching' (map fromRef refs) repo

{- Includes HEAD in the output, if asked for it. -}
matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)]
matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo

{- List of (shas, branches) matching a given ref or refs. -}
matching' :: [String] -> Repo -> IO [(Sha, Branch)]
matching' ps repo = map gen . lines <$>
	pipeReadStrict (Param "show-ref" : map Param ps) repo
  where
	gen l = let (r, b) = separate (== ' ') l
		in (Ref r, Ref b)

{- List of (shas, branches) matching a given ref spec.
 - Duplicate shas are filtered out. -}
matchingUniq :: [Ref] -> Repo -> IO [(Sha, Branch)]
matchingUniq refs repo = nubBy uniqref <$> matching refs repo
  where
	uniqref (a, _) (b, _) = a == b

{- Gets the sha of the tree a ref uses. -}
tree :: Ref -> Repo -> IO (Maybe Sha)
tree ref = extractSha <$$> pipeReadStrict
	[ Param "rev-parse", Param (fromRef ref ++ ":") ]

{- Checks if a String is a legal git ref name.
 -
 - The rules for this are complex; see git-check-ref-format(1) -}
legal :: Bool -> String -> Bool
legal allowonelevel s = all (== False) illegal
  where
	illegal =
		[ any ("." `isPrefixOf`) pathbits
		, any (".lock" `isSuffixOf`) pathbits
		, not allowonelevel && length pathbits < 2
		, contains ".."
		, any (\c -> contains [c]) illegalchars
		, begins "/"
		, ends "/"
		, contains "//"
		, ends "."
		, contains "@{"
		, null s
		]
	contains v = v `isInfixOf` s
	ends v = v `isSuffixOf` s
	begins v = v `isPrefixOf` s

	pathbits = split "/" s
	illegalchars = " ~^:?*[\\" ++ controlchars
	controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)]


code:
{- git reflog interface
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.RefLog where

import Common
import Git
import Git.Command
import Git.Sha

{- Gets the reflog for a given branch. -}
get :: Branch -> Repo -> IO [Sha]
get b = mapMaybe extractSha . lines <$$> pipeReadStrict
	[ Param "log"
	, Param "-g"
	, Param "--format=%H"
	, Param (fromRef b)
	]


code:
{- git remote stuff
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Git.Remote where

import Common
import Git
import Git.Types
import qualified Git.Command
import qualified Git.BuildVersion

import Data.Char
import qualified Data.Map as M
import Network.URI
#ifdef mingw32_HOST_OS
import Git.FilePath
#endif

{- Construct a legal git remote name out of an arbitrary input string.
 -
 - There seems to be no formal definition of this in the git source,
 - just some ad-hoc checks, and some other things that fail with certian
 - types of names (like ones starting with '-').
 -}
makeLegalName :: String -> RemoteName
makeLegalName s = case filter legal $ replace "/" "_" s of
	-- it can't be empty
	[] -> "unnamed"
	-- it can't start with / or - or .
	'.':s' -> makeLegalName s'
	'/':s' -> makeLegalName s'
	'-':s' -> makeLegalName s'
	s' -> s'
  where
	{- Only alphanumerics, and a few common bits of punctuation common
	 - in hostnames. -}
	legal '_' = True
	legal '.' = True
	legal c = isAlphaNum c

remove :: RemoteName -> Repo -> IO ()
remove remotename = Git.Command.run
	[ Param "remote"
	-- name of this subcommand changed
	, Param $
		if Git.BuildVersion.older "1.8.0"
			then "rm"
			else "remove"
	, Param remotename
	]

data RemoteLocation = RemoteUrl String | RemotePath FilePath

remoteLocationIsUrl :: RemoteLocation -> Bool
remoteLocationIsUrl (RemoteUrl _) = True
remoteLocationIsUrl _ = False

remoteLocationIsSshUrl :: RemoteLocation -> Bool
remoteLocationIsSshUrl (RemoteUrl u) = "ssh://" `isPrefixOf` u
remoteLocationIsSshUrl _ = False

{- Determines if a given remote location is an url, or a local
 - path. Takes the repository's insteadOf configuration into account. -}
parseRemoteLocation :: String -> Repo -> RemoteLocation
parseRemoteLocation s repo = ret $ calcloc s
  where
  	ret v
#ifdef mingw32_HOST_OS
		| dosstyle v = RemotePath (dospath v)
#endif
		| scpstyle v = RemoteUrl (scptourl v)
		| urlstyle v = RemoteUrl v
		| otherwise = RemotePath v
	-- insteadof config can rewrite remote location
	calcloc l
		| null insteadofs = l
		| otherwise = replacement ++ drop (length bestvalue) l
	  where
		replacement = drop (length prefix) $
			take (length bestkey - length suffix) bestkey
		(bestkey, bestvalue) = maximumBy longestvalue insteadofs
		longestvalue (_, a) (_, b) = compare b a
		insteadofs = filterconfig $ \(k, v) ->
			startswith prefix k &&
			endswith suffix k &&
			startswith v l
		filterconfig f = filter f $
			concatMap splitconfigs $ M.toList $ fullconfig repo
		splitconfigs (k, vs) = map (\v -> (k, v)) vs
		(prefix, suffix) = ("url." , ".insteadof")
	urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v
	-- git remotes can be written scp style -- [user@]host:dir
	-- but foo::bar is a git-remote-helper location instead
	scpstyle v = ":" `isInfixOf` v
		&& not ("//" `isInfixOf` v)
		&& not ("::" `isInfixOf` v)
	scptourl v = "ssh://" ++ host ++ slash dir
	  where
		(host, dir) = separate (== ':') v
		slash d	| d == "" = "/~/" ++ d
			| "/" `isPrefixOf` d = d
			| "~" `isPrefixOf` d = '/':d
			| otherwise = "/~/" ++ d
#ifdef mingw32_HOST_OS
	-- git on Windows will write a path to .git/config with "drive:",
	-- which is not to be confused with a "host:"
	dosstyle = hasDrive
	dospath = fromInternalGitPath
#endif


code:
{- git repository recovery
 -
 - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.Repair (
	runRepair,
	runRepairOf,
	removeBadBranches,
	successfulRepair,
	cleanCorruptObjects,
	retrieveMissingObjects,
	resetLocalBranches,
	checkIndex,
	checkIndexFast,
	missingIndex,
	emptyGoodCommits,
	isTrackingBranch,
) where

import Common
import Git
import Git.Command
import Git.Objects
import Git.Sha
import Git.Types
import Git.Fsck
import Git.Index
import qualified Git.Config as Config
import qualified Git.Construct as Construct
import qualified Git.LsTree as LsTree
import qualified Git.LsFiles as LsFiles
import qualified Git.Ref as Ref
import qualified Git.RefLog as RefLog
import qualified Git.UpdateIndex as UpdateIndex
import qualified Git.Branch as Branch
import Utility.Tmp
import Utility.Rsync
import Utility.FileMode

import qualified Data.Set as S
import qualified Data.ByteString.Lazy as L
import Data.Tuple.Utils

{- Given a set of bad objects found by git fsck, which may not
 - be complete, finds and removes all corrupt objects. -}
cleanCorruptObjects :: FsckResults -> Repo -> IO ()
cleanCorruptObjects fsckresults r = do
	void $ explodePacks r
	mapM_ removeLoose (S.toList $ knownMissing fsckresults)
	mapM_ removeBad =<< listLooseObjectShas r
  where
	removeLoose s = nukeFile (looseObjectFile r s)
	removeBad s = do
		void $ tryIO $ allowRead $  looseObjectFile r s
		whenM (isMissing s r) $
			removeLoose s

{- Explodes all pack files, and deletes them.
 -
 - First moves all pack files to a temp dir, before unpacking them each in
 - turn.
 -
 - This is because unpack-objects will not unpack a pack file if it's in the
 - git repo.
 -
 - Also, this prevents unpack-objects from possibly looking at corrupt
 - pack files to see if they contain an object, while unpacking a
 - non-corrupt pack file.
 -}
explodePacks :: Repo -> IO Bool
explodePacks r = go =<< listPackFiles r
  where
	go [] = return False
	go packs = withTmpDir "packs" $ \tmpdir -> do
		putStrLn "Unpacking all pack files."
		forM_ packs $ \packfile -> do
			moveFile packfile (tmpdir </> takeFileName packfile)
			nukeFile $ packIdxFile packfile
		forM_ packs $ \packfile -> do
			let tmp = tmpdir </> takeFileName packfile
			allowRead tmp
			-- May fail, if pack file is corrupt.
			void $ tryIO $
				pipeWrite [Param "unpack-objects", Param "-r"] r $ \h ->
				L.hPut h =<< L.readFile tmp
		return True

{- Try to retrieve a set of missing objects, from the remotes of a
 - repository. Returns any that could not be retreived.
 -
 - If another clone of the repository exists locally, which might not be a
 - remote of the repo being repaired, its path can be passed as a reference
 - repository.
 -}
retrieveMissingObjects :: FsckResults -> Maybe FilePath -> Repo -> IO FsckResults
retrieveMissingObjects missing referencerepo r
	| not (foundBroken missing) = return missing
	| otherwise = withTmpDir "tmprepo" $ \tmpdir -> do
		unlessM (boolSystem "git" [Params "init", File tmpdir]) $
			error $ "failed to create temp repository in " ++ tmpdir
		tmpr <- Config.read =<< Construct.fromAbsPath tmpdir
		stillmissing <- pullremotes tmpr (remotes r) fetchrefstags missing
		if S.null (knownMissing stillmissing)
			then return stillmissing
			else pullremotes tmpr (remotes r) fetchallrefs stillmissing
  where
	pullremotes tmpr [] fetchrefs stillmissing = case referencerepo of
		Nothing -> return stillmissing
		Just p -> ifM (fetchfrom p fetchrefs tmpr)
			( do
				void $ explodePacks tmpr
				void $ copyObjects tmpr r
				case stillmissing of
					FsckFailed -> return $ FsckFailed
					FsckFoundMissing s t -> FsckFoundMissing
						<$> findMissing (S.toList s) r
						<*> pure t
			, return stillmissing
			)
	pullremotes tmpr (rmt:rmts) fetchrefs ms
		| not (foundBroken ms) = return ms
		| otherwise = do
			putStrLn $ "Trying to recover missing objects from remote " ++ repoDescribe rmt ++ "."
			ifM (fetchfrom (repoLocation rmt) fetchrefs tmpr)
				( do
					void $ explodePacks tmpr
					void $ copyObjects tmpr r
					case ms of
						FsckFailed -> pullremotes tmpr rmts fetchrefs ms
						FsckFoundMissing s t -> do
							stillmissing <- findMissing (S.toList s) r
							pullremotes tmpr rmts fetchrefs (FsckFoundMissing stillmissing t)
				, pullremotes tmpr rmts fetchrefs ms
				)
	fetchfrom fetchurl ps = runBool $
		[ Param "fetch"
		, Param fetchurl
		, Params "--force --update-head-ok --quiet"
		] ++ ps
	-- fetch refs and tags
	fetchrefstags = [ Param "+refs/heads/*:refs/heads/*", Param "--tags"]
	-- Fetch all available refs (more likely to fail,
	-- as the remote may have refs it refuses to send).
	fetchallrefs = [ Param "+*:*" ]

{- Copies all objects from the src repository to the dest repository.
 - This is done using rsync, so it copies all missing objects, and all
 - objects they rely on. -}
copyObjects :: Repo -> Repo -> IO Bool
copyObjects srcr destr = rsync
	[ Param "-qr"
	, File $ addTrailingPathSeparator $ objectsDir srcr
	, File $ addTrailingPathSeparator $ objectsDir destr
	]

{- To deal with missing objects that cannot be recovered, resets any
 - local branches to point to an old commit before the missing
 - objects. Returns all branches that were changed, and deleted.
 -}
resetLocalBranches :: MissingObjects -> GoodCommits -> Repo -> IO ([Branch], [Branch], GoodCommits)
resetLocalBranches missing goodcommits r =
	go [] [] goodcommits =<< filter islocalbranch <$> getAllRefs r
  where
	islocalbranch b = "refs/heads/" `isPrefixOf` fromRef b
	go changed deleted gcs [] = return (changed, deleted, gcs)
	go changed deleted gcs (b:bs) = do
		(mc, gcs') <- findUncorruptedCommit missing gcs b r
		case mc of
			Just c
				| c == b -> go changed deleted gcs' bs
				| otherwise -> do
					reset b c
					go (b:changed) deleted gcs' bs
			Nothing -> do
				nukeBranchRef b r
				go changed (b:deleted) gcs' bs
	reset b c = do
		nukeBranchRef b	r
		void $ runBool
			[ Param "branch"
			, Param (fromRef $ Ref.base b)
			, Param (fromRef c)
			] r

isTrackingBranch :: Ref -> Bool
isTrackingBranch b = "refs/remotes/" `isPrefixOf` fromRef b

{- To deal with missing objects that cannot be recovered, removes
 - any branches (filtered by a predicate) that reference them
 - Returns a list of all removed branches.
 -}
removeBadBranches :: (Ref -> Bool) -> Repo -> IO [Branch]
removeBadBranches removablebranch r = fst <$> removeBadBranches' removablebranch S.empty emptyGoodCommits r

removeBadBranches' :: (Ref -> Bool) -> MissingObjects -> GoodCommits -> Repo -> IO ([Branch], GoodCommits)
removeBadBranches' removablebranch missing goodcommits r =
	go [] goodcommits =<< filter removablebranch <$> getAllRefs r
  where
	go removed gcs [] = return (removed, gcs)
	go removed gcs (b:bs) = do
		(ok, gcs') <- verifyCommit missing gcs b r
		if ok
			then go removed gcs' bs
			else do
				nukeBranchRef b r
				go (b:removed) gcs' bs

badBranches :: MissingObjects -> Repo -> IO [Branch]
badBranches missing r = filterM isbad =<< getAllRefs r
  where
	isbad b = not . fst <$> verifyCommit missing emptyGoodCommits b r

{- Gets all refs, including ones that are corrupt.
 - git show-ref does not output refs to commits that are directly
 - corrupted, so it is not used.
 -
 - Relies on packed refs being exploded before it's called.
 -}
getAllRefs :: Repo -> IO [Ref]
getAllRefs r = map toref <$> dirContentsRecursive refdir
  where
  	refdir = localGitDir r </> "refs"
	toref = Ref . relPathDirToFile (localGitDir r)

explodePackedRefsFile :: Repo -> IO ()
explodePackedRefsFile r = do
	let f = packedRefsFile r
	whenM (doesFileExist f) $ do
		rs <- mapMaybe parsePacked . lines
			<$> catchDefaultIO "" (safeReadFile f)
		forM_ rs makeref
		nukeFile f
  where
	makeref (sha, ref) = do
		let dest = localGitDir r </> fromRef ref
		createDirectoryIfMissing True (parentDir dest)
		unlessM (doesFileExist dest) $
			writeFile dest (fromRef sha)

packedRefsFile :: Repo -> FilePath
packedRefsFile r = localGitDir r </> "packed-refs"

parsePacked :: String -> Maybe (Sha, Ref)
parsePacked l = case words l of
	(sha:ref:[])
		| isJust (extractSha sha) && Ref.legal True ref ->
			Just (Ref sha, Ref ref)
	_ -> Nothing

{- git-branch -d cannot be used to remove a branch that is directly
 - pointing to a corrupt commit. -}
nukeBranchRef :: Branch -> Repo -> IO ()
nukeBranchRef b r = nukeFile $ localGitDir r </> fromRef b

{- Finds the most recent commit to a branch that does not need any
 - of the missing objects. If the input branch is good as-is, returns it.
 - Otherwise, tries to traverse the commits in the branch to find one
 - that is ok. That might fail, if one of them is corrupt, or if an object
 - at the root of the branch is missing. Finally, looks for an old version
 - of the branch from the reflog.
 -}
findUncorruptedCommit :: MissingObjects -> GoodCommits -> Branch -> Repo -> IO (Maybe Sha, GoodCommits)
findUncorruptedCommit missing goodcommits branch r = do
	(ok, goodcommits') <- verifyCommit missing goodcommits branch r
	if ok
		then return (Just branch, goodcommits')
		else do
			(ls, cleanup) <- pipeNullSplit
				[ Param "log"
				, Param "-z"
				, Param "--format=%H"
				, Param (fromRef branch)
				] r
			let branchshas = catMaybes $ map extractSha ls
			reflogshas <- RefLog.get branch r
			-- XXX Could try a bit harder here, and look
			-- for uncorrupted old commits in branches in the
			-- reflog.
			cleanup `after` findfirst goodcommits (branchshas ++ reflogshas)
  where
	findfirst gcs [] = return (Nothing, gcs)
	findfirst gcs (c:cs) = do
		(ok, gcs') <- verifyCommit missing gcs c r
		if ok
			then return (Just c, gcs')
			else findfirst gcs' cs

{- Verifies that none of the missing objects in the set are used by
 - the commit. Also adds to a set of commit shas that have been verified to
 - be good, which can be passed into subsequent calls to avoid
 - redundant work when eg, chasing down branches to find the first
 - uncorrupted commit. -}
verifyCommit :: MissingObjects -> GoodCommits -> Sha -> Repo -> IO (Bool, GoodCommits)
verifyCommit missing goodcommits commit r
	| checkGoodCommit commit goodcommits = return (True, goodcommits)
	| otherwise = do
		(ls, cleanup) <- pipeNullSplit
			[ Param "log"
			, Param "-z"
			, Param "--format=%H %T"
			, Param (fromRef commit)
			] r
		let committrees = map parse ls
		if any isNothing committrees || null committrees
			then do
				void cleanup
				return (False, goodcommits)
			else do
				let cts = catMaybes committrees
				ifM (cleanup <&&> check cts)
					( return (True, addGoodCommits (map fst cts) goodcommits)
					, return (False, goodcommits)
					)
  where
	parse l = case words l of
		(commitsha:treesha:[]) -> (,)
			<$> extractSha commitsha
			<*> extractSha treesha
		_ -> Nothing
	check [] = return True
	check ((c, t):rest)
		| checkGoodCommit c goodcommits = return True
		| otherwise = verifyTree missing t r <&&> check rest

{- Verifies that a tree is good, including all trees and blobs
 - referenced by it. -}
verifyTree :: MissingObjects -> Sha -> Repo -> IO Bool
verifyTree missing treesha r
	| S.member treesha missing = return False
	| otherwise = do
		(ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams treesha) r
		let objshas = map (extractSha . LsTree.sha . LsTree.parseLsTree) ls
		if any isNothing objshas || any (`S.member` missing) (catMaybes objshas)
			then do
				void cleanup
				return False
			-- as long as ls-tree succeeded, we're good
			else cleanup

{- Checks that the index file only refers to objects that are not missing,
 - and is not itself corrupt. Note that a missing index file is not
 - considered a problem (repo may be new). -}
checkIndex :: Repo -> IO Bool
checkIndex r = do
	(bad, _good, cleanup) <- partitionIndex r
	if null bad
		then cleanup
		else do
			void cleanup
			return False

{- Does not check every object the index refers to, but only that the index
 - itself is not corrupt. -}
checkIndexFast :: Repo -> IO Bool
checkIndexFast r = do
	(indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r
	length indexcontents `seq` cleanup

missingIndex :: Repo -> IO Bool
missingIndex r = not <$> doesFileExist (localGitDir r </> "index")

{- Finds missing and ok files staged in the index. -}
partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool)
partitionIndex r = do
	(indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r
	l <- forM indexcontents $ \i -> case i of
		(_file, Just sha, Just _mode) -> (,) <$> isMissing sha r <*> pure i
		_ -> pure (False, i)
	let (bad, good) = partition fst l
	return (map snd bad, map snd good, cleanup)

{- Rewrites the index file, removing from it any files whose blobs are
 - missing. Returns the list of affected files. -}
rewriteIndex :: Repo -> IO [FilePath]
rewriteIndex r
	| repoIsLocalBare r = return []
	| otherwise = do
		(bad, good, cleanup) <- partitionIndex r
		unless (null bad) $ do
			nukeFile (indexFile r)
			UpdateIndex.streamUpdateIndex r
				=<< (catMaybes <$> mapM reinject good)
		void cleanup
		return $ map fst3 bad
  where
	reinject (file, Just sha, Just mode) = case toBlobType mode of
		Nothing -> return Nothing
		Just blobtype -> Just <$>
			UpdateIndex.stageFile sha blobtype file r
	reinject _ = return Nothing

newtype GoodCommits = GoodCommits (S.Set Sha)

emptyGoodCommits :: GoodCommits
emptyGoodCommits = GoodCommits S.empty

checkGoodCommit :: Sha -> GoodCommits -> Bool
checkGoodCommit sha (GoodCommits s) = S.member sha s

addGoodCommits :: [Sha] -> GoodCommits -> GoodCommits
addGoodCommits shas (GoodCommits s) = GoodCommits $
	S.union s (S.fromList shas)

displayList :: [String] -> String -> IO ()
displayList items header
	| null items = return ()
	| otherwise = do
		putStrLn header
		putStr $ unlines $ map (\i -> "\t" ++ i) truncateditems
  where
  	numitems = length items
	truncateditems
		| numitems > 10 = take 10 items ++ ["(and " ++ show (numitems - 10) ++ " more)"]
		| otherwise = items

{- Fix problems that would prevent repair from working at all
 -
 - A missing or corrupt .git/HEAD makes git not treat the repository as a
 - git repo. If there is a git repo in a parent directory, it may move up
 - the tree and use that one instead. So, cannot use `git show-ref HEAD` to
 - test it.
 -
 - Explode the packed refs file, to simplify dealing with refs, and because
 - fsck can complain about bad refs in it.
 -}
preRepair :: Repo -> IO ()
preRepair g = do
	unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do
		nukeFile headfile
		writeFile headfile "ref: refs/heads/master"
	explodePackedRefsFile g
	unless (repoIsLocalBare g) $ do
		let f = indexFile g
		void $ tryIO $ allowWrite f
  where
	headfile = localGitDir g </> "HEAD"
	validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s)

{- Put it all together. -}
runRepair :: (Ref -> Bool) -> Bool -> Repo -> IO (Bool, [Branch])
runRepair removablebranch forced g = do
	preRepair g
	putStrLn "Running git fsck ..."
	fsckresult <- findBroken False g
	if foundBroken fsckresult
		then runRepair' removablebranch fsckresult forced Nothing g
		else do
			bad <- badBranches S.empty g
			if null bad
				then do
					putStrLn "No problems found."
					return (True, [])
				else runRepair' removablebranch fsckresult forced Nothing g

runRepairOf :: FsckResults -> (Ref -> Bool) -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch])
runRepairOf fsckresult removablebranch forced referencerepo g = do
	preRepair g
	runRepair' removablebranch fsckresult forced referencerepo g

runRepair' :: (Ref -> Bool) -> FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch])
runRepair' removablebranch fsckresult forced referencerepo g = do
	cleanCorruptObjects fsckresult g
	missing <- findBroken False g
	stillmissing <- retrieveMissingObjects missing referencerepo g
	case stillmissing of
		FsckFoundMissing s t
			| S.null s -> if repoIsLocalBare g
				then checkbadbranches s
				else ifM (checkIndex g)
					( checkbadbranches s
					, do
						putStrLn "No missing objects found, but the index file is corrupt!"
						if forced
							then corruptedindex
							else needforce
					)
			| otherwise -> if forced
				then ifM (checkIndex g)
					( forcerepair s t
					, corruptedindex
					)
				else do
					putStrLn $ unwords
						[ show (S.size s)
						, "missing objects could not be recovered!"
						]
					unsuccessfulfinish
		FsckFailed
			| forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex g)
				( do
					cleanCorruptObjects FsckFailed g
					stillmissing' <- findBroken False g
					case stillmissing' of
						FsckFailed -> return (False, [])
						FsckFoundMissing s t -> forcerepair s t
				, corruptedindex
				)
			| otherwise -> unsuccessfulfinish
  where
	repairbranches missing = do
		(removedbranches, goodcommits) <- removeBadBranches' removablebranch missing emptyGoodCommits g
		let remotebranches = filter isTrackingBranch removedbranches
		unless (null remotebranches) $
			putStrLn $ unwords
				[ "Removed"
				, show (length remotebranches)
				, "remote tracking branches that referred to missing objects."
				]
		(resetbranches, deletedbranches, _) <- resetLocalBranches missing goodcommits g
		displayList (map fromRef resetbranches)
			"Reset these local branches to old versions before the missing objects were committed:"
		displayList (map fromRef deletedbranches)
			"Deleted these local branches, which could not be recovered due to missing objects:"
		return (resetbranches ++ deletedbranches)

	checkbadbranches missing = do
		bad <- badBranches missing g
		case (null bad, forced) of
			(True, _) -> successfulfinish []
			(False, False) -> do
				displayList (map fromRef bad)
					"Some git branches refer to missing objects:"
				unsuccessfulfinish
			(False, True) -> successfulfinish =<< repairbranches missing

	forcerepair missing fscktruncated = do
		modifiedbranches <- repairbranches missing
		deindexedfiles <- rewriteIndex g
		displayList deindexedfiles
			"Removed these missing files from the index. You should look at what files are present in your working tree and git add them back to the index when appropriate."

		-- When the fsck results were truncated, try
		-- fscking again, and as long as different
		-- missing objects are found, continue
		-- the repair process.
		if fscktruncated
			then do
				fsckresult' <- findBroken False g
				case fsckresult' of
					FsckFailed -> do
						putStrLn "git fsck is failing"
						return (False, modifiedbranches)
					FsckFoundMissing s _
						| S.null s -> successfulfinish modifiedbranches
						| S.null (s `S.difference` missing) -> do
							putStrLn $ unwords
								[ show (S.size s)
								, "missing objects could not be recovered!"
								]
							return (False, modifiedbranches)
						| otherwise -> do
							(ok, modifiedbranches') <- runRepairOf fsckresult' removablebranch forced referencerepo g
							return (ok, modifiedbranches++modifiedbranches')
			else successfulfinish modifiedbranches

	corruptedindex = do
		nukeFile (indexFile g)
		-- The corrupted index can prevent fsck from finding other
		-- problems, so re-run repair.
		fsckresult' <- findBroken False g
		result <- runRepairOf fsckresult' removablebranch forced referencerepo g
		putStrLn "Removed the corrupted index file. You should look at what files are present in your working tree and git add them back to the index when appropriate."
		return result

	successfulfinish modifiedbranches
		| null modifiedbranches = do
			mapM_ putStrLn
				[ "Successfully recovered repository!"
				, "You should run \"git fsck\" to make sure, but it looks like everything was recovered ok."
				]
			return (True, modifiedbranches)
		| otherwise = do
			unless (repoIsLocalBare g) $ do
				mcurr <- Branch.currentUnsafe g
				case mcurr of
					Nothing -> return ()
					Just curr -> when (any (== curr) modifiedbranches) $ do
						putStrLn $ unwords
							[ "You currently have"
							, fromRef curr
							, "checked out. You may have staged changes in the index that can be committed to recover the lost state of this branch!"
							]
			putStrLn "Successfully recovered repository!"
			putStrLn "Please carefully check that the changes mentioned above are ok.."
			return (True, modifiedbranches)

	unsuccessfulfinish = do
		if repoIsLocalBare g
			then do
				putStrLn "If you have a clone of this bare repository, you should add it as a remote of this repository, and retry."
				putStrLn "If there are no clones of this repository, you can instead retry with the --force parameter to force recovery to a possibly usable state."
				return (False, [])
			else needforce
	needforce = do
		putStrLn "To force a recovery to a usable state, retry with the --force parameter."
		return (False, [])

successfulRepair :: (Bool, [Branch]) -> Bool
successfulRepair = fst

safeReadFile :: FilePath -> IO String
safeReadFile f = do
	allowRead f
	readFileStrictAnyEncoding f


code:
{- git SHA stuff
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.Sha where

import Common
import Git.Types

{- 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 Sha
getSha subcommand a = maybe bad return =<< extractSha <$> a
  where
	bad = error $ "failed to read sha from git " ++ subcommand

{- Extracts the Sha from a string. There can be a trailing newline after
 - it, but nothing else. -}
extractSha :: String -> Maybe Sha
extractSha s
	| len == shaSize = val s
	| len == shaSize + 1 && length s' == shaSize = val s'
	| otherwise = Nothing
  where
	len = length s
	s' = firstLine s
	val v
		| all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v
		| otherwise = Nothing

{- Size of a git sha. -}
shaSize :: Int
shaSize = 40

nullSha :: Ref
nullSha = Ref $ replicate shaSize '0'

{- Git's magic empty tree. -}
emptyTree :: Ref
emptyTree = Ref "4b825dc642cb6eb9a060e54bf8d69288fbee4904"


code:
{- git core.sharedRepository handling
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.SharedRepository where

import Data.Char

import Common
import Git
import qualified Git.Config

data SharedRepository = UnShared | GroupShared | AllShared | UmaskShared Int

getSharedRepository :: Repo -> SharedRepository
getSharedRepository r =
	case map toLower $ Git.Config.get "core.sharedrepository" "" r of
		"1" -> GroupShared
		"group" -> GroupShared
		"true" -> GroupShared
		"all" -> AllShared
		"world" -> AllShared
		"everybody" -> AllShared
		v -> maybe UnShared UmaskShared (readish v)


code:
{- git data types
 -
 - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.Types where

import Network.URI
import qualified Data.Map as M
import System.Posix.Types
import Utility.SafeCommand
import Utility.URI ()

{- Support repositories on local disk, and repositories accessed via an URL.
 -
 - Repos on local disk have a git directory, and unless bare, a worktree.
 -
 - A local repo may not have had its config read yet, in which case all
 - that's known about it is its path.
 -
 - Finally, an Unknown repository may be known to exist, but nothing
 - else known about it.
 -}
data RepoLocation
	= Local { gitdir :: FilePath, worktree :: Maybe FilePath }
	| LocalUnknown FilePath
	| Url URI
	| Unknown
	deriving (Show, Eq, Ord)

data Repo = Repo
	{ location :: RepoLocation
	, config :: M.Map String String
	-- a given git config key can actually have multiple values
	, fullconfig :: M.Map String [String]
	, remotes :: [Repo]
	-- remoteName holds the name used for this repo in remotes
	, remoteName :: Maybe RemoteName
	-- alternate environment to use when running git commands
	, gitEnv :: Maybe [(String, String)]
	-- global options to pass to git when running git commands
	, gitGlobalOpts :: [CommandParam]
	} deriving (Show, Eq, Ord)

type RemoteName = String

{- A git ref. Can be a sha1, or a branch or tag name. -}
newtype Ref = Ref String
	deriving (Eq, Ord, Read, Show)

fromRef :: Ref -> String
fromRef (Ref s) = s

{- Aliases for Ref. -}
type Branch = Ref
type Sha = Ref
type Tag = Ref

{- A date in the format described in gitrevisions. Includes the
 - braces, eg, "{yesterday}" -}
newtype RefDate = RefDate String

{- Types of objects that can be stored in git. -}
data ObjectType = BlobObject | CommitObject | TreeObject
	deriving (Eq)

instance Show ObjectType where
	show BlobObject = "blob"
	show CommitObject = "commit"
	show TreeObject = "tree"

readObjectType :: String -> Maybe ObjectType
readObjectType "blob" = Just BlobObject
readObjectType "commit" = Just CommitObject
readObjectType "tree" = Just TreeObject
readObjectType _ = Nothing

{- Types of blobs. -}
data BlobType = FileBlob | ExecutableBlob | SymlinkBlob
	deriving (Eq)

{- Git uses magic numbers to denote the type of a blob. -}
instance Show BlobType where
	show FileBlob = "100644"
	show ExecutableBlob = "100755"
	show SymlinkBlob = "120000"

readBlobType :: String -> Maybe BlobType
readBlobType "100644" = Just FileBlob
readBlobType "100755" = Just ExecutableBlob
readBlobType "120000" = Just SymlinkBlob
readBlobType _ = Nothing

toBlobType :: FileMode -> Maybe BlobType
toBlobType 0o100644 = Just FileBlob
toBlobType 0o100755 = Just ExecutableBlob
toBlobType 0o120000 = Just SymlinkBlob
toBlobType _ = Nothing


code:
{- git-union-merge library
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.UnionMerge (
	merge,
	mergeIndex
) where

import qualified Data.ByteString.Lazy as L
import qualified Data.Set as S

import Common
import Git
import Git.Sha
import Git.CatFile
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.
 -
 - Should be run with a temporary index file configured by useIndex.
 -}
merge :: Ref -> Ref -> Repo -> IO ()
merge x y repo = do
	h <- catFileStart repo
	streamUpdateIndex repo
		[ lsTree x repo
		, mergeTrees x y h repo
		]
	catFileStop h

{- Merges a list of branches into the index. Previously staged changes in
 - the index are preserved (and participate in the merge).
 -
 - update-index is run once per ref in turn, so that each ref is merged on
 - top of the merge for the previous ref. It would be more efficient, but
 - harder to calculate a single union merge involving all the refs, as well
 - as the index.
 -}
mergeIndex :: CatFileHandle -> Repo -> [Ref] -> IO ()
mergeIndex h repo bs = forM_ bs $ \b ->
	streamUpdateIndex repo [mergeTreeIndex b h repo]

{- For merging two trees. -}
mergeTrees :: Ref -> Ref -> CatFileHandle -> Repo -> Streamer
mergeTrees (Ref x) (Ref y) h = doMerge h $ "diff-tree":diffOpts ++ [x, y]

{- For merging a single tree into the index. -}
mergeTreeIndex :: Ref -> CatFileHandle -> Repo -> Streamer
mergeTreeIndex (Ref x) h = doMerge h $
	"diff-index" : diffOpts ++ ["--cached", x]

diffOpts :: [String]
diffOpts = ["--raw", "-z", "-r", "--no-renames", "-l0"]

{- Streams update-index changes to perform a merge,
 - using git to get a raw diff. -}
doMerge :: CatFileHandle -> [String] -> Repo -> Streamer
doMerge ch differ repo streamer = do
	(diff, cleanup) <- pipeNullSplit (map Param differ) repo
	go diff
	void $ cleanup
  where
	go [] = noop
	go (info:file:rest) = mergeFile info file ch repo >>=
		maybe (go rest) (\l -> streamer l >> go rest)
	go (_:[]) = error $ "parse error " ++ show differ

{- Given an info line from a git raw diff, and the filename, generates
 - a line suitable for update-index that union merges the two sides of the
 - diff. -}
mergeFile :: String -> FilePath -> CatFileHandle -> Repo -> IO (Maybe String)
mergeFile info file h repo = case filter (/= nullSha) [Ref asha, Ref bsha] of
	[] -> return Nothing
	(sha:[]) -> use sha
	shas -> use
		=<< either return (\s -> hashObject BlobObject (unlines s) repo)
		=<< calcMerge . zip shas <$> mapM getcontents shas
  where
	[_colonmode, _bmode, asha, bsha, _status] = words info
	use sha = return $ Just $
		updateIndexLine sha FileBlob $ asTopFilePath file
	-- We don't know how the file is encoded, but need to
	-- split it into lines to union merge. Using the
	-- FileSystemEncoding for this is a hack, but ensures there
	-- are no decoding errors. Note that this works because
	-- hashObject sets fileEncoding on its write handle.
	getcontents s = lines . encodeW8 . L.unpack <$> catObject h s

{- Calculates a union merge between a list of refs, with contents.
 -
 - When possible, reuses the content of an existing ref, rather than
 - generating new content.
 -}
calcMerge :: [(Ref, [String])] -> Either Ref [String]
calcMerge shacontents
	| null reuseable = Right $ new
	| otherwise = Left $ fst $ Prelude.head reuseable
  where
	reuseable = filter (\c -> sorteduniq (snd c) == new) shacontents
	new = sorteduniq $ concat $ map snd shacontents
	sorteduniq = S.toList . S.fromList


code:
{- git-update-index library
 -
 - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE BangPatterns, CPP #-}

module Git.UpdateIndex (
	Streamer,
	pureStreamer,
	streamUpdateIndex,
	streamUpdateIndex',
	startUpdateIndex,
	stopUpdateIndex,
	lsTree,
	lsSubTree,
	updateIndexLine,
	stageFile,
	unstageFile,
	stageSymlink
) where

import Common
import Git
import Git.Types
import Git.Command
import Git.FilePath
import Git.Sha

import Control.Exception (bracket)

{- Streamers are passed a callback and should feed it lines in the form
 - read by update-index, and generated by ls-tree. -}
type Streamer = (String -> IO ()) -> IO ()

{- A streamer with a precalculated value. -}
pureStreamer :: String -> Streamer
pureStreamer !s = \streamer -> streamer s

{- Streams content into update-index from a list of Streamers. -}
streamUpdateIndex :: Repo -> [Streamer] -> IO ()
streamUpdateIndex repo as = bracket (startUpdateIndex repo) stopUpdateIndex $
	(\h -> forM_ as $ streamUpdateIndex' h)

data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle

streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO ()
streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do
	hPutStr h s
	hPutStr h "\0"

startUpdateIndex :: Repo -> IO UpdateIndexHandle
startUpdateIndex repo = do
	(Just h, _, _, p) <- createProcess (gitCreateProcess params repo)
		{ std_in = CreatePipe }
	fileEncoding h
	return $ UpdateIndexHandle p h
  where
	params = map Param ["update-index", "-z", "--index-info"]

stopUpdateIndex :: UpdateIndexHandle -> IO Bool
stopUpdateIndex (UpdateIndexHandle p h) = do
	hClose h
	checkSuccessProcess p

{- A streamer that adds the current tree for a ref. Useful for eg, copying
 - and modifying branches. -}
lsTree :: Ref -> Repo -> Streamer
lsTree (Ref x) repo streamer = do
	(s, cleanup) <- pipeNullSplit params repo
	mapM_ streamer s
	void $ cleanup
  where
	params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
lsSubTree :: Ref -> FilePath -> Repo -> Streamer
lsSubTree (Ref x) p repo streamer = do
	(s, cleanup) <- pipeNullSplit params repo
	mapM_ streamer s
	void $ cleanup
  where
	params = map Param ["ls-tree", "-z", "-r", "--full-tree", x, p]

{- Generates a line suitable to be fed into update-index, to add
 - a given file with a given sha. -}
updateIndexLine :: Sha -> BlobType -> TopFilePath -> String
updateIndexLine sha filetype file =
	show filetype ++ " blob " ++ fromRef sha ++ "\t" ++ indexPath file

stageFile :: Sha -> BlobType -> FilePath -> Repo -> IO Streamer
stageFile sha filetype file repo = do
	p <- toTopFilePath file repo
	return $ pureStreamer $ updateIndexLine sha filetype p

{- A streamer that removes a file from the index. -}
unstageFile :: FilePath -> Repo -> IO Streamer
unstageFile file repo = do
	p <- toTopFilePath file repo
	return $ pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p

{- A streamer that adds a symlink to the index. -}
stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer
stageSymlink file sha repo = do
	!line <- updateIndexLine
		<$> pure sha
		<*> pure SymlinkBlob
		<*> toTopFilePath file repo
	return $ pureStreamer line

indexPath :: TopFilePath -> InternalGitPath
indexPath = toInternalGitPath . getTopFilePath


code:
{- git repository urls
 -
 - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.Url (
	scheme,
	host,
	port,
	hostuser,
	authority,
) where

import Network.URI hiding (scheme, authority)

import Common
import Git.Types
import Git

{- Scheme of an URL repo. -}
scheme :: Repo -> String
scheme Repo { location = Url u } = uriScheme u
scheme repo = notUrl repo

{- Work around a bug in the real uriRegName
 - <http://trac.haskell.org/network/ticket/40> -}
uriRegName' :: URIAuth -> String
uriRegName' a = fixup $ uriRegName a
  where
	fixup x@('[':rest)
		| rest !! len == ']' = take len rest
		| otherwise = x
	  where
		len  = length rest - 1
	fixup x = x

{- Hostname of an URL repo. -}
host :: Repo -> Maybe String
host = authpart uriRegName'

{- Port of an URL repo, if it has a nonstandard one. -}
port :: Repo -> Maybe Integer
port r =
	case authpart uriPort r of
		Nothing -> Nothing
		Just ":" -> Nothing
		Just (':':p) -> readish p
		Just _ -> Nothing

{- Hostname of an URL repo, including any username (ie, "user@host") -}
hostuser :: Repo -> Maybe String
hostuser r = (++)
	<$> authpart uriUserInfo r
	<*> authpart uriRegName' r

{- The full authority portion an URL repo. (ie, "user@host:port") -}
authority :: Repo -> Maybe String
authority = authpart assemble
  where
	assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a

{- Applies a function to extract part of the uriAuthority of an URL repo. -}
authpart :: (URIAuth -> a) -> Repo -> Maybe a
authpart a Repo { location = Url u } = a <$> uriAuthority u
authpart _ repo = notUrl repo

notUrl :: Repo -> a
notUrl repo = error $
	"acting on local git repo " ++ repoDescribe repo ++ " not supported"


code:
{- git versions
 -
 - Copyright 2011, 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.Version where

import Common

data GitVersion = GitVersion String Integer
	deriving (Eq)

instance Ord GitVersion where
	compare (GitVersion _ x) (GitVersion _ y) = compare x y

instance Show GitVersion where
	show (GitVersion s _) = s

installed :: IO GitVersion
installed = normalize . extract <$> readProcess "git" ["--version"]
  where
  	extract s = case lines s of
		[] -> ""
		(l:_) -> unwords $ drop 2 $ words l

{- To compare dotted versions like 1.7.7 and 1.8, they are normalized to
 - a somewhat arbitrary integer representation. -}
normalize :: String -> GitVersion
normalize v = GitVersion v $
	sum $ mult 1 $ reverse $ extend precision $ take precision $
		map readi $ split "." v
  where
	extend n l = l ++ replicate (n - length l) 0
	mult _ [] = []
	mult n (x:xs) = (n*x) : mult (n*10^width) xs
	readi :: String -> Integer
	readi s = case reads s of
		((x,_):_) -> x
		_ -> 0
	precision = 10 -- number of segments of the version to compare
	width = length "yyyymmddhhmmss" -- maximum width of a segment