From 2db8167ddbfa080b44509d4532d7d34887cdc64a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 29 Jun 2021 13:28:25 -0400 Subject: merge from git-annex Fixes 2 bugs, one a data loss bug. It is possible to get those fixes without merging all the other changes, if a backport is wanted. --- Git/Branch.hs | 17 +++++++- Git/CatFile.hs | 2 +- Git/Command.hs | 12 +++--- Git/Construct.hs | 93 +++++++++++++++++++++------------------- Git/CurrentRepo.hs | 5 ++- Git/Env.hs | 52 +++++++++++++++++++++++ Git/LsTree.hs | 121 +++++++++++++++++++++++++++++++++-------------------- Git/Ref.hs | 24 +++++++---- Git/Remote.hs | 28 +++++++++---- Git/Repair.hs | 52 ++++++++++++++--------- Git/Types.hs | 1 + Git/Url.hs | 21 ++++------ 12 files changed, 278 insertions(+), 150 deletions(-) create mode 100644 Git/Env.hs (limited to 'Git') diff --git a/Git/Branch.hs b/Git/Branch.hs index fcae905..54af101 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -1,6 +1,6 @@ {- git branch stuff - - - Copyright 2011 Joey Hess + - Copyright 2011-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -166,7 +166,7 @@ commitCommand' runner commitmode ps = runner $ -} commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha) commit commitmode allowempty message branch parentrefs repo = do - tree <- getSha "write-tree" $ pipeReadStrict [Param "write-tree"] repo + tree <- writeTree repo ifM (cancommit tree) ( do sha <- commitTree commitmode message parentrefs tree repo @@ -185,6 +185,19 @@ commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha commitAlways commitmode message branch parentrefs repo = fromJust <$> commit commitmode True message branch parentrefs repo +-- Throws exception if the index is locked, with an error message output by +-- git on stderr. +writeTree :: Repo -> IO Sha +writeTree repo = getSha "write-tree" $ + pipeReadStrict [Param "write-tree"] repo + +-- Avoids error output if the command fails due to eg, the index being locked. +writeTreeQuiet :: Repo -> IO (Maybe Sha) +writeTreeQuiet repo = extractSha <$> withNullHandle go + where + go nullh = pipeReadStrict' (\p -> p { std_err = UseHandle nullh }) + [Param "write-tree"] repo + commitTree :: CommitMode -> String -> [Ref] -> Ref -> Repo -> IO Sha commitTree commitmode message parentrefs tree repo = getSha "commit-tree" $ diff --git a/Git/CatFile.hs b/Git/CatFile.hs index 6bea8c0..b9f8305 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -326,7 +326,7 @@ catObjectStream repo a = withCatFileStream False repo go (hClose hin) (catObjectReader readObjectContent c hout) feeder c h (v, ref) = do - liftIO $ writeChan c (ref, v) + writeChan c (ref, v) S8.hPutStrLn h (fromRef' ref) catObjectMetaDataStream diff --git a/Git/Command.hs b/Git/Command.hs index fef7eb9..2358b17 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -70,17 +70,15 @@ pipeReadLazy params repo = assertLocal repo $ do - Nonzero exit status is ignored. -} pipeReadStrict :: [CommandParam] -> Repo -> IO S.ByteString -pipeReadStrict = pipeReadStrict' S.hGetContents +pipeReadStrict = pipeReadStrict' id -{- The reader action must be strict. -} -pipeReadStrict' :: (Handle -> IO a) -> [CommandParam] -> Repo -> IO a -pipeReadStrict' reader params repo = assertLocal repo $ withCreateProcess p go +pipeReadStrict' :: (CreateProcess -> CreateProcess) -> [CommandParam] -> Repo -> IO S.ByteString +pipeReadStrict' fp params repo = assertLocal repo $ withCreateProcess p go where - p = (gitCreateProcess params repo) - { std_out = CreatePipe } + p = fp (gitCreateProcess params repo) { std_out = CreatePipe } go _ (Just outh) _ pid = do - output <- reader outh + output <- S.hGetContents outh hClose outh void $ waitForProcess pid return output diff --git a/Git/Construct.hs b/Git/Construct.hs index 8b63ac4..c013eb2 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -1,6 +1,6 @@ {- Construction of Git Repo objects - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -57,54 +57,58 @@ fromCwd = getCurrentDirectory >>= seekUp {- Local Repo constructor, accepts a relative or absolute path. -} fromPath :: RawFilePath -> IO Repo -fromPath dir = fromAbsPath =<< absPath dir +fromPath dir + -- When dir == "foo/.git", git looks for "foo/.git/.git", + -- and failing that, uses "foo" as the repository. + | (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir = + ifM (doesDirectoryExist $ fromRawFilePath dir ".git") + ( ret dir + , ret (P.takeDirectory canondir) + ) + | otherwise = ifM (doesDirectoryExist (fromRawFilePath dir)) + ( checkGitDirFile dir >>= maybe (ret dir) (pure . newFrom) + -- 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 + ) + where + ret = pure . newFrom . LocalUnknown + canondir = P.dropTrailingPathSeparator dir {- Local Repo constructor, requires an absolute path to the repo be - specified. -} fromAbsPath :: RawFilePath -> IO Repo fromAbsPath dir - | absoluteGitPath dir = hunt + | absoluteGitPath dir = fromPath dir | otherwise = error $ "internal error, " ++ show dir ++ " is not absolute" - where - ret = pure . newFrom . LocalUnknown - canondir = P.dropTrailingPathSeparator dir - {- When dir == "foo/.git", git looks for "foo/.git/.git", - - and failing that, uses "foo" as the repository. -} - hunt - | (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir = - ifM (doesDirectoryExist $ fromRawFilePath dir ".git") - ( ret dir - , ret (P.takeDirectory canondir) - ) - | otherwise = ifM (doesDirectoryExist (fromRawFilePath dir)) - ( checkGitDirFile dir >>= maybe (ret dir) (pure . newFrom) - -- 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. +{- Construct a Repo for a remote's url. - - Git is somewhat forgiving about urls to repositories, allowing - - eg spaces that are not normally allowed unescaped in urls. + - eg spaces that are not normally allowed unescaped in urls. Such + - characters get escaped. + - + - This will always succeed, even if the url cannot be parsed + - or is invalid, because git can also function despite remotes having + - such urls, only failing if such a remote is used. -} fromUrl :: String -> IO Repo fromUrl url - | not (isURI url) = fromUrlStrict $ escapeURIString isUnescapedInURI url - | otherwise = fromUrlStrict url + | not (isURI url) = fromUrl' $ escapeURIString isUnescapedInURI url + | otherwise = fromUrl' url -fromUrlStrict :: String -> IO Repo -fromUrlStrict url - | "file://" `isPrefixOf` url = fromAbsPath $ toRawFilePath $ - unEscapeString $ uriPath u - | otherwise = pure $ newFrom $ Url u - where - u = fromMaybe bad $ parseURI url - bad = error $ "bad url " ++ url +fromUrl' :: String -> IO Repo +fromUrl' url + | "file://" `isPrefixOf` url = case parseURI url of + Just u -> fromAbsPath $ toRawFilePath $ unEscapeString $ uriPath u + Nothing -> pure $ newFrom $ UnparseableUrl url + | otherwise = case parseURI url of + Just u -> pure $ newFrom $ Url u + Nothing -> pure $ newFrom $ UnparseableUrl url {- Creates a repo that has an unknown location. -} fromUnknown :: Repo @@ -116,24 +120,24 @@ 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 -> + | otherwise = case (Url.authority reference, Url.scheme reference) of + (Just auth, Just s) -> let absurl = concat - [ Url.scheme reference + [ s , "//" , auth , fromRawFilePath (repoPath r) ] in r { location = Url $ fromJust $ parseURI absurl } + _ -> r {- Calculates a list of a repo's configured remotes, by parsing its config. -} fromRemotes :: Repo -> IO [Repo] -fromRemotes repo = mapM construct remotepairs +fromRemotes repo = catMaybes <$> mapM construct remotepairs where filterconfig f = filter f $ M.toList $ config repo filterkeys f = filterconfig (\(k,_) -> f k) - remotepairs = filterkeys isRemoteKey + remotepairs = filterkeys isRemoteUrlKey construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation (fromConfigValue v) repo @@ -145,8 +149,10 @@ remoteNamed n constructor = do {- Sets the name of a remote based on the git config key, such as - "remote.foo.url". -} -remoteNamedFromKey :: ConfigKey -> IO Repo -> IO Repo -remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName +remoteNamedFromKey :: ConfigKey -> IO Repo -> IO (Maybe Repo) +remoteNamedFromKey k r = case remoteKeyToRemoteName k of + Nothing -> pure Nothing + Just n -> Just <$> remoteNamed n r {- Constructs a new Repo for one of a Repo's remotes using a given - location (ie, an url). -} @@ -187,6 +193,7 @@ expandTilde = expandt True expandt True ('~':'/':cs) = do h <- myHomeDir return $ h cs + expandt True "~" = myHomeDir expandt True ('~':cs) = do let (name, rest) = findname "" cs u <- getUserEntryForName name diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs index 25bdc5c..9261eab 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -10,6 +10,7 @@ module Git.CurrentRepo where import Common +import Git import Git.Types import Git.Construct import qualified Git.Config @@ -46,12 +47,12 @@ get = do wt <- maybe (worktree (location r)) Just <$> getpathenvprefix "GIT_WORK_TREE" prefix case wt of - Nothing -> return r + Nothing -> relPath r Just d -> do curr <- R.getCurrentDirectory unless (d `dirContains` curr) $ setCurrentDirectory (fromRawFilePath d) - return $ addworktree wt r + relPath $ addworktree wt r where getpathenv s = do v <- getEnv s diff --git a/Git/Env.hs b/Git/Env.hs new file mode 100644 index 0000000..fb0377f --- /dev/null +++ b/Git/Env.hs @@ -0,0 +1,52 @@ +{- Adjusting the environment while running git commands. + - + - Copyright 2014-2016 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Git.Env where + +import Common +import Git +import Git.Types +import Utility.Env + +{- Adjusts the gitEnv of a Repo. Copies the system environment if the repo + - does not have any gitEnv yet. -} +adjustGitEnv :: Repo -> ([(String, String)] -> [(String, String)]) -> IO Repo +adjustGitEnv g adj = do + e <- maybe getEnvironment return (gitEnv g) + let e' = adj e + return $ g { gitEnv = Just e' } + where + +addGitEnv :: Repo -> String -> String -> IO Repo +addGitEnv g var val = adjustGitEnv g (addEntry var val) + +{- Environment variables to use when running a command. + - Includes GIT_DIR pointing at the repo, and GIT_WORK_TREE when the repo + - is not bare. Also includes anything added to the Repo's gitEnv, + - and a copy of the rest of the system environment. -} +propGitEnv :: Repo -> IO [(String, String)] +propGitEnv g = do + g' <- addGitEnv g "GIT_DIR" (fromRawFilePath (localGitDir g)) + g'' <- maybe (pure g') + (addGitEnv g' "GIT_WORK_TREE" . fromRawFilePath) + (repoWorkTree g) + return $ fromMaybe [] (gitEnv g'') + +{- Use with any action that makes a commit to set metadata. -} +commitWithMetaData :: CommitMetaData -> CommitMetaData -> (Repo -> IO a) -> Repo -> IO a +commitWithMetaData authormetadata committermetadata a g = + a =<< adjustGitEnv g adj + where + adj = mkadj "AUTHOR" authormetadata + . mkadj "COMMITTER" committermetadata + mkadj p md = go "NAME" commitName + . go "EMAIL" commitEmail + . go "DATE" commitDate + where + go s getv = case getv md of + Nothing -> id + Just v -> addEntry ("GIT_" ++ p ++ "_" ++ s) v diff --git a/Git/LsTree.hs b/Git/LsTree.hs index cd0d406..a49c4ea 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -1,13 +1,14 @@ {- git ls-tree interface - - - Copyright 2011-2020 Joey Hess + - Copyright 2011-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} module Git.LsTree ( TreeItem(..), - LsTreeMode(..), + LsTreeRecursive(..), + LsTreeLong(..), lsTree, lsTree', lsTreeStrict, @@ -27,6 +28,7 @@ import Utility.Attoparsec import Numeric import Data.Either +import Data.Char import System.Posix.Types import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -38,44 +40,55 @@ data TreeItem = TreeItem { mode :: FileMode , typeobj :: S.ByteString , sha :: Ref + , size :: Maybe FileSize , file :: TopFilePath + -- ^ only available when long is used } deriving (Show) -data LsTreeMode = LsTreeRecursive | LsTreeNonRecursive +data LsTreeRecursive = LsTreeRecursive | LsTreeNonRecursive + +{- Enabling --long also gets the size of tree items. + - This slows down ls-tree some, since it has to look up the size of each + - blob. + -} +data LsTreeLong = LsTreeLong Bool {- Lists the contents of a tree, with lazy output. -} -lsTree :: LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool) +lsTree :: LsTreeRecursive -> LsTreeLong -> Ref -> Repo -> IO ([TreeItem], IO Bool) lsTree = lsTree' [] -lsTree' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool) -lsTree' ps lsmode t repo = do - (l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo - return (rights (map parseLsTree l), cleanup) +lsTree' :: [CommandParam] -> LsTreeRecursive -> LsTreeLong -> Ref -> Repo -> IO ([TreeItem], IO Bool) +lsTree' ps recursive long t repo = do + (l, cleanup) <- pipeNullSplit (lsTreeParams recursive long t ps) repo + return (rights (map (parseLsTree long) l), cleanup) -lsTreeStrict :: LsTreeMode -> Ref -> Repo -> IO [TreeItem] +lsTreeStrict :: LsTreeRecursive -> LsTreeLong -> Ref -> Repo -> IO [TreeItem] lsTreeStrict = lsTreeStrict' [] -lsTreeStrict' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO [TreeItem] -lsTreeStrict' ps lsmode t repo = rights . map parseLsTreeStrict - <$> pipeNullSplitStrict (lsTreeParams lsmode t ps) repo +lsTreeStrict' :: [CommandParam] -> LsTreeRecursive -> LsTreeLong -> Ref -> Repo -> IO [TreeItem] +lsTreeStrict' ps recursive long t repo = rights . map (parseLsTreeStrict long) + <$> pipeNullSplitStrict (lsTreeParams recursive long t ps) repo -lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam] -lsTreeParams lsmode r ps = +lsTreeParams :: LsTreeRecursive -> LsTreeLong -> Ref -> [CommandParam] -> [CommandParam] +lsTreeParams recursive long r ps = [ Param "ls-tree" , Param "--full-tree" , Param "-z" - ] ++ recursiveparams ++ ps ++ + ] ++ recursiveparams ++ longparams ++ ps ++ [ Param "--" , File $ fromRef r ] where - recursiveparams = case lsmode of + recursiveparams = case recursive of LsTreeRecursive -> [ Param "-r" ] LsTreeNonRecursive -> [] + longparams = case long of + LsTreeLong True -> [ Param "--long" ] + LsTreeLong False -> [] {- Lists specified files in a tree. -} -lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem] -lsTreeFiles t fs repo = rights . map (parseLsTree . L.fromStrict) +lsTreeFiles :: LsTreeLong -> Ref -> [FilePath] -> Repo -> IO [TreeItem] +lsTreeFiles long t fs repo = rights . map (parseLsTree long . L.fromStrict) <$> pipeNullSplitStrict ps repo where ps = @@ -86,41 +99,57 @@ lsTreeFiles t fs repo = rights . map (parseLsTree . L.fromStrict) , File $ fromRef t ] ++ map File fs -parseLsTree :: L.ByteString -> Either String TreeItem -parseLsTree b = case A.parse parserLsTree b of +parseLsTree :: LsTreeLong -> L.ByteString -> Either String TreeItem +parseLsTree long b = case A.parse (parserLsTree long) b of A.Done _ r -> Right r A.Fail _ _ err -> Left err -parseLsTreeStrict :: S.ByteString -> Either String TreeItem -parseLsTreeStrict b = go (AS.parse parserLsTree b) +parseLsTreeStrict :: LsTreeLong -> S.ByteString -> Either String TreeItem +parseLsTreeStrict long b = go (AS.parse (parserLsTree long) b) where go (AS.Done _ r) = Right r go (AS.Fail _ _ err) = Left err go (AS.Partial c) = go (c mempty) {- Parses a line of ls-tree output, in format: - - mode SP type SP sha TAB file + - mode SP type SP sha TAB file + - Or long format: + - mode SP type SP sha SPACES size TAB file - - - (The --long format is not currently supported.) -} -parserLsTree :: A.Parser TreeItem -parserLsTree = TreeItem - -- mode - <$> octal - <* A8.char ' ' - -- type - <*> A8.takeTill (== ' ') - <* A8.char ' ' - -- sha - <*> (Ref <$> A8.takeTill (== '\t')) - <* A8.char '\t' - -- file - <*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString) - -{- Inverse of parseLsTree -} -formatLsTree :: TreeItem -> String -formatLsTree ti = unwords - [ showOct (mode ti) "" - , decodeBS (typeobj ti) - , fromRef (sha ti) - , fromRawFilePath (getTopFilePath (file ti)) - ] + - The TAB can also be a space. Git does not use that, but an earlier + - version of formatLsTree did, and this keeps parsing what it output + - working. + -} +parserLsTree :: LsTreeLong -> A.Parser TreeItem +parserLsTree long = case long of + LsTreeLong False -> + startparser <*> pure Nothing <* filesep <*> fileparser + LsTreeLong True -> + startparser <* sizesep <*> sizeparser <* filesep <*> fileparser + where + startparser = TreeItem + -- mode + <$> octal + <* A8.char ' ' + -- type + <*> A8.takeTill (== ' ') + <* A8.char ' ' + -- sha + <*> (Ref <$> A8.takeTill A8.isSpace) + + fileparser = asTopFilePath . Git.Filename.decode <$> A.takeByteString + + sizeparser = fmap Just A8.decimal + + filesep = A8.space + + sizesep = A.many1 A8.space + +{- Inverse of parseLsTree. Note that the long output format is not + - generated, so any size information is not included. -} +formatLsTree :: TreeItem -> S.ByteString +formatLsTree ti = S.intercalate (S.singleton (fromIntegral (ord ' '))) + [ 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 7179a4e..6929a8e 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -64,12 +64,17 @@ branchRef = underBase "refs/heads" {- 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 :: RawFilePath -> Ref -fileRef f = Ref $ ":./" <> toInternalGitPath f +fileRef :: RawFilePath -> IO Ref +fileRef f = 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' {- A Ref that can be used to refer to a file in a particular branch. -} branchFileRef :: Branch -> RawFilePath -> Ref @@ -81,10 +86,13 @@ 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 -> Ref -fileFromRef r f = let (Ref fr) = fileRef f in Ref (fromRef' r <> fr) +fileFromRef :: Ref -> RawFilePath -> IO Ref +fileFromRef r f = do + (Ref fr) <- fileRef f + return (Ref (fromRef' r <> fr)) -{- Checks if a ref exists. -} +{- Checks if a ref exists. Note that it must be fully qualified, + - eg refs/heads/master rather than master. -} exists :: Ref -> Repo -> IO Bool exists ref = runBool [ Param "show-ref" diff --git a/Git/Remote.hs b/Git/Remote.hs index 7c6cfc2..8f5d99f 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -1,6 +1,6 @@ {- git remote stuff - - - Copyright 2012 Joey Hess + - Copyright 2012-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -23,14 +23,22 @@ import Network.URI import Git.FilePath #endif -{- Is a git config key one that specifies the location of a remote? -} -isRemoteKey :: ConfigKey -> Bool -isRemoteKey (ConfigKey k) = "remote." `S.isPrefixOf` k && ".url" `S.isSuffixOf` k +{- Is a git config key one that specifies the url of a remote? -} +isRemoteUrlKey :: ConfigKey -> Bool +isRemoteUrlKey = isRemoteKey "url" -{- Get a remote's name from the config key that specifies its location. -} -remoteKeyToRemoteName :: ConfigKey -> RemoteName -remoteKeyToRemoteName (ConfigKey k) = decodeBS' $ - S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k +isRemoteKey :: S.ByteString -> ConfigKey -> Bool +isRemoteKey want (ConfigKey k) = + "remote." `S.isPrefixOf` k && ("." <> want) `S.isSuffixOf` k + +{- Get a remote's name from the a config key such as remote.name.url + - or any other per-remote config key. -} +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) + | otherwise = Nothing {- Construct a legal git remote name out of an arbitrary input string. - @@ -99,7 +107,9 @@ parseRemoteLocation s repo = ret $ calcloc s 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 supports URIs that contain unescaped characters such as + -- spaces. So to test if it's a (git) URI, escape those. + urlstyle v = isURI (escapeURIString isUnescapedInURI 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 diff --git a/Git/Repair.hs b/Git/Repair.hs index 034d7e9..144c96f 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -1,6 +1,6 @@ {- git repository recovery - - - Copyright 2013-2014 Joey Hess + - Copyright 2013-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -29,6 +29,7 @@ import Git.Sha import Git.Types import Git.Fsck import Git.Index +import Git.Env import qualified Git.Config as Config import qualified Git.Construct as Construct import qualified Git.LsTree as LsTree @@ -61,15 +62,14 @@ cleanCorruptObjects fsckresults r = do whenM (isMissing s r) $ removeLoose s -{- Explodes all pack files, and deletes them. +{- Explodes all pack files to loose objects, and deletes the pack files. - - - First moves all pack files to a temp dir, before unpacking them each in - - turn. + - git unpack-objects will not unpack objects from a pack file that are + - in the git repo. So, GIT_OBJECT_DIRECTORY is pointed to a temporary + - directory, and the loose objects then are moved into place, before + - deleting the pack files. - - - 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 + - Also, that prevents unpack-objects from possibly looking at corrupt - pack files to see if they contain an object, while unpacking a - non-corrupt pack file. -} @@ -78,18 +78,28 @@ explodePacks r = go =<< listPackFiles r where go [] = return False go packs = withTmpDir "packs" $ \tmpdir -> do + r' <- addGitEnv r "GIT_OBJECT_DIRECTORY" tmpdir putStrLn "Unpacking all pack files." forM_ packs $ \packfile -> do - moveFile packfile (tmpdir takeFileName packfile) - removeWhenExistsWith R.removeLink - (packIdxFile (toRawFilePath packfile)) - forM_ packs $ \packfile -> do - let tmp = tmpdir takeFileName packfile - allowRead (toRawFilePath tmp) + -- Just in case permissions are messed up. + allowRead (toRawFilePath packfile) -- May fail, if pack file is corrupt. void $ tryIO $ - pipeWrite [Param "unpack-objects", Param "-r"] r $ \h -> - L.hPut h =<< L.readFile tmp + pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h -> + L.hPut h =<< L.readFile packfile + objs <- dirContentsRecursive tmpdir + forM_ objs $ \objfile -> do + f <- relPathDirToFile + (toRawFilePath tmpdir) + (toRawFilePath objfile) + let dest = objectsDir r P. f + createDirectoryIfMissing True + (fromRawFilePath (parentDir dest)) + moveFile objfile (fromRawFilePath dest) + forM_ packs $ \packfile -> do + let f = toRawFilePath packfile + removeWhenExistsWith R.removeLink f + removeWhenExistsWith R.removeLink (packIdxFile f) return True {- Try to retrieve a set of missing objects, from the remotes of a @@ -105,7 +115,10 @@ retrieveMissingObjects missing referencerepo r | otherwise = withTmpDir "tmprepo" $ \tmpdir -> do unlessM (boolSystem "git" [Param "init", File tmpdir]) $ error $ "failed to create temp repository in " ++ tmpdir - tmpr <- Config.read =<< Construct.fromAbsPath (toRawFilePath tmpdir) + tmpr <- Config.read =<< Construct.fromPath (toRawFilePath tmpdir) + let repoconfig r' = fromRawFilePath (localGitDir r' P. "config") + whenM (doesFileExist (repoconfig r)) $ + L.readFile (repoconfig r) >>= L.writeFile (repoconfig tmpr) rs <- Construct.fromRemotes r stillmissing <- pullremotes tmpr rs fetchrefstags missing if S.null (knownMissing stillmissing) @@ -351,8 +364,9 @@ verifyTree :: MissingObjects -> Sha -> Repo -> IO Bool verifyTree missing treesha r | S.member treesha missing = return False | otherwise = do - (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive treesha []) r - let objshas = mapMaybe (LsTree.sha <$$> eitherToMaybe . LsTree.parseLsTree) ls + let nolong = LsTree.LsTreeLong False + (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive nolong treesha []) r + let objshas = mapMaybe (LsTree.sha <$$> eitherToMaybe . LsTree.parseLsTree nolong) ls if any (`S.member` missing) objshas then do void cleanup diff --git a/Git/Types.hs b/Git/Types.hs index 73c4fe6..db1c71b 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -34,6 +34,7 @@ data RepoLocation = Local { gitdir :: RawFilePath, worktree :: Maybe RawFilePath } | LocalUnknown RawFilePath | Url URI + | UnparseableUrl String | Unknown deriving (Show, Eq, Ord) diff --git a/Git/Url.hs b/Git/Url.hs index 8430655..ad0e61b 100644 --- a/Git/Url.hs +++ b/Git/Url.hs @@ -1,6 +1,6 @@ {- git repository urls - - - Copyright 2010, 2011 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -18,12 +18,11 @@ import Network.URI hiding (scheme, authority, path) 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 +scheme :: Repo -> Maybe String +scheme Repo { location = Url u } = Just (uriScheme u) +scheme _ = Nothing {- Work around a bug in the real uriRegName - -} @@ -65,13 +64,9 @@ authority = authpart assemble {- 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 +authpart _ _ = Nothing {- Path part of an URL repo. -} -path :: Repo -> FilePath -path Repo { location = Url u } = uriPath u -path repo = notUrl repo - -notUrl :: Repo -> a -notUrl repo = error $ - "acting on local git repo " ++ repoDescribe repo ++ " not supported" +path :: Repo -> Maybe FilePath +path Repo { location = Url u } = Just (uriPath u) +path _ = Nothing -- cgit v1.2.3