From ef3214bd2856e5927eda83eeab969e421ee923ea Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 15 Dec 2015 20:46:53 -0400 Subject: merge from git-annex --- Git/Construct.hs | 17 +++++++++------ Git/Destroyer.hs | 1 - Git/Filename.hs | 4 ++-- Git/LsFiles.hs | 66 +++++++++++++++++++++++++++++++++++++++++++++----------- Git/LsTree.hs | 29 ++++++++++++++++++------- Git/RefLog.hs | 19 +++++++++------- Git/Repair.hs | 8 ++++--- Git/Version.hs | 2 ++ 8 files changed, 106 insertions(+), 40 deletions(-) (limited to 'Git') diff --git a/Git/Construct.hs b/Git/Construct.hs index 5b20605..03dd29f 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -58,24 +58,29 @@ fromPath dir = fromAbsPath =<< absPath dir - specified. -} fromAbsPath :: FilePath -> IO Repo fromAbsPath dir - | absoluteGitPath dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt ) + | absoluteGitPath dir = hunt | otherwise = error $ "internal error, " ++ dir ++ " is not absolute" where ret = pure . 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 + , ret (takeDirectory canondir) ) - | otherwise = ret dir + | otherwise = ifM (doesDirectoryExist dir) + ( ret dir + -- git falls back to dir.git when dir doesn't + -- exist, as long as dir didn't end with a + -- path separator + , if dir == canondir + then ret (dir ++ ".git") + else ret dir + ) {- Remote Repo constructor. Throws exception on invalid url. - diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs index 2ac4dae..e923796 100644 --- a/Git/Destroyer.hs +++ b/Git/Destroyer.hs @@ -21,7 +21,6 @@ import Utility.Tmp import qualified Data.ByteString as B import Data.Word -import System.PosixCompat.Types {- Ways to damange a git repository. -} data Damage diff --git a/Git/Filename.hs b/Git/Filename.hs index 382eb8d..ee84d48 100644 --- a/Git/Filename.hs +++ b/Git/Filename.hs @@ -24,5 +24,5 @@ encode :: FilePath -> String encode s = "\"" ++ encode_c s ++ "\"" {- for quickcheck -} -prop_idempotent_deencode :: String -> Bool -prop_idempotent_deencode s = s == decode (encode s) +prop_isomorphic_deencode :: String -> Bool +prop_isomorphic_deencode s = s == decode (encode s) diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index e80c1b2..f945838 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -35,14 +35,23 @@ 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 +inRepo l = pipeNullSplit $ + Param "ls-files" : + Param "--cached" : + Param "-z" : + Param "--" : + 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 + params = concat + [ [ Param "ls-files", Param "--others"] + , exclude + , [ Param "-z", Param "--" ] + , map File l + ] exclude | include_ignored = [] | otherwise = [Param "--exclude-standard"] @@ -50,28 +59,51 @@ notInRepo include_ignored l repo = pipeNullSplit params repo {- 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 +allFiles l = pipeNullSplit $ + Param "ls-files" : + Param "--cached" : + Param "--others" : + Param "-z" : + Param "--" : + 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 + params = + Param "ls-files" : + Param "--deleted" : + Param "-z" : + Param "--" : + 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 + params = + Param "ls-files" : + Param "--modified" : + Param "-z" : + Param "--" : + 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 + params = + Param "ls-files" : + Param "--modified" : + Param "--others" : + Param "--exclude-standard" : + Param "-z" : + Param "--" : + map File l {- Returns a list of all files that are staged for commit. -} staged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) @@ -85,7 +117,7 @@ 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"] + prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] suffix = Param "--" : map File l type StagedDetails = (FilePath, Maybe Sha, Maybe FileMode) @@ -93,7 +125,7 @@ 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"] +stagedOthersDetails = stagedDetails' [Param "--others", Param "--exclude-standard"] {- Returns details about all files that are staged in the index. -} stagedDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool) @@ -106,7 +138,7 @@ stagedDetails' ps l repo = do (ls, cleanup) <- pipeNullSplit params repo return (map parse ls, cleanup) where - params = Params "ls-files --stage -z" : ps ++ + params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ Param "--" : map File l parse s | null file = (s, Nothing, Nothing) @@ -135,7 +167,12 @@ typeChanged' ps l repo = do currdir <- getCurrentDirectory return (map (\f -> relPathDirToFileAbs currdir $ top f) fs, cleanup) where - prefix = [Params "diff --name-only --diff-filter=T -z"] + prefix = + [ Param "diff" + , Param "--name-only" + , Param "--diff-filter=T" + , Param "-z" + ] suffix = Param "--" : (if null l then [File "."] else map File l) {- A item in conflict has two possible values. @@ -166,7 +203,12 @@ 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 + params = + Param "ls-files" : + Param "--unmerged" : + Param "-z" : + Param "--" : + map File l data InternalUnmerged = InternalUnmerged { isus :: Bool diff --git a/Git/LsTree.hs b/Git/LsTree.hs index 7ef9518..1ed6247 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -13,10 +13,6 @@ module Git.LsTree ( parseLsTree ) where -import Numeric -import Control.Applicative -import System.Posix.Types - import Common import Git import Git.Command @@ -24,6 +20,9 @@ import Git.Sha import Git.FilePath import qualified Git.Filename +import Numeric +import System.Posix.Types + data TreeItem = TreeItem { mode :: FileMode , typeobj :: String @@ -35,16 +34,30 @@ data TreeItem = TreeItem - with lazy output. -} lsTree :: Ref -> Repo -> IO [TreeItem] lsTree t repo = map parseLsTree - <$> pipeNullSplitZombie (lsTreeParams t) repo + <$> pipeNullSplitZombie (lsTreeParams t []) repo -lsTreeParams :: Ref -> [CommandParam] -lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ fromRef t ] +lsTreeParams :: Ref -> [CommandParam] -> [CommandParam] +lsTreeParams r ps = + [ Param "ls-tree" + , Param "--full-tree" + , Param "-z" + , Param "-r" + ] ++ ps ++ + [ Param "--" + , File $ fromRef r + ] {- 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 + ps = + [ Param "ls-tree" + , Param "--full-tree" + , Param "-z" + , Param "--" + , File $ fromRef t + ] ++ map File fs {- Parses a line of ls-tree output. - (The --long format is not currently supported.) -} diff --git a/Git/RefLog.hs b/Git/RefLog.hs index 7c20047..57f35e9 100644 --- a/Git/RefLog.hs +++ b/Git/RefLog.hs @@ -14,14 +14,17 @@ import Git.Sha {- Gets the reflog for a given branch. -} get :: Branch -> Repo -> IO [Sha] -get = get' [] +get b = getMulti [b] -get' :: [CommandParam] -> Branch -> Repo -> IO [Sha] -get' ps b = mapMaybe extractSha . lines <$$> pipeReadStrict ps' +{- Gets reflogs for multiple branches. -} +getMulti :: [Branch] -> Repo -> IO [Sha] +getMulti bs = get' (map (Param . fromRef) bs) + +get' :: [CommandParam] -> Repo -> IO [Sha] +get' ps = mapMaybe extractSha . lines <$$> pipeReadStrict ps' where - ps' = - [ Param "log" - , Param "-g" - , Param "--format=%H" - , Param (fromRef b) + ps' = catMaybes + [ Just $ Param "log" + , Just $ Param "-g" + , Just $ Param "--format=%H" ] ++ ps diff --git a/Git/Repair.hs b/Git/Repair.hs index 2557e3b..b441f13 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -99,7 +99,7 @@ retrieveMissingObjects :: FsckResults -> Maybe FilePath -> Repo -> IO FsckResult retrieveMissingObjects missing referencerepo r | not (foundBroken missing) = return missing | otherwise = withTmpDir "tmprepo" $ \tmpdir -> do - unlessM (boolSystem "git" [Params "init", File tmpdir]) $ + unlessM (boolSystem "git" [Param "init", File tmpdir]) $ error $ "failed to create temp repository in " ++ tmpdir tmpr <- Config.read =<< Construct.fromAbsPath tmpdir stillmissing <- pullremotes tmpr (remotes r) fetchrefstags missing @@ -140,7 +140,9 @@ retrieveMissingObjects missing referencerepo r ps' = [ Param "fetch" , Param fetchurl - , Params "--force --update-head-ok --quiet" + , Param "--force" + , Param "--update-head-ok" + , Param "--quiet" ] ++ ps fetchr' = fetchr { gitGlobalOpts = gitGlobalOpts fetchr ++ nogc } nogc = [ Param "-c", Param "gc.auto=0" ] @@ -339,7 +341,7 @@ 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 + (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 diff --git a/Git/Version.hs b/Git/Version.hs index ecd1244..19ff945 100644 --- a/Git/Version.hs +++ b/Git/Version.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Git.Version ( installed, older, -- cgit v1.2.3