From c244daa32328f478bbf38a79f2fcacb138a1049f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 4 May 2022 11:40:38 -0400 Subject: merge from git-annex --- CHANGELOG | 4 +- COPYRIGHT | 4 +- Git/Branch.hs | 19 ++++-- Git/CatFile.hs | 57 ++++++++++------ Git/Command.hs | 2 +- Git/Config.hs | 16 +++-- Git/Construct.hs | 5 +- Git/LsFiles.hs | 32 +++++++-- Git/LsTree.hs | 2 +- Git/Ref.hs | 33 ++++++---- Git/Remote.hs | 4 +- Git/Types.hs | 10 +-- Git/UpdateIndex.hs | 4 +- Utility/CopyFile.hs | 18 ++++- Utility/Data.hs | 18 ++++- Utility/Debug.hs | 4 +- Utility/FileSystemEncoding.hs | 148 +++++++----------------------------------- Utility/HumanNumber.hs | 10 ++- Utility/InodeCache.hs | 9 +-- Utility/Metered.hs | 52 +++++++++++++-- Utility/Path.hs | 48 +++++++++++++- Utility/Tmp.hs | 18 ++++- Utility/Tmp/Dir.hs | 8 ++- git-repair.cabal | 12 ++-- 24 files changed, 312 insertions(+), 225 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 3d0ca96..737693b 100644 --- a/CHANGELOG +++ b/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 Wed, 04 May 2022 11:33:48 -0400 + -- Joey Hess Wed, 04 May 2022 11:43:15 -0400 git-repair (1.20210629) unstable; urgency=medium diff --git a/COPYRIGHT b/COPYRIGHT index cbd1cdc..08fb2ea 100644 --- a/COPYRIGHT +++ b/COPYRIGHT @@ -2,11 +2,11 @@ Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ Source: git://git-repair.branchable.com/ Files: * -Copyright: © 2013-2019 Joey Hess +Copyright: © 2013-2022 Joey Hess License: AGPL-3+ Files: Utility/* -Copyright: 2012-2014 Joey Hess +Copyright: 2012-2022 Joey Hess License: BSD-2-clause Files: Utility/Attoparsec.hs diff --git a/Git/Branch.hs b/Git/Branch.hs index 54af101..f30e357 100644 --- a/Git/Branch.hs +++ b/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 diff --git a/Git/CatFile.hs b/Git/CatFile.hs index b9f8305..f33ad49 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -1,6 +1,6 @@ {- git cat-file interface - - - Copyright 2011-2020 Joey Hess + - Copyright 2011-2021 Joey Hess - - 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,8 +59,12 @@ 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 @@ -64,22 +72,31 @@ 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 diff --git a/Git/Command.hs b/Git/Command.hs index 2358b17..894f6ae 100644 --- a/Git/Command.hs +++ b/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 () diff --git a/Git/Config.hs b/Git/Config.hs index 20ddf79..5deba6b 100644 --- a/Git/Config.hs +++ b/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,6 +241,14 @@ 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 @@ -248,8 +256,8 @@ 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)] diff --git a/Git/Construct.hs b/Git/Construct.hs index c013eb2..a5e825e 100644 --- a/Git/Construct.hs +++ b/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 diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index 297c068..cc824f2 100644 --- a/Git/LsFiles.hs +++ b/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~ 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. - diff --git a/Git/LsTree.hs b/Git/LsTree.hs index a49c4ea..fb3b3e1 100644 --- a/Git/LsTree.hs +++ b/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))) diff --git a/Git/Ref.hs b/Git/Ref.hs index 6929a8e..2d2874a 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -64,17 +64,21 @@ branchRef = underBase "refs/heads" {- A Ref that can be used to refer to a file in the repository, as staged - in the index. + - + - If the input file is located outside the repository, returns Nothing. -} -fileRef :: RawFilePath -> IO Ref -fileRef f = do +fileRef :: RawFilePath -> Repo -> IO (Maybe Ref) +fileRef f repo = do -- The filename could be absolute, or contain eg "../repo/file", -- neither of which work in a ref, so convert it to a minimal -- relative path. f' <- relPathCwdToFile f - -- Prefixing the file with ./ makes this work even when in a - -- subdirectory of a repo. Eg, ./foo in directory bar refers - -- to bar/foo, not to foo in the top of the repository. - return $ Ref $ ":./" <> toInternalGitPath f' + return $ if repoPath repo `dirContains` f' + -- Prefixing the file with ./ makes this work even when in a + -- subdirectory of a repo. Eg, ./foo in directory bar refers + -- to bar/foo, not to foo in the top of the repository. + then Just $ Ref $ ":./" <> toInternalGitPath f' + else Nothing {- A Ref that can be used to refer to a file in a particular branch. -} branchFileRef :: Branch -> RawFilePath -> Ref @@ -82,14 +86,17 @@ branchFileRef branch f = Ref $ fromRef' branch <> ":" <> toInternalGitPath f {- Converts a Ref to refer to the content of the Ref on a given date. -} dateRef :: Ref -> RefDate -> Ref -dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS' d +dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS d {- A Ref that can be used to refer to a file in the repository as it - - appears in a given Ref. -} -fileFromRef :: Ref -> RawFilePath -> IO Ref -fileFromRef r f = do - (Ref fr) <- fileRef f - return (Ref (fromRef' r <> fr)) + - appears in a given Ref. + - + - If the file path is located outside the repository, returns Nothing. + -} +fileFromRef :: Ref -> RawFilePath -> Repo -> IO (Maybe Ref) +fileFromRef r f repo = fileRef f repo >>= return . \case + Just (Ref fr) -> Just (Ref (fromRef' r <> fr)) + Nothing -> Nothing {- Checks if a ref exists. Note that it must be fully qualified, - eg refs/heads/master rather than master. -} @@ -177,7 +184,7 @@ tree (Ref ref) = extractSha <$$> pipeReadStrict [ Param "rev-parse" , Param "--verify" , Param "--quiet" - , Param (decodeBS' ref') + , Param (decodeBS ref') ] where ref' = if ":" `S.isInfixOf` ref diff --git a/Git/Remote.hs b/Git/Remote.hs index 8f5d99f..80accca 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -37,7 +37,7 @@ remoteKeyToRemoteName :: ConfigKey -> Maybe RemoteName remoteKeyToRemoteName (ConfigKey k) | "remote." `S.isPrefixOf` k = let n = S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k - in if S.null n then Nothing else Just (decodeBS' n) + in if S.null n then Nothing else Just (decodeBS n) | otherwise = Nothing {- Construct a legal git remote name out of an arbitrary input string. @@ -90,7 +90,7 @@ parseRemoteLocation s repo = ret $ calcloc s | null insteadofs = l | otherwise = replacement ++ drop (S.length bestvalue) l where - replacement = decodeBS' $ S.drop (S.length prefix) $ + replacement = decodeBS $ S.drop (S.length prefix) $ S.take (S.length bestkey - S.length suffix) bestkey (bestkey, bestvalue) = case maximumBy longestvalue insteadofs of diff --git a/Git/Types.hs b/Git/Types.hs index db1c71b..68045fc 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -75,7 +75,7 @@ instance Default ConfigValue where def = ConfigValue mempty fromConfigKey :: ConfigKey -> String -fromConfigKey (ConfigKey s) = decodeBS' s +fromConfigKey (ConfigKey s) = decodeBS s instance Show ConfigKey where show = fromConfigKey @@ -88,16 +88,16 @@ instance FromConfigValue S.ByteString where fromConfigValue NoConfigValue = mempty instance FromConfigValue String where - fromConfigValue = decodeBS' . fromConfigValue + fromConfigValue = decodeBS . fromConfigValue instance Show ConfigValue where show = fromConfigValue instance IsString ConfigKey where - fromString = ConfigKey . encodeBS' + fromString = ConfigKey . encodeBS instance IsString ConfigValue where - fromString = ConfigValue . encodeBS' + fromString = ConfigValue . encodeBS type RemoteName = String @@ -106,7 +106,7 @@ newtype Ref = Ref S.ByteString deriving (Eq, Ord, Read, Show) fromRef :: Ref -> String -fromRef = decodeBS' . fromRef' +fromRef = decodeBS . fromRef' fromRef' :: Ref -> S.ByteString fromRef' (Ref s) = s diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 8e406b1..74816a6 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -80,14 +80,14 @@ lsTree (Ref x) repo streamer = do mapM_ streamer s void $ cleanup where - params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS' x] + params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS 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", decodeBS' x, p] + params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x, p] {- Generates a line suitable to be fed into update-index, to add - a given file with a given sha. -} diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs index f851326..9c93e70 100644 --- a/Utility/CopyFile.hs +++ b/Utility/CopyFile.hs @@ -1,6 +1,6 @@ {- file copying - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2021 Joey Hess - - License: BSD-2-clause -} @@ -30,6 +30,12 @@ copyMetaDataParams meta = map snd $ filter fst , Param "-p") , (not allmeta && BuildInfo.cp_preserve_timestamps , Param "--preserve=timestamps") + -- cp -a may preserve xattrs that have special meaning, + -- eg to NFS, and have even been observed to prevent later + -- changing the permissions of the file. So prevent preserving + -- xattrs. + , (allmeta && BuildInfo.cp_a && BuildInfo.cp_no_preserve_xattr_supported + , Param "--no-preserve=xattr") ] where allmeta = meta == CopyAllMetaData @@ -50,11 +56,17 @@ copyFileExternal meta src dest = do | otherwise = copyMetaDataParams meta {- When a filesystem supports CoW (and cp does), uses it to make - - an efficient copy of a file. Otherwise, returns False. -} + - an efficient copy of a file. Otherwise, returns False. + - + - The dest file must not exist yet, or it will fail to make a CoW copy, + - and will return False. + - + - Note that in coreutil 9.0, cp uses CoW by default, without needing an + - option. This code is only needed to support older versions. + -} copyCoW :: CopyMetaData -> FilePath -> FilePath -> IO Bool copyCoW meta src dest | BuildInfo.cp_reflink_supported = do - void $ tryIO $ removeFile dest -- When CoW is not supported, cp will complain to stderr, -- so have to discard its stderr. ok <- catchBoolIO $ withNullHandle $ \nullh -> diff --git a/Utility/Data.hs b/Utility/Data.hs index 5510845..faf9b34 100644 --- a/Utility/Data.hs +++ b/Utility/Data.hs @@ -1,6 +1,6 @@ {- utilities for simple data types - - - Copyright 2013 Joey Hess + - Copyright 2013-2021 Joey Hess - - License: BSD-2-clause -} @@ -10,8 +10,12 @@ module Utility.Data ( firstJust, eitherToMaybe, + s2w8, + w82s, ) where +import Data.Word + {- First item in the list that is not Nothing. -} firstJust :: Eq a => [Maybe a] -> Maybe a firstJust ms = case dropWhile (== Nothing) ms of @@ -20,3 +24,15 @@ firstJust ms = case dropWhile (== Nothing) ms of eitherToMaybe :: Either a b -> Maybe b eitherToMaybe = either (const Nothing) Just + +c2w8 :: Char -> Word8 +c2w8 = fromIntegral . fromEnum + +w82c :: Word8 -> Char +w82c = toEnum . fromIntegral + +s2w8 :: String -> [Word8] +s2w8 = map c2w8 + +w82s :: [Word8] -> String +w82s = map w82c diff --git a/Utility/Debug.hs b/Utility/Debug.hs index e0be9c9..6e6e701 100644 --- a/Utility/Debug.hs +++ b/Utility/Debug.hs @@ -34,7 +34,7 @@ newtype DebugSource = DebugSource S.ByteString deriving (Eq, Show) instance IsString DebugSource where - fromString = DebugSource . encodeBS' + fromString = DebugSource . encodeBS -- | Selects whether to display a message from a source. data DebugSelector @@ -97,6 +97,6 @@ fastDebug (DebugSelector p) src msg formatDebugMessage :: DebugSource -> String -> IO S.ByteString formatDebugMessage (DebugSource src) msg = do - t <- encodeBS' . formatTime defaultTimeLocale "[%F %X%Q]" + t <- encodeBS . formatTime defaultTimeLocale "[%F %X%Q]" <$> getZonedTime return (t <> " (" <> src <> ") " <> encodeBS msg) diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index 1f7c76b..2a1dc81 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -1,6 +1,6 @@ {- GHC File system encoding handling. - - - Copyright 2012-2016 Joey Hess + - Copyright 2012-2021 Joey Hess - - License: BSD-2-clause -} @@ -11,7 +11,6 @@ module Utility.FileSystemEncoding ( useFileSystemEncoding, fileEncoding, - withFilePath, RawFilePath, fromRawFilePath, toRawFilePath, @@ -19,36 +18,22 @@ module Utility.FileSystemEncoding ( encodeBL, decodeBS, encodeBS, - decodeBL', - encodeBL', - decodeBS', - encodeBS', truncateFilePath, - s2w8, - w82s, - c2w8, - w82c, ) where import qualified GHC.Foreign as GHC import qualified GHC.IO.Encoding as Encoding -import Foreign.C import System.IO import System.IO.Unsafe -import Data.Word import System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import Data.ByteString.Unsafe (unsafePackMallocCStringLen) #ifdef mingw32_HOST_OS import qualified Data.ByteString.UTF8 as S8 import qualified Data.ByteString.Lazy.UTF8 as L8 -#else -import Data.List -import Utility.Split #endif -import Utility.Exception - {- Makes all subsequent Handles that are opened, as well as stdio Handles, - use the filesystem encoding, instead of the encoding of the current - locale. @@ -81,40 +66,10 @@ fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding fileEncoding h = hSetEncoding h Encoding.utf8 #endif -{- Marshal a Haskell FilePath into a NUL terminated C string using temporary - - storage. The FilePath is encoded using the filesystem encoding, - - reversing the decoding that should have been done when the FilePath - - was obtained. -} -withFilePath :: FilePath -> (CString -> IO a) -> IO a -withFilePath fp f = Encoding.getFileSystemEncoding - >>= \enc -> GHC.withCString enc fp f - -{- Encodes a FilePath into a String, applying the filesystem encoding. - - - - There are very few things it makes sense to do with such an encoded - - string. It's not a legal filename; it should not be displayed. - - So this function is not exported, but instead used by the few functions - - that can usefully consume it. - - - - This use of unsafePerformIO is belived to be safe; GHC's interface - - only allows doing this conversion with CStrings, and the CString buffer - - is allocated, used, and deallocated within the call, with no side - - effects. - - - - If the FilePath contains a value that is not legal in the filesystem - - encoding, rather than thowing an exception, it will be returned as-is. - -} -{-# NOINLINE _encodeFilePath #-} -_encodeFilePath :: FilePath -> String -_encodeFilePath fp = unsafePerformIO $ do - enc <- Encoding.getFileSystemEncoding - GHC.withCString enc fp (GHC.peekCString Encoding.char8) - `catchNonAsync` (\_ -> return fp) - {- Decodes a ByteString into a FilePath, applying the filesystem encoding. -} decodeBL :: L.ByteString -> FilePath #ifndef mingw32_HOST_OS -decodeBL = encodeW8NUL . L.unpack +decodeBL = decodeBS . L.toStrict #else {- On Windows, we assume that the ByteString is utf-8, since Windows - only uses unicode for filenames. -} @@ -124,104 +79,45 @@ decodeBL = L8.toString {- Encodes a FilePath into a ByteString, applying the filesystem encoding. -} encodeBL :: FilePath -> L.ByteString #ifndef mingw32_HOST_OS -encodeBL = L.pack . decodeW8NUL +encodeBL = L.fromStrict . encodeBS #else encodeBL = L8.fromString #endif decodeBS :: S.ByteString -> FilePath #ifndef mingw32_HOST_OS -decodeBS = encodeW8NUL . S.unpack +-- This does the same thing as System.FilePath.ByteString.decodeFilePath, +-- with an identical implementation. However, older versions of that library +-- truncated at NUL, which this must not do, because it may end up used on +-- something other than a unix filepath. +{-# NOINLINE decodeBS #-} +decodeBS b = unsafePerformIO $ do + enc <- Encoding.getFileSystemEncoding + S.useAsCStringLen b (GHC.peekCStringLen enc) #else decodeBS = S8.toString #endif encodeBS :: FilePath -> S.ByteString #ifndef mingw32_HOST_OS -encodeBS = S.pack . decodeW8NUL +-- This does the same thing as System.FilePath.ByteString.encodeFilePath, +-- with an identical implementation. However, older versions of that library +-- truncated at NUL, which this must not do, because it may end up used on +-- something other than a unix filepath. +{-# NOINLINE encodeBS #-} +encodeBS f = unsafePerformIO $ do + enc <- Encoding.getFileSystemEncoding + GHC.newCStringLen enc f >>= unsafePackMallocCStringLen #else encodeBS = S8.fromString #endif -{- Faster version that assumes the string does not contain NUL; - - if it does it will be truncated before the NUL. -} -decodeBS' :: S.ByteString -> FilePath -#ifndef mingw32_HOST_OS -decodeBS' = encodeW8 . S.unpack -#else -decodeBS' = S8.toString -#endif - -encodeBS' :: FilePath -> S.ByteString -#ifndef mingw32_HOST_OS -encodeBS' = S.pack . decodeW8 -#else -encodeBS' = S8.fromString -#endif - -decodeBL' :: L.ByteString -> FilePath -#ifndef mingw32_HOST_OS -decodeBL' = encodeW8 . L.unpack -#else -decodeBL' = L8.toString -#endif - -encodeBL' :: FilePath -> L.ByteString -#ifndef mingw32_HOST_OS -encodeBL' = L.pack . decodeW8 -#else -encodeBL' = L8.fromString -#endif - fromRawFilePath :: RawFilePath -> FilePath fromRawFilePath = decodeFilePath toRawFilePath :: FilePath -> RawFilePath toRawFilePath = encodeFilePath -#ifndef mingw32_HOST_OS -{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding. - - - - w82s produces a String, which may contain Chars that are invalid - - unicode. From there, this is really a simple matter of applying the - - file system encoding, only complicated by GHC's interface to doing so. - - - - Note that the encoding stops at any NUL in the input. FilePaths - - cannot contain embedded NUL, but Haskell Strings may. - -} -{-# NOINLINE encodeW8 #-} -encodeW8 :: [Word8] -> FilePath -encodeW8 w8 = unsafePerformIO $ do - enc <- Encoding.getFileSystemEncoding - GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc - -decodeW8 :: FilePath -> [Word8] -decodeW8 = s2w8 . _encodeFilePath - -{- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -} -encodeW8NUL :: [Word8] -> FilePath -encodeW8NUL = intercalate [nul] . map encodeW8 . splitc (c2w8 nul) - where - nul = '\NUL' - -decodeW8NUL :: FilePath -> [Word8] -decodeW8NUL = intercalate [c2w8 nul] . map decodeW8 . splitc nul - where - nul = '\NUL' -#endif - -c2w8 :: Char -> Word8 -c2w8 = fromIntegral . fromEnum - -w82c :: Word8 -> Char -w82c = toEnum . fromIntegral - -s2w8 :: String -> [Word8] -s2w8 = map c2w8 - -w82s :: [Word8] -> String -w82s = map w82c - {- Truncates a FilePath to the given number of bytes (or less), - as represented on disk. - @@ -233,8 +129,8 @@ truncateFilePath :: Int -> FilePath -> FilePath truncateFilePath n = go . reverse where go f = - let bytes = decodeW8 f - in if length bytes <= n + let b = encodeBS f + in if S.length b <= n then reverse f else go (drop 1 f) #else diff --git a/Utility/HumanNumber.hs b/Utility/HumanNumber.hs index 6143cef..04a18b0 100644 --- a/Utility/HumanNumber.hs +++ b/Utility/HumanNumber.hs @@ -1,6 +1,6 @@ {- numbers for humans - - - Copyright 2012-2013 Joey Hess + - Copyright 2012-2021 Joey Hess - - License: BSD-2-clause -} @@ -11,11 +11,15 @@ module Utility.HumanNumber (showImprecise) where - of decimal digits. -} showImprecise :: RealFrac a => Int -> a -> String showImprecise precision n - | precision == 0 || remainder == 0 = show (round n :: Integer) - | otherwise = show int ++ "." ++ striptrailing0s (pad0s $ show remainder) + | precision == 0 || remainder' == 0 = show (round n :: Integer) + | otherwise = show int' ++ "." ++ striptrailing0s (pad0s $ show remainder') where int :: Integer (int, frac) = properFraction n remainder = round (frac * 10 ^ precision) :: Integer + (int', remainder') + -- carry the 1 + | remainder == 10 ^ precision = (int + 1, 0) + | otherwise = (int, remainder) pad0s s = replicate (precision - length s) '0' ++ s striptrailing0s = reverse . dropWhile (== '0') . reverse diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs index 9a21c63..b697ab3 100644 --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -55,7 +55,7 @@ import Data.Time.Clock.POSIX #ifdef mingw32_HOST_OS import Data.Word (Word64) #else -import System.Posix.Files +import qualified System.Posix.Files as Posix #endif data InodeCachePrim = InodeCachePrim FileID FileSize MTime @@ -200,7 +200,7 @@ toInodeCache' (TSDelta getdelta) f s inode #ifdef mingw32_HOST_OS mtime <- utcTimeToPOSIXSeconds <$> getModificationTime (fromRawFilePath f) #else - let mtime = modificationTimeHiRes s + let mtime = Posix.modificationTimeHiRes s #endif return $ Just $ InodeCache $ InodeCachePrim inode sz (MTimeHighRes (mtime + highResTime delta)) | otherwise = pure Nothing @@ -300,11 +300,6 @@ instance Arbitrary MTime where , (50, MTimeHighRes <$> arbitrary) ] -#ifdef mingw32_HOST_OS -instance Arbitrary FileID where - arbitrary = fromIntegral <$> (arbitrary :: Gen Word64) -#endif - prop_read_show_inodecache :: InodeCache -> Bool prop_read_show_inodecache c = case readInodeCache (showInodeCache c) of Nothing -> False diff --git a/Utility/Metered.hs b/Utility/Metered.hs index a7c9c37..8fd9c9b 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -37,6 +37,7 @@ module Utility.Metered ( demeterCommandEnv, avoidProgress, rateLimitMeterUpdate, + bwLimitMeterUpdate, Meter, mkMeter, setMeterTotalSize, @@ -51,6 +52,7 @@ import Utility.Percentage import Utility.DataUnits import Utility.HumanTime import Utility.SimpleProtocol as Proto +import Utility.ThreadScheduler import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S @@ -380,6 +382,46 @@ rateLimitMeterUpdate delta (Meter totalsizev _ _ _) meterupdate = do meterupdate n else putMVar lastupdate prev +-- | Bandwidth limiting by inserting a delay at the point that a meter is +-- updated. +-- +-- This will only work when the actions that use bandwidth are run in the +-- same process and thread as the call to the MeterUpdate. +-- +-- For example, if the desired bandwidth is 100kb/s, and over the past +-- 1/10th of a second, 30kb was sent, then the current bandwidth is +-- 300kb/s, 3x as fast as desired. So, after getting the next chunk, +-- pause for twice as long as it took to get it. +bwLimitMeterUpdate :: ByteSize -> Duration -> MeterUpdate -> IO MeterUpdate +bwLimitMeterUpdate bwlimit duration meterupdate + | bwlimit <= 0 = return meterupdate + | otherwise = do + nowtime <- getPOSIXTime + mv <- newMVar (nowtime, Nothing) + return (mu mv) + where + mu mv n@(BytesProcessed i) = do + endtime <- getPOSIXTime + (starttime, mprevi) <- takeMVar mv + + case mprevi of + Just previ -> do + let runtime = endtime - starttime + let currbw = fromIntegral (i - previ) / runtime + let pausescale = if currbw > bwlimit' + then (currbw / bwlimit') - 1 + else 0 + unboundDelay (floor (runtime * pausescale * msecs)) + Nothing -> return () + + meterupdate n + + nowtime <- getPOSIXTime + putMVar mv (nowtime, Just i) + + bwlimit' = fromIntegral (bwlimit * durationSeconds duration) + msecs = fromIntegral oneSecond + data Meter = Meter (MVar (Maybe TotalSize)) (MVar MeterState) (MVar String) DisplayMeter data MeterState = MeterState @@ -417,12 +459,14 @@ updateMeter (Meter totalsizev sv bv displaymeter) new = do -- | Display meter to a Handle. displayMeterHandle :: Handle -> RenderMeter -> DisplayMeter displayMeterHandle h rendermeter v msize old new = do + olds <- takeMVar v let s = rendermeter msize old new - olds <- swapMVar v s + let padding = replicate (length olds - length s) ' ' + let s' = s <> padding + putMVar v s' -- Avoid writing when the rendered meter has not changed. - when (olds /= s) $ do - let padding = replicate (length olds - length s) ' ' - hPutStr h ('\r':s ++ padding) + when (olds /= s') $ do + hPutStr h ('\r':s') hFlush h -- | Clear meter displayed by displayMeterHandle. May be called before diff --git a/Utility/Path.hs b/Utility/Path.hs index cfda748..b5aeb16 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -95,13 +95,49 @@ upFrom dir dirContains :: RawFilePath -> RawFilePath -> Bool dirContains a b = a == b || a' == b' - || (addTrailingPathSeparator a') `B.isPrefixOf` b' - || a' == "." && normalise ("." b') == b' + || (a'' `B.isPrefixOf` b' && avoiddotdotb) + || a' == "." && normalise ("." b') == b' && nodotdot b' + || dotdotcontains where a' = norm a + a'' = addTrailingPathSeparator a' b' = norm b norm = normalise . simplifyPath + {- This handles the case where a is ".." and b is "../..", + - which is not inside a. Similarly, "../.." does not contain + - "../../../". Due to the use of norm, cases like + - "../../foo/../../" get converted to eg "../../.." and + - so do not need to be handled specially here. + - + - When this is called, we already know that + - a'' is a prefix of b', so all that needs to be done is drop + - that prefix, and check if the next path component is ".." + -} + avoiddotdotb = nodotdot $ B.drop (B.length a'') b' + + nodotdot p = all (not . isdotdot) (splitPath p) + + isdotdot s = dropTrailingPathSeparator s == ".." + + {- This handles the case where a is ".." or "../.." etc, + - and b is "foo" or "../foo" etc. The rule is that when + - a is entirely ".." components, b is under it when it starts + - with fewer ".." components. + - + - Due to the use of norm, cases like "../../foo/../../" get + - converted to eg "../../../" and so do not need to be handled + - specially here. + -} + dotdotcontains + | isAbsolute b' = False + | otherwise = + let aps = splitPath a' + bps = splitPath b' + in if all isdotdot aps + then length (takeWhile isdotdot bps) < length aps + else False + {- Given an original list of paths, and an expanded list derived from it, - which may be arbitrarily reordered, generates a list of lists, where - each sublist corresponds to one of the original paths. @@ -187,7 +223,13 @@ relPathDirToFileAbs from to dotdots = replicate (length pfrom - numcommon) ".." numcommon = length common #ifdef mingw32_HOST_OS - normdrive = map toLower . takeWhile (/= ':') . fromRawFilePath . takeDrive + normdrive = map toLower + -- Get just the drive letter, removing any leading + -- path separator, which takeDrive leaves on the drive + -- letter. + . dropWhileEnd (isPathSeparator . fromIntegral . ord) + . fromRawFilePath + . takeDrive #endif {- Checks if a command is available in PATH. diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index 5877f68..92bd921 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -14,6 +14,7 @@ module Utility.Tmp ( withTmpFile, withTmpFileIn, relatedTemplate, + openTmpFileIn, ) where import System.IO @@ -21,6 +22,7 @@ import System.FilePath import System.Directory import Control.Monad.IO.Class import System.PosixCompat.Files hiding (removeLink) +import System.IO.Error import Utility.Exception import Utility.FileSystemEncoding @@ -28,6 +30,18 @@ import Utility.FileMode type Template = String +{- This is the same as openTempFile, except when there is an + - error, it displays the template as well as the directory, + - to help identify what call was responsible. + -} +openTmpFileIn :: FilePath -> String -> IO (FilePath, Handle) +openTmpFileIn dir template = openTempFile dir template + `catchIO` decoraterrror + where + decoraterrror e = throwM $ + let loc = ioeGetLocation e ++ " template " ++ template + in annotateIOError e loc Nothing Nothing + {- Runs an action like writeFile, writing to a temp file first and - then moving it into place. The temp file is stored in the same - directory as the final file to avoid cross-device renames. @@ -43,7 +57,7 @@ viaTmp a file content = bracketIO setup cleanup use template = relatedTemplate (base ++ ".tmp") setup = do createDirectoryIfMissing True dir - openTempFile dir template + openTmpFileIn dir template cleanup (tmpfile, h) = do _ <- tryIO $ hClose h tryIO $ removeFile tmpfile @@ -73,7 +87,7 @@ withTmpFile template a = do withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a withTmpFileIn tmpdir template a = bracket create remove use where - create = liftIO $ openTempFile tmpdir template + create = liftIO $ openTmpFileIn tmpdir template remove (name, h) = liftIO $ do hClose h catchBoolIO (removeFile name >> return True) diff --git a/Utility/Tmp/Dir.hs b/Utility/Tmp/Dir.hs index c68ef86..904b65a 100644 --- a/Utility/Tmp/Dir.hs +++ b/Utility/Tmp/Dir.hs @@ -1,6 +1,6 @@ {- Temporary directories - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2022 Joey Hess - - License: BSD-2-clause -} @@ -63,8 +63,10 @@ removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do -- after a process has just written to it and exited. -- Because it's crap, presumably. So, ignore failure -- to delete the temp directory. - _ <- tryIO $ removeDirectoryRecursive tmpdir + _ <- tryIO $ go tmpdir return () #else - removeDirectoryRecursive tmpdir + go tmpdir #endif + where + go = removeDirectoryRecursive diff --git a/git-repair.cabal b/git-repair.cabal index ed3d68e..582821d 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -1,11 +1,11 @@ Name: git-repair -Version: 1.20210629 +Version: 1.20220404 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess Author: Joey Hess Stability: Stable -Copyright: 2013-2021 Joey Hess +Copyright: 2013-2022 Joey Hess License-File: COPYRIGHT Build-Type: Custom Homepage: http://git-repair.branchable.com/ @@ -26,9 +26,9 @@ Extra-Source-Files: git-repair.1 custom-setup - Setup-Depends: base (>= 4.11.1.0 && < 5.0), + Setup-Depends: base (>= 4.11.1.0), hslogger, split, unix-compat, process, unix, filepath, - filepath-bytestring (>= 1.4.2.1.1), async, + filepath-bytestring (>= 1.4.2.1.4), async, exceptions, bytestring, directory, IfElse, data-default, mtl, Cabal, time @@ -43,11 +43,11 @@ Executable git-repair Default-Extensions: LambdaCase Build-Depends: split, hslogger, directory, filepath, containers, mtl, unix-compat (>= 0.5), bytestring, exceptions (>= 0.6), transformers, - base (>= 4.11.1.0 && < 5.0), IfElse, text, process, time, QuickCheck, + base (>= 4.11.1.0), IfElse, text, process, time, QuickCheck, utf8-string, async, optparse-applicative (>= 0.14.1), data-default, deepseq, attoparsec, network-uri (>= 2.6), network (>= 2.6), - filepath-bytestring (>= 1.4.2.1.0), + filepath-bytestring (>= 1.4.2.1.4), time if (os(windows)) -- cgit v1.2.3