merge from git-annex

CHANGELOG

@@ -1,9 +1,9 @@
-git-repair (1.20210630) UNRELEASED; urgency=medium
+git-repair (1.20220404) unstable; urgency=medium
 
  * Avoid treating refs that are not commit objects as evidence of
  repository corruption.
 
- -- Joey Hess <[email protected]> Wed, 04 May 2022 11:33:48 -0400
+ -- Joey Hess <[email protected]> Wed, 04 May 2022 11:43:15 -0400
 
 git-repair (1.20210629) unstable; urgency=medium
 

COPYRIGHT

@@ -2,11 +2,11 @@ Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
 Source: git:https://git-repair.branchable.com/
 
 Files: *
-Copyright: © 2013-2019 Joey Hess <[email protected]>
+Copyright: © 2013-2022 Joey Hess <[email protected]>
 License: AGPL-3+
 
 Files: Utility/*
-Copyright: 2012-2014 Joey Hess <[email protected]>
+Copyright: 2012-2022 Joey Hess <[email protected]>
 License: BSD-2-clause
 
 Files: Utility/Attoparsec.hs

Git/Branch.hs

@@ -121,6 +121,13 @@ fastForward branch (first:rest) repo =
  (False, True) -> findbest c rs -- worse
  (False, False) -> findbest c rs -- same
 
+{- Should the commit avoid the usual summary output? -}
+newtype CommitQuiet = CommitQuiet Bool
+
+applyCommitQuiet :: CommitQuiet -> [CommandParam] -> [CommandParam]
+applyCommitQuiet (CommitQuiet True) ps = Param "--quiet" : ps
+applyCommitQuiet (CommitQuiet False) ps = ps
+
 {- The user may have set commit.gpgsign, intending all their manual
  - commits to be signed. But signing automatic/background commits could
  - easily lead to unwanted gpg prompts or failures.
@@ -148,12 +155,14 @@ applyCommitModeForCommitTree commitmode ps r
  ps' = applyCommitMode commitmode ps
 
 {- Commit via the usual git command. -}
-commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool
+commitCommand :: CommitMode -> CommitQuiet -> [CommandParam] -> Repo -> IO Bool
 commitCommand = commitCommand' runBool
 
-commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> [CommandParam] -> Repo -> IO a
-commitCommand' runner commitmode ps = runner $
- Param "commit" : applyCommitMode commitmode ps
+commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> CommitQuiet -> [CommandParam] -> Repo -> IO a
+commitCommand' runner commitmode commitquiet ps =
+ runner $ Param "commit" : ps'
+ where
+ ps' = applyCommitMode commitmode (applyCommitQuiet commitquiet ps)
 
 {- Commits the index into the specified branch (or other ref), 
  - with the specified parent refs, and returns the committed sha.
@@ -162,7 +171,7 @@ commitCommand' runner commitmode ps = runner $
  - one parent, and it has the same tree that would be committed.
  -
  - Unlike git-commit, does not run any hooks, or examine the work tree
- - in any way.
+ - in any way, or output a summary.
  -}
 commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)
 commit commitmode allowempty message branch parentrefs repo = do

Git/CatFile.hs

@@ -1,6 +1,6 @@
 {- git cat-file interface
  -
- - Copyright 2011-2020 Joey Hess <[email protected]>
+ - Copyright 2011-2021 Joey Hess <[email protected]>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -10,9 +10,13 @@
 
 module Git.CatFile (
  CatFileHandle,
+ CatFileMetaDataHandle,
  catFileStart,
+ catFileMetaDataStart,
  catFileStart',
+ catFileMetaDataStart',
  catFileStop,
+ catFileMetaDataStop,
  catFile,
  catFileDetails,
  catTree,
@@ -55,31 +59,44 @@ import Utility.Tuple
 
 data CatFileHandle = CatFileHandle 
  { catFileProcess :: CoProcess.CoProcessHandle
- , checkFileProcess :: CoProcess.CoProcessHandle
- , gitRepo :: Repo
+ , catFileGitRepo :: Repo
+ }
+
+data CatFileMetaDataHandle = CatFileMetaDataHandle
+ { checkFileProcess :: CoProcess.CoProcessHandle
+ , checkFileGitRepo :: Repo
  }
 
 catFileStart :: Repo -> IO CatFileHandle
 catFileStart = catFileStart' True
 
 catFileStart' :: Bool -> Repo -> IO CatFileHandle
 catFileStart' restartable repo = CatFileHandle
- <$> startp "--batch"
- <*> startp ("--batch-check=" ++ batchFormat)
+ <$> startcat restartable repo "--batch"
+ <*> pure repo
+
+catFileMetaDataStart :: Repo -> IO CatFileMetaDataHandle
+catFileMetaDataStart = catFileMetaDataStart' True
+
+catFileMetaDataStart' :: Bool -> Repo -> IO CatFileMetaDataHandle
+catFileMetaDataStart' restartable repo = CatFileMetaDataHandle
+ <$> startcat restartable repo ("--batch-check=" ++ batchFormat)
  <*> pure repo
- where
- startp p = gitCoProcessStart restartable
- [ Param "cat-file"
- , Param p
- ] repo
 
 batchFormat :: String
 batchFormat = "%(objectname) %(objecttype) %(objectsize)"
 
+startcat :: Bool -> Repo -> String -> IO CoProcess.CoProcessHandle
+startcat restartable repo p = gitCoProcessStart restartable
+ [ Param "cat-file"
+ , Param p
+ ] repo
+
 catFileStop :: CatFileHandle -> IO ()
-catFileStop h = do
- CoProcess.stop (catFileProcess h)
- CoProcess.stop (checkFileProcess h)
+catFileStop = CoProcess.stop . catFileProcess
+
+catFileMetaDataStop :: CatFileMetaDataHandle -> IO ()
+catFileMetaDataStop = CoProcess.stop . checkFileProcess
 
 {- Reads a file from a specified branch. -}
 catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString
@@ -106,16 +123,16 @@ catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \f
  Nothing -> error $ "unknown response from git cat-file " ++ show (header, object)
  where
  -- Slow fallback path for filenames containing newlines.
- newlinefallback = queryObjectType object (gitRepo h) >>= \case
+ newlinefallback = queryObjectType object (catFileGitRepo h) >>= \case
  Nothing -> return Nothing
- Just objtype -> queryContent object (gitRepo h) >>= \case
+ Just objtype -> queryContent object (catFileGitRepo h) >>= \case
  Nothing -> return Nothing
  Just content -> do
  -- only the --batch interface allows getting
  -- the sha, so have to re-hash the object
  sha <- hashObject' objtype
  (flip L.hPut content)
- (gitRepo h)
+ (catFileGitRepo h)
  return (Just (content, sha, objtype))
 
 readObjectContent :: Handle -> ParsedResp -> IO L.ByteString
@@ -131,7 +148,7 @@ readObjectContent h (ParsedResp _ _ size) = do
 readObjectContent _ DNE = error "internal"
 
 {- Gets the size and type of an object, without reading its content. -}
-catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType))
+catObjectMetaData :: CatFileMetaDataHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType))
 catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do
  resp <- S8.hGetLine from
  case parseResp object resp of
@@ -142,9 +159,9 @@ catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $
  where
  -- Slow fallback path for filenames containing newlines.
  newlinefallback = do
- sha <- Git.Ref.sha object (gitRepo h)
- sz <- querySize object (gitRepo h)
- objtype <- queryObjectType object (gitRepo h)
+ sha <- Git.Ref.sha object (checkFileGitRepo h)
+ sz <- querySize object (checkFileGitRepo h)
+ objtype <- queryObjectType object (checkFileGitRepo h)
  return $ (,,) <$> sha <*> sz <*> objtype
 
 data ParsedResp = ParsedResp Sha ObjectType FileSize | DNE

Git/Command.hs

@@ -39,7 +39,7 @@ runBool params repo = assertLocal repo $
 run :: [CommandParam] -> Repo -> IO ()
 run params repo = assertLocal repo $
  unlessM (runBool params repo) $
- error $ "git " ++ show params ++ " failed"
+ giveup $ "git " ++ show params ++ " failed"
 
 {- Runs git and forces it to be quiet, throwing an error if it fails. -}
 runQuiet :: [CommandParam] -> Repo -> IO ()

Git/Config.hs

@@ -170,7 +170,7 @@ parse s st
 
 {- Checks if a string from git config is a true/false value. -}
 isTrueFalse :: String -> Maybe Bool
-isTrueFalse = isTrueFalse' . ConfigValue . encodeBS'
+isTrueFalse = isTrueFalse' . ConfigValue . encodeBS
 
 isTrueFalse' :: ConfigValue -> Maybe Bool
 isTrueFalse' (ConfigValue s)
@@ -241,15 +241,23 @@ fromFile r f = fromPipe r "git"
  , Param "--list"
  ] ConfigList
 
+{- Changes a git config setting in .git/config. -}
+change :: ConfigKey -> S.ByteString -> Repo -> IO Bool
+change (ConfigKey k) v = Git.Command.runBool
+ [ Param "config"
+ , Param (decodeBS k)
+ , Param (decodeBS v)
+ ]
+
 {- Changes a git config setting in the specified config file.
  - (Creates the file if it does not already exist.) -}
 changeFile :: FilePath -> ConfigKey -> S.ByteString -> IO Bool
 changeFile f (ConfigKey k) v = boolSystem "git"
  [ Param "config"
  , Param "--file"
  , File f
- , Param (decodeBS' k)
- , Param (decodeBS' v)
+ , Param (decodeBS k)
+ , Param (decodeBS v)
  ]
 
 {- Unsets a git config setting, in both the git repo,
@@ -264,4 +272,4 @@ unset ck@(ConfigKey k) r = ifM (Git.Command.runBool ps r)
  , return Nothing
  )
  where
- ps = [Param "config", Param "--unset-all", Param (decodeBS' k)]
+ ps = [Param "config", Param "--unset-all", Param (decodeBS k)]

Git/Construct.hs

@@ -184,7 +184,10 @@ expandTilde :: FilePath -> IO FilePath
 #ifdef mingw32_HOST_OS
 expandTilde = return
 #else
-expandTilde = expandt True
+expandTilde p = expandt True p
+ -- If unable to expand a tilde, eg due to a user not existing,
+ -- use the path as given.
+ `catchNonAsync` (const (return p))
  where
  expandt _ [] = return ""
  expandt _ ('/':cs) = do

Git/LsFiles.hs

@@ -5,6 +5,8 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE OverloadedStrings #-}
+
 module Git.LsFiles (
  Options(..),
  inRepo,
@@ -66,7 +68,7 @@ safeForLsFiles r = isNothing (remoteName r)
 guardSafeForLsFiles :: Repo -> IO a -> IO a
 guardSafeForLsFiles r a
  | safeForLsFiles r = a
- | otherwise = error $ "git ls-files is unsafe to run on repository " ++ repoDescribe r
+ | otherwise = giveup $ "git ls-files is unsafe to run on repository " ++ repoDescribe r
 
 data Options = ErrorUnmatch
 
@@ -236,7 +238,14 @@ data Unmerged = Unmerged
  { unmergedFile :: RawFilePath
  , unmergedTreeItemType :: Conflicting TreeItemType
  , unmergedSha :: Conflicting Sha
- }
+ , unmergedSiblingFile :: Maybe RawFilePath
+ -- ^ Normally this is Nothing, because a
+ -- merge conflict is represented as a single file with two
+ -- stages. However, git resolvers sometimes choose to stage
+ -- two files, one for each side of the merge conflict. In such a case,
+ -- this is used for the name of the second file, which is related
+ -- to the first file. (Eg, "foo" and "foo~ref")
+ } deriving (Show)
 
 {- Returns a list of the files in the specified locations that have
  - unresolved merge conflicts.
@@ -246,12 +255,12 @@ data Unmerged = Unmerged
  - 1 = old version, can be ignored
  - 2 = us
  - 3 = them
- - If a line is omitted, that side removed the file.
+ - If line 2 or 3 is omitted, that side removed the file.
  -}
 unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool)
 unmerged l repo = guardSafeForLsFiles repo $ do
  (fs, cleanup) <- pipeNullSplit params repo
- return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup)
+ return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL) fs, cleanup)
  where
  params = 
  Param "ls-files" :
@@ -265,7 +274,7 @@ data InternalUnmerged = InternalUnmerged
  , ifile :: RawFilePath
  , itreeitemtype :: Maybe TreeItemType
  , isha :: Maybe Sha
- }
+ } deriving (Show)
 
 parseUnmerged :: String -> Maybe InternalUnmerged
 parseUnmerged s
@@ -277,7 +286,7 @@ parseUnmerged s
  then Nothing
  else do
  treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype)
- sha <- extractSha (encodeBS' rawsha)
+ sha <- extractSha (encodeBS rawsha)
  return $ InternalUnmerged (stage == 2) (toRawFilePath file)
  (Just treeitemtype) (Just sha)
  _ -> Nothing
@@ -296,16 +305,25 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest
  { unmergedFile = ifile i
  , unmergedTreeItemType = Conflicting treeitemtypeA treeitemtypeB
  , unmergedSha = Conflicting shaA shaB
+ , unmergedSiblingFile = if ifile sibi == ifile i
+ then Nothing
+ else Just (ifile sibi)
  }
  findsib templatei [] = ([], removed templatei)
  findsib templatei (l:ls)
- | ifile l == ifile templatei = (ls, l)
+ | ifile l == ifile templatei || issibfile templatei l = (ls, l)
  | otherwise = (l:ls, removed templatei)
  removed templatei = templatei
  { isus = not (isus templatei)
  , itreeitemtype = Nothing
  , isha = Nothing
  }
+ -- foo~<ref> are unmerged sibling files of foo
+ -- Some versions or resolvers of git stage the sibling files,
+ -- other versions or resolvers do not.
+ issibfile x y = (ifile x <> "~") `S.isPrefixOf` ifile y
+ && isus x || isus y
+ && not (isus x && isus y)
 
 {- Gets the InodeCache equivilant information stored in the git index.
  -

Git/LsTree.hs

@@ -149,7 +149,7 @@ parserLsTree long = case long of
  - generated, so any size information is not included. -}
 formatLsTree :: TreeItem -> S.ByteString
 formatLsTree ti = S.intercalate (S.singleton (fromIntegral (ord ' ')))
- [ encodeBS' (showOct (mode ti) "")
+ [ encodeBS (showOct (mode ti) "")
  , typeobj ti
  , fromRef' (sha ti)
  ] <> (S.cons (fromIntegral (ord '\t')) (getTopFilePath (file ti)))