git-annex/Git/LsFiles.hs

{- git ls-files interface
 -
 - Copyright 2010,2012 Joey Hess <id@joeyh.name>
 -
 - 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
import Data.Char

{- Somewhat unexpectedly, git-ls-files does its own wildcard expansion
 - of files passed to it. To avoid that, and only get back exactly the
 - files we asked for, slash-escape punctuation in the filename. -}
mkFile :: FilePath -> CommandParam
mkFile = File . concatMap go
  where
	go c
		| c `elem` "*?[]" = ['\\', c]
		| otherwise = [c]

{- 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 mkFile 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 mkFile 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 mkFile 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 mkFile 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 mkFile 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 mkFile 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 mkFile 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 mkFile 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.
	top <- absPath (repoPath repo)
	currdir <- getCurrentDirectory
	return (map (\f -> relPathDirToFileAbs currdir $ top </> f) fs, cleanup)
  where
	prefix = [Params "diff --name-only --diff-filter=T -z"]
	suffix = Param "--" : (if null l then [File "."] else map mkFile 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 mkFile 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
		}