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. --- Build/TestConfig.hs | 2 +- CHANGELOG | 9 ++++ Git.hs | 8 ++- 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 +++----- Utility/Batch.hs | 2 +- Utility/CopyFile.hs | 83 +++++++++++++++++++++++++++++++ Utility/Debug.hs | 102 ++++++++++++++++++++++++++++++++++++++ Utility/Exception.hs | 2 +- Utility/InodeCache.hs | 8 ++- Utility/Metered.hs | 20 ++++---- Utility/Path.hs | 78 +++++++++++++++++------------ Utility/Path/AbsRel.hs | 20 +++++--- Utility/Process.hs | 7 +-- Utility/QuickCheck.hs | 3 +- Utility/ThreadScheduler.hs | 1 + git-repair.cabal | 7 ++- 27 files changed, 569 insertions(+), 211 deletions(-) create mode 100644 Git/Env.hs create mode 100644 Utility/CopyFile.hs create mode 100644 Utility/Debug.hs diff --git a/Build/TestConfig.hs b/Build/TestConfig.hs index 2f7213f..988db58 100644 --- a/Build/TestConfig.hs +++ b/Build/TestConfig.hs @@ -97,7 +97,7 @@ searchCmd success failure cmdsparams = search cmdsparams - the command. -} findCmdPath :: ConfigKey -> String -> Test findCmdPath k command = do - ifM (inPath command) + ifM (inSearchPath command) ( return $ Config k $ MaybeStringConfig $ Just command , do r <- getM find ["/usr/sbin", "/sbin", "/usr/local/sbin"] diff --git a/CHANGELOG b/CHANGELOG index b845a6b..af763df 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,12 @@ +git-repair (1.20210112) UNRELEASED; urgency=medium + + * Fixed bug that interrupting the program while it was fixing repository + corruption would lose objects that were contained in pack files. + * Fix reversion in version 1.20200504 that prevented fetching + missing objects from remotes. + + -- Joey Hess Tue, 29 Jun 2021 13:15:59 -0400 + git-repair (1.20210111) unstable; urgency=medium * Improve output to not give the impression it's stalled running fsck diff --git a/Git.hs b/Git.hs index 32cf82e..f8eedc0 100644 --- a/Git.hs +++ b/Git.hs @@ -3,7 +3,7 @@ - This is written to be completely independant of git-annex and should be - suitable for other uses. - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -55,6 +55,7 @@ import Utility.FileMode repoDescribe :: Repo -> String repoDescribe Repo { remoteName = Just name } = name repoDescribe Repo { location = Url url } = show url +repoDescribe Repo { location = UnparseableUrl url } = url repoDescribe Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir repoDescribe Repo { location = Local { gitdir = dir } } = fromRawFilePath dir repoDescribe Repo { location = LocalUnknown dir } = fromRawFilePath dir @@ -63,13 +64,14 @@ repoDescribe Repo { location = Unknown } = "UNKNOWN" {- Location of the repo, either as a path or url. -} repoLocation :: Repo -> String repoLocation Repo { location = Url url } = show url +repoLocation Repo { location = UnparseableUrl url } = url repoLocation Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir repoLocation Repo { location = Local { gitdir = dir } } = fromRawFilePath dir repoLocation Repo { location = LocalUnknown dir } = fromRawFilePath dir repoLocation Repo { location = Unknown } = error "unknown repoLocation" {- Path to a repository. For non-bare, this is the worktree, for bare, - - it's the gitdir, and for URL repositories, is the path on the remote + - it's the gitdit, and for URL repositories, is the path on the remote - host. -} repoPath :: Repo -> RawFilePath repoPath Repo { location = Url u } = toRawFilePath $ unEscapeString $ uriPath u @@ -77,6 +79,7 @@ repoPath Repo { location = Local { worktree = Just d } } = d repoPath Repo { location = Local { gitdir = d } } = d repoPath Repo { location = LocalUnknown dir } = dir repoPath Repo { location = Unknown } = error "unknown repoPath" +repoPath Repo { location = UnparseableUrl _u } = error "unknwon repoPath" repoWorkTree :: Repo -> Maybe RawFilePath repoWorkTree Repo { location = Local { worktree = Just d } } = Just d @@ -91,6 +94,7 @@ localGitDir _ = error "unknown localGitDir" - or bare and non-bare, these functions help with that. -} repoIsUrl :: Repo -> Bool repoIsUrl Repo { location = Url _ } = True +repoIsUrl Repo { location = UnparseableUrl _ } = True repoIsUrl _ = False repoIsSsh :: Repo -> Bool 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 diff --git a/Utility/Batch.hs b/Utility/Batch.hs index 58e326e..6ed7881 100644 --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -57,7 +57,7 @@ nonBatchCommandMaker = id getBatchCommandMaker :: IO BatchCommandMaker getBatchCommandMaker = do #ifndef mingw32_HOST_OS - nicers <- filterM (inPath . fst) + nicers <- filterM (inSearchPath . fst) [ ("nice", []) , ("ionice", ["-c3"]) , ("nocache", []) diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs new file mode 100644 index 0000000..f851326 --- /dev/null +++ b/Utility/CopyFile.hs @@ -0,0 +1,83 @@ +{- file copying + - + - Copyright 2010-2019 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.CopyFile ( + copyFileExternal, + copyCoW, + createLinkOrCopy, + CopyMetaData(..) +) where + +import Common +import qualified BuildInfo + +data CopyMetaData + -- Copy timestamps when possible, but no other metadata, and + -- when copying a symlink, makes a copy of its content. + = CopyTimeStamps + -- Copy all metadata when possible. + | CopyAllMetaData + deriving (Eq) + +copyMetaDataParams :: CopyMetaData -> [CommandParam] +copyMetaDataParams meta = map snd $ filter fst + [ (allmeta && BuildInfo.cp_a, Param "-a") + , (allmeta && BuildInfo.cp_p && not BuildInfo.cp_a + , Param "-p") + , (not allmeta && BuildInfo.cp_preserve_timestamps + , Param "--preserve=timestamps") + ] + where + allmeta = meta == CopyAllMetaData + +{- The cp command is used, because I hate reinventing the wheel, + - and because this allows easy access to features like cp --reflink + - and preserving metadata. -} +copyFileExternal :: CopyMetaData -> FilePath -> FilePath -> IO Bool +copyFileExternal meta src dest = do + -- Delete any existing dest file because an unwritable file + -- would prevent cp from working. + void $ tryIO $ removeFile dest + boolSystem "cp" $ params ++ [File src, File dest] + where + params + | BuildInfo.cp_reflink_supported = + Param "--reflink=auto" : copyMetaDataParams meta + | otherwise = copyMetaDataParams meta + +{- When a filesystem supports CoW (and cp does), uses it to make + - an efficient copy of a file. Otherwise, returns False. -} +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 -> + let p = (proc "cp" $ toCommand $ params ++ [File src, File dest]) + { std_out = UseHandle nullh + , std_err = UseHandle nullh + } + in withCreateProcess p $ \_ _ _ -> checkSuccessProcess + -- When CoW is not supported, cp creates the destination + -- file but leaves it empty. + unless ok $ + void $ tryIO $ removeFile dest + return ok + | otherwise = return False + where + params = Param "--reflink=always" : copyMetaDataParams meta + +{- Create a hard link if the filesystem allows it, and fall back to copying + - the file. -} +createLinkOrCopy :: FilePath -> FilePath -> IO Bool +createLinkOrCopy src dest = go `catchIO` const fallback + where + go = do + createLink src dest + return True + fallback = copyFileExternal CopyAllMetaData src dest diff --git a/Utility/Debug.hs b/Utility/Debug.hs new file mode 100644 index 0000000..e0be9c9 --- /dev/null +++ b/Utility/Debug.hs @@ -0,0 +1,102 @@ +{- Debug output + - + - Copyright 2021 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-tabs -w #-} + +module Utility.Debug ( + DebugSource(..), + DebugSelector(..), + configureDebug, + getDebugSelector, + debug, + fastDebug +) where + +import qualified Data.ByteString as S +import Data.IORef +import Data.String +import Data.Time +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Semigroup as Sem +import Prelude + +import Utility.FileSystemEncoding + +-- | The source of a debug message. For example, this could be a module or +-- function name. +newtype DebugSource = DebugSource S.ByteString + deriving (Eq, Show) + +instance IsString DebugSource where + fromString = DebugSource . encodeBS' + +-- | Selects whether to display a message from a source. +data DebugSelector + = DebugSelector (DebugSource -> Bool) + | NoDebugSelector + +instance Sem.Semigroup DebugSelector where + DebugSelector a <> DebugSelector b = DebugSelector (\v -> a v || b v) + NoDebugSelector <> NoDebugSelector = NoDebugSelector + NoDebugSelector <> b = b + a <> NoDebugSelector = a + +instance Monoid DebugSelector where + mempty = NoDebugSelector + +-- | Configures debugging. +configureDebug + :: (S.ByteString -> IO ()) + -- ^ Used to display debug output. + -> DebugSelector + -> IO () +configureDebug src p = writeIORef debugConfigGlobal (src, p) + +-- | Gets the currently configured DebugSelector. +getDebugSelector :: IO DebugSelector +getDebugSelector = snd <$> readIORef debugConfigGlobal + +-- A global variable for the debug configuration. +{-# NOINLINE debugConfigGlobal #-} +debugConfigGlobal :: IORef (S.ByteString -> IO (), DebugSelector) +debugConfigGlobal = unsafePerformIO $ newIORef (dontshow, selectnone) + where + dontshow _ = return () + selectnone = NoDebugSelector + +-- | Displays a debug message, if that has been enabled by configureDebug. +-- +-- This is reasonably fast when debugging is not enabled, but since it does +-- have to consult a IORef each time, using it in a tight loop may slow +-- down the program. +debug :: DebugSource -> String -> IO () +debug src msg = readIORef debugConfigGlobal >>= \case + (displayer, NoDebugSelector) -> + displayer =<< formatDebugMessage src msg + (displayer, DebugSelector p) + | p src -> displayer =<< formatDebugMessage src msg + | otherwise -> return () + +-- | Displays a debug message, if the DebugSelector allows. +-- +-- When the DebugSelector does not let the message be displayed, this runs +-- very quickly, allowing it to be used inside tight loops. +fastDebug :: DebugSelector -> DebugSource -> String -> IO () +fastDebug NoDebugSelector src msg = do + (displayer, _) <- readIORef debugConfigGlobal + displayer =<< formatDebugMessage src msg +fastDebug (DebugSelector p) src msg + | p src = fastDebug NoDebugSelector src msg + | otherwise = return () + +formatDebugMessage :: DebugSource -> String -> IO S.ByteString +formatDebugMessage (DebugSource src) msg = do + t <- encodeBS' . formatTime defaultTimeLocale "[%F %X%Q]" + <$> getZonedTime + return (t <> " (" <> src <> ") " <> encodeBS msg) diff --git a/Utility/Exception.hs b/Utility/Exception.hs index 273f844..4c60eac 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -39,7 +39,7 @@ import Utility.Data {- Like error, this throws an exception. Unlike error, if this exception - is not caught, it won't generate a backtrace. So use this for situations - - where there's a problem that the user is expeected to see in some + - where there's a problem that the user is expected to see in some - circumstances. -} giveup :: [Char] -> a giveup = errorWithoutStackTrace diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs index 74c6dff..9a21c63 100644 --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -24,6 +24,7 @@ module Utility.InodeCache ( showInodeCache, genInodeCache, toInodeCache, + toInodeCache', InodeCacheKey, inodeCacheToKey, @@ -189,7 +190,10 @@ genInodeCache f delta = catchDefaultIO Nothing $ toInodeCache delta f =<< R.getFileStatus f toInodeCache :: TSDelta -> RawFilePath -> FileStatus -> IO (Maybe InodeCache) -toInodeCache (TSDelta getdelta) f s +toInodeCache d f s = toInodeCache' d f s (fileID s) + +toInodeCache' :: TSDelta -> RawFilePath -> FileStatus -> FileID -> IO (Maybe InodeCache) +toInodeCache' (TSDelta getdelta) f s inode | isRegularFile s = do delta <- getdelta sz <- getFileSize' f s @@ -198,7 +202,7 @@ toInodeCache (TSDelta getdelta) f s #else let mtime = modificationTimeHiRes s #endif - return $ Just $ InodeCache $ InodeCachePrim (fileID s) sz (MTimeHighRes (mtime + highResTime delta)) + return $ Just $ InodeCache $ InodeCachePrim inode sz (MTimeHighRes (mtime + highResTime delta)) | otherwise = pure Nothing {- Some filesystem get new random inodes each time they are mounted. diff --git a/Utility/Metered.hs b/Utility/Metered.hs index 1715f0b..a7c9c37 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -1,6 +1,6 @@ {- Metered IO and actions - - - Copyright 2012-2020 Joey Hess + - Copyright 2012-2021 Joey Hess - - License: BSD-2-clause -} @@ -118,23 +118,24 @@ withMeteredFile :: FilePath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a withMeteredFile f meterupdate a = withBinaryFile f ReadMode $ \h -> hGetContentsMetered h meterupdate >>= a -{- Writes a ByteString to a Handle, updating a meter as it's written. -} -meteredWrite :: MeterUpdate -> Handle -> L.ByteString -> IO () -meteredWrite meterupdate h = void . meteredWrite' meterupdate h +{- Calls the action repeatedly with chunks from the lazy ByteString. + - Updates the meter after each chunk is processed. -} +meteredWrite :: MeterUpdate -> (S.ByteString -> IO ()) -> L.ByteString -> IO () +meteredWrite meterupdate a = void . meteredWrite' meterupdate a -meteredWrite' :: MeterUpdate -> Handle -> L.ByteString -> IO BytesProcessed -meteredWrite' meterupdate h = go zeroBytesProcessed . L.toChunks +meteredWrite' :: MeterUpdate -> (S.ByteString -> IO ()) -> L.ByteString -> IO BytesProcessed +meteredWrite' meterupdate a = go zeroBytesProcessed . L.toChunks where go sofar [] = return sofar go sofar (c:cs) = do - S.hPut h c + a c let !sofar' = addBytesProcessed sofar $ S.length c meterupdate sofar' go sofar' cs meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO () meteredWriteFile meterupdate f b = withBinaryFile f WriteMode $ \h -> - meteredWrite meterupdate h b + meteredWrite meterupdate (S.hPut h) b {- Applies an offset to a MeterUpdate. This can be useful when - performing a sequence of actions, such as multiple meteredWriteFiles, @@ -424,7 +425,8 @@ displayMeterHandle h rendermeter v msize old new = do hPutStr h ('\r':s ++ padding) hFlush h --- | Clear meter displayed by displayMeterHandle. +-- | Clear meter displayed by displayMeterHandle. May be called before +-- outputting something else, followed by more calls to displayMeterHandle. clearMeterHandle :: Meter -> Handle -> IO () clearMeterHandle (Meter _ _ v _) h = do olds <- readMVar v diff --git a/Utility/Path.hs b/Utility/Path.hs index 6bd407e..cfda748 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -18,11 +18,12 @@ module Utility.Path ( segmentPaths', runSegmentPaths, runSegmentPaths', - inPath, - searchPath, dotfile, splitShortExtensions, relPathDirToFileAbs, + inSearchPath, + searchPath, + searchPathContents, ) where import System.FilePath.ByteString @@ -30,11 +31,13 @@ import qualified System.FilePath as P import qualified Data.ByteString as B import Data.List import Data.Maybe +import Control.Monad import Control.Applicative import Prelude import Utility.Monad import Utility.SystemDirectory +import Utility.Exception #ifdef mingw32_HOST_OS import Data.Char @@ -136,33 +139,6 @@ runSegmentPaths c a paths = segmentPaths c paths <$> a paths runSegmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[r]] runSegmentPaths' si c a paths = segmentPaths' si c paths <$> a paths -{- Checks if a command is available in PATH. - - - - The command may be fully-qualified, in which case, this succeeds as - - long as it exists. -} -inPath :: String -> IO Bool -inPath command = isJust <$> searchPath command - -{- Finds a command in PATH and returns the full path to it. - - - - The command may be fully qualified already, in which case it will - - be returned if it exists. - - - - Note that this will find commands in PATH that are not executable. - -} -searchPath :: String -> IO (Maybe FilePath) -searchPath command - | P.isAbsolute command = check command - | otherwise = P.getSearchPath >>= getM indir - where - indir d = check $ d P. command - check f = firstM doesFileExist -#ifdef mingw32_HOST_OS - [f, f ++ ".exe"] -#else - [f] -#endif - {- Checks if a filename is a unix dotfile. All files inside dotdirs - count as dotfiles. -} dotfile :: RawFilePath -> Bool @@ -189,8 +165,7 @@ splitShortExtensions' maxextension = go [] (base, ext) = splitExtension f len = B.length ext -{- This requires the first path to be absolute, and the - - second path cannot contain ../ or ./ +{- This requires both paths to be absolute and normalized. - - On Windows, if the paths are on different drives, - a relative path is not possible and the path is simply @@ -214,3 +189,44 @@ relPathDirToFileAbs from to #ifdef mingw32_HOST_OS normdrive = map toLower . takeWhile (/= ':') . fromRawFilePath . takeDrive #endif + +{- Checks if a command is available in PATH. + - + - The command may be fully-qualified, in which case, this succeeds as + - long as it exists. -} +inSearchPath :: String -> IO Bool +inSearchPath command = isJust <$> searchPath command + +{- Finds a command in PATH and returns the full path to it. + - + - The command may be fully qualified already, in which case it will + - be returned if it exists. + - + - Note that this will find commands in PATH that are not executable. + -} +searchPath :: String -> IO (Maybe FilePath) +searchPath command + | P.isAbsolute command = check command + | otherwise = P.getSearchPath >>= getM indir + where + indir d = check $ d P. command + check f = firstM doesFileExist +#ifdef mingw32_HOST_OS + [f, f ++ ".exe"] +#else + [f] +#endif + +{- Finds commands in PATH that match a predicate. Note that the predicate + - matches on the basename of the command, but the full path to it is + - returned. + - + - Note that this will find commands in PATH that are not executable. + -} +searchPathContents :: (FilePath -> Bool) -> IO [FilePath] +searchPathContents p = + filterM doesFileExist + =<< (concat <$> (P.getSearchPath >>= mapM go)) + where + go d = map (d P.) . filter p + <$> catchDefaultIO [] (getDirectoryContents d) diff --git a/Utility/Path/AbsRel.hs b/Utility/Path/AbsRel.hs index 0026bd6..857dd5e 100644 --- a/Utility/Path/AbsRel.hs +++ b/Utility/Path/AbsRel.hs @@ -1,6 +1,6 @@ {- absolute and relative path manipulation - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2021 Joey Hess - - License: BSD-2-clause -} @@ -19,6 +19,7 @@ module Utility.Path.AbsRel ( ) where import System.FilePath.ByteString +import qualified Data.ByteString as B #ifdef mingw32_HOST_OS import System.Directory (getCurrentDirectory) #else @@ -64,22 +65,27 @@ absPath file #endif return $ absPathFrom cwd file -{- Constructs a relative path from the CWD to a file. +{- Constructs the minimal relative path from the CWD to a file. - - For example, assuming CWD is /tmp/foo/bar: - relPathCwdToFile "/tmp/foo" == ".." - relPathCwdToFile "/tmp/foo/bar" == "" + - relPathCwdToFile "../bar/baz" == "baz" -} relPathCwdToFile :: RawFilePath -> IO RawFilePath -relPathCwdToFile f = do +relPathCwdToFile f + -- Optimisation: Avoid doing any IO when the path is relative + -- and does not contain any ".." component. + | isRelative f && not (".." `B.isInfixOf` f) = return f + | otherwise = do #ifdef mingw32_HOST_OS - c <- toRawFilePath <$> getCurrentDirectory + c <- toRawFilePath <$> getCurrentDirectory #else - c <- getWorkingDirectory + c <- getWorkingDirectory #endif - relPathDirToFile c f + relPathDirToFile c f -{- Constructs a relative path from a directory to a file. -} +{- Constructs a minimal relative path from a directory to a file. -} relPathDirToFile :: RawFilePath -> RawFilePath -> IO RawFilePath relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to diff --git a/Utility/Process.hs b/Utility/Process.hs index 4a725c8..4cf6105 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -7,6 +7,7 @@ -} {-# LANGUAGE CPP, Rank2Types, LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Process ( @@ -38,10 +39,10 @@ import Utility.Process.Shim as X (CreateProcess(..), ProcessHandle, StdStream(.. import Utility.Misc import Utility.Exception import Utility.Monad +import Utility.Debug import System.Exit import System.IO -import System.Log.Logger import Control.Monad.IO.Class import Control.Concurrent.Async import qualified Data.ByteString as S @@ -187,7 +188,7 @@ withCreateProcess p action = bracket (createProcess p) cleanupProcess debugProcess :: CreateProcess -> ProcessHandle -> IO () debugProcess p h = do pid <- getPid h - debugM "Utility.Process" $ unwords + debug "Utility.Process" $ unwords [ describePid pid , action ++ ":" , showCmd p @@ -211,7 +212,7 @@ waitForProcess h = do -- Have to get pid before waiting, which closes the ProcessHandle. pid <- getPid h r <- Utility.Process.Shim.waitForProcess h - debugM "Utility.Process" (describePid pid ++ " done " ++ show r) + debug "Utility.Process" (describePid pid ++ " done " ++ show r) return r cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index 2093670..650f559 100644 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -12,8 +12,7 @@ module Utility.QuickCheck ( module X , TestableString , fromTestableString - , TestableFilePath - , fromTestableFilePath + , TestableFilePath(..) , nonNegative , positive ) where diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs index ef69ead..9ab94d9 100644 --- a/Utility/ThreadScheduler.hs +++ b/Utility/ThreadScheduler.hs @@ -15,6 +15,7 @@ module Utility.ThreadScheduler ( threadDelaySeconds, waitForTermination, oneSecond, + unboundDelay, ) where import Control.Monad diff --git a/git-repair.cabal b/git-repair.cabal index cf01c06..64fb890 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -30,7 +30,7 @@ custom-setup hslogger, split, unix-compat, process, unix, filepath, filepath-bytestring (>= 1.4.2.1.1), async, exceptions, bytestring, directory, IfElse, data-default, - mtl, Cabal + mtl, Cabal, time source-repository head type: git @@ -47,7 +47,8 @@ Executable git-repair 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.0), + time if (os(windows)) Build-Depends: setenv @@ -70,6 +71,7 @@ Executable git-repair Git.CurrentRepo Git.Destroyer Git.DiffTreeItem + Git.Env Git.FilePath Git.Filename Git.Fsck @@ -91,6 +93,7 @@ Executable git-repair Utility.Applicative Utility.Batch Utility.CoProcess + Utility.Debug Utility.Data Utility.DataUnits Utility.Directory -- cgit v1.2.3