From 5329bfd56f821185c2ed55de1ed537a95b01b83c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 2 Jan 2020 12:44:38 -0400 Subject: add news item for git-repair 1.20200102 --- doc/news/version_1.20141027.mdwn | 1 - doc/news/version_1.20200102.mdwn | 7 +++++++ 2 files changed, 7 insertions(+), 1 deletion(-) delete mode 100644 doc/news/version_1.20141027.mdwn create mode 100644 doc/news/version_1.20200102.mdwn diff --git a/doc/news/version_1.20141027.mdwn b/doc/news/version_1.20141027.mdwn deleted file mode 100644 index b65c652..0000000 --- a/doc/news/version_1.20141027.mdwn +++ /dev/null @@ -1 +0,0 @@ -git-repair 1.20140613 released diff --git a/doc/news/version_1.20200102.mdwn b/doc/news/version_1.20200102.mdwn new file mode 100644 index 0000000..372a457 --- /dev/null +++ b/doc/news/version_1.20200102.mdwn @@ -0,0 +1,7 @@ +git-repair 1.20200102 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * Relicensed AGPL. + * Merge from git-annex. + * Removed the network-uri build flag. + * Increased required version of several dependencies. + * Added dependencies on deepseq, attoparsec and filepath-bytestring."""]] \ No newline at end of file -- cgit v1.2.3 From d842225a9b1a0267ced787ea5a1b9c841231fbe3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 3 Jan 2020 13:45:10 -0400 Subject: merge improvements from debian/copyright --- COPYRIGHT | 39 ++++++++++++++++++++++++++++++++++++--- 1 file changed, 36 insertions(+), 3 deletions(-) diff --git a/COPYRIGHT b/COPYRIGHT index cd51274..cbd1cdc 100644 --- a/COPYRIGHT +++ b/COPYRIGHT @@ -1,14 +1,19 @@ -Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ -Source: native package +Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ +Source: git://git-repair.branchable.com/ Files: * Copyright: © 2013-2019 Joey Hess License: AGPL-3+ Files: Utility/* -Copyright: 2012-2019 Joey Hess +Copyright: 2012-2014 Joey Hess License: BSD-2-clause +Files: Utility/Attoparsec.hs +Copyright: (C) 2019 Joey Hess + (C) 2007-2015 Bryan O'Sullivan +License: BSD-3-clause + License: BSD-2-clause Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions @@ -31,6 +36,34 @@ License: BSD-2-clause OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +License: BSD-3-clause + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + . + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + . + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + . + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + . + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + License: AGPL-3+ GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007 -- cgit v1.2.3 From 6ea7eac330f73699d965cef7b8ee23d7218415a8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 1 Apr 2020 13:12:47 -0400 Subject: Fix a few documentation typos. --- CHANGELOG | 6 ++++++ doc/index.mdwn | 2 +- git-repair.1 | 2 +- git-repair.cabal | 2 +- 4 files changed, 9 insertions(+), 3 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 50f9332..528034e 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,9 @@ +git-repair (1.20200103) UNRELEASED; urgency=medium + + * Fix a few documentation typos. + + -- Joey Hess Wed, 01 Apr 2020 13:12:33 -0400 + git-repair (1.20200102) unstable; urgency=medium * Relicensed AGPL. diff --git a/doc/index.mdwn b/doc/index.mdwn index 503c2c2..9ff06de 100644 --- a/doc/index.mdwn +++ b/doc/index.mdwn @@ -27,7 +27,7 @@ Then to install it: ## how it works `git-repair` starts by deleting all corrupt objects, and -retreiving all missing objects that it can from the remotes of the +retrieving all missing objects that it can from the remotes of the repository. If that is not sufficient to fully recover the repository, it can also diff --git a/git-repair.1 b/git-repair.1 index 7780095..8b72d1f 100644 --- a/git-repair.1 +++ b/git-repair.1 @@ -9,7 +9,7 @@ git\-repair [\-\-force] This can fix a corrupt or broken git repository, which git fsck would only complain has problems. .PP -It does by deleting all corrupt objects, and retreiving all missing +It does by deleting all corrupt objects, and retrieving all missing objects that it can from the remotes of the repository. .PP If that is not sufficient to fully recover the repository, it can also diff --git a/git-repair.cabal b/git-repair.cabal index f273cb3..2637586 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -10,7 +10,7 @@ License-File: COPYRIGHT Build-Type: Custom Homepage: http://git-repair.branchable.com/ Category: Utility -Synopsis: repairs a damanged git repisitory +Synopsis: repairs a damaged git repository Description: git-repair can repair various forms of damage to git repositories. . -- cgit v1.2.3 From 8c4352a0a544b2e5a4ed717999fc7c6ecb0a328f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 4 May 2020 15:38:39 -0400 Subject: merge from git-annex * Improve fetching from a remote with an url in host:path format. * Merge from git-annex. --- Build/Configure.hs | 1 - CHANGELOG | 2 + Git.hs | 1 + Git/Branch.hs | 22 +-- Git/CatFile.hs | 89 ++++++------ Git/Command.hs | 9 +- Git/Config.hs | 73 ++++++---- Git/DiffTreeItem.hs | 7 +- Git/FilePath.hs | 2 +- Git/Fsck.hs | 3 +- Git/HashObject.hs | 3 +- Git/LsFiles.hs | 146 +++++++++++++++----- Git/LsTree.hs | 5 +- Git/Objects.hs | 2 +- Git/Ref.hs | 54 +++++--- Git/RefLog.hs | 5 +- Git/Remote.hs | 15 ++- Git/Repair.hs | 54 ++++---- Git/Sha.hs | 63 ++++++--- Git/Types.hs | 30 ++++- Git/UpdateIndex.hs | 8 +- Utility/CoProcess.hs | 1 + Utility/Directory.hs | 81 ++++++++++- Utility/FileSystemEncoding.hs | 15 +-- Utility/HumanTime.hs | 5 +- Utility/InodeCache.hs | 307 ++++++++++++++++++++++++++++++++++++++++++ Utility/Misc.hs | 8 ++ Utility/Path.hs | 17 ++- Utility/Process.hs | 16 +-- Utility/RawFilePath.hs | 50 +++++++ Utility/TimeStamp.hs | 58 ++++++++ git-repair.cabal | 4 + 32 files changed, 924 insertions(+), 232 deletions(-) create mode 100644 Utility/InodeCache.hs create mode 100644 Utility/RawFilePath.hs create mode 100644 Utility/TimeStamp.hs diff --git a/Build/Configure.hs b/Build/Configure.hs index 1a3527f..3460f04 100644 --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -4,7 +4,6 @@ module Build.Configure where -import System.Environment import Control.Monad.IfElse import Control.Applicative import Prelude diff --git a/CHANGELOG b/CHANGELOG index 528034e..e6b5521 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,6 +1,8 @@ git-repair (1.20200103) UNRELEASED; urgency=medium * Fix a few documentation typos. + * Improve fetching from a remote with an url in host:path format. + * Merge from git-annex. -- Joey Hess Wed, 01 Apr 2020 13:12:33 -0400 diff --git a/Git.hs b/Git.hs index 87a8d19..d33345e 100644 --- a/Git.hs +++ b/Git.hs @@ -14,6 +14,7 @@ module Git ( Repo(..), Ref(..), fromRef, + fromRef', Branch, Sha, Tag, diff --git a/Git/Branch.hs b/Git/Branch.hs index 699fbf5..fcae905 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -18,6 +18,7 @@ import qualified Git.Config import qualified Git.Ref import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 {- The currently checked out branch. - @@ -39,25 +40,27 @@ current r = do {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Branch) -currentUnsafe r = parse . firstLine' - <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r +currentUnsafe r = parse . firstLine' <$> pipeReadStrict + [ Param "symbolic-ref" + , Param "-q" + , Param $ fromRef Git.Ref.headRef + ] r where parse b | B.null b = Nothing - | otherwise = Just $ Git.Ref $ decodeBS b + | otherwise = Just $ Git.Ref b {- Checks if the second branch has any commits not present on the first - branch. -} changed :: Branch -> Branch -> Repo -> IO Bool changed origbranch newbranch repo | origbranch == newbranch = return False - | otherwise = not . null + | otherwise = not . B.null <$> changed' origbranch newbranch [Param "-n1"] repo where -changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String -changed' origbranch newbranch extraps repo = - decodeBS <$> pipeReadStrict ps repo +changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO B.ByteString +changed' origbranch newbranch extraps repo = pipeReadStrict ps repo where ps = [ Param "log" @@ -68,7 +71,7 @@ changed' origbranch newbranch extraps repo = {- Lists commits that are in the second branch and not in the first branch. -} changedCommits :: Branch -> Branch -> [CommandParam] -> Repo -> IO [Sha] changedCommits origbranch newbranch extraps repo = - catMaybes . map extractSha . lines + catMaybes . map extractSha . B8.lines <$> changed' origbranch newbranch extraps repo {- Check if it's possible to fast-forward from the old @@ -163,8 +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" $ - decodeBS' <$> pipeReadStrict [Param "write-tree"] repo + tree <- getSha "write-tree" $ pipeReadStrict [Param "write-tree"] repo ifM (cancommit tree) ( do sha <- commitTree commitmode message parentrefs tree repo diff --git a/Git/CatFile.hs b/Git/CatFile.hs index 6402001..1769e57 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -1,10 +1,12 @@ {- git cat-file interface - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.CatFile ( CatFileHandle, catFileStart, @@ -22,7 +24,9 @@ module Git.CatFile ( import System.IO import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.ByteString.Char8 as S8 +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 import qualified Data.Map as M import Data.String import Data.Char @@ -69,11 +73,11 @@ catFileStop h = do {- Reads a file from a specified branch. -} catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString catFile h branch file = catObject h $ Ref $ - fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file) + fromRef' branch <> ":" <> toInternalGitPath file catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) catFileDetails h branch file = catObjectDetails h $ Ref $ - fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file) + fromRef' branch <> ":" <> toInternalGitPath file {- Uses a running git cat-file read the content of an object. - Objects that do not exist will have "" returned. -} @@ -82,9 +86,9 @@ catObject h object = maybe L.empty fst3 <$> catObjectDetails h object catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType)) catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \from -> do - header <- hGetLine from + header <- S8.hGetLine from case parseResp object header of - Just (ParsedResp sha size objtype) -> do + Just (ParsedResp sha objtype size) -> do content <- S.hGet from (fromIntegral size) eatchar '\n' from return $ Just (L.fromChunks [content], sha, objtype) @@ -112,9 +116,9 @@ catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \f {- Gets the size and type of an object, without reading its content. -} catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType)) catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do - resp <- hGetLine from + resp <- S8.hGetLine from case parseResp object resp of - Just (ParsedResp sha size objtype) -> + Just (ParsedResp sha objtype size) -> return $ Just (sha, size, objtype) Just DNE -> return Nothing Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object) @@ -126,36 +130,39 @@ catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ objtype <- queryObjectType object (gitRepo h) return $ (,,) <$> sha <*> sz <*> objtype -data ParsedResp = ParsedResp Sha FileSize ObjectType | DNE +data ParsedResp = ParsedResp Sha ObjectType FileSize | DNE + deriving (Show) query :: CoProcess.CoProcessHandle -> Ref -> IO a -> (Handle -> IO a) -> IO a query hdl object newlinefallback receive -- git cat-file --batch uses a line based protocol, so when the -- filename itself contains a newline, have to fall back to another -- method of getting the information. - | '\n' `elem` s = newlinefallback + | '\n' `S8.elem` s = newlinefallback -- git strips carriage return from the end of a line, out of some -- misplaced desire to support windows, so also use the newline -- fallback for those. - | "\r" `isSuffixOf` s = newlinefallback + | "\r" `S8.isSuffixOf` s = newlinefallback | otherwise = CoProcess.query hdl send receive where - send to = hPutStrLn to s - s = fromRef object + send to = S8.hPutStrLn to s + s = fromRef' object + +parseResp :: Ref -> S.ByteString -> Maybe ParsedResp +parseResp object s + | " missing" `S.isSuffixOf` s -- less expensive than full check + && s == fromRef' object <> " missing" = Just DNE + | otherwise = eitherToMaybe $ A.parseOnly respParser s -parseResp :: Ref -> String -> Maybe ParsedResp -parseResp object l - | " missing" `isSuffixOf` l -- less expensive than full check - && l == fromRef object ++ " missing" = Just DNE - | otherwise = case words l of - [sha, objtype, size] - | length sha == shaSize -> - case (readObjectType (encodeBS objtype), reads size) of - (Just t, [(bytes, "")]) -> - Just $ ParsedResp (Ref sha) bytes t - _ -> Nothing - | otherwise -> Nothing - _ -> Nothing +respParser :: A.Parser ParsedResp +respParser = ParsedResp + <$> (maybe (fail "bad sha") return . extractSha =<< nextword) + <* A8.char ' ' + <*> (maybe (fail "bad object type") return . readObjectType =<< nextword) + <* A8.char ' ' + <*> A8.decimal + where + nextword = A8.takeTill (== ' ') querySingle :: CommandParam -> Ref -> Repo -> (Handle -> IO a) -> IO (Maybe a) querySingle o r repo reader = assertLocal repo $ @@ -219,39 +226,39 @@ catTree h treeref = go <$> catObjectDetails h treeref catCommit :: CatFileHandle -> Ref -> IO (Maybe Commit) catCommit h commitref = go <$> catObjectDetails h commitref where - go (Just (b, _, CommitObject)) = parseCommit b + go (Just (b, _, CommitObject)) = parseCommit (L.toStrict b) go _ = Nothing -parseCommit :: L.ByteString -> Maybe Commit +parseCommit :: S.ByteString -> Maybe Commit parseCommit b = Commit - <$> (extractSha . L8.unpack =<< field "tree") - <*> Just (maybe [] (mapMaybe (extractSha . L8.unpack)) (fields "parent")) + <$> (extractSha =<< field "tree") + <*> Just (maybe [] (mapMaybe extractSha) (fields "parent")) <*> (parsemetadata <$> field "author") <*> (parsemetadata <$> field "committer") - <*> Just (L8.unpack $ L.intercalate (L.singleton nl) message) + <*> Just (decodeBS $ S.intercalate (S.singleton nl) message) where field n = headMaybe =<< fields n fields n = M.lookup (fromString n) fieldmap fieldmap = M.fromListWith (++) ((map breakfield) header) breakfield l = - let (k, sp_v) = L.break (== sp) l - in (k, [L.drop 1 sp_v]) - (header, message) = separate L.null ls - ls = L.split nl b + let (k, sp_v) = S.break (== sp) l + in (k, [S.drop 1 sp_v]) + (header, message) = separate S.null ls + ls = S.split nl b -- author and committer lines have the form: "name date" -- The email is always present, even if empty "<>" parsemetadata l = CommitMetaData - { commitName = whenset $ L.init name_sp + { commitName = whenset $ S.init name_sp , commitEmail = whenset email - , commitDate = whenset $ L.drop 2 gt_sp_date + , commitDate = whenset $ S.drop 2 gt_sp_date } where - (name_sp, rest) = L.break (== lt) l - (email, gt_sp_date) = L.break (== gt) (L.drop 1 rest) + (name_sp, rest) = S.break (== lt) l + (email, gt_sp_date) = S.break (== gt) (S.drop 1 rest) whenset v - | L.null v = Nothing - | otherwise = Just (L8.unpack v) + | S.null v = Nothing + | otherwise = Just (decodeBS v) nl = fromIntegral (ord '\n') sp = fromIntegral (ord ' ') diff --git a/Git/Command.hs b/Git/Command.hs index eb20af2..15157a0 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -81,11 +81,16 @@ pipeReadStrict' reader params repo = assertLocal repo $ {- Runs a git command, feeding it an input, and returning its output, - which is expected to be fairly small, since it's all read into memory - strictly. -} -pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO String +pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO S.ByteString pipeWriteRead params writer repo = assertLocal repo $ writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) - (gitEnv repo) writer (Just adjusthandle) + (gitEnv repo) writer' where + writer' = case writer of + Nothing -> Nothing + Just a -> Just $ \h -> do + adjusthandle h + a h adjusthandle h = hSetNewlineMode h noNewlineTranslation {- Runs a git command, feeding it input on a handle with an action. -} diff --git a/Git/Config.hs b/Git/Config.hs index 4b60664..f50d5eb 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -1,6 +1,6 @@ {- git repository configuration handling - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -14,6 +14,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.Char import qualified System.FilePath.ByteString as P +import Control.Concurrent.Async import Common import Git @@ -58,7 +59,7 @@ read' repo = go repo go Repo { location = LocalUnknown d } = git_config d go _ = assertLocal repo $ error "internal" git_config d = withHandle StdoutHandle createProcessSuccess p $ - hRead repo + hRead repo ConfigNullList where params = ["config", "--null", "--list"] p = (proc "git" params) @@ -73,7 +74,7 @@ global = do ifM (doesFileExist $ home ".gitconfig") ( do repo <- withHandle StdoutHandle createProcessSuccess p $ - hRead (Git.Construct.fromUnknown) + hRead (Git.Construct.fromUnknown) ConfigNullList return $ Just repo , return Nothing ) @@ -82,18 +83,18 @@ global = do p = (proc "git" params) {- Reads git config from a handle and populates a repo with it. -} -hRead :: Repo -> Handle -> IO Repo -hRead repo h = do +hRead :: Repo -> ConfigStyle -> Handle -> IO Repo +hRead repo st h = do val <- S.hGetContents h - store val repo + store val st repo {- Stores a git config into a Repo, returning the new version of the Repo. - The git config may be multiple lines, or a single line. - Config settings can be updated incrementally. -} -store :: S.ByteString -> Repo -> IO Repo -store s repo = do - let c = parse s +store :: S.ByteString -> ConfigStyle -> Repo -> IO Repo +store s st repo = do + let c = parse s st updateLocation $ repo { config = (M.map Prelude.head c) `M.union` config repo , fullconfig = M.unionWith (++) c (fullconfig repo) @@ -134,27 +135,30 @@ updateLocation' r l = do top <- absPath $ fromRawFilePath (gitdir l) let p = absPathFrom top (fromRawFilePath d) return $ l { worktree = Just (toRawFilePath p) } + Just NoConfigValue -> return l return $ r { location = l' } +data ConfigStyle = ConfigList | ConfigNullList + {- Parses git config --list or git config --null --list output into a - config map. -} -parse :: S.ByteString -> M.Map ConfigKey [ConfigValue] -parse s +parse :: S.ByteString -> ConfigStyle -> M.Map ConfigKey [ConfigValue] +parse s st | S.null s = M.empty - -- --list output will have a '=' in the first line - -- (The first line of --null --list output is the name of a key, - -- which is assumed to never contain '='.) - | S.elem eq firstline = sep eq $ S.split nl s - -- --null --list output separates keys from values with newlines - | otherwise = sep nl $ S.split 0 s + | otherwise = case st of + ConfigList -> sep eq $ S.split nl s + ConfigNullList -> sep nl $ S.split 0 s where nl = fromIntegral (ord '\n') eq = fromIntegral (ord '=') - firstline = S.takeWhile (/= nl) s sep c = M.fromListWith (++) - . map (\(k,v) -> (ConfigKey k, [ConfigValue (S.drop 1 v)])) + . map (\(k,v) -> (ConfigKey k, [mkval v])) . map (S.break (== c)) + + mkval v + | S.null v = NoConfigValue + | otherwise = ConfigValue (S.drop 1 v) {- Checks if a string from git config is a true/false value. -} isTrueFalse :: String -> Maybe Bool @@ -162,11 +166,21 @@ isTrueFalse = isTrueFalse' . ConfigValue . encodeBS' isTrueFalse' :: ConfigValue -> Maybe Bool isTrueFalse' (ConfigValue s) + | s' == "yes" = Just True + | s' == "on" = Just True | s' == "true" = Just True + | s' == "1" = Just True + + | s' == "no" = Just False + | s' == "off" = Just False | s' == "false" = Just False + | s' == "0" = Just False + | s' == "" = Just False + | otherwise = Nothing where s' = S8.map toLower s +isTrueFalse' NoConfigValue = Just True boolConfig :: Bool -> String boolConfig True = "true" @@ -184,25 +198,28 @@ coreBare = "core.bare" {- Runs a command to get the configuration of a repo, - and returns a repo populated with the configuration, as well as the raw - - output of the command. -} -fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, S.ByteString)) -fromPipe r cmd params = try $ - withHandle StdoutHandle createProcessSuccess p $ \h -> do - val <- S.hGetContents h - r' <- store val r - return (r', val) + - output and any standard output of the command. -} +fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, S.ByteString)) +fromPipe r cmd params st = try $ + withOEHandles createProcessSuccess p $ \(hout, herr) -> do + geterr <- async $ S.hGetContents herr + getval <- async $ S.hGetContents hout + val <- wait getval + err <- wait geterr + r' <- store val st r + return (r', val, err) where p = proc cmd $ toCommand params {- Reads git config from a specified file and returns the repo populated - with the configuration. -} -fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString)) +fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString, S.ByteString)) fromFile r f = fromPipe r "git" [ Param "config" , Param "--file" , File f , Param "--list" - ] + ] ConfigList {- Changes a git config setting in the specified config file. - (Creates the file if it does not already exist.) -} diff --git a/Git/DiffTreeItem.hs b/Git/DiffTreeItem.hs index ffda2e8..090ad3e 100644 --- a/Git/DiffTreeItem.hs +++ b/Git/DiffTreeItem.hs @@ -10,6 +10,7 @@ module Git.DiffTreeItem ( ) where import System.Posix.Types +import qualified Data.ByteString as S import Git.FilePath import Git.Types @@ -17,8 +18,8 @@ import Git.Types data DiffTreeItem = DiffTreeItem { srcmode :: FileMode , dstmode :: FileMode - , srcsha :: Sha -- nullSha if file was added - , dstsha :: Sha -- nullSha if file was deleted - , status :: String + , srcsha :: Sha -- null sha if file was added + , dstsha :: Sha -- null sha if file was deleted + , status :: S.ByteString , file :: TopFilePath } deriving Show diff --git a/Git/FilePath.hs b/Git/FilePath.hs index 66a0159..d31b421 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -50,7 +50,7 @@ data BranchFilePath = BranchFilePath Ref TopFilePath {- Git uses the branch:file form to refer to a BranchFilePath -} descBranchFilePath :: BranchFilePath -> S.ByteString descBranchFilePath (BranchFilePath b f) = - encodeBS' (fromRef b) <> ":" <> getTopFilePath f + fromRef' b <> ":" <> getTopFilePath f {- Path to a TopFilePath, within the provided git repo. -} fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath diff --git a/Git/Fsck.hs b/Git/Fsck.hs index 6f33e11..69a9e9f 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -139,7 +139,8 @@ isMissing s r = either (const True) (const False) <$> tryIO dump ] r findShas :: [String] -> [Sha] -findShas = catMaybes . map extractSha . concat . map words . filter wanted +findShas = catMaybes . map (extractSha . encodeBS') + . concat . map words . filter wanted where wanted l = not ("dangling " `isPrefixOf` l) diff --git a/Git/HashObject.hs b/Git/HashObject.hs index 3787c9c..bcad9a1 100644 --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -18,6 +18,7 @@ import qualified Utility.CoProcess as CoProcess import Utility.Tmp import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.ByteString.Builder @@ -39,7 +40,7 @@ hashFile :: HashObjectHandle -> FilePath -> IO Sha hashFile h file = CoProcess.query h send receive where send to = hPutStrLn to =<< absPath file - receive from = getSha "hash-object" $ hGetLine from + receive from = getSha "hash-object" $ S8.hGetLine from class HashableBlob t where hashableBlobToHandle :: Handle -> t -> IO () diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index 5534307..830b5f5 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -1,6 +1,6 @@ {- git ls-files interface - - - Copyright 2010-2018 Joey Hess + - Copyright 2010-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -24,6 +24,7 @@ module Git.LsFiles ( Unmerged(..), unmerged, StagedDetails, + inodeCaches, ) where import Common @@ -31,17 +32,45 @@ import Git import Git.Command import Git.Types import Git.Sha +import Utility.InodeCache +import Utility.TimeStamp import Numeric +import Data.Char import System.Posix.Types -import qualified Data.ByteString.Lazy as L +import qualified Data.Map as M +import qualified Data.ByteString as S -{- Scans for files that are checked into git's index at the specified locations. -} +{- It's only safe to use git ls-files on the current repo, not on a remote. + - + - Git has some strange behavior when git ls-files is used with repos + - that are not the one that the cwd is in: + - git --git-dir=../foo/.git --worktree=../foo ../foo fails saying + - "../foo is outside repository". + - That does not happen when an absolute path is provided. + - + - Also, the files output by ls-files are relative to the cwd. + - Unless it's run on remote. Then it's relative to the top of the remote + - repo. + - + - So, best to avoid that class of problems. + -} +safeForLsFiles :: Repo -> Bool +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 + +{- Lists files that are checked into git's index at the specified paths. + - With no paths, all files are listed. + -} inRepo :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) inRepo = inRepo' [] inRepo' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -inRepo' ps l repo = pipeNullSplit' params repo +inRepo' ps l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" : @@ -53,14 +82,15 @@ inRepo' ps l repo = pipeNullSplit' params repo {- Files that are checked into the index or have been committed to a - branch. -} inRepoOrBranch :: Branch -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -inRepoOrBranch (Ref b) = inRepo' [Param $ "--with-tree=" ++ b] +inRepoOrBranch b = inRepo' [Param $ "--with-tree=" ++ fromRef b] {- Scans for files at the specified locations that are not checked into git. -} notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) notInRepo = notInRepo' [] notInRepo' :: [CommandParam] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -notInRepo' ps include_ignored l repo = pipeNullSplit' params repo +notInRepo' ps include_ignored l repo = guardSafeForLsFiles repo $ + pipeNullSplit' params repo where params = concat [ [ Param "ls-files", Param "--others"] @@ -81,18 +111,20 @@ notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"] {- Finds all files in the specified locations, whether checked into git or - not. -} allFiles :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -allFiles l = pipeNullSplit' $ - Param "ls-files" : - Param "--cached" : - Param "--others" : - Param "-z" : - Param "--" : - map (File . fromRawFilePath) l +allFiles l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo + where + params = + Param "ls-files" : + Param "--cached" : + Param "--others" : + Param "-z" : + Param "--" : + map (File . fromRawFilePath) l {- Returns a list of files in the specified locations that have been - deleted. -} deleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -deleted l repo = pipeNullSplit' params repo +deleted l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" : @@ -104,7 +136,7 @@ deleted l repo = pipeNullSplit' params repo {- Returns a list of files in the specified locations that have been - modified. -} modified :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -modified l repo = pipeNullSplit' params repo +modified l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" : @@ -116,7 +148,7 @@ modified l repo = pipeNullSplit' params repo {- Files that have been modified or are not checked into git (and are not - ignored). -} modifiedOthers :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -modifiedOthers l repo = pipeNullSplit' params repo +modifiedOthers l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" : @@ -137,7 +169,8 @@ stagedNotDeleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"] staged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -staged' ps l repo = pipeNullSplit' (prefix ++ ps ++ suffix) repo +staged' ps l repo = guardSafeForLsFiles repo $ + pipeNullSplit' (prefix ++ ps ++ suffix) repo where prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] suffix = Param "--" : map (File . fromRawFilePath) l @@ -156,19 +189,22 @@ stagedDetails = stagedDetails' [] {- Gets details about staged files, including the Sha of their staged - contents. -} stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) -stagedDetails' ps l repo = do - (ls, cleanup) <- pipeNullSplit params repo - return (map parse ls, cleanup) +stagedDetails' ps l repo = guardSafeForLsFiles repo $ do + (ls, cleanup) <- pipeNullSplit' params repo + return (map parseStagedDetails ls, cleanup) where params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ Param "--" : map (File . fromRawFilePath) l - parse s - | null file = (L.toStrict s, Nothing, Nothing) - | otherwise = (toRawFilePath file, extractSha $ take shaSize rest, readmode mode) - where - (metadata, file) = separate (== '\t') (decodeBL' s) - (mode, rest) = separate (== ' ') metadata - readmode = fst <$$> headMaybe . readOct + +parseStagedDetails :: S.ByteString -> StagedDetails +parseStagedDetails s + | S.null file = (s, Nothing, Nothing) + | otherwise = (file, extractSha sha, readmode mode) + where + (metadata, file) = separate' (== fromIntegral (ord '\t')) s + (mode, metadata') = separate' (== fromIntegral (ord ' ')) metadata + (sha, _) = separate' (== fromIntegral (ord ' ')) metadata' + readmode = fst <$$> headMaybe . readOct . decodeBS' {- Returns a list of the files in the specified locations that are staged - for commit, and whose type has changed. -} @@ -181,7 +217,7 @@ typeChanged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChanged = typeChanged' [] typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -typeChanged' ps l repo = do +typeChanged' ps l repo = guardSafeForLsFiles repo $ do (fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo -- git diff returns filenames relative to the top of the git repo; -- convert to filenames relative to the cwd, like git ls-files. @@ -221,7 +257,7 @@ data Unmerged = Unmerged - If a line is omitted, that side removed the file. -} unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool) -unmerged l repo = do +unmerged l repo = guardSafeForLsFiles repo $ do (fs, cleanup) <- pipeNullSplit params repo return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup) where @@ -249,7 +285,7 @@ parseUnmerged s then Nothing else do treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype) - sha <- extractSha rawsha + sha <- extractSha (encodeBS' rawsha) return $ InternalUnmerged (stage == 2) (toRawFilePath file) (Just treeitemtype) (Just sha) _ -> Nothing @@ -278,3 +314,53 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest , itreeitemtype = Nothing , isha = Nothing } + +{- Gets the InodeCache equivilant information stored in the git index. + - + - Note that this uses a --debug option whose output could change at some + - point in the future. If the output is not as expected, will use Nothing. + -} +inodeCaches :: [RawFilePath] -> Repo -> IO ([(FilePath, Maybe InodeCache)], IO Bool) +inodeCaches locs repo = guardSafeForLsFiles repo $ do + (ls, cleanup) <- pipeNullSplit params repo + return (parse Nothing (map decodeBL ls), cleanup) + where + params = + Param "ls-files" : + Param "--cached" : + Param "-z" : + Param "--debug" : + Param "--" : + map (File . fromRawFilePath) locs + + parse Nothing (f:ls) = parse (Just f) ls + parse (Just f) (s:[]) = + let i = parsedebug s + in (f, i) : [] + parse (Just f) (s:ls) = + let (d, f') = splitdebug s + i = parsedebug d + in (f, i) : parse (Just f') ls + parse _ _ = [] + + -- First 5 lines are --debug output, remainder is the next filename. + -- This assumes that --debug does not start outputting more lines. + splitdebug s = case splitc '\n' s of + (d1:d2:d3:d4:d5:rest) -> + ( intercalate "\n" [d1, d2, d3, d4, d5] + , intercalate "\n" rest + ) + _ -> ("", s) + + -- This parser allows for some changes to the --debug output, + -- including reordering, or adding more items. + parsedebug s = do + let l = words s + let iskey v = ":" `isSuffixOf` v + let m = M.fromList $ zip + (filter iskey l) + (filter (not . iskey) l) + mkInodeCache + <$> (readish =<< M.lookup "ino:" m) + <*> (readish =<< M.lookup "size:" m) + <*> (parsePOSIXTime =<< (replace ":" "." <$> M.lookup "mtime:" m)) diff --git a/Git/LsTree.hs b/Git/LsTree.hs index a3d8383..ead501f 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -21,7 +21,6 @@ module Git.LsTree ( import Common import Git import Git.Command -import Git.Sha import Git.FilePath import qualified Git.Filename import Utility.Attoparsec @@ -94,10 +93,10 @@ parserLsTree = TreeItem <$> octal <* A8.char ' ' -- type - <*> A.takeTill (== 32) + <*> A8.takeTill (== ' ') <* A8.char ' ' -- sha - <*> (Ref . decodeBS' <$> A.take shaSize) + <*> (Ref <$> A8.takeTill (== '\t')) <* A8.char '\t' -- file <*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString) diff --git a/Git/Objects.hs b/Git/Objects.hs index c9ede4d..6a24087 100644 --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -26,7 +26,7 @@ listPackFiles r = filter (".pack" `isSuffixOf`) listLooseObjectShas :: Repo -> IO [Sha] listLooseObjectShas r = catchDefaultIO [] $ - mapMaybe (extractSha . concat . reverse . take 2 . reverse . splitDirectories) + mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories) <$> dirContentsRecursiveSkipping (== "pack") True (objectsDir r) looseObjectFile :: Repo -> Sha -> FilePath diff --git a/Git/Ref.hs b/Git/Ref.hs index 621e328..104a1db 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -17,6 +17,7 @@ import Git.Types import Data.Char (chr, ord) import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 headRef :: Ref headRef = Ref "HEAD" @@ -25,7 +26,7 @@ headFile :: Repo -> FilePath headFile r = fromRawFilePath (localGitDir r) "HEAD" setHeadRef :: Ref -> Repo -> IO () -setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref) +setHeadRef ref r = S.writeFile (headFile r) ("ref: " <> fromRef' ref) {- Converts a fully qualified git ref into a user-visible string. -} describe :: Ref -> String @@ -41,10 +42,11 @@ base = removeBase "refs/heads/" . removeBase "refs/remotes/" {- Removes a directory such as "refs/heads/master" from a - fully qualified ref. Any ref not starting with it is left as-is. -} removeBase :: String -> Ref -> Ref -removeBase dir (Ref r) - | prefix `isPrefixOf` r = Ref (drop (length prefix) r) - | otherwise = Ref r +removeBase dir r + | prefix `isPrefixOf` rs = Ref $ encodeBS $ drop (length prefix) rs + | otherwise = r where + rs = fromRef r prefix = case end dir of ['/'] -> dir _ -> dir ++ "/" @@ -53,7 +55,7 @@ removeBase dir (Ref r) - refs/heads/master, yields a version of that ref under the directory, - such as refs/remotes/origin/master. -} underBase :: String -> Ref -> Ref -underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r) +underBase dir r = Ref $ encodeBS dir <> "/" <> fromRef' (base r) {- Convert a branch such as "master" into a fully qualified ref. -} branchRef :: Branch -> Ref @@ -66,21 +68,25 @@ branchRef = underBase "refs/heads" - of a repo. -} fileRef :: RawFilePath -> Ref -fileRef f = Ref $ ":./" ++ fromRawFilePath f +fileRef f = Ref $ ":./" <> f {- Converts a Ref to refer to the content of the Ref on a given date. -} dateRef :: Ref -> RefDate -> Ref -dateRef (Ref r) (RefDate d) = Ref $ r ++ "@" ++ 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 -> Ref -fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr) +fileFromRef r f = let (Ref fr) = fileRef f in Ref (fromRef' r <> fr) {- Checks if a ref exists. -} exists :: Ref -> Repo -> IO Bool exists ref = runBool - [Param "show-ref", Param "--verify", Param "-q", Param $ fromRef ref] + [ Param "show-ref" + , Param "--verify" + , Param "-q" + , Param $ fromRef ref + ] {- The file used to record a ref. (Git also stores some refs in a - packed-refs file.) -} @@ -107,26 +113,26 @@ sha branch repo = process <$> showref repo ] process s | S.null s = Nothing - | otherwise = Just $ Ref $ decodeBS' $ firstLine' s + | otherwise = Just $ Ref $ firstLine' s headSha :: Repo -> IO (Maybe Sha) headSha = sha headRef {- List of (shas, branches) matching a given ref or refs. -} matching :: [Ref] -> Repo -> IO [(Sha, Branch)] -matching refs repo = matching' (map fromRef refs) repo +matching = matching' [] {- Includes HEAD in the output, if asked for it. -} matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)] -matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo +matchingWithHEAD = matching' [Param "--head"] -{- List of (shas, branches) matching a given ref spec. -} -matching' :: [String] -> Repo -> IO [(Sha, Branch)] -matching' ps repo = map gen . lines . decodeBS' <$> - pipeReadStrict (Param "show-ref" : map Param ps) repo +matching' :: [CommandParam] -> [Ref] -> Repo -> IO [(Sha, Branch)] +matching' ps rs repo = map gen . S8.lines <$> + pipeReadStrict (Param "show-ref" : ps ++ rps) repo where - gen l = let (r, b) = separate (== ' ') l + gen l = let (r, b) = separate' (== fromIntegral (ord ' ')) l in (Ref r, Ref b) + rps = map (Param . fromRef) rs {- List of (shas, branches) matching a given ref. - Duplicate shas are filtered out. -} @@ -137,7 +143,7 @@ matchingUniq refs repo = nubBy uniqref <$> matching refs repo {- List of all refs. -} list :: Repo -> IO [(Sha, Ref)] -list = matching' [] +list = matching' [] [] {- Deletes a ref. This can delete refs that are not branches, - which git branch --delete refuses to delete. -} @@ -154,13 +160,17 @@ delete oldvalue ref = run - The ref may be something like a branch name, and it could contain - ":subdir" if a subtree is wanted. -} tree :: Ref -> Repo -> IO (Maybe Sha) -tree (Ref ref) = extractSha . decodeBS <$$> pipeReadStrict - [ Param "rev-parse", Param "--verify", Param "--quiet", Param ref' ] +tree (Ref ref) = extractSha <$$> pipeReadStrict + [ Param "rev-parse" + , Param "--verify" + , Param "--quiet" + , Param (decodeBS' ref') + ] where - ref' = if ":" `isInfixOf` ref + ref' = if ":" `S.isInfixOf` ref then ref -- de-reference commit objects to the tree - else ref ++ ":" + else ref <> ":" {- Checks if a String is a legal git ref name. - diff --git a/Git/RefLog.hs b/Git/RefLog.hs index 7ba8713..b98833c 100644 --- a/Git/RefLog.hs +++ b/Git/RefLog.hs @@ -12,6 +12,9 @@ import Git import Git.Command import Git.Sha +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 + {- Gets the reflog for a given branch. -} get :: Branch -> Repo -> IO [Sha] get b = getMulti [b] @@ -21,7 +24,7 @@ getMulti :: [Branch] -> Repo -> IO [Sha] getMulti bs = get' (map (Param . fromRef) bs) get' :: [CommandParam] -> Repo -> IO [Sha] -get' ps = mapMaybe extractSha . lines . decodeBS <$$> pipeReadStrict ps' +get' ps = mapMaybe (extractSha . S.copy) . S8.lines <$$> pipeReadStrict ps' where ps' = catMaybes [ Just $ Param "log" diff --git a/Git/Remote.hs b/Git/Remote.hs index 69d6b52..7c6cfc2 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -84,12 +84,17 @@ parseRemoteLocation s repo = ret $ calcloc s where replacement = decodeBS' $ S.drop (S.length prefix) $ S.take (S.length bestkey - S.length suffix) bestkey - (ConfigKey bestkey, ConfigValue bestvalue) = maximumBy longestvalue insteadofs + (bestkey, bestvalue) = + case maximumBy longestvalue insteadofs of + (ConfigKey k, ConfigValue v) -> (k, v) + (ConfigKey k, NoConfigValue) -> (k, mempty) longestvalue (_, a) (_, b) = compare b a - insteadofs = filterconfig $ \(ConfigKey k, ConfigValue v) -> - prefix `S.isPrefixOf` k && - suffix `S.isSuffixOf` k && - v `S.isPrefixOf` encodeBS l + insteadofs = filterconfig $ \case + (ConfigKey k, ConfigValue v) -> + prefix `S.isPrefixOf` k && + suffix `S.isSuffixOf` k && + v `S.isPrefixOf` encodeBS l + (_, NoConfigValue) -> False filterconfig f = filter f $ concatMap splitconfigs $ M.toList $ fullconfig repo splitconfigs (k, vs) = map (\v -> (k, v)) vs diff --git a/Git/Repair.hs b/Git/Repair.hs index 66e6811..f81aa78 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -122,24 +122,26 @@ retrieveMissingObjects missing referencerepo r ) pullremotes tmpr (rmt:rmts) fetchrefs ms | not (foundBroken ms) = return ms - | otherwise = do - putStrLn $ "Trying to recover missing objects from remote " ++ repoDescribe rmt ++ "." - ifM (fetchfrom (repoLocation rmt) fetchrefs tmpr) - ( do - void $ explodePacks tmpr - void $ copyObjects tmpr r - case ms of - FsckFailed -> pullremotes tmpr rmts fetchrefs ms - FsckFoundMissing s t -> do - stillmissing <- findMissing (S.toList s) r - pullremotes tmpr rmts fetchrefs (FsckFoundMissing stillmissing t) - , pullremotes tmpr rmts fetchrefs ms - ) - fetchfrom fetchurl ps fetchr = runBool ps' fetchr' + | otherwise = case remoteName rmt of + Just n -> do + putStrLn $ "Trying to recover missing objects from remote " ++ n ++ "." + ifM (fetchfrom n fetchrefs tmpr) + ( do + void $ explodePacks tmpr + void $ copyObjects tmpr r + case ms of + FsckFailed -> pullremotes tmpr rmts fetchrefs ms + FsckFoundMissing s t -> do + stillmissing <- findMissing (S.toList s) r + pullremotes tmpr rmts fetchrefs (FsckFoundMissing stillmissing t) + , pullremotes tmpr rmts fetchrefs ms + ) + Nothing -> pullremotes tmpr rmts fetchrefs ms + fetchfrom loc ps fetchr = runBool ps' fetchr' where ps' = [ Param "fetch" - , Param fetchurl + , Param loc , Param "--force" , Param "--update-head-ok" , Param "--quiet" @@ -232,7 +234,7 @@ getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) "refs") getAllRefs' :: FilePath -> IO [Ref] getAllRefs' refdir = do let topsegs = length (splitPath refdir) - 1 - let toref = Ref . joinPath . drop topsegs . splitPath + let toref = Ref . encodeBS' . joinPath . drop topsegs . splitPath map toref <$> dirContentsRecursive refdir explodePackedRefsFile :: Repo -> IO () @@ -245,8 +247,9 @@ explodePackedRefsFile r = do nukeFile f where makeref (sha, ref) = do - let dest = fromRawFilePath (localGitDir r) fromRef ref - createDirectoryIfMissing True (parentDir dest) + let gitd = fromRawFilePath (localGitDir r) + let dest = gitd fromRef ref + createDirectoryUnder gitd (parentDir dest) unlessM (doesFileExist dest) $ writeFile dest (fromRef sha) @@ -256,8 +259,8 @@ packedRefsFile r = fromRawFilePath (localGitDir r) "packed-refs" parsePacked :: String -> Maybe (Sha, Ref) parsePacked l = case words l of (sha:ref:[]) - | isJust (extractSha sha) && Ref.legal True ref -> - Just (Ref sha, Ref ref) + | isJust (extractSha (encodeBS' sha)) && Ref.legal True ref -> + Just (Ref (encodeBS' sha), Ref (encodeBS' ref)) _ -> Nothing {- git-branch -d cannot be used to remove a branch that is directly @@ -278,13 +281,13 @@ findUncorruptedCommit missing goodcommits branch r = do if ok then return (Just branch, goodcommits') else do - (ls, cleanup) <- pipeNullSplit + (ls, cleanup) <- pipeNullSplit' [ Param "log" , Param "-z" , Param "--format=%H" , Param (fromRef branch) ] r - let branchshas = catMaybes $ map (extractSha . decodeBL) ls + let branchshas = catMaybes $ map extractSha ls reflogshas <- RefLog.get branch r -- XXX Could try a bit harder here, and look -- for uncorrupted old commits in branches in the @@ -327,8 +330,8 @@ verifyCommit missing goodcommits commit r where parse l = case words l of (commitsha:treesha:[]) -> (,) - <$> extractSha commitsha - <*> extractSha treesha + <$> extractSha (encodeBS' commitsha) + <*> extractSha (encodeBS' treesha) _ -> Nothing check [] = return True check ((c, t):rest) @@ -447,7 +450,8 @@ preRepair g = do void $ tryIO $ allowWrite f where headfile = fromRawFilePath (localGitDir g) "HEAD" - validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s) + validhead s = "ref: refs/" `isPrefixOf` s + || isJust (extractSha (encodeBS' s)) {- Put it all together. -} runRepair :: (Ref -> Bool) -> Bool -> Repo -> IO (Bool, [Branch]) diff --git a/Git/Sha.hs b/Git/Sha.hs index cc33cac..a66c34e 100644 --- a/Git/Sha.hs +++ b/Git/Sha.hs @@ -1,43 +1,74 @@ {- git SHA stuff - - - Copyright 2011 Joey Hess + - Copyright 2011,2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Sha where import Common import Git.Types +import qualified Data.ByteString as S +import Data.Char + {- Runs an action that causes a git subcommand to emit a Sha, and strips - any trailing newline, returning the sha. -} -getSha :: String -> IO String -> IO Sha +getSha :: String -> IO S.ByteString -> IO Sha getSha subcommand a = maybe bad return =<< extractSha <$> a where bad = error $ "failed to read sha from git " ++ subcommand -{- Extracts the Sha from a string. There can be a trailing newline after - - it, but nothing else. -} -extractSha :: String -> Maybe Sha +{- Extracts the Sha from a ByteString. + - + - There can be a trailing newline after it, but nothing else. + -} +extractSha :: S.ByteString -> Maybe Sha extractSha s - | len == shaSize = val s - | len == shaSize + 1 && length s' == shaSize = val s' + | len `elem` shaSizes = val s + | len - 1 `elem` shaSizes && S.length s' == len - 1 = val s' | otherwise = Nothing where - len = length s - s' = firstLine s + len = S.length s + s' = firstLine' s val v - | all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v + | S.all validinsha v = Just $ Ref v | otherwise = Nothing + validinsha w = or + [ w >= 48 && w <= 57 -- 0-9 + , w >= 97 && w <= 102 -- a-f + , w >= 65 && w <= 70 -- A-F + ] -{- Size of a git sha. -} -shaSize :: Int -shaSize = 40 +{- Sizes of git shas. -} +shaSizes :: [Int] +shaSizes = + [ 40 -- sha1 (must come first) + , 64 -- sha256 + ] -nullSha :: Ref -nullSha = Ref $ replicate shaSize '0' +{- Git plumbing often uses a all 0 sha to represent things like a + - deleted file. -} +nullShas :: [Sha] +nullShas = map (\n -> Ref (S.replicate n zero)) shaSizes + where + zero = fromIntegral (ord '0') -{- Git's magic empty tree. -} +{- Sha to provide to git plumbing when deleting a file. + - + - It's ok to provide a sha1; git versions that use sha256 will map the + - sha1 to the sha256, or probably just treat all null sha1 specially + - the same as all null sha256. -} +deleteSha :: Sha +deleteSha = Prelude.head nullShas + +{- Git's magic empty tree. + - + - It's ok to provide the sha1 of this to git to refer to an empty tree; + - git versions that use sha256 will map the sha1 to the sha256. + -} emptyTree :: Ref emptyTree = Ref "4b825dc642cb6eb9a060e54bf8d69288fbee4904" diff --git a/Git/Types.hs b/Git/Types.hs index 9c2754a..4bf61e5 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -1,12 +1,11 @@ {- git data types - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Git.Types where @@ -18,6 +17,8 @@ import qualified Data.ByteString as S import System.Posix.Types import Utility.SafeCommand import Utility.FileSystemEncoding +import qualified Data.Semigroup as Sem +import Prelude {- Support repositories on local disk, and repositories accessed via an URL. - @@ -54,8 +55,20 @@ data Repo = Repo newtype ConfigKey = ConfigKey S.ByteString deriving (Ord, Eq) -newtype ConfigValue = ConfigValue S.ByteString - deriving (Ord, Eq, Semigroup, Monoid) +data ConfigValue + = ConfigValue S.ByteString + | NoConfigValue + -- ^ git treats a setting with no value as different than a setting + -- with an empty value + deriving (Ord, Eq) + +instance Sem.Semigroup ConfigValue where + ConfigValue a <> ConfigValue b = ConfigValue (a <> b) + a <> NoConfigValue = a + NoConfigValue <> b = b + +instance Monoid ConfigValue where + mempty = ConfigValue mempty instance Default ConfigValue where def = ConfigValue mempty @@ -68,6 +81,7 @@ instance Show ConfigKey where fromConfigValue :: ConfigValue -> String fromConfigValue (ConfigValue s) = decodeBS' s +fromConfigValue NoConfigValue = mempty instance Show ConfigValue where show = fromConfigValue @@ -81,11 +95,14 @@ instance IsString ConfigValue where type RemoteName = String {- A git ref. Can be a sha1, or a branch or tag name. -} -newtype Ref = Ref String +newtype Ref = Ref S.ByteString deriving (Eq, Ord, Read, Show) fromRef :: Ref -> String -fromRef (Ref s) = s +fromRef = decodeBS' . fromRef' + +fromRef' :: Ref -> S.ByteString +fromRef' (Ref s) = s {- Aliases for Ref. -} type Branch = Ref @@ -98,6 +115,7 @@ newtype RefDate = RefDate String {- Types of objects that can be stored in git. -} data ObjectType = BlobObject | CommitObject | TreeObject + deriving (Show) readObjectType :: S.ByteString -> Maybe ObjectType readObjectType "blob" = Just BlobObject diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 9f07cf5..f0331d5 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -75,14 +75,14 @@ lsTree (Ref x) repo streamer = do mapM_ streamer s void $ cleanup where - params = map Param ["ls-tree", "-z", "-r", "--full-tree", 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", 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. -} @@ -90,7 +90,7 @@ updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> L.ByteString updateIndexLine sha treeitemtype file = L.fromStrict $ fmtTreeItemType treeitemtype <> " blob " - <> encodeBS (fromRef sha) + <> fromRef' sha <> "\t" <> indexPath file @@ -108,7 +108,7 @@ unstageFile file repo = do unstageFile' :: TopFilePath -> Streamer unstageFile' p = pureStreamer $ L.fromStrict $ "0 " - <> encodeBS' (fromRef nullSha) + <> fromRef' deleteSha <> "\t" <> indexPath p diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs index 2bae40f..e091d43 100644 --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -10,6 +10,7 @@ module Utility.CoProcess ( CoProcessHandle, + CoProcessState(..), start, stop, query, diff --git a/Utility/Directory.hs b/Utility/Directory.hs index e2c6a94..8b5b88b 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -1,11 +1,12 @@ {- directory traversal and manipulation - - - Copyright 2011-2014 Joey Hess + - Copyright 2011-2020 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Directory ( @@ -13,25 +14,28 @@ module Utility.Directory ( module Utility.SystemDirectory ) where -import System.IO.Error import Control.Monad import System.FilePath import System.PosixCompat.Files import Control.Applicative +import Control.Monad.IO.Class +import Control.Monad.IfElse import System.IO.Unsafe (unsafeInterleaveIO) +import System.IO.Error import Data.Maybe import Prelude #ifndef mingw32_HOST_OS import Utility.SafeCommand -import Control.Monad.IfElse #endif import Utility.SystemDirectory +import Utility.Path import Utility.Tmp import Utility.Exception import Utility.Monad import Utility.Applicative +import Utility.PartialPrelude dirCruft :: FilePath -> Bool dirCruft "." = True @@ -154,3 +158,74 @@ nukeFile file = void $ tryWhenExists go #else go = removeFile file #endif + +{- Like createDirectoryIfMissing True, but it will only create + - missing parent directories up to but not including the directory + - in the first parameter. + - + - For example, createDirectoryUnder "/tmp/foo" "/tmp/foo/bar/baz" + - will create /tmp/foo/bar if necessary, but if /tmp/foo does not exist, + - it will throw an exception. + - + - The exception thrown is the same that createDirectory throws if the + - parent directory does not exist. + - + - If the second FilePath is not under the first + - FilePath (or the same as it), it will fail with an exception + - even if the second FilePath's parent directory already exists. + - + - Either or both of the FilePaths can be relative, or absolute. + - They will be normalized as necessary. + - + - Note that, the second FilePath, if relative, is relative to the current + - working directory, not to the first FilePath. + -} +createDirectoryUnder :: FilePath -> FilePath -> IO () +createDirectoryUnder topdir dir = + createDirectoryUnder' topdir dir createDirectory + +createDirectoryUnder' + :: (MonadIO m, MonadCatch m) + => FilePath + -> FilePath + -> (FilePath -> m ()) + -> m () +createDirectoryUnder' topdir dir0 mkdir = do + p <- liftIO $ relPathDirToFile topdir dir0 + let dirs = splitDirectories p + -- Catch cases where the dir is not beneath the topdir. + -- If the relative path between them starts with "..", + -- it's not. And on Windows, if they are on different drives, + -- the path will not be relative. + if headMaybe dirs == Just ".." || isAbsolute p + then liftIO $ ioError $ customerror userErrorType + ("createDirectoryFrom: not located in " ++ topdir) + -- If dir0 is the same as the topdir, don't try to create + -- it, but make sure it does exist. + else if null dirs + then liftIO $ unlessM (doesDirectoryExist topdir) $ + ioError $ customerror doesNotExistErrorType + "createDirectoryFrom: does not exist" + else createdirs $ + map (topdir ) (reverse (scanl1 () dirs)) + where + customerror t s = mkIOError t s Nothing (Just dir0) + + createdirs [] = pure () + createdirs (dir:[]) = createdir dir (liftIO . ioError) + createdirs (dir:dirs) = createdir dir $ \_ -> do + createdirs dirs + createdir dir (liftIO . ioError) + + -- This is the same method used by createDirectoryIfMissing, + -- in particular the handling of errors that occur when the + -- directory already exists. See its source for explanation + -- of several subtleties. + createdir dir notexisthandler = tryIO (mkdir dir) >>= \case + Right () -> pure () + Left e + | isDoesNotExistError e -> notexisthandler e + | isAlreadyExistsError e || isPermissionError e -> + liftIO $ unlessM (doesDirectoryExist dir) $ + ioError e + | otherwise -> liftIO $ ioError e diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index f9e9814..4c099ff 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -43,6 +43,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.UTF8 as S8 import qualified Data.ByteString.Lazy.UTF8 as L8 #endif +import System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath) import Utility.Exception import Utility.Split @@ -171,21 +172,11 @@ encodeBL' = L.pack . decodeW8 encodeBL' = L8.fromString #endif -{- Recent versions of the unix package have this alias; defined here - - for backwards compatibility. -} -type RawFilePath = S.ByteString - -{- Note that the RawFilePath is assumed to never contain NUL, - - since filename's don't. This should only be used with actual - - RawFilePaths not arbitrary ByteString that may contain NUL. -} fromRawFilePath :: RawFilePath -> FilePath -fromRawFilePath = decodeBS' +fromRawFilePath = decodeFilePath -{- Note that the FilePath is assumed to never contain NUL, - - since filename's don't. This should only be used with actual FilePaths - - not arbitrary String that may contain NUL. -} toRawFilePath :: FilePath -> RawFilePath -toRawFilePath = encodeBS' +toRawFilePath = encodeFilePath {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding. - diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs index 01fbeac..d90143e 100644 --- a/Utility/HumanTime.hs +++ b/Utility/HumanTime.hs @@ -19,6 +19,7 @@ module Utility.HumanTime ( import Utility.PartialPrelude import Utility.QuickCheck +import Control.Monad.Fail as Fail (MonadFail(..)) import qualified Data.Map as M import Data.Time.Clock import Data.Time.Clock.POSIX (POSIXTime) @@ -44,7 +45,7 @@ daysToDuration :: Integer -> Duration daysToDuration i = Duration $ i * dsecs {- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -} -parseDuration :: Monad m => String -> m Duration +parseDuration :: MonadFail m => String -> m Duration parseDuration = maybe parsefail (return . Duration) . go 0 where go n [] = return n @@ -55,7 +56,7 @@ parseDuration = maybe parsefail (return . Duration) . go 0 u <- M.lookup c unitmap go (n + num * u) rest _ -> return $ n + num - parsefail = fail "duration parse error; expected eg \"5m\" or \"1h5m\"" + parsefail = Fail.fail "duration parse error; expected eg \"5m\" or \"1h5m\"" fromDuration :: Duration -> String fromDuration Duration { durationSeconds = d } diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs new file mode 100644 index 0000000..d890fc7 --- /dev/null +++ b/Utility/InodeCache.hs @@ -0,0 +1,307 @@ +{- Caching a file's inode, size, and modification time + - to see when it's changed. + - + - Copyright 2013-2019 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Utility.InodeCache ( + InodeCache, + mkInodeCache, + InodeComparisonType(..), + inodeCacheFileSize, + + compareStrong, + compareWeak, + compareBy, + + readInodeCache, + showInodeCache, + genInodeCache, + toInodeCache, + + InodeCacheKey, + inodeCacheToKey, + inodeCacheToFileSize, + inodeCacheToMtime, + inodeCacheToEpochTime, + inodeCacheEpochTimeRange, + + SentinalFile(..), + SentinalStatus(..), + TSDelta, + noTSDelta, + writeSentinalFile, + checkSentinalFile, + sentinalFileExists, + + prop_read_show_inodecache +) where + +import Common +import Utility.TimeStamp +import Utility.QuickCheck +import qualified Utility.RawFilePath as R + +import System.PosixCompat.Types +import Data.Time.Clock.POSIX + +#ifdef mingw32_HOST_OS +import Data.Word (Word64) +#else +import System.Posix.Files +#endif + +data InodeCachePrim = InodeCachePrim FileID FileSize MTime + deriving (Show, Eq, Ord) + +newtype InodeCache = InodeCache InodeCachePrim + deriving (Show) + +mkInodeCache :: FileID -> FileSize -> POSIXTime -> InodeCache +mkInodeCache inode sz mtime = InodeCache $ + InodeCachePrim inode sz (MTimeHighRes mtime) + +inodeCacheFileSize :: InodeCache -> FileSize +inodeCacheFileSize (InodeCache (InodeCachePrim _ sz _)) = sz + +{- Inode caches can be compared in two different ways, either weakly + - or strongly. -} +data InodeComparisonType = Weakly | Strongly + deriving (Eq, Ord, Show) + +{- Strong comparison, including inodes. -} +compareStrong :: InodeCache -> InodeCache -> Bool +compareStrong (InodeCache x) (InodeCache y) = x == y + +{- Weak comparison of the inode caches, comparing the size and mtime, + - but not the actual inode. Useful when inodes have changed, perhaps + - due to some filesystems being remounted. + - + - The weak mtime comparison treats any mtimes that are within 2 seconds + - of one-another as the same. This is because FAT has only a 2 second + - resolution. When a FAT filesystem is used on Linux, higher resolution + - timestamps maybe are cached and used by Linux, but they are lost + - on unmount, so after a remount, the timestamp can appear to have changed. + -} +compareWeak :: InodeCache -> InodeCache -> Bool +compareWeak (InodeCache (InodeCachePrim _ size1 mtime1)) (InodeCache (InodeCachePrim _ size2 mtime2)) = + size1 == size2 && (abs (lowResTime mtime1 - lowResTime mtime2) < 2) + +compareBy :: InodeComparisonType -> InodeCache -> InodeCache -> Bool +compareBy Strongly = compareStrong +compareBy Weakly = compareWeak + +{- For use in a Map; it's determined at creation time whether this + - uses strong or weak comparison for Eq. -} +data InodeCacheKey = InodeCacheKey InodeComparisonType InodeCachePrim + deriving (Ord, Show) + +instance Eq InodeCacheKey where + (InodeCacheKey ctx x) == (InodeCacheKey cty y) = + compareBy (maximum [ctx,cty]) (InodeCache x ) (InodeCache y) + +inodeCacheToKey :: InodeComparisonType -> InodeCache -> InodeCacheKey +inodeCacheToKey ct (InodeCache prim) = InodeCacheKey ct prim + +inodeCacheToFileSize :: InodeCache -> FileSize +inodeCacheToFileSize (InodeCache (InodeCachePrim _ sz _)) = sz + +inodeCacheToMtime :: InodeCache -> POSIXTime +inodeCacheToMtime (InodeCache (InodeCachePrim _ _ mtime)) = highResTime mtime + +inodeCacheToEpochTime :: InodeCache -> EpochTime +inodeCacheToEpochTime (InodeCache (InodeCachePrim _ _ mtime)) = lowResTime mtime + +-- Returns min, max EpochTime that weakly match the time of the InodeCache. +inodeCacheEpochTimeRange :: InodeCache -> (EpochTime, EpochTime) +inodeCacheEpochTimeRange i = + let t = inodeCacheToEpochTime i + in (t-1, t+1) + +{- For backwards compatability, support low-res mtime with no + - fractional seconds. -} +data MTime = MTimeLowRes EpochTime | MTimeHighRes POSIXTime + deriving (Show, Ord) + +{- A low-res time compares equal to any high-res time in the same second. -} +instance Eq MTime where + MTimeLowRes a == MTimeLowRes b = a == b + MTimeHighRes a == MTimeHighRes b = a == b + MTimeHighRes a == MTimeLowRes b = lowResTime a == b + MTimeLowRes a == MTimeHighRes b = a == lowResTime b + +class MultiResTime t where + lowResTime :: t -> EpochTime + highResTime :: t -> POSIXTime + +instance MultiResTime EpochTime where + lowResTime = id + highResTime = realToFrac + +instance MultiResTime POSIXTime where + lowResTime = fromInteger . floor + highResTime = id + +instance MultiResTime MTime where + lowResTime (MTimeLowRes t) = t + lowResTime (MTimeHighRes t) = lowResTime t + highResTime (MTimeLowRes t) = highResTime t + highResTime (MTimeHighRes t) = t + +showInodeCache :: InodeCache -> String +showInodeCache (InodeCache (InodeCachePrim inode size (MTimeHighRes mtime))) = + let (t, d) = separate (== '.') (takeWhile (/= 's') (show mtime)) + in unwords + [ show inode + , show size + , t + , d + ] +showInodeCache (InodeCache (InodeCachePrim inode size (MTimeLowRes mtime))) = + unwords + [ show inode + , show size + , show mtime + ] + +readInodeCache :: String -> Maybe InodeCache +readInodeCache s = case words s of + (inode:size:mtime:[]) -> do + i <- readish inode + sz <- readish size + t <- readish mtime + return $ InodeCache $ InodeCachePrim i sz (MTimeLowRes t) + (inode:size:mtime:mtimedecimal:_) -> do + i <- readish inode + sz <- readish size + t <- parsePOSIXTime $ mtime ++ '.' : mtimedecimal + return $ InodeCache $ InodeCachePrim i sz (MTimeHighRes t) + _ -> Nothing + +genInodeCache :: RawFilePath -> TSDelta -> IO (Maybe InodeCache) +genInodeCache f delta = catchDefaultIO Nothing $ + toInodeCache delta (fromRawFilePath f) =<< R.getFileStatus f + +toInodeCache :: TSDelta -> FilePath -> FileStatus -> IO (Maybe InodeCache) +toInodeCache (TSDelta getdelta) f s + | isRegularFile s = do + delta <- getdelta + sz <- getFileSize' f s +#ifdef mingw32_HOST_OS + mtime <- utcTimeToPOSIXSeconds <$> getModificationTime f +#else + let mtime = modificationTimeHiRes s +#endif + return $ Just $ InodeCache $ InodeCachePrim (fileID s) sz (MTimeHighRes (mtime + highResTime delta)) + | otherwise = pure Nothing + +{- Some filesystem get new random inodes each time they are mounted. + - To detect this and other problems, a sentinal file can be created. + - Its InodeCache at the time of its creation is written to the cache file, + - so changes can later be detected. -} +data SentinalFile = SentinalFile + { sentinalFile :: RawFilePath + , sentinalCacheFile :: RawFilePath + } + deriving (Show) + +{- On Windows, the mtime of a file appears to change when the time zone is + - changed. To deal with this, a TSDelta can be used; the delta is added to + - the mtime when generating an InodeCache. The current delta can be found + - by looking at the SentinalFile. Effectively, this makes all InodeCaches + - use the same time zone that was in use when the sential file was + - originally written. -} +newtype TSDelta = TSDelta (IO EpochTime) + +noTSDelta :: TSDelta +noTSDelta = TSDelta (pure 0) + +writeSentinalFile :: SentinalFile -> IO () +writeSentinalFile s = do + writeFile (fromRawFilePath (sentinalFile s)) "" + maybe noop (writeFile (fromRawFilePath (sentinalCacheFile s)) . showInodeCache) + =<< genInodeCache (sentinalFile s) noTSDelta + +data SentinalStatus = SentinalStatus + { sentinalInodesChanged :: Bool + , sentinalTSDelta :: TSDelta + } + +{- Checks if the InodeCache of the sentinal file is the same + - as it was when it was originally created. + - + - On Windows, time stamp differences are ignored, since they change + - with the timezone. + - + - When the sential file does not exist, InodeCaches canot reliably be + - compared, so the assumption is that there is has been a change. + -} +checkSentinalFile :: SentinalFile -> IO SentinalStatus +checkSentinalFile s = do + mold <- loadoldcache + case mold of + Nothing -> return dummy + (Just old) -> do + mnew <- gennewcache + case mnew of + Nothing -> return dummy + Just new -> return $ calc old new + where + loadoldcache = catchDefaultIO Nothing $ + readInodeCache <$> readFile (fromRawFilePath (sentinalCacheFile s)) + gennewcache = genInodeCache (sentinalFile s) noTSDelta + calc (InodeCache (InodeCachePrim oldinode oldsize oldmtime)) (InodeCache (InodeCachePrim newinode newsize newmtime)) = + SentinalStatus (not unchanged) tsdelta + where +#ifdef mingw32_HOST_OS + -- Since mtime can appear to change when the time zone is + -- changed in windows, we cannot look at the mtime for the + -- sentinal file. + unchanged = oldinode == newinode && oldsize == newsize && (newmtime == newmtime) + tsdelta = TSDelta $ do + -- Run when generating an InodeCache, + -- to get the current delta. + mnew <- gennewcache + return $ case mnew of + Just (InodeCache (InodeCachePrim _ _ currmtime)) -> + lowResTime oldmtime - lowResTime currmtime + Nothing -> 0 +#else + unchanged = oldinode == newinode && oldsize == newsize && oldmtime == newmtime + tsdelta = noTSDelta +#endif + dummy = SentinalStatus True noTSDelta + +sentinalFileExists :: SentinalFile -> IO Bool +sentinalFileExists s = allM R.doesPathExist [sentinalCacheFile s, sentinalFile s] + +instance Arbitrary InodeCache where + arbitrary = + let prim = InodeCachePrim + <$> arbitrary + <*> arbitrary + <*> arbitrary + in InodeCache <$> prim + +instance Arbitrary MTime where + arbitrary = frequency + -- timestamp is not usually negative + [ (50, MTimeLowRes <$> (abs . fromInteger <$> arbitrary)) + , (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 + Just c' -> compareStrong c c' diff --git a/Utility/Misc.hs b/Utility/Misc.hs index 2f1766e..01ae178 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -11,6 +11,7 @@ module Utility.Misc ( hGetContentsStrict, readFileStrict, separate, + separate', firstLine, firstLine', segment, @@ -54,6 +55,13 @@ separate c l = unbreak $ break c l | null b = r | otherwise = (a, tail b) +separate' :: (Word8 -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString) +separate' c l = unbreak $ S.break c l + where + unbreak r@(a, b) + | S.null b = r + | otherwise = (a, S.tail b) + {- Breaks out the first line. -} firstLine :: String -> String firstLine = takeWhile (/= '\n') diff --git a/Utility/Path.hs b/Utility/Path.hs index ecc752c..a8ab918 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -41,7 +41,7 @@ import Prelude import Utility.Monad import Utility.UserInfo -import Utility.Directory +import Utility.SystemDirectory import Utility.Split import Utility.FileSystemEncoding @@ -73,6 +73,8 @@ simplifyPath path = dropTrailingPathSeparator $ p' = dropTrailingPathSeparator p {- Makes a path absolute. + - + - Also simplifies it using simplifyPath. - - The first parameter is a base directory (ie, the cwd) to use if the path - is not already absolute, and should itsef be absolute. @@ -123,13 +125,20 @@ dirContains a b = a == b norm = normalise . simplifyPath {- Converts a filename into an absolute path. + - + - Also simplifies it using simplifyPath. - - Unlike Directory.canonicalizePath, this does not require the path - already exists. -} absPath :: FilePath -> IO FilePath -absPath file = do - cwd <- getCurrentDirectory - return $ absPathFrom cwd file +absPath file + -- Avoid unncessarily getting the current directory when the path + -- is already absolute. absPathFrom uses simplifyPath + -- so also used here for consistency. + | isAbsolute file = return $ simplifyPath file + | otherwise = do + cwd <- getCurrentDirectory + return $ absPathFrom cwd file {- Constructs a relative path from the CWD to a file. - diff --git a/Utility/Process.hs b/Utility/Process.hs index af3a5f4..e7142b9 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -1,7 +1,7 @@ {- System.Process enhancements, including additional ways of running - processes, and logging. - - - Copyright 2012-2015 Joey Hess + - Copyright 2012-2020 Joey Hess - - License: BSD-2-clause -} @@ -53,6 +53,7 @@ import System.Log.Logger import Control.Concurrent import qualified Control.Exception as E import Control.Monad +import qualified Data.ByteString as S type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a @@ -85,25 +86,20 @@ writeReadProcessEnv -> [String] -> Maybe [(String, String)] -> (Maybe (Handle -> IO ())) - -> (Maybe (Handle -> IO ())) - -> IO String -writeReadProcessEnv cmd args environ writestdin adjusthandle = do + -> IO S.ByteString +writeReadProcessEnv cmd args environ writestdin = do (Just inh, Just outh, _, pid) <- createProcess p - maybe (return ()) (\a -> a inh) adjusthandle - maybe (return ()) (\a -> a outh) adjusthandle - -- fork off a thread to start consuming the output - output <- hGetContents outh outMVar <- newEmptyMVar - _ <- forkIO $ E.evaluate (length output) >> putMVar outMVar () + _ <- forkIO $ putMVar outMVar =<< S.hGetContents outh -- now write and flush any input maybe (return ()) (\a -> a inh >> hFlush inh) writestdin hClose inh -- done with stdin -- wait on the output - takeMVar outMVar + output <- takeMVar outMVar hClose outh -- wait on the process diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs new file mode 100644 index 0000000..6a5f704 --- /dev/null +++ b/Utility/RawFilePath.hs @@ -0,0 +1,50 @@ +{- Portability shim around System.Posix.Files.ByteString + - + - On unix, this makes syscalls using RawFilesPaths as efficiently as + - possible. + - + - On Windows, filenames are in unicode, so RawFilePaths have to be + - decoded. So this library will work, but less efficiently than using + - FilePath would. + - + - Copyright 2019 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.RawFilePath ( + RawFilePath, + readSymbolicLink, + getFileStatus, + getSymbolicLinkStatus, + doesPathExist, +) where + +#ifndef mingw32_HOST_OS +import Utility.FileSystemEncoding (RawFilePath) +import System.Posix.Files.ByteString + +doesPathExist :: RawFilePath -> IO Bool +doesPathExist = fileExist + +#else +import qualified Data.ByteString as B +import System.PosixCompat (FileStatus) +import qualified System.PosixCompat as P +import qualified System.Directory as D +import Utility.FileSystemEncoding + +readSymbolicLink :: RawFilePath -> IO RawFilePath +readSymbolicLink f = toRawFilePath <$> P.readSymbolicLink (fromRawFilePath f) + +getFileStatus :: RawFilePath -> IO FileStatus +getFileStatus = P.getFileStatus . fromRawFilePath + +getSymbolicLinkStatus :: RawFilePath -> IO FileStatus +getSymbolicLinkStatus = P.getSymbolicLinkStatus . fromRawFilePath + +doesPathExist :: RawFilePath -> IO Bool +doesPathExist = D.doesPathExist . fromRawFilePath +#endif diff --git a/Utility/TimeStamp.hs b/Utility/TimeStamp.hs new file mode 100644 index 0000000..b740d7b --- /dev/null +++ b/Utility/TimeStamp.hs @@ -0,0 +1,58 @@ +{- timestamp parsing and formatting + - + - Copyright 2015-2019 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.TimeStamp ( + parserPOSIXTime, + parsePOSIXTime, + formatPOSIXTime, +) where + +import Utility.Data + +import Data.Time.Clock.POSIX +import Data.Time +import Data.Ratio +import Control.Applicative +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Attoparsec.ByteString as A +import Data.Attoparsec.ByteString.Char8 (char, decimal, signed, isDigit_w8) + +{- Parses how POSIXTime shows itself: "1431286201.113452s" + - (The "s" is included for historical reasons and is optional.) + - Also handles the format with no decimal seconds. -} +parserPOSIXTime :: A.Parser POSIXTime +parserPOSIXTime = mkPOSIXTime + <$> signed decimal + <*> (declen <|> pure (0, 0)) + <* optional (char 's') + where + declen :: A.Parser (Integer, Int) + declen = do + _ <- char '.' + b <- A.takeWhile isDigit_w8 + let len = B.length b + d <- either fail pure $ + A.parseOnly (decimal <* A.endOfInput) b + return (d, len) + +parsePOSIXTime :: String -> Maybe POSIXTime +parsePOSIXTime s = eitherToMaybe $ + A.parseOnly (parserPOSIXTime <* A.endOfInput) (B8.pack s) + +{- This implementation allows for higher precision in a POSIXTime than + - supported by the system's Double, and avoids the complications of + - floating point. -} +mkPOSIXTime :: Integer -> (Integer, Int) -> POSIXTime +mkPOSIXTime n (d, dlen) + | n < 0 = fromIntegral n - fromRational r + | otherwise = fromIntegral n + fromRational r + where + r = d % (10 ^ dlen) + +formatPOSIXTime :: String -> POSIXTime -> String +formatPOSIXTime fmt t = formatTime defaultTimeLocale fmt (posixSecondsToUTCTime t) diff --git a/git-repair.cabal b/git-repair.cabal index 2637586..d25f702 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -28,6 +28,7 @@ Extra-Source-Files: custom-setup Setup-Depends: base (>= 4.11.1.0 && < 5.0), hslogger, split, unix-compat, process, unix, filepath, + filepath-bytestring (>= 1.4.2.1.1), exceptions, bytestring, directory, IfElse, data-default, mtl, Cabal @@ -103,6 +104,7 @@ Executable git-repair Utility.Format Utility.HumanNumber Utility.HumanTime + Utility.InodeCache Utility.Metered Utility.Misc Utility.Monad @@ -112,11 +114,13 @@ Executable git-repair Utility.Process Utility.Process.Shim Utility.QuickCheck + Utility.RawFilePath Utility.Rsync Utility.SafeCommand Utility.Split Utility.SystemDirectory Utility.ThreadScheduler + Utility.TimeStamp Utility.Tmp Utility.Tmp.Dir Utility.Tuple -- cgit v1.2.3 From b0e0f21b7d3ce5c546c0a0a5b6f5ffb2d1e67672 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 4 May 2020 15:40:33 -0400 Subject: releasing package git-repair version 1.20200102-1 --- CHANGELOG | 4 ++-- git-repair.cabal | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index e6b5521..c3b43a4 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,10 +1,10 @@ -git-repair (1.20200103) UNRELEASED; urgency=medium +git-repair (1.20200504) unstable; urgency=medium * Fix a few documentation typos. * Improve fetching from a remote with an url in host:path format. * Merge from git-annex. - -- Joey Hess Wed, 01 Apr 2020 13:12:33 -0400 + -- Joey Hess Mon, 04 May 2020 15:38:53 -0400 git-repair (1.20200102) unstable; urgency=medium diff --git a/git-repair.cabal b/git-repair.cabal index d25f702..3607d00 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -1,11 +1,11 @@ Name: git-repair -Version: 1.20200102 +Version: 1.20200504 Cabal-Version: >= 1.8 License: AGPL-3 Maintainer: Joey Hess Author: Joey Hess Stability: Stable -Copyright: 2013 Joey Hess +Copyright: 2013-2020 Joey Hess License-File: COPYRIGHT Build-Type: Custom Homepage: http://git-repair.branchable.com/ -- cgit v1.2.3 From bfc77ce0ed37576a252e97061b4fd2ba6c9d1df0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 4 May 2020 15:41:54 -0400 Subject: add news item for git-repair 1.20200102-1 --- doc/news/version_1.20151215.mdwn | 5 ----- doc/news/version_1.20200102-1.mdwn | 14 ++++++++++++++ 2 files changed, 14 insertions(+), 5 deletions(-) delete mode 100644 doc/news/version_1.20151215.mdwn create mode 100644 doc/news/version_1.20200102-1.mdwn diff --git a/doc/news/version_1.20151215.mdwn b/doc/news/version_1.20151215.mdwn deleted file mode 100644 index 79b16f1..0000000 --- a/doc/news/version_1.20151215.mdwn +++ /dev/null @@ -1,5 +0,0 @@ -git-repair 1.20151215 released with [[!toggle text="these changes"]] -[[!toggleable text=""" - * Fix insecure temporary permissions and potential denial of - service attack when creating temp dirs. Closes: #[807341](http://bugs.debian.org/807341) - * Merge from git-annex."""]] \ No newline at end of file diff --git a/doc/news/version_1.20200102-1.mdwn b/doc/news/version_1.20200102-1.mdwn new file mode 100644 index 0000000..e15d9c5 --- /dev/null +++ b/doc/news/version_1.20200102-1.mdwn @@ -0,0 +1,14 @@ +git-repair 1.20200102-1 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * New upstream release. + - Tighten build-dep on optparse-applicative + - Add build-deps on split, filepath-bytestring, attoparsec, data-default + - Drop build-dep on missingh. + * Drop all patches. + Either merged upstream or obsoleted by upstream changes. + * d/copyright updates: + - Main project license is now AGPL-3+ + - Add stanza for Utility/Attoparsec.hs + - Update copyright years. + * Stop adding upstream entries to debian/changelog. + * wrap-and-sort -abst"""]] \ No newline at end of file -- cgit v1.2.3 From 4cffd73f2aeedebc65729ccbada6309717f963ca Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 4 May 2020 15:42:35 -0400 Subject: added by script due to reading debian/changelog rather than CHANGELOG --- doc/news/version_1.20200102-1.mdwn | 14 -------------- 1 file changed, 14 deletions(-) delete mode 100644 doc/news/version_1.20200102-1.mdwn diff --git a/doc/news/version_1.20200102-1.mdwn b/doc/news/version_1.20200102-1.mdwn deleted file mode 100644 index e15d9c5..0000000 --- a/doc/news/version_1.20200102-1.mdwn +++ /dev/null @@ -1,14 +0,0 @@ -git-repair 1.20200102-1 released with [[!toggle text="these changes"]] -[[!toggleable text=""" - * New upstream release. - - Tighten build-dep on optparse-applicative - - Add build-deps on split, filepath-bytestring, attoparsec, data-default - - Drop build-dep on missingh. - * Drop all patches. - Either merged upstream or obsoleted by upstream changes. - * d/copyright updates: - - Main project license is now AGPL-3+ - - Add stanza for Utility/Attoparsec.hs - - Update copyright years. - * Stop adding upstream entries to debian/changelog. - * wrap-and-sort -abst"""]] \ No newline at end of file -- cgit v1.2.3 From d5456f857a089b46ecfe4bd0c6c0657afd92cbaf Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 4 May 2020 15:45:36 -0400 Subject: bump cabal-version hackage now requires 1.10 or newer --- git-repair.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/git-repair.cabal b/git-repair.cabal index 3607d00..1db6272 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -1,6 +1,6 @@ Name: git-repair Version: 1.20200504 -Cabal-Version: >= 1.8 +Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess Author: Joey Hess -- cgit v1.2.3 From a1ca5df11dd4bf7df04aa7625c9bc2e2ff8dc426 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 4 May 2020 15:46:32 -0400 Subject: add news item for git-repair 1.20200102-1 --- doc/news/version_1.20200102-1.mdwn | 14 ++++++++++++++ 1 file changed, 14 insertions(+) create mode 100644 doc/news/version_1.20200102-1.mdwn diff --git a/doc/news/version_1.20200102-1.mdwn b/doc/news/version_1.20200102-1.mdwn new file mode 100644 index 0000000..e15d9c5 --- /dev/null +++ b/doc/news/version_1.20200102-1.mdwn @@ -0,0 +1,14 @@ +git-repair 1.20200102-1 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * New upstream release. + - Tighten build-dep on optparse-applicative + - Add build-deps on split, filepath-bytestring, attoparsec, data-default + - Drop build-dep on missingh. + * Drop all patches. + Either merged upstream or obsoleted by upstream changes. + * d/copyright updates: + - Main project license is now AGPL-3+ + - Add stanza for Utility/Attoparsec.hs + - Update copyright years. + * Stop adding upstream entries to debian/changelog. + * wrap-and-sort -abst"""]] \ No newline at end of file -- cgit v1.2.3 From 62fe45c02f541d2246a0cdb52538e0af2a75a059 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 4 May 2020 15:51:02 -0400 Subject: remove again --- doc/news/version_1.20200102-1.mdwn | 14 -------------- 1 file changed, 14 deletions(-) delete mode 100644 doc/news/version_1.20200102-1.mdwn diff --git a/doc/news/version_1.20200102-1.mdwn b/doc/news/version_1.20200102-1.mdwn deleted file mode 100644 index e15d9c5..0000000 --- a/doc/news/version_1.20200102-1.mdwn +++ /dev/null @@ -1,14 +0,0 @@ -git-repair 1.20200102-1 released with [[!toggle text="these changes"]] -[[!toggleable text=""" - * New upstream release. - - Tighten build-dep on optparse-applicative - - Add build-deps on split, filepath-bytestring, attoparsec, data-default - - Drop build-dep on missingh. - * Drop all patches. - Either merged upstream or obsoleted by upstream changes. - * d/copyright updates: - - Main project license is now AGPL-3+ - - Add stanza for Utility/Attoparsec.hs - - Update copyright years. - * Stop adding upstream entries to debian/changelog. - * wrap-and-sort -abst"""]] \ No newline at end of file -- cgit v1.2.3 From 31c7f57bfd07315e68cefe917bf29603c44c2d58 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 4 May 2020 15:52:37 -0400 Subject: changes required by cabal-version 1.10 Extensions got renamed. Default-Language is required. I had to put Haskell98 because there are subtle differences between 98 and 2010 and git-annex has always been built with the default, which was 98 when there was a default. I don't know how to establish that git-annex will behave the same under 2010. --- git-repair.cabal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/git-repair.cabal b/git-repair.cabal index 1db6272..2ea10fa 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -39,7 +39,8 @@ source-repository head Executable git-repair Main-Is: git-repair.hs GHC-Options: -threaded -Wall -fno-warn-tabs - Extensions: LambdaCase + Default-Language: Haskell98 + 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, -- cgit v1.2.3 From 28ef5eec13a4cdc3e55beefa7c956aac6666a71f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 4 May 2020 15:53:15 -0400 Subject: add -O2 git-annex builds with -O2 and iirc some things may have different laziness behavior or something under default level so use the same level here --- git-repair.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/git-repair.cabal b/git-repair.cabal index 2ea10fa..a3cf246 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -38,7 +38,7 @@ source-repository head Executable git-repair Main-Is: git-repair.hs - GHC-Options: -threaded -Wall -fno-warn-tabs + GHC-Options: -threaded -Wall -fno-warn-tabs -O2 Default-Language: Haskell98 Default-Extensions: LambdaCase Build-Depends: split, hslogger, directory, filepath, containers, mtl, -- cgit v1.2.3 From 6c804d1a1c04c4d4285dfac4a281ce35eb51fa5e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 4 May 2020 15:54:19 -0400 Subject: add news item for git-repair 1.20200504 --- doc/news/version_1.20200504.mdwn | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 doc/news/version_1.20200504.mdwn diff --git a/doc/news/version_1.20200504.mdwn b/doc/news/version_1.20200504.mdwn new file mode 100644 index 0000000..545cd64 --- /dev/null +++ b/doc/news/version_1.20200504.mdwn @@ -0,0 +1,5 @@ +git-repair 1.20200504 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * Fix a few documentation typos. + * Improve fetching from a remote with an url in host:path format. + * Merge from git-annex."""]] \ No newline at end of file -- cgit v1.2.3 From b3e72e94efbce652f25fb99d6c6ace8beb2a52d4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 19 Oct 2020 11:09:39 -0400 Subject: change to Haskell2010 I put in 98 before under the mistaken idea that ghc defaulted to 98, but it has actually defaulted to 2010 for some time. Anyway, the differences are slight. --- git-repair.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/git-repair.cabal b/git-repair.cabal index a3cf246..d374f50 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -39,7 +39,7 @@ source-repository head Executable git-repair Main-Is: git-repair.hs GHC-Options: -threaded -Wall -fno-warn-tabs -O2 - Default-Language: Haskell98 + Default-Language: Haskell2010 Default-Extensions: LambdaCase Build-Depends: split, hslogger, directory, filepath, containers, mtl, unix-compat (>= 0.5), bytestring, exceptions (>= 0.6), transformers, -- cgit v1.2.3 From ad48349741384ed0e49fab9cf13ac7f90aba0dd1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 11 Jan 2021 21:52:32 -0400 Subject: Merge from git-annex. --- CHANGELOG | 6 + Common.hs | 2 + Git.hs | 25 ++-- Git/CatFile.hs | 181 ++++++++++++++++++++--- Git/Command.hs | 53 ++++--- Git/Config.hs | 62 +++++--- Git/Construct.hs | 97 +++++++----- Git/CurrentRepo.hs | 37 +++-- Git/Destroyer.hs | 7 +- Git/FilePath.hs | 3 +- Git/Filename.hs | 28 ++-- Git/Fsck.hs | 54 ++++--- Git/HashObject.hs | 6 +- Git/Index.hs | 22 +-- Git/LsFiles.hs | 174 +++++++++++----------- Git/LsTree.hs | 23 ++- Git/Objects.hs | 32 ++-- Git/Ref.hs | 9 +- Git/Repair.hs | 66 +++++---- Git/Types.hs | 25 +++- Git/UpdateIndex.hs | 66 +++++---- Git/Version.hs | 2 +- Utility/Batch.hs | 28 +--- Utility/Directory.hs | 142 +----------------- Utility/Directory/Create.hs | 102 +++++++++++++ Utility/DottedVersion.hs | 2 +- Utility/Env/Set.hs | 6 + Utility/Exception.hs | 2 +- Utility/FileMode.hs | 47 +++--- Utility/FileSize.hs | 14 +- Utility/FileSystemEncoding.hs | 9 +- Utility/Format.hs | 46 ++++-- Utility/HumanTime.hs | 11 +- Utility/InodeCache.hs | 6 +- Utility/Metered.hs | 174 ++++++++++++++-------- Utility/MoveFile.hs | 74 ++++++++++ Utility/Path.hs | 244 ++++++++++-------------------- Utility/Path/AbsRel.hs | 93 ++++++++++++ Utility/Process.hs | 337 +++++++++++++++++++++--------------------- Utility/QuickCheck.hs | 41 ++++- Utility/RawFilePath.hs | 48 +++++- Utility/Rsync.hs | 6 +- Utility/SafeCommand.hs | 55 +------ Utility/SimpleProtocol.hs | 151 +++++++++++++++++++ Utility/Tmp.hs | 23 ++- git-repair.cabal | 6 +- git-repair.hs | 2 +- 47 files changed, 1604 insertions(+), 1045 deletions(-) create mode 100644 Utility/Directory/Create.hs create mode 100644 Utility/MoveFile.hs create mode 100644 Utility/Path/AbsRel.hs create mode 100644 Utility/SimpleProtocol.hs diff --git a/CHANGELOG b/CHANGELOG index c3b43a4..f38d6b2 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,9 @@ +git-repair (1.20210111) UNRELEASED; urgency=medium + + * Merge from git-annex. + + -- Joey Hess Mon, 11 Jan 2021 21:52:06 -0400 + git-repair (1.20200504) unstable; urgency=medium * Fix a few documentation typos. diff --git a/Common.hs b/Common.hs index 6bd2e7a..5a658a6 100644 --- a/Common.hs +++ b/Common.hs @@ -25,7 +25,9 @@ import Utility.Exception as X import Utility.SafeCommand as X import Utility.Process as X import Utility.Path as X +import Utility.Path.AbsRel as X import Utility.Directory as X +import Utility.MoveFile as X import Utility.Monad as X import Utility.Data as X import Utility.Applicative as X diff --git a/Git.hs b/Git.hs index d33345e..32cf82e 100644 --- a/Git.hs +++ b/Git.hs @@ -3,11 +3,12 @@ - This is written to be completely independant of git-annex and should be - suitable for other uses. - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Git ( @@ -37,10 +38,12 @@ module Git ( relPath, ) where +import qualified Data.ByteString as B import Network.URI (uriPath, uriScheme, unEscapeString) #ifndef mingw32_HOST_OS import System.Posix.Files #endif +import qualified System.FilePath.ByteString as P import Common import Git.Types @@ -130,14 +133,13 @@ assertLocal repo action | otherwise = action {- Path to a repository's gitattributes file. -} -attributes :: Repo -> FilePath +attributes :: Repo -> RawFilePath attributes repo | repoIsLocalBare repo = attributesLocal repo - | otherwise = fromRawFilePath (repoPath repo) ".gitattributes" + | otherwise = repoPath repo P. ".gitattributes" -attributesLocal :: Repo -> FilePath -attributesLocal repo = fromRawFilePath (localGitDir repo) - "info" "attributes" +attributesLocal :: Repo -> RawFilePath +attributesLocal repo = localGitDir repo P. "info" P. "attributes" {- Path to a given hook script in a repository, only if the hook exists - and is executable. -} @@ -159,13 +161,13 @@ relPath = adjustPath torel where torel p = do p' <- relPathCwdToFile p - return $ if null p' then "." else p' + return $ if B.null p' then "." else p' {- Adusts the path to a local Repo using the provided function. -} -adjustPath :: (FilePath -> IO FilePath) -> Repo -> IO Repo +adjustPath :: (RawFilePath -> IO RawFilePath) -> Repo -> IO Repo adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do - d' <- f' d - w' <- maybe (pure Nothing) (Just <$$> f') w + d' <- f d + w' <- maybe (pure Nothing) (Just <$$> f) w return $ r { location = l { gitdir = d' @@ -173,8 +175,7 @@ adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do } } where - f' v = toRawFilePath <$> f (fromRawFilePath v) adjustPath f r@(Repo { location = LocalUnknown d }) = do - d' <- toRawFilePath <$> f (fromRawFilePath d) + d' <- f d return $ r { location = LocalUnknown d' } adjustPath _ r = pure r diff --git a/Git/CatFile.hs b/Git/CatFile.hs index 1769e57..6bea8c0 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} module Git.CatFile ( CatFileHandle, @@ -19,6 +20,9 @@ module Git.CatFile ( catObject, catObjectDetails, catObjectMetaData, + catObjectStreamLsTree, + catObjectStream, + catObjectMetaDataStream, ) where import System.IO @@ -27,12 +31,15 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8 import qualified Data.Attoparsec.ByteString as A import qualified Data.Attoparsec.ByteString.Char8 as A8 -import qualified Data.Map as M +import qualified Data.Map.Strict as M import Data.String import Data.Char import Numeric import System.Posix.Types import Text.Read +import Control.Concurrent.Async +import Control.Concurrent.Chan +import Control.Monad.IO.Class (MonadIO) import Common import Git @@ -40,9 +47,10 @@ import Git.Sha import qualified Git.Ref import Git.Command import Git.Types -import Git.FilePath import Git.HashObject +import qualified Git.LsTree as LsTree import qualified Utility.CoProcess as CoProcess +import qualified Git.BuildVersion as BuildVersion import Utility.Tuple data CatFileHandle = CatFileHandle @@ -57,7 +65,7 @@ catFileStart = catFileStart' True catFileStart' :: Bool -> Repo -> IO CatFileHandle catFileStart' restartable repo = CatFileHandle <$> startp "--batch" - <*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)" + <*> startp ("--batch-check=" ++ batchFormat) <*> pure repo where startp p = gitCoProcessStart restartable @@ -65,6 +73,9 @@ catFileStart' restartable repo = CatFileHandle , Param p ] repo +batchFormat :: String +batchFormat = "%(objectname) %(objecttype) %(objectsize)" + catFileStop :: CatFileHandle -> IO () catFileStop h = do CoProcess.stop (catFileProcess h) @@ -72,12 +83,12 @@ catFileStop h = do {- Reads a file from a specified branch. -} catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString -catFile h branch file = catObject h $ Ref $ - fromRef' branch <> ":" <> toInternalGitPath file +catFile h branch file = catObject h $ + Git.Ref.branchFileRef branch file catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) -catFileDetails h branch file = catObjectDetails h $ Ref $ - fromRef' branch <> ":" <> toInternalGitPath file +catFileDetails h branch file = catObjectDetails h $ + Git.Ref.branchFileRef branch file {- Uses a running git cat-file read the content of an object. - Objects that do not exist will have "" returned. -} @@ -88,18 +99,12 @@ catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, Object catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \from -> do header <- S8.hGetLine from case parseResp object header of - Just (ParsedResp sha objtype size) -> do - content <- S.hGet from (fromIntegral size) - eatchar '\n' from - return $ Just (L.fromChunks [content], sha, objtype) + Just r@(ParsedResp sha objtype _size) -> do + content <- readObjectContent from r + return $ Just (content, sha, objtype) Just DNE -> return Nothing Nothing -> error $ "unknown response from git cat-file " ++ show (header, object) where - eatchar expected from = do - c <- hGetChar from - when (c /= expected) $ - error $ "missing " ++ (show expected) ++ " from git cat-file" - -- Slow fallback path for filenames containing newlines. newlinefallback = queryObjectType object (gitRepo h) >>= \case Nothing -> return Nothing @@ -113,6 +118,18 @@ catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \f (gitRepo h) return (Just (content, sha, objtype)) +readObjectContent :: Handle -> ParsedResp -> IO L.ByteString +readObjectContent h (ParsedResp _ _ size) = do + content <- S.hGet h (fromIntegral size) + eatchar '\n' + return (L.fromChunks [content]) + where + eatchar expected = do + c <- hGetChar h + when (c /= expected) $ + error $ "missing " ++ (show expected) ++ " from git cat-file" +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 h object = query (checkFileProcess h) object newlinefallback $ \from -> do @@ -180,14 +197,16 @@ querySingle o r repo reader = assertLocal repo $ , std_in = Inherit , std_out = CreatePipe } - pid <- createProcess p' - let h = stdoutHandle pid - output <- reader h - hClose h - ifM (checkSuccessProcess (processHandle pid)) + withCreateProcess p' go + where + go _ (Just outh) _ pid = do + output <- reader outh + hClose outh + ifM (checkSuccessProcess pid) ( return (Just output) , return Nothing ) + go _ _ _ _ = error "internal" querySize :: Ref -> Repo -> IO (Maybe FileSize) querySize r repo = maybe Nothing (readMaybe . takeWhile (/= '\n')) @@ -264,3 +283,123 @@ parseCommit b = Commit sp = fromIntegral (ord ' ') lt = fromIntegral (ord '<') gt = fromIntegral (ord '>') + +{- Uses cat-file to stream the contents of the files as efficiently + - as possible. This is much faster than querying it repeatedly per file. + -} +catObjectStreamLsTree + :: (MonadMask m, MonadIO m) + => [LsTree.TreeItem] + -> (LsTree.TreeItem -> Maybe v) + -> Repo + -> (IO (Maybe (v, Maybe L.ByteString)) -> m a) + -> m a +catObjectStreamLsTree l want repo reader = withCatFileStream False repo $ + \c hin hout -> bracketIO + (async $ feeder c hin) + cancel + (const (reader (catObjectReader readObjectContent c hout))) + where + feeder c h = do + forM_ l $ \ti -> case want ti of + Nothing -> return () + Just v -> do + let sha = LsTree.sha ti + liftIO $ writeChan c (sha, v) + S8.hPutStrLn h (fromRef' sha) + hClose h + +catObjectStream + :: (MonadMask m, MonadIO m) + => Repo + -> ( + ((v, Ref) -> IO ()) -- ^ call to feed values in + -> IO () -- call once all values are fed in + -> IO (Maybe (v, Maybe L.ByteString)) -- call to read results + -> m a + ) + -> m a +catObjectStream repo a = withCatFileStream False repo go + where + go c hin hout = a + (feeder c hin) + (hClose hin) + (catObjectReader readObjectContent c hout) + feeder c h (v, ref) = do + liftIO $ writeChan c (ref, v) + S8.hPutStrLn h (fromRef' ref) + +catObjectMetaDataStream + :: (MonadMask m, MonadIO m) + => Repo + -> ( + ((v, Ref) -> IO ()) -- ^ call to feed values in + -> IO () -- call once all values are fed in + -> IO (Maybe (v, Maybe (Sha, FileSize, ObjectType))) -- call to read results + -> m a + ) + -> m a +catObjectMetaDataStream repo a = withCatFileStream True repo go + where + go c hin hout = a + (feeder c hin) + (hClose hin) + (catObjectReader (\_h r -> pure (conv r)) c hout) + + feeder c h (v, ref) = do + liftIO $ writeChan c (ref, v) + S8.hPutStrLn h (fromRef' ref) + + conv (ParsedResp sha ty sz) = (sha, sz, ty) + conv DNE = error "internal" + +catObjectReader + :: (Handle -> ParsedResp -> IO t) + -> Chan (Ref, a) + -> Handle + -> IO (Maybe (a, Maybe t)) +catObjectReader getv c h = ifM (hIsEOF h) + ( return Nothing + , do + (ref, f) <- liftIO $ readChan c + resp <- S8.hGetLine h + case parseResp ref resp of + Just r@(ParsedResp {}) -> do + v <- getv h r + return (Just (f, Just v)) + Just DNE -> return (Just (f, Nothing)) + Nothing -> error $ "unknown response from git cat-file " ++ show resp + ) + +withCatFileStream + :: (MonadMask m, MonadIO m) + => Bool + -> Repo + -> (Chan v -> Handle -> Handle -> m a) + -> m a +withCatFileStream check repo reader = assertLocal repo $ + bracketIO start stop $ \(c, hin, hout, _) -> reader c hin hout + where + params = catMaybes + [ Just $ Param "cat-file" + , Just $ Param ("--batch" ++ (if check then "-check" else "") ++ "=" ++ batchFormat) + -- This option makes it faster, but is not present in + -- older versions of git. + , if BuildVersion.older "2.4.3" + then Nothing + else Just $ Param "--buffer" + ] + + start = do + let p = gitCreateProcess params repo + (Just hin, Just hout, _, pid) <- createProcess p + { std_in = CreatePipe + , std_out = CreatePipe + } + c <- newChan + return (c, hin, hout, pid) + + stop (_, hin, hout, pid) = do + hClose hin + hClose hout + void $ checkSuccessProcess pid diff --git a/Git/Command.hs b/Git/Command.hs index 15157a0..fef7eb9 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -1,6 +1,6 @@ {- running git commands - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -43,15 +43,19 @@ run params repo = assertLocal repo $ {- Runs git and forces it to be quiet, throwing an error if it fails. -} runQuiet :: [CommandParam] -> Repo -> IO () -runQuiet params repo = withQuietOutput createProcessSuccess $ - (proc "git" $ toCommand $ gitCommandLine (params) repo) - { env = gitEnv repo } +runQuiet params repo = withNullHandle $ \nullh -> + let p = (proc "git" $ toCommand $ gitCommandLine (params) repo) + { env = gitEnv repo + , std_out = UseHandle nullh + , std_err = UseHandle nullh + } + in withCreateProcess p $ \_ _ _ -> forceSuccessProcess p {- Runs a git command and returns its output, lazily. - - Also returns an action that should be used when the output is all - read, that will wait on the command, and - - return True if it succeeded. Failure to wait will result in zombies. + - return True if it succeeded. -} pipeReadLazy :: [CommandParam] -> Repo -> IO (L.ByteString, IO Bool) pipeReadLazy params repo = assertLocal repo $ do @@ -70,13 +74,17 @@ pipeReadStrict = pipeReadStrict' S.hGetContents {- The reader action must be strict. -} pipeReadStrict' :: (Handle -> IO a) -> [CommandParam] -> Repo -> IO a -pipeReadStrict' reader params repo = assertLocal repo $ - withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do - output <- reader h - hClose h - return output +pipeReadStrict' reader params repo = assertLocal repo $ withCreateProcess p go where - p = gitCreateProcess params repo + p = (gitCreateProcess params repo) + { std_out = CreatePipe } + + go _ (Just outh) _ pid = do + output <- reader outh + hClose outh + void $ waitForProcess pid + return output + go _ _ _ _ = error "internal" {- Runs a git command, feeding it an input, and returning its output, - which is expected to be fairly small, since it's all read into memory @@ -95,9 +103,16 @@ pipeWriteRead params writer repo = assertLocal repo $ {- Runs a git command, feeding it input on a handle with an action. -} pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO () -pipeWrite params repo = assertLocal repo $ - withHandle StdinHandle createProcessSuccess $ - gitCreateProcess params repo +pipeWrite params repo feeder = assertLocal repo $ + let p = (gitCreateProcess params repo) + { std_in = CreatePipe } + in withCreateProcess p (go p) + where + go p (Just hin) _ _ pid = do + feeder hin + hClose hin + forceSuccessProcess p pid + go _ _ _ _ _ = error "internal" {- Reads null terminated output of a git command (as enabled by the -z - parameter), and splits it. -} @@ -119,16 +134,6 @@ pipeNullSplitStrict params repo = do s <- pipeReadStrict params repo return $ filter (not . S.null) $ S.split 0 s -pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [L.ByteString] -pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo - -pipeNullSplitZombie' :: [CommandParam] -> Repo -> IO [S.ByteString] -pipeNullSplitZombie' params repo = leaveZombie <$> pipeNullSplit' params repo - -{- Doesn't run the cleanup action. A zombie results. -} -leaveZombie :: (a, IO Bool) -> a -leaveZombie = fst - {- Runs a git command as a coprocess. -} gitCoProcessStart :: Bool -> [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle gitCoProcessStart restartable params repo = CoProcess.start numrestarts "git" diff --git a/Git/Config.hs b/Git/Config.hs index f50d5eb..20ddf79 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -58,29 +58,37 @@ read' repo = go repo go Repo { location = Local { gitdir = d } } = git_config d go Repo { location = LocalUnknown d } = git_config d go _ = assertLocal repo $ error "internal" - git_config d = withHandle StdoutHandle createProcessSuccess p $ - hRead repo ConfigNullList + git_config d = withCreateProcess p (git_config' p) where params = ["config", "--null", "--list"] p = (proc "git" params) { cwd = Just (fromRawFilePath d) , env = gitEnv repo + , std_out = CreatePipe } + git_config' p _ (Just hout) _ pid = + forceSuccessProcess p pid + `after` + hRead repo ConfigNullList hout + git_config' _ _ _ _ _ = error "internal" {- Gets the global git config, returning a dummy Repo containing it. -} global :: IO (Maybe Repo) global = do home <- myHomeDir ifM (doesFileExist $ home ".gitconfig") - ( do - repo <- withHandle StdoutHandle createProcessSuccess p $ - hRead (Git.Construct.fromUnknown) ConfigNullList - return $ Just repo + ( Just <$> withCreateProcess p go , return Nothing ) where params = ["config", "--null", "--list", "--global"] p = (proc "git" params) + { std_out = CreatePipe } + go _ (Just hout) _ pid = + forceSuccessProcess p pid + `after` + hRead (Git.Construct.fromUnknown) ConfigNullList hout + go _ _ _ _ = error "internal" {- Reads git config from a handle and populates a repo with it. -} hRead :: Repo -> ConfigStyle -> Handle -> IO Repo @@ -132,9 +140,9 @@ updateLocation' r l = do Nothing -> return l Just (ConfigValue d) -> do {- core.worktree is relative to the gitdir -} - top <- absPath $ fromRawFilePath (gitdir l) - let p = absPathFrom top (fromRawFilePath d) - return $ l { worktree = Just (toRawFilePath p) } + top <- absPath (gitdir l) + let p = absPathFrom top d + return $ l { worktree = Just p } Just NoConfigValue -> return l return $ r { location = l' } @@ -177,6 +185,10 @@ isTrueFalse' (ConfigValue s) | s' == "0" = Just False | s' == "" = Just False + -- Git treats any number other than 0 as true, + -- including negative numbers. + | S8.all (\c -> isDigit c || c == '-') s' = Just True + | otherwise = Nothing where s' = S8.map toLower s @@ -198,22 +210,30 @@ coreBare = "core.bare" {- Runs a command to get the configuration of a repo, - and returns a repo populated with the configuration, as well as the raw - - output and any standard output of the command. -} -fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, S.ByteString)) -fromPipe r cmd params st = try $ - withOEHandles createProcessSuccess p $ \(hout, herr) -> do - geterr <- async $ S.hGetContents herr - getval <- async $ S.hGetContents hout - val <- wait getval - err <- wait geterr - r' <- store val st r - return (r', val, err) + - output and the standard error of the command. -} +fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, String)) +fromPipe r cmd params st = tryNonAsync $ withCreateProcess p go where - p = proc cmd $ toCommand params + p = (proc cmd $ toCommand params) + { std_out = CreatePipe + , std_err = CreatePipe + } + go _ (Just hout) (Just herr) pid = + withAsync (getstderr pid herr []) $ \errreader -> do + val <- S.hGetContents hout + err <- wait errreader + forceSuccessProcess p pid + r' <- store val st r + return (r', val, err) + go _ _ _ _ = error "internal" + + getstderr pid herr c = hGetLineUntilExitOrEOF pid herr >>= \case + Just l -> getstderr pid herr (l:c) + Nothing -> return (unlines (reverse c)) {- Reads git config from a specified file and returns the repo populated - with the configuration. -} -fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString, S.ByteString)) +fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString, String)) fromFile r f = fromPipe r "git" [ Param "config" , Param "--file" diff --git a/Git/Construct.hs b/Git/Construct.hs index 5b656eb..8b63ac4 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -1,10 +1,11 @@ {- Construction of Git Repo objects - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Git.Construct ( @@ -21,6 +22,7 @@ module Git.Construct ( repoAbsPath, checkForRepo, newFrom, + adjustGitDirFile, ) where #ifndef mingw32_HOST_OS @@ -37,6 +39,9 @@ import Git.FilePath import qualified Git.Url as Url import Utility.UserInfo +import qualified Data.ByteString as B +import qualified System.FilePath.ByteString as P + {- Finds the git repository used for the cwd, which may be in a parent - directory. -} fromCwd :: IO (Maybe Repo) @@ -45,40 +50,40 @@ fromCwd = getCurrentDirectory >>= seekUp seekUp dir = do r <- checkForRepo dir case r of - Nothing -> case upFrom dir of + Nothing -> case upFrom (toRawFilePath dir) of Nothing -> return Nothing - Just d -> seekUp d + Just d -> seekUp (fromRawFilePath d) Just loc -> pure $ Just $ newFrom loc {- Local Repo constructor, accepts a relative or absolute path. -} -fromPath :: FilePath -> IO Repo +fromPath :: RawFilePath -> IO Repo fromPath dir = fromAbsPath =<< absPath dir {- Local Repo constructor, requires an absolute path to the repo be - specified. -} -fromAbsPath :: FilePath -> IO Repo +fromAbsPath :: RawFilePath -> IO Repo fromAbsPath dir - | absoluteGitPath (encodeBS dir) = hunt + | absoluteGitPath dir = hunt | otherwise = - error $ "internal error, " ++ dir ++ " is not absolute" + error $ "internal error, " ++ show dir ++ " is not absolute" where - ret = pure . newFrom . LocalUnknown . toRawFilePath - canondir = dropTrailingPathSeparator dir + 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 - | (pathSeparator:".git") `isSuffixOf` canondir = - ifM (doesDirectoryExist $ dir ".git") + | (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir = + ifM (doesDirectoryExist $ fromRawFilePath dir ".git") ( ret dir - , ret (takeDirectory canondir) + , ret (P.takeDirectory canondir) ) - | otherwise = ifM (doesDirectoryExist dir) - ( ret dir + | 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") + then ret (dir <> ".git") else ret dir ) @@ -94,7 +99,8 @@ fromUrl url fromUrlStrict :: String -> IO Repo fromUrlStrict url - | "file://" `isPrefixOf` url = fromAbsPath $ unEscapeString $ uriPath u + | "file://" `isPrefixOf` url = fromAbsPath $ toRawFilePath $ + unEscapeString $ uriPath u | otherwise = pure $ newFrom $ Url u where u = fromMaybe bad $ parseURI url @@ -128,7 +134,8 @@ fromRemotes repo = mapM construct remotepairs filterconfig f = filter f $ M.toList $ config repo filterkeys f = filterconfig (\(k,_) -> f k) remotepairs = filterkeys isRemoteKey - construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (fromConfigValue v) repo) + construct (k,v) = remoteNamedFromKey k $ + fromRemoteLocation (fromConfigValue v) repo {- Sets the name of a remote when constructing the Repo to represent it. -} remoteNamed :: String -> IO Repo -> IO Repo @@ -154,18 +161,18 @@ fromRemoteLocation s repo = gen $ parseRemoteLocation s repo fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do dir' <- expandTilde dir - fromPath $ fromRawFilePath (repoPath repo) dir' + fromPath $ repoPath repo P. toRawFilePath dir' {- Git remotes can have a directory that is specified relative - to the user's home directory, or that contains tilde expansions. - This converts such a directory to an absolute path. - Note that it has to run on the system where the remote is. -} -repoAbsPath :: FilePath -> IO FilePath +repoAbsPath :: RawFilePath -> IO RawFilePath repoAbsPath d = do - d' <- expandTilde d + d' <- expandTilde (fromRawFilePath d) h <- myHomeDir - return $ h d' + return $ toRawFilePath $ h d' expandTilde :: FilePath -> IO FilePath #ifdef mingw32_HOST_OS @@ -198,7 +205,7 @@ expandTilde = expandt True checkForRepo :: FilePath -> IO (Maybe RepoLocation) checkForRepo dir = check isRepo $ - check gitDirFile $ + check (checkGitDirFile (toRawFilePath dir)) $ check isBareRepo $ return Nothing where @@ -217,22 +224,40 @@ checkForRepo dir = gitSignature (".git" "gitdir") isBareRepo = checkdir $ gitSignature "config" <&&> doesDirectoryExist (dir "objects") - gitDirFile = do - -- git-submodule, git-worktree, and --separate-git-dir - -- make .git be a file pointing to the real git directory. - c <- firstLine <$> - catchDefaultIO "" (readFile $ dir ".git") - return $ if gitdirprefix `isPrefixOf` c - then Just $ Local - { gitdir = toRawFilePath $ absPathFrom dir $ - drop (length gitdirprefix) c - , worktree = Just (toRawFilePath dir) - } - else Nothing - where - gitdirprefix = "gitdir: " gitSignature file = doesFileExist $ dir file +-- Check for a .git file. +checkGitDirFile :: RawFilePath -> IO (Maybe RepoLocation) +checkGitDirFile dir = adjustGitDirFile' $ Local + { gitdir = dir P. ".git" + , worktree = Just dir + } + +-- git-submodule, git-worktree, and --separate-git-dir +-- make .git be a file pointing to the real git directory. +-- Detect that, and return a RepoLocation with gitdir pointing +-- to the real git directory. +adjustGitDirFile :: RepoLocation -> IO RepoLocation +adjustGitDirFile loc = fromMaybe loc <$> adjustGitDirFile' loc + +adjustGitDirFile' :: RepoLocation -> IO (Maybe RepoLocation) +adjustGitDirFile' loc = do + let gd = gitdir loc + c <- firstLine <$> catchDefaultIO "" (readFile (fromRawFilePath gd)) + if gitdirprefix `isPrefixOf` c + then do + top <- fromRawFilePath . P.takeDirectory <$> absPath gd + return $ Just $ loc + { gitdir = absPathFrom + (toRawFilePath top) + (toRawFilePath + (drop (length gitdirprefix) c)) + } + else return Nothing + where + gitdirprefix = "gitdir: " + + newFrom :: RepoLocation -> Repo newFrom l = Repo { location = l diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs index 054a81e..25bdc5c 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -1,10 +1,12 @@ {- The current git repository. - - - Copyright 2012 Joey Hess + - Copyright 2012-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.CurrentRepo where import Common @@ -13,6 +15,10 @@ import Git.Construct import qualified Git.Config import Utility.Env import Utility.Env.Set +import qualified Utility.RawFilePath as R + +import qualified Data.ByteString as B +import qualified System.FilePath.ByteString as P {- Gets the current git repository. - @@ -37,14 +43,14 @@ get = do gd <- getpathenv "GIT_DIR" r <- configure gd =<< fromCwd prefix <- getpathenv "GIT_PREFIX" - wt <- maybe (fromRawFilePath <$> worktree (location r)) Just + wt <- maybe (worktree (location r)) Just <$> getpathenvprefix "GIT_WORK_TREE" prefix case wt of Nothing -> return r Just d -> do - curr <- getCurrentDirectory + curr <- R.getCurrentDirectory unless (d `dirContains` curr) $ - setCurrentDirectory d + setCurrentDirectory (fromRawFilePath d) return $ addworktree wt r where getpathenv s = do @@ -52,34 +58,35 @@ get = do case v of Just d -> do unsetEnv s - return (Just d) + return (Just (toRawFilePath d)) Nothing -> return Nothing - getpathenvprefix s (Just prefix) | not (null prefix) = + getpathenvprefix s (Just prefix) | not (B.null prefix) = getpathenv s >>= \case Nothing -> return Nothing Just d | d == "." -> return (Just d) - | otherwise -> Just <$> absPath (prefix d) + | otherwise -> Just + <$> absPath (prefix P. d) getpathenvprefix s _ = getpathenv s configure Nothing (Just r) = Git.Config.read r configure (Just d) _ = do absd <- absPath d - curr <- getCurrentDirectory - r <- Git.Config.read $ newFrom $ - Local - { gitdir = toRawFilePath absd - , worktree = Just (toRawFilePath curr) - } + curr <- R.getCurrentDirectory + loc <- adjustGitDirFile $ Local + { gitdir = absd + , worktree = Just curr + } + r <- Git.Config.read $ newFrom loc return $ if Git.Config.isBare r then r { location = (location r) { worktree = Nothing } } else r - configure Nothing Nothing = giveup "Not in a git repository." addworktree w r = changelocation r $ Local { gitdir = gitdir (location r) - , worktree = fmap toRawFilePath w + , worktree = w } + changelocation r l = r { location = l } diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs index 3dc8529..4d84eec 100644 --- a/Git/Destroyer.hs +++ b/Git/Destroyer.hs @@ -95,12 +95,12 @@ applyDamage ds r = do case d of Empty s -> withfile s $ \f -> withSaneMode f $ do - nukeFile f + removeWhenExistsWith removeLink f writeFile f "" Reverse s -> withfile s $ \f -> withSaneMode f $ B.writeFile f =<< B.reverse <$> B.readFile f - Delete s -> withfile s $ nukeFile + Delete s -> withfile s $ removeWhenExistsWith removeLink AppendGarbage s garbage -> withfile s $ \f -> withSaneMode f $ @@ -145,4 +145,5 @@ applyDamage ds r = do ] withSaneMode :: FilePath -> IO () -> IO () -withSaneMode f = withModifiedFileMode f (addModes [ownerWriteMode, ownerReadMode]) +withSaneMode f = withModifiedFileMode (toRawFilePath f) + (addModes [ownerWriteMode, ownerReadMode]) diff --git a/Git/FilePath.hs b/Git/FilePath.hs index d31b421..feed8f6 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -58,8 +58,7 @@ fromTopFilePath p repo = P.combine (repoPath repo) (getTopFilePath p) {- The input FilePath can be absolute, or relative to the CWD. -} toTopFilePath :: RawFilePath -> Git.Repo -> IO TopFilePath -toTopFilePath file repo = TopFilePath . toRawFilePath - <$> relPathDirToFile (fromRawFilePath (repoPath repo)) (fromRawFilePath file) +toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file {- The input RawFilePath must already be relative to the top of the git - repository -} diff --git a/Git/Filename.hs b/Git/Filename.hs index 010e5ba..2fa4c59 100644 --- a/Git/Filename.hs +++ b/Git/Filename.hs @@ -10,6 +10,7 @@ module Git.Filename where import Common import Utility.Format (decode_c, encode_c) +import Utility.QuickCheck import Data.Char import Data.Word @@ -35,21 +36,14 @@ decode b = case S.uncons b of encode :: RawFilePath -> S.ByteString encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\"" -prop_encode_decode_roundtrip :: FilePath -> Bool -prop_encode_decode_roundtrip s = s' == - fromRawFilePath (decode (encode (toRawFilePath s'))) +-- Encoding and then decoding roundtrips only when the string does not +-- contain high unicode, because eg, both "\12345" and "\227\128\185" +-- are encoded to "\343\200\271". +-- +-- That is not a real-world problem, and using TestableFilePath +-- limits what's tested to ascii, so avoids running into it. +prop_encode_decode_roundtrip :: TestableFilePath -> Bool +prop_encode_decode_roundtrip ts = + s == fromRawFilePath (decode (encode (toRawFilePath s))) where - s' = nonul (nohigh s) - -- Encoding and then decoding roundtrips only when - -- the string does not contain high unicode, because eg, - -- both "\12345" and "\227\128\185" are encoded to - -- "\343\200\271". - -- - -- This property papers over the problem, by only - -- testing ascii - nohigh = filter isAscii - -- A String can contain a NUL, but toRawFilePath - -- truncates on the NUL, which is generally fine - -- because unix filenames cannot contain NUL. - -- So the encoding only roundtrips when there is no nul. - nonul = filter (/= '\NUL') + s = fromTestableFilePath ts diff --git a/Git/Fsck.hs b/Git/Fsck.hs index 69a9e9f..7440b92 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -77,27 +77,31 @@ findBroken batchmode r = do then toBatchCommand (command, params) else return (command, params) - p@(_, _, _, pid) <- createProcess $ - (proc command' (toCommand params')) - { std_out = CreatePipe - , std_err = CreatePipe - } - (o1, o2) <- concurrently - (parseFsckOutput maxobjs r (stdoutHandle p)) - (parseFsckOutput maxobjs r (stderrHandle p)) - fsckok <- checkSuccessProcess pid - case mappend o1 o2 of - FsckOutput badobjs truncated - | S.null badobjs && not fsckok -> return FsckFailed - | otherwise -> return $ FsckFoundMissing badobjs truncated - NoFsckOutput - | not fsckok -> return FsckFailed - | otherwise -> return noproblem - -- If all fsck output was duplicateEntries warnings, - -- the repository is not broken, it just has some unusual - -- tree objects in it. So ignore nonzero exit status. - AllDuplicateEntriesWarning -> return noproblem + let p = (proc command' (toCommand params')) + { std_out = CreatePipe + , std_err = CreatePipe + } + withCreateProcess p go where + go _ (Just outh) (Just errh) pid = do + (o1, o2) <- concurrently + (parseFsckOutput maxobjs r outh pid) + (parseFsckOutput maxobjs r errh pid) + fsckok <- checkSuccessProcess pid + case mappend o1 o2 of + FsckOutput badobjs truncated + | S.null badobjs && not fsckok -> return FsckFailed + | otherwise -> return $ FsckFoundMissing badobjs truncated + NoFsckOutput + | not fsckok -> return FsckFailed + | otherwise -> return noproblem + -- If all fsck output was duplicateEntries warnings, + -- the repository is not broken, it just has some + -- unusual tree objects in it. So ignore nonzero + -- exit status. + AllDuplicateEntriesWarning -> return noproblem + go _ _ _ _ = error "internal" + maxobjs = 10000 noproblem = FsckFoundMissing S.empty False @@ -117,9 +121,9 @@ knownMissing (FsckFoundMissing s _) = s findMissing :: [Sha] -> Repo -> IO MissingObjects findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs -parseFsckOutput :: Int -> Repo -> Handle -> IO FsckOutput -parseFsckOutput maxobjs r h = do - ls <- lines <$> hGetContents h +parseFsckOutput :: Int -> Repo -> Handle -> ProcessHandle -> IO FsckOutput +parseFsckOutput maxobjs r h pid = do + ls <- getlines [] if null ls then return NoFsckOutput else if all ("duplicateEntries" `isInfixOf`) ls @@ -129,6 +133,10 @@ parseFsckOutput maxobjs r h = do let !truncated = length shas > maxobjs missingobjs <- findMissing (take maxobjs shas) r return $ FsckOutput missingobjs truncated + where + getlines c = hGetLineUntilExitOrEOF pid h >>= \case + Nothing -> return (reverse c) + Just l -> getlines (l:c) isMissing :: Sha -> Repo -> IO Bool isMissing s r = either (const True) (const False) <$> tryIO dump diff --git a/Git/HashObject.hs b/Git/HashObject.hs index bcad9a1..98bd440 100644 --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -36,10 +36,10 @@ hashObjectStop :: HashObjectHandle -> IO () hashObjectStop = CoProcess.stop {- Injects a file into git, returning the Sha of the object. -} -hashFile :: HashObjectHandle -> FilePath -> IO Sha +hashFile :: HashObjectHandle -> RawFilePath -> IO Sha hashFile h file = CoProcess.query h send receive where - send to = hPutStrLn to =<< absPath file + send to = S8.hPutStrLn to =<< absPath file receive from = getSha "hash-object" $ S8.hGetLine from class HashableBlob t where @@ -60,7 +60,7 @@ hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha hashBlob h b = withTmpFile "hash" $ \tmp tmph -> do hashableBlobToHandle tmph b hClose tmph - hashFile h tmp + hashFile h (toRawFilePath tmp) {- Injects some content into git, returning its Sha. - diff --git a/Git/Index.hs b/Git/Index.hs index afd29c2..b55fc04 100644 --- a/Git/Index.hs +++ b/Git/Index.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Index where import Common @@ -12,6 +14,8 @@ import Git import Utility.Env import Utility.Env.Set +import qualified System.FilePath.ByteString as P + indexEnv :: String indexEnv = "GIT_INDEX_FILE" @@ -26,8 +30,8 @@ indexEnv = "GIT_INDEX_FILE" - - So, an absolute path is the only safe option for this to return. -} -indexEnvVal :: FilePath -> IO String -indexEnvVal = absPath +indexEnvVal :: RawFilePath -> IO String +indexEnvVal p = fromRawFilePath <$> absPath p {- Forces git to use the specified index file. - @@ -36,7 +40,7 @@ indexEnvVal = absPath - - Warning: Not thread safe. -} -override :: FilePath -> Repo -> IO (IO ()) +override :: RawFilePath -> Repo -> IO (IO ()) override index _r = do res <- getEnv var val <- indexEnvVal index @@ -48,13 +52,13 @@ override index _r = do reset _ = unsetEnv var {- The normal index file. Does not check GIT_INDEX_FILE. -} -indexFile :: Repo -> FilePath -indexFile r = fromRawFilePath (localGitDir r) "index" +indexFile :: Repo -> RawFilePath +indexFile r = localGitDir r P. "index" {- The index file git will currently use, checking GIT_INDEX_FILE. -} -currentIndexFile :: Repo -> IO FilePath -currentIndexFile r = fromMaybe (indexFile r) <$> getEnv indexEnv +currentIndexFile :: Repo -> IO RawFilePath +currentIndexFile r = maybe (indexFile r) toRawFilePath <$> getEnv indexEnv {- Git locks the index by creating this file. -} -indexFileLock :: FilePath -> FilePath -indexFileLock f = f ++ ".lock" +indexFileLock :: RawFilePath -> RawFilePath +indexFileLock f = f <> ".lock" diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index 830b5f5..297c068 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -1,22 +1,24 @@ {- git ls-files interface - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} module Git.LsFiles ( + Options(..), inRepo, + inRepoDetails, inRepoOrBranch, notInRepo, notInRepoIncludingEmptyDirectories, allFiles, deleted, modified, - modifiedOthers, staged, stagedNotDeleted, - stagedOthersDetails, + usualStageNum, + mergeConflictHeadStageNum, stagedDetails, typeChanged, typeChangedStaged, @@ -34,12 +36,15 @@ import Git.Types import Git.Sha import Utility.InodeCache import Utility.TimeStamp +import Utility.Attoparsec +import qualified Utility.RawFilePath as R -import Numeric -import Data.Char import System.Posix.Types import qualified Data.Map as M import qualified Data.ByteString as S +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 +import qualified System.FilePath.ByteString as P {- It's only safe to use git ls-files on the current repo, not on a remote. - @@ -63,101 +68,75 @@ guardSafeForLsFiles r a | safeForLsFiles r = a | otherwise = error $ "git ls-files is unsafe to run on repository " ++ repoDescribe r +data Options = ErrorUnmatch + +opParam :: Options -> CommandParam +opParam ErrorUnmatch = Param "--error-unmatch" + {- Lists files that are checked into git's index at the specified paths. - With no paths, all files are listed. -} -inRepo :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -inRepo = inRepo' [] +inRepo :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +inRepo = inRepo' [Param "--cached"] -inRepo' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -inRepo' ps l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo +inRepo' :: [CommandParam] -> [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +inRepo' ps os l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" : - Param "--cached" : Param "-z" : - ps ++ + map opParam os ++ ps ++ (Param "--" : map (File . fromRawFilePath) l) +{- Lists the same files inRepo does, but with sha and mode. -} +inRepoDetails :: [Options] -> [RawFilePath] -> Repo -> IO ([(RawFilePath, Sha, FileMode)], IO Bool) +inRepoDetails = stagedDetails' parser . map opParam + where + parser s = case parseStagedDetails s of + Just (file, sha, mode, stagenum) + | stagenum == usualStageNum || stagenum == mergeConflictHeadStageNum -> + Just (file, sha, mode) + _ -> Nothing + {- Files that are checked into the index or have been committed to a - branch. -} -inRepoOrBranch :: Branch -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -inRepoOrBranch b = inRepo' [Param $ "--with-tree=" ++ fromRef b] +inRepoOrBranch :: Branch -> [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +inRepoOrBranch b = inRepo' + [ Param "--cached" + , Param ("--with-tree=" ++ fromRef b) + ] {- Scans for files at the specified locations that are not checked into git. -} -notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +notInRepo :: [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) notInRepo = notInRepo' [] -notInRepo' :: [CommandParam] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -notInRepo' ps include_ignored l repo = guardSafeForLsFiles repo $ - pipeNullSplit' params repo +notInRepo' :: [CommandParam] -> [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +notInRepo' ps os include_ignored = + inRepo' (Param "--others" : ps ++ exclude) os where - params = concat - [ [ Param "ls-files", Param "--others"] - , ps - , exclude - , [ Param "-z", Param "--" ] - , map (File . fromRawFilePath) l - ] exclude | include_ignored = [] | otherwise = [Param "--exclude-standard"] {- Scans for files at the specified locations that are not checked into - git. Empty directories are included in the result. -} -notInRepoIncludingEmptyDirectories :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +notInRepoIncludingEmptyDirectories :: [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"] {- Finds all files in the specified locations, whether checked into git or - not. -} -allFiles :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -allFiles l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo - where - params = - Param "ls-files" : - Param "--cached" : - Param "--others" : - Param "-z" : - Param "--" : - map (File . fromRawFilePath) l +allFiles :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +allFiles = inRepo' [Param "--cached", Param "--others"] {- Returns a list of files in the specified locations that have been - deleted. -} -deleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -deleted l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo - where - params = - Param "ls-files" : - Param "--deleted" : - Param "-z" : - Param "--" : - map (File . fromRawFilePath) l +deleted :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +deleted = inRepo' [Param "--deleted"] {- Returns a list of files in the specified locations that have been - modified. -} -modified :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -modified l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo - where - params = - Param "ls-files" : - Param "--modified" : - Param "-z" : - Param "--" : - map (File . fromRawFilePath) l - -{- Files that have been modified or are not checked into git (and are not - - ignored). -} -modifiedOthers :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -modifiedOthers l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo - where - params = - Param "ls-files" : - Param "--modified" : - Param "--others" : - Param "--exclude-standard" : - Param "-z" : - Param "--" : - map (File . fromRawFilePath) l +modified :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +modified = inRepo' [Param "--modified"] {- Returns a list of all files that are staged for commit. -} staged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) @@ -175,36 +154,49 @@ staged' ps l repo = guardSafeForLsFiles repo $ prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] suffix = Param "--" : map (File . fromRawFilePath) l -type StagedDetails = (RawFilePath, Maybe Sha, Maybe FileMode) +type StagedDetails = (RawFilePath, Sha, FileMode, StageNum) + +type StageNum = Int -{- Returns details about files that are staged in the index, - - as well as files not yet in git. Skips ignored files. -} -stagedOthersDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) -stagedOthersDetails = stagedDetails' [Param "--others", Param "--exclude-standard"] +{- Used when not in a merge conflict. -} +usualStageNum :: Int +usualStageNum = 0 -{- Returns details about all files that are staged in the index. -} +{- WHen in a merge conflict, git uses stage number 2 for the local HEAD + - side of the merge conflict. -} +mergeConflictHeadStageNum :: Int +mergeConflictHeadStageNum = 2 + +{- Returns details about all files that are staged in the index. + - + - Note that, during a conflict, a file will appear in the list + - more than once with different stage numbers. + -} stagedDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) -stagedDetails = stagedDetails' [] +stagedDetails = stagedDetails' parseStagedDetails [] -{- Gets details about staged files, including the Sha of their staged - - contents. -} -stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) -stagedDetails' ps l repo = guardSafeForLsFiles repo $ do +stagedDetails' :: (S.ByteString -> Maybe t) -> [CommandParam] -> [RawFilePath] -> Repo -> IO ([t], IO Bool) +stagedDetails' parser ps l repo = guardSafeForLsFiles repo $ do (ls, cleanup) <- pipeNullSplit' params repo - return (map parseStagedDetails ls, cleanup) + return (mapMaybe parser ls, cleanup) where params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ Param "--" : map (File . fromRawFilePath) l -parseStagedDetails :: S.ByteString -> StagedDetails -parseStagedDetails s - | S.null file = (s, Nothing, Nothing) - | otherwise = (file, extractSha sha, readmode mode) +parseStagedDetails :: S.ByteString -> Maybe StagedDetails +parseStagedDetails = eitherToMaybe . A.parseOnly parser where - (metadata, file) = separate' (== fromIntegral (ord '\t')) s - (mode, metadata') = separate' (== fromIntegral (ord ' ')) metadata - (sha, _) = separate' (== fromIntegral (ord ' ')) metadata' - readmode = fst <$$> headMaybe . readOct . decodeBS' + parser = do + mode <- octal + void $ A8.char ' ' + sha <- maybe (fail "bad sha") return . extractSha =<< nextword + void $ A8.char ' ' + stagenum <- A8.decimal + void $ A8.char '\t' + file <- A.takeByteString + return (file, sha, mode, stagenum) + + nextword = A8.takeTill (== ' ') {- Returns a list of the files in the specified locations that are staged - for commit, and whose type has changed. -} @@ -218,12 +210,12 @@ typeChanged = typeChanged' [] typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChanged' ps l repo = guardSafeForLsFiles repo $ do - (fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo + (fs, cleanup) <- pipeNullSplit' (prefix ++ ps ++ suffix) repo -- git diff returns filenames relative to the top of the git repo; -- convert to filenames relative to the cwd, like git ls-files. - top <- absPath (fromRawFilePath (repoPath repo)) - currdir <- getCurrentDirectory - return (map (\f -> toRawFilePath (relPathDirToFileAbs currdir $ top decodeBL' f)) fs, cleanup) + top <- absPath (repoPath repo) + currdir <- R.getCurrentDirectory + return (map (\f -> relPathDirToFileAbs currdir $ top P. f) fs, cleanup) where prefix = [ Param "diff" diff --git a/Git/LsTree.hs b/Git/LsTree.hs index ead501f..cd0d406 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -1,17 +1,17 @@ {- git ls-tree interface - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE BangPatterns #-} - module Git.LsTree ( TreeItem(..), LsTreeMode(..), lsTree, lsTree', + lsTreeStrict, + lsTreeStrict', lsTreeParams, lsTreeFiles, parseLsTree, @@ -30,6 +30,7 @@ import Data.Either import System.Posix.Types import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import qualified Data.Attoparsec.ByteString as AS import qualified Data.Attoparsec.ByteString.Lazy as A import qualified Data.Attoparsec.ByteString.Char8 as A8 @@ -38,7 +39,7 @@ data TreeItem = TreeItem , typeobj :: S.ByteString , sha :: Ref , file :: TopFilePath - } deriving Show + } deriving (Show) data LsTreeMode = LsTreeRecursive | LsTreeNonRecursive @@ -51,6 +52,13 @@ lsTree' ps lsmode t repo = do (l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo return (rights (map parseLsTree l), cleanup) +lsTreeStrict :: LsTreeMode -> 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 + lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam] lsTreeParams lsmode r ps = [ Param "ls-tree" @@ -83,6 +91,13 @@ parseLsTree b = case A.parse parserLsTree 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) + 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 - diff --git a/Git/Objects.hs b/Git/Objects.hs index 6a24087..9b7165c 100644 --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -5,39 +5,45 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Objects where import Common import Git import Git.Sha -objectsDir :: Repo -> FilePath -objectsDir r = fromRawFilePath (localGitDir r) "objects" +import qualified Data.ByteString as B +import qualified System.FilePath.ByteString as P + +objectsDir :: Repo -> RawFilePath +objectsDir r = localGitDir r P. "objects" -packDir :: Repo -> FilePath -packDir r = objectsDir r "pack" +packDir :: Repo -> RawFilePath +packDir r = objectsDir r P. "pack" -packIdxFile :: FilePath -> FilePath -packIdxFile = flip replaceExtension "idx" +packIdxFile :: RawFilePath -> RawFilePath +packIdxFile = flip P.replaceExtension "idx" listPackFiles :: Repo -> IO [FilePath] listPackFiles r = filter (".pack" `isSuffixOf`) - <$> catchDefaultIO [] (dirContents $ packDir r) + <$> catchDefaultIO [] (dirContents $ fromRawFilePath $ packDir r) listLooseObjectShas :: Repo -> IO [Sha] listLooseObjectShas r = catchDefaultIO [] $ mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories) - <$> dirContentsRecursiveSkipping (== "pack") True (objectsDir r) + <$> dirContentsRecursiveSkipping (== "pack") True (fromRawFilePath (objectsDir r)) -looseObjectFile :: Repo -> Sha -> FilePath -looseObjectFile r sha = objectsDir r prefix rest +looseObjectFile :: Repo -> Sha -> RawFilePath +looseObjectFile r sha = objectsDir r P. prefix P. rest where - (prefix, rest) = splitAt 2 (fromRef sha) + (prefix, rest) = B.splitAt 2 (fromRef' sha) listAlternates :: Repo -> IO [FilePath] -listAlternates r = catchDefaultIO [] (lines <$> readFile alternatesfile) +listAlternates r = catchDefaultIO [] $ + lines <$> readFile (fromRawFilePath alternatesfile) where - alternatesfile = objectsDir r "info" "alternates" + alternatesfile = objectsDir r P. "info" P. "alternates" {- A repository recently cloned with --shared will have one or more - alternates listed, and contain no loose objects or packs. -} diff --git a/Git/Ref.hs b/Git/Ref.hs index 104a1db..7179a4e 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -1,6 +1,6 @@ {- git ref stuff - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -14,6 +14,7 @@ import Git import Git.Command import Git.Sha import Git.Types +import Git.FilePath import Data.Char (chr, ord) import qualified Data.ByteString as S @@ -68,7 +69,11 @@ branchRef = underBase "refs/heads" - of a repo. -} fileRef :: RawFilePath -> Ref -fileRef f = Ref $ ":./" <> f +fileRef f = Ref $ ":./" <> toInternalGitPath f + +{- A Ref that can be used to refer to a file in a particular branch. -} +branchFileRef :: Branch -> RawFilePath -> Ref +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 diff --git a/Git/Repair.hs b/Git/Repair.hs index f81aa78..ea682a2 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Repair ( runRepair, runRepairOf, @@ -35,13 +37,15 @@ import qualified Git.Ref as Ref import qualified Git.RefLog as RefLog import qualified Git.UpdateIndex as UpdateIndex import qualified Git.Branch as Branch +import Utility.Directory.Create import Utility.Tmp.Dir import Utility.Rsync import Utility.FileMode -import Utility.Tuple +import qualified Utility.RawFilePath as R import qualified Data.Set as S import qualified Data.ByteString.Lazy as L +import qualified System.FilePath.ByteString as P {- Given a set of bad objects found by git fsck, which may not - be complete, finds and removes all corrupt objects. -} @@ -51,9 +55,9 @@ cleanCorruptObjects fsckresults r = do mapM_ removeLoose (S.toList $ knownMissing fsckresults) mapM_ removeBad =<< listLooseObjectShas r where - removeLoose s = nukeFile (looseObjectFile r s) + removeLoose s = removeWhenExistsWith R.removeLink (looseObjectFile r s) removeBad s = do - void $ tryIO $ allowRead $ looseObjectFile r s + void $ tryIO $ allowRead $ looseObjectFile r s whenM (isMissing s r) $ removeLoose s @@ -77,10 +81,11 @@ explodePacks r = go =<< listPackFiles r putStrLn "Unpacking all pack files." forM_ packs $ \packfile -> do moveFile packfile (tmpdir takeFileName packfile) - nukeFile $ packIdxFile packfile + removeWhenExistsWith R.removeLink + (packIdxFile (toRawFilePath packfile)) forM_ packs $ \packfile -> do let tmp = tmpdir takeFileName packfile - allowRead tmp + allowRead (toRawFilePath tmp) -- May fail, if pack file is corrupt. void $ tryIO $ pipeWrite [Param "unpack-objects", Param "-r"] r $ \h -> @@ -100,7 +105,7 @@ 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 tmpdir + tmpr <- Config.read =<< Construct.fromAbsPath (toRawFilePath tmpdir) rs <- Construct.fromRemotes r stillmissing <- pullremotes tmpr rs fetchrefstags missing if S.null (knownMissing stillmissing) @@ -161,8 +166,8 @@ retrieveMissingObjects missing referencerepo r copyObjects :: Repo -> Repo -> IO Bool copyObjects srcr destr = rsync [ Param "-qr" - , File $ addTrailingPathSeparator $ objectsDir srcr - , File $ addTrailingPathSeparator $ objectsDir destr + , File $ addTrailingPathSeparator $ fromRawFilePath $ objectsDir srcr + , File $ addTrailingPathSeparator $ fromRawFilePath $ objectsDir destr ] {- To deal with missing objects that cannot be recovered, resets any @@ -240,18 +245,20 @@ getAllRefs' refdir = do explodePackedRefsFile :: Repo -> IO () explodePackedRefsFile r = do let f = packedRefsFile r + let f' = toRawFilePath f whenM (doesFileExist f) $ do rs <- mapMaybe parsePacked . lines - <$> catchDefaultIO "" (safeReadFile f) + <$> catchDefaultIO "" (safeReadFile f') forM_ rs makeref - nukeFile f + removeWhenExistsWith R.removeLink f' where makeref (sha, ref) = do - let gitd = fromRawFilePath (localGitDir r) - let dest = gitd fromRef ref + let gitd = localGitDir r + let dest = gitd P. fromRef' ref + let dest' = fromRawFilePath dest createDirectoryUnder gitd (parentDir dest) - unlessM (doesFileExist dest) $ - writeFile dest (fromRef sha) + unlessM (doesFileExist dest') $ + writeFile dest' (fromRef sha) packedRefsFile :: Repo -> FilePath packedRefsFile r = fromRawFilePath (localGitDir r) "packed-refs" @@ -266,7 +273,7 @@ parsePacked l = case words l of {- git-branch -d cannot be used to remove a branch that is directly - pointing to a corrupt commit. -} nukeBranchRef :: Branch -> Repo -> IO () -nukeBranchRef b r = nukeFile $ fromRawFilePath (localGitDir r) fromRef b +nukeBranchRef b r = removeWhenExistsWith R.removeLink $ localGitDir r P. fromRef' b {- Finds the most recent commit to a branch that does not need any - of the missing objects. If the input branch is good as-is, returns it. @@ -379,9 +386,8 @@ missingIndex r = not <$> doesFileExist (fromRawFilePath (localGitDir r) "ind partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool) partitionIndex r = do (indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r - l <- forM indexcontents $ \i -> case i of - (_file, Just sha, Just _mode) -> (,) <$> isMissing sha r <*> pure i - _ -> pure (False, i) + l <- forM indexcontents $ \i@(_file, sha, _mode, _stagenum) -> + (,) <$> isMissing sha r <*> pure i let (bad, good) = partition fst l return (map snd bad, map snd good, cleanup) @@ -393,17 +399,16 @@ rewriteIndex r | otherwise = do (bad, good, cleanup) <- partitionIndex r unless (null bad) $ do - nukeFile (indexFile r) + removeWhenExistsWith R.removeLink (indexFile r) UpdateIndex.streamUpdateIndex r =<< (catMaybes <$> mapM reinject good) void cleanup - return $ map (fromRawFilePath . fst3) bad + return $ map (\(file,_, _, _) -> fromRawFilePath file) bad where - reinject (file, Just sha, Just mode) = case toTreeItemType mode of + reinject (file, sha, mode, _) = case toTreeItemType mode of Nothing -> return Nothing Just treeitemtype -> Just <$> UpdateIndex.stageFile sha treeitemtype (fromRawFilePath file) r - reinject _ = return Nothing newtype GoodCommits = GoodCommits (S.Set Sha) @@ -442,14 +447,13 @@ displayList items header preRepair :: Repo -> IO () preRepair g = do unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do - nukeFile headfile - writeFile headfile "ref: refs/heads/master" + removeWhenExistsWith R.removeLink headfile + writeFile (fromRawFilePath headfile) "ref: refs/heads/master" explodePackedRefsFile g - unless (repoIsLocalBare g) $ do - let f = indexFile g - void $ tryIO $ allowWrite f + unless (repoIsLocalBare g) $ + void $ tryIO $ allowWrite $ indexFile g where - headfile = fromRawFilePath (localGitDir g) "HEAD" + headfile = localGitDir g P. "HEAD" validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha (encodeBS' s)) @@ -571,7 +575,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do else successfulfinish modifiedbranches corruptedindex = do - nukeFile (indexFile g) + removeWhenExistsWith R.removeLink (indexFile g) -- The corrupted index can prevent fsck from finding other -- problems, so re-run repair. fsckresult' <- findBroken False g @@ -615,7 +619,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do successfulRepair :: (Bool, [Branch]) -> Bool successfulRepair = fst -safeReadFile :: FilePath -> IO String +safeReadFile :: RawFilePath -> IO String safeReadFile f = do allowRead f - readFileStrict f + readFileStrict (fromRawFilePath f) diff --git a/Git/Types.hs b/Git/Types.hs index 4bf61e5..73c4fe6 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} module Git.Types where @@ -79,9 +79,15 @@ fromConfigKey (ConfigKey s) = decodeBS' s instance Show ConfigKey where show = fromConfigKey -fromConfigValue :: ConfigValue -> String -fromConfigValue (ConfigValue s) = decodeBS' s -fromConfigValue NoConfigValue = mempty +class FromConfigValue a where + fromConfigValue :: ConfigValue -> a + +instance FromConfigValue S.ByteString where + fromConfigValue (ConfigValue s) = s + fromConfigValue NoConfigValue = mempty + +instance FromConfigValue String where + fromConfigValue = decodeBS' . fromConfigValue instance Show ConfigValue where show = fromConfigValue @@ -129,7 +135,12 @@ fmtObjectType CommitObject = "commit" fmtObjectType TreeObject = "tree" {- Types of items in a tree. -} -data TreeItemType = TreeFile | TreeExecutable | TreeSymlink | TreeSubmodule +data TreeItemType + = TreeFile + | TreeExecutable + | TreeSymlink + | TreeSubmodule + | TreeSubtree deriving (Eq, Show) {- Git uses magic numbers to denote the type of a tree item. -} @@ -138,6 +149,7 @@ readTreeItemType "100644" = Just TreeFile readTreeItemType "100755" = Just TreeExecutable readTreeItemType "120000" = Just TreeSymlink readTreeItemType "160000" = Just TreeSubmodule +readTreeItemType "040000" = Just TreeSubtree readTreeItemType _ = Nothing fmtTreeItemType :: TreeItemType -> S.ByteString @@ -145,12 +157,14 @@ fmtTreeItemType TreeFile = "100644" fmtTreeItemType TreeExecutable = "100755" fmtTreeItemType TreeSymlink = "120000" fmtTreeItemType TreeSubmodule = "160000" +fmtTreeItemType TreeSubtree = "040000" toTreeItemType :: FileMode -> Maybe TreeItemType toTreeItemType 0o100644 = Just TreeFile toTreeItemType 0o100755 = Just TreeExecutable toTreeItemType 0o120000 = Just TreeSymlink toTreeItemType 0o160000 = Just TreeSubmodule +toTreeItemType 0o040000 = Just TreeSubtree toTreeItemType _ = Nothing fromTreeItemType :: TreeItemType -> FileMode @@ -158,6 +172,7 @@ fromTreeItemType TreeFile = 0o100644 fromTreeItemType TreeExecutable = 0o100755 fromTreeItemType TreeSymlink = 0o120000 fromTreeItemType TreeSubmodule = 0o160000 +fromTreeItemType TreeSubtree = 0o040000 data Commit = Commit { commitTree :: Sha diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index f0331d5..8e406b1 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -1,6 +1,6 @@ {- git-update-index library - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -12,8 +12,7 @@ module Git.UpdateIndex ( pureStreamer, streamUpdateIndex, streamUpdateIndex', - startUpdateIndex, - stopUpdateIndex, + withUpdateIndex, lsTree, lsSubTree, updateIndexLine, @@ -32,7 +31,9 @@ import Git.FilePath import Git.Sha import qualified Git.DiffTreeItem as Diff +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import Control.Monad.IO.Class {- Streamers are passed a callback and should feed it lines in the form - read by update-index, and generated by ls-tree. -} @@ -44,28 +45,32 @@ pureStreamer !s = \streamer -> streamer s {- Streams content into update-index from a list of Streamers. -} streamUpdateIndex :: Repo -> [Streamer] -> IO () -streamUpdateIndex repo as = bracket (startUpdateIndex repo) stopUpdateIndex $ - (\h -> forM_ as $ streamUpdateIndex' h) +streamUpdateIndex repo as = withUpdateIndex repo $ \h -> + forM_ as $ streamUpdateIndex' h -data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle +data UpdateIndexHandle = UpdateIndexHandle Handle streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO () -streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do +streamUpdateIndex' (UpdateIndexHandle h) a = a $ \s -> do L.hPutStr h s L.hPutStr h "\0" -startUpdateIndex :: Repo -> IO UpdateIndexHandle -startUpdateIndex repo = do - (Just h, _, _, p) <- createProcess (gitCreateProcess params repo) - { std_in = CreatePipe } - return $ UpdateIndexHandle p h +withUpdateIndex :: (MonadIO m, MonadMask m) => Repo -> (UpdateIndexHandle -> m a) -> m a +withUpdateIndex repo a = bracket setup cleanup go where params = map Param ["update-index", "-z", "--index-info"] - -stopUpdateIndex :: UpdateIndexHandle -> IO Bool -stopUpdateIndex (UpdateIndexHandle p h) = do - hClose h - checkSuccessProcess p + + setup = liftIO $ createProcess $ + (gitCreateProcess params repo) + { std_in = CreatePipe } + go p = do + r <- a (UpdateIndexHandle (stdinHandle p)) + liftIO $ do + hClose (stdinHandle p) + void $ checkSuccessProcess (processHandle p) + return r + + cleanup = liftIO . cleanupProcess {- A streamer that adds the current tree for a ref. Useful for eg, copying - and modifying branches. -} @@ -113,12 +118,12 @@ unstageFile' p = pureStreamer $ L.fromStrict $ <> indexPath p {- A streamer that adds a symlink to the index. -} -stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer +stageSymlink :: RawFilePath -> Sha -> Repo -> IO Streamer stageSymlink file sha repo = do !line <- updateIndexLine <$> pure sha <*> pure TreeSymlink - <*> toTopFilePath (toRawFilePath file) repo + <*> toTopFilePath file repo return $ pureStreamer line {- A streamer that applies a DiffTreeItem to the index. -} @@ -131,16 +136,8 @@ indexPath :: TopFilePath -> InternalGitPath indexPath = toInternalGitPath . getTopFilePath {- Refreshes the index, by checking file stat information. -} -refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool -refreshIndex repo feeder = do - (Just h, _, _, p) <- createProcess (gitCreateProcess params repo) - { std_in = CreatePipe } - feeder $ \f -> do - hPutStr h f - hPutStr h "\0" - hFlush h - hClose h - checkSuccessProcess p +refreshIndex :: Repo -> ((RawFilePath -> IO ()) -> IO ()) -> IO Bool +refreshIndex repo feeder = withCreateProcess p go where params = [ Param "update-index" @@ -149,3 +146,14 @@ refreshIndex repo feeder = do , Param "-z" , Param "--stdin" ] + + p = (gitCreateProcess params repo) + { std_in = CreatePipe } + + go (Just h) _ _ pid = do + feeder $ \f -> + S.hPut h (S.snoc f 0) + hFlush h + hClose h + checkSuccessProcess pid + go _ _ _ _ = error "internal" diff --git a/Git/Version.hs b/Git/Version.hs index 5ecaca0..9119f5d 100644 --- a/Git/Version.hs +++ b/Git/Version.hs @@ -14,7 +14,7 @@ module Git.Version ( GitVersion, ) where -import Common +import Utility.Process import Utility.DottedVersion type GitVersion = DottedVersion diff --git a/Utility/Batch.hs b/Utility/Batch.hs index 1d66881..58e326e 100644 --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -1,6 +1,6 @@ {- Running a long or expensive batch operation niced. - - - Copyright 2013 Joey Hess + - Copyright 2013-2020 Joey Hess - - License: BSD-2-clause -} @@ -10,6 +10,7 @@ module Utility.Batch ( batch, BatchCommandMaker, + nonBatchCommandMaker, getBatchCommandMaker, toBatchCommand, batchCommand, @@ -22,7 +23,6 @@ import Common import Control.Concurrent.Async import System.Posix.Process #endif -import qualified Control.Exception as E {- Runs an operation, at batch priority. - @@ -42,17 +42,18 @@ batch a = wait =<< batchthread batchthread = asyncBound $ do setProcessPriority 0 maxNice a + maxNice = 19 #else batch a = a #endif -maxNice :: Int -maxNice = 19 - {- Makes a command be run by whichever of nice, ionice, and nocache - are available in the path. -} type BatchCommandMaker = (String, [CommandParam]) -> (String, [CommandParam]) +nonBatchCommandMaker :: BatchCommandMaker +nonBatchCommandMaker = id + getBatchCommandMaker :: IO BatchCommandMaker getBatchCommandMaker = do #ifndef mingw32_HOST_OS @@ -75,11 +76,7 @@ toBatchCommand v = do return $ batchmaker v {- Runs a command in a way that's suitable for batch jobs that can be - - interrupted. - - - - If the calling thread receives an async exception, it sends the - - command a SIGTERM, and after the command finishes shuttting down, - - it re-raises the async exception. -} + - interrupted. -} batchCommand :: String -> [CommandParam] -> IO Bool batchCommand command params = batchCommandEnv command params Nothing @@ -87,13 +84,4 @@ batchCommandEnv :: String -> [CommandParam] -> Maybe [(String, String)] -> IO Bo batchCommandEnv command params environ = do batchmaker <- getBatchCommandMaker let (command', params') = batchmaker (command, params) - let p = proc command' $ toCommand params' - (_, _, _, pid) <- createProcess $ p { env = environ } - r <- E.try (waitForProcess pid) :: IO (Either E.SomeException ExitCode) - case r of - Right ExitSuccess -> return True - Right _ -> return False - Left asyncexception -> do - terminateProcess pid - void $ waitForProcess pid - E.throwIO asyncexception + boolSystemEnv command' params' environ diff --git a/Utility/Directory.hs b/Utility/Directory.hs index 8b5b88b..38adf17 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -16,26 +16,16 @@ module Utility.Directory ( import Control.Monad import System.FilePath -import System.PosixCompat.Files +import System.PosixCompat.Files hiding (removeLink) import Control.Applicative -import Control.Monad.IO.Class -import Control.Monad.IfElse import System.IO.Unsafe (unsafeInterleaveIO) -import System.IO.Error import Data.Maybe import Prelude -#ifndef mingw32_HOST_OS -import Utility.SafeCommand -#endif - import Utility.SystemDirectory -import Utility.Path -import Utility.Tmp import Utility.Exception import Utility.Monad import Utility.Applicative -import Utility.PartialPrelude dirCruft :: FilePath -> Bool dirCruft "." = True @@ -101,131 +91,9 @@ dirTreeRecursiveSkipping skipdir topdir = go [] [topdir] =<< catchDefaultIO [] (dirContents dir) go (subdirs++dir:c) dirs -{- Moves one filename to another. - - First tries a rename, but falls back to moving across devices if needed. -} -moveFile :: FilePath -> FilePath -> IO () -moveFile src dest = tryIO (rename src dest) >>= onrename - where - onrename (Right _) = noop - onrename (Left e) - | isPermissionError e = rethrow - | isDoesNotExistError e = rethrow - | otherwise = viaTmp mv dest "" - where - rethrow = throwM e - - mv tmp _ = do - -- copyFile is likely not as optimised as - -- the mv command, so we'll use the command. - -- - -- But, while Windows has a "mv", it does not seem very - -- reliable, so use copyFile there. -#ifndef mingw32_HOST_OS - -- If dest is a directory, mv would move the file - -- into it, which is not desired. - whenM (isdir dest) rethrow - ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] - let e' = e -#else - r <- tryIO $ copyFile src tmp - let (ok, e') = case r of - Left err -> (False, err) - Right _ -> (True, e) -#endif - unless ok $ do - -- delete any partial - _ <- tryIO $ removeFile tmp - throwM e' - -#ifndef mingw32_HOST_OS - isdir f = do - r <- tryIO $ getFileStatus f - case r of - (Left _) -> return False - (Right s) -> return $ isDirectory s -#endif - -{- Removes a file, which may or may not exist, and does not have to - - be a regular file. - - - - Note that an exception is thrown if the file exists but - - cannot be removed. -} -nukeFile :: FilePath -> IO () -nukeFile file = void $ tryWhenExists go - where -#ifndef mingw32_HOST_OS - go = removeLink file -#else - go = removeFile file -#endif - -{- Like createDirectoryIfMissing True, but it will only create - - missing parent directories up to but not including the directory - - in the first parameter. +{- Use with an action that removes something, which may or may not exist. - - - For example, createDirectoryUnder "/tmp/foo" "/tmp/foo/bar/baz" - - will create /tmp/foo/bar if necessary, but if /tmp/foo does not exist, - - it will throw an exception. - - - - The exception thrown is the same that createDirectory throws if the - - parent directory does not exist. - - - - If the second FilePath is not under the first - - FilePath (or the same as it), it will fail with an exception - - even if the second FilePath's parent directory already exists. - - - - Either or both of the FilePaths can be relative, or absolute. - - They will be normalized as necessary. - - - - Note that, the second FilePath, if relative, is relative to the current - - working directory, not to the first FilePath. + - If an exception is thrown due to it not existing, it is ignored. -} -createDirectoryUnder :: FilePath -> FilePath -> IO () -createDirectoryUnder topdir dir = - createDirectoryUnder' topdir dir createDirectory - -createDirectoryUnder' - :: (MonadIO m, MonadCatch m) - => FilePath - -> FilePath - -> (FilePath -> m ()) - -> m () -createDirectoryUnder' topdir dir0 mkdir = do - p <- liftIO $ relPathDirToFile topdir dir0 - let dirs = splitDirectories p - -- Catch cases where the dir is not beneath the topdir. - -- If the relative path between them starts with "..", - -- it's not. And on Windows, if they are on different drives, - -- the path will not be relative. - if headMaybe dirs == Just ".." || isAbsolute p - then liftIO $ ioError $ customerror userErrorType - ("createDirectoryFrom: not located in " ++ topdir) - -- If dir0 is the same as the topdir, don't try to create - -- it, but make sure it does exist. - else if null dirs - then liftIO $ unlessM (doesDirectoryExist topdir) $ - ioError $ customerror doesNotExistErrorType - "createDirectoryFrom: does not exist" - else createdirs $ - map (topdir ) (reverse (scanl1 () dirs)) - where - customerror t s = mkIOError t s Nothing (Just dir0) - - createdirs [] = pure () - createdirs (dir:[]) = createdir dir (liftIO . ioError) - createdirs (dir:dirs) = createdir dir $ \_ -> do - createdirs dirs - createdir dir (liftIO . ioError) - - -- This is the same method used by createDirectoryIfMissing, - -- in particular the handling of errors that occur when the - -- directory already exists. See its source for explanation - -- of several subtleties. - createdir dir notexisthandler = tryIO (mkdir dir) >>= \case - Right () -> pure () - Left e - | isDoesNotExistError e -> notexisthandler e - | isAlreadyExistsError e || isPermissionError e -> - liftIO $ unlessM (doesDirectoryExist dir) $ - ioError e - | otherwise -> liftIO $ ioError e +removeWhenExistsWith :: (a -> IO ()) -> a -> IO () +removeWhenExistsWith f a = void $ tryWhenExists $ f a diff --git a/Utility/Directory/Create.hs b/Utility/Directory/Create.hs new file mode 100644 index 0000000..32c0bcf --- /dev/null +++ b/Utility/Directory/Create.hs @@ -0,0 +1,102 @@ +{- directory creating + - + - Copyright 2011-2020 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Directory.Create ( + createDirectoryUnder, + createDirectoryUnder', +) where + +import Control.Monad +import Control.Applicative +import Control.Monad.IO.Class +import Control.Monad.IfElse +import System.IO.Error +import Data.Maybe +import qualified System.FilePath.ByteString as P +import Prelude + +import Utility.SystemDirectory +import Utility.Path.AbsRel +import Utility.Exception +import Utility.FileSystemEncoding +import qualified Utility.RawFilePath as R +import Utility.PartialPrelude + +{- Like createDirectoryIfMissing True, but it will only create + - missing parent directories up to but not including the directory + - in the first parameter. + - + - For example, createDirectoryUnder "/tmp/foo" "/tmp/foo/bar/baz" + - will create /tmp/foo/bar if necessary, but if /tmp/foo does not exist, + - it will throw an exception. + - + - The exception thrown is the same that createDirectory throws if the + - parent directory does not exist. + - + - If the second FilePath is not under the first + - FilePath (or the same as it), it will fail with an exception + - even if the second FilePath's parent directory already exists. + - + - Either or both of the FilePaths can be relative, or absolute. + - They will be normalized as necessary. + - + - Note that, the second FilePath, if relative, is relative to the current + - working directory, not to the first FilePath. + -} +createDirectoryUnder :: RawFilePath -> RawFilePath -> IO () +createDirectoryUnder topdir dir = + createDirectoryUnder' topdir dir R.createDirectory + +createDirectoryUnder' + :: (MonadIO m, MonadCatch m) + => RawFilePath + -> RawFilePath + -> (RawFilePath -> m ()) + -> m () +createDirectoryUnder' topdir dir0 mkdir = do + p <- liftIO $ relPathDirToFile topdir dir0 + let dirs = P.splitDirectories p + -- Catch cases where the dir is not beneath the topdir. + -- If the relative path between them starts with "..", + -- it's not. And on Windows, if they are on different drives, + -- the path will not be relative. + if headMaybe dirs == Just ".." || P.isAbsolute p + then liftIO $ ioError $ customerror userErrorType + ("createDirectoryFrom: not located in " ++ fromRawFilePath topdir) + -- If dir0 is the same as the topdir, don't try to create + -- it, but make sure it does exist. + else if null dirs + then liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $ + ioError $ customerror doesNotExistErrorType + "createDirectoryFrom: does not exist" + else createdirs $ + map (topdir P.) (reverse (scanl1 (P.) dirs)) + where + customerror t s = mkIOError t s Nothing (Just (fromRawFilePath dir0)) + + createdirs [] = pure () + createdirs (dir:[]) = createdir dir (liftIO . ioError) + createdirs (dir:dirs) = createdir dir $ \_ -> do + createdirs dirs + createdir dir (liftIO . ioError) + + -- This is the same method used by createDirectoryIfMissing, + -- in particular the handling of errors that occur when the + -- directory already exists. See its source for explanation + -- of several subtleties. + createdir dir notexisthandler = tryIO (mkdir dir) >>= \case + Right () -> pure () + Left e + | isDoesNotExistError e -> notexisthandler e + | isAlreadyExistsError e || isPermissionError e -> + liftIO $ unlessM (doesDirectoryExist (fromRawFilePath dir)) $ + ioError e + | otherwise -> liftIO $ ioError e diff --git a/Utility/DottedVersion.hs b/Utility/DottedVersion.hs index dff3717..84b8463 100644 --- a/Utility/DottedVersion.hs +++ b/Utility/DottedVersion.hs @@ -13,7 +13,7 @@ module Utility.DottedVersion ( normalize, ) where -import Common +import Utility.Split data DottedVersion = DottedVersion String Integer deriving (Eq) diff --git a/Utility/Env/Set.hs b/Utility/Env/Set.hs index f14674c..45d2e7f 100644 --- a/Utility/Env/Set.hs +++ b/Utility/Env/Set.hs @@ -10,6 +10,7 @@ module Utility.Env.Set ( setEnv, unsetEnv, + legalInEnvVar, ) where #ifdef mingw32_HOST_OS @@ -18,6 +19,7 @@ import Utility.Env #else import qualified System.Posix.Env as PE #endif +import Data.Char {- Sets an environment variable. To overwrite an existing variable, - overwrite must be True. @@ -41,3 +43,7 @@ unsetEnv = PE.unsetEnv #else unsetEnv = System.SetEnv.unsetEnv #endif + +legalInEnvVar :: Char -> Bool +legalInEnvVar '_' = True +legalInEnvVar c = isAsciiLower c || isAsciiUpper c || (isNumber c && isAscii c) diff --git a/Utility/Exception.hs b/Utility/Exception.hs index bcadb78..273f844 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 excpected to see in some + - where there's a problem that the user is expeected to see in some - circumstances. -} giveup :: [Char] -> a giveup = errorWithoutStackTrace diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index 7d36c55..6725601 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -1,11 +1,12 @@ {- File mode utilities. - - - Copyright 2010-2017 Joey Hess + - Copyright 2010-2020 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.FileMode ( module Utility.FileMode, @@ -15,32 +16,30 @@ module Utility.FileMode ( import System.IO import Control.Monad import System.PosixCompat.Types -import System.PosixCompat.Files -#ifndef mingw32_HOST_OS -import System.Posix.Files (symbolicLinkMode) -import Control.Monad.IO.Class (liftIO) -#endif -import Control.Monad.IO.Class (MonadIO) +import System.PosixCompat.Files hiding (removeLink) +import Control.Monad.IO.Class import Foreign (complement) import Control.Monad.Catch import Utility.Exception +import Utility.FileSystemEncoding +import qualified Utility.RawFilePath as R {- Applies a conversion function to a file's mode. -} -modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO () +modifyFileMode :: RawFilePath -> (FileMode -> FileMode) -> IO () modifyFileMode f convert = void $ modifyFileMode' f convert -modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode +modifyFileMode' :: RawFilePath -> (FileMode -> FileMode) -> IO FileMode modifyFileMode' f convert = do - s <- getFileStatus f + s <- R.getFileStatus f let old = fileMode s let new = convert old when (new /= old) $ - setFileMode f new + R.setFileMode f new return old {- Runs an action after changing a file's mode, then restores the old mode. -} -withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a +withModifiedFileMode :: RawFilePath -> (FileMode -> FileMode) -> IO a -> IO a withModifiedFileMode file convert a = bracket setup cleanup go where setup = modifyFileMode' file convert @@ -73,15 +72,15 @@ otherGroupModes = ] {- Removes the write bits from a file. -} -preventWrite :: FilePath -> IO () +preventWrite :: RawFilePath -> IO () preventWrite f = modifyFileMode f $ removeModes writeModes {- Turns a file's owner write bit back on. -} -allowWrite :: FilePath -> IO () +allowWrite :: RawFilePath -> IO () allowWrite f = modifyFileMode f $ addModes [ownerWriteMode] {- Turns a file's owner read bit back on. -} -allowRead :: FilePath -> IO () +allowRead :: RawFilePath -> IO () allowRead f = modifyFileMode f $ addModes [ownerReadMode] {- Allows owner and group to read and write to a file. -} @@ -91,20 +90,12 @@ groupSharedModes = , ownerReadMode, groupReadMode ] -groupWriteRead :: FilePath -> IO () +groupWriteRead :: RawFilePath -> IO () groupWriteRead f = modifyFileMode f $ addModes groupSharedModes checkMode :: FileMode -> FileMode -> Bool checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor -{- Checks if a file mode indicates it's a symlink. -} -isSymLink :: FileMode -> Bool -#ifdef mingw32_HOST_OS -isSymLink _ = False -#else -isSymLink = checkMode symbolicLinkMode -#endif - {- Checks if a file has any executable bits set. -} isExecutable :: FileMode -> Bool isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0 @@ -160,7 +151,7 @@ isSticky = checkMode stickyMode stickyMode :: FileMode stickyMode = 512 -setSticky :: FilePath -> IO () +setSticky :: RawFilePath -> IO () setSticky f = modifyFileMode f $ addModes [stickyMode] #endif @@ -173,13 +164,13 @@ setSticky f = modifyFileMode f $ addModes [stickyMode] - On a filesystem that does not support file permissions, this is the same - as writeFile. -} -writeFileProtected :: FilePath -> String -> IO () +writeFileProtected :: RawFilePath -> String -> IO () writeFileProtected file content = writeFileProtected' file (\h -> hPutStr h content) -writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO () +writeFileProtected' :: RawFilePath -> (Handle -> IO ()) -> IO () writeFileProtected' file writer = protectedOutput $ - withFile file WriteMode $ \h -> do + withFile (fromRawFilePath file) WriteMode $ \h -> do void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes writer h diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs index 8544ad4..a503fda 100644 --- a/Utility/FileSize.hs +++ b/Utility/FileSize.hs @@ -1,4 +1,6 @@ {- File size. + - + - Copyright 2015-2020 Joey Hess - - License: BSD-2-clause -} @@ -12,10 +14,12 @@ module Utility.FileSize ( getFileSize', ) where -import System.PosixCompat.Files +import System.PosixCompat.Files hiding (removeLink) +import qualified Utility.RawFilePath as R #ifdef mingw32_HOST_OS import Control.Exception (bracket) import System.IO +import Utility.FileSystemEncoding #endif type FileSize = Integer @@ -26,18 +30,18 @@ type FileSize = Integer - FileOffset which maxes out at 2 gb. - See https://github.com/jystic/unix-compat/issues/16 -} -getFileSize :: FilePath -> IO FileSize +getFileSize :: R.RawFilePath -> IO FileSize #ifndef mingw32_HOST_OS -getFileSize f = fmap (fromIntegral . fileSize) (getFileStatus f) +getFileSize f = fmap (fromIntegral . fileSize) (R.getFileStatus f) #else -getFileSize f = bracket (openFile f ReadMode) hClose hFileSize +getFileSize f = bracket (openFile (fromRawFilePath f) ReadMode) hClose hFileSize #endif {- Gets the size of the file, when its FileStatus is already known. - - On windows, uses getFileSize. Otherwise, the FileStatus contains the - size, so this does not do any work. -} -getFileSize' :: FilePath -> FileStatus -> IO FileSize +getFileSize' :: R.RawFilePath -> FileStatus -> IO FileSize #ifndef mingw32_HOST_OS getFileSize' _ s = return $ fromIntegral $ fileSize s #else diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index 4c099ff..1f7c76b 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -36,17 +36,18 @@ import Foreign.C import System.IO import System.IO.Unsafe import Data.Word -import Data.List +import System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L #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 System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath) import Utility.Exception -import Utility.Split {- Makes all subsequent Handles that are opened, as well as stdio Handles, - use the filesystem encoding, instead of the encoding of the current @@ -178,6 +179,7 @@ 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 @@ -206,6 +208,7 @@ decodeW8NUL :: FilePath -> [Word8] decodeW8NUL = intercalate [c2w8 nul] . map decodeW8 . splitc nul where nul = '\NUL' +#endif c2w8 :: Char -> Word8 c2w8 = fromIntegral . fromEnum diff --git a/Utility/Format.hs b/Utility/Format.hs index a2470fa..466988c 100644 --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -1,6 +1,6 @@ {- Formatted string handling. - - - Copyright 2010, 2011 Joey Hess + - Copyright 2010-2020 Joey Hess - - License: BSD-2-clause -} @@ -9,8 +9,10 @@ module Utility.Format ( Format, gen, format, + formatContainsVar, decode_c, encode_c, + encode_c', prop_encode_c_decode_c_roundtrip ) where @@ -29,9 +31,14 @@ type FormatString = String {- A format consists of a list of fragments. -} type Format = [Frag] -{- A fragment is either a constant string, - - or a variable, with a justification. -} -data Frag = Const String | Var String Justify +{- A fragment is either a constant string, or a variable. -} +data Frag + = Const String + | Var + { varName :: String + , varJustify :: Justify + , varEscaped :: Bool + } deriving (Show) data Justify = LeftJustified Int | RightJustified Int | UnJustified @@ -45,10 +52,8 @@ format :: Format -> Variables -> String format f vars = concatMap expand f where expand (Const s) = s - expand (Var name j) - | "escaped_" `isPrefixOf` name = - justify j $ encode_c_strict $ - getvar $ drop (length "escaped_") name + expand (Var name j esc) + | esc = justify j $ encode_c' isSpace $ getvar name | otherwise = justify j $ getvar name getvar name = fromMaybe "" $ M.lookup name vars justify UnJustified s = s @@ -61,6 +66,8 @@ format f vars = concatMap expand f - format string, such as "${foo} ${bar;10} ${baz;-10}\n" - - (This is the same type of format string used by dpkg-query.) + - + - Also, "${escaped_foo}" will apply encode_c to the value of variable foo. -} gen :: FormatString -> Format gen = filter (not . empty) . fuse [] . scan [] . decode_c @@ -94,12 +101,24 @@ gen = filter (not . empty) . fuse [] . scan [] . decode_c | i < 0 = LeftJustified (-1 * i) | otherwise = RightJustified i novar v = "${" ++ reverse v - foundvar f v p = scan (Var (reverse v) p : f) + foundvar f varname_r p = + let varname = reverse varname_r + var = if "escaped_" `isPrefixOf` varname + then Var (drop (length "escaped_") varname) p True + else Var varname p False + in scan (var : f) empty :: Frag -> Bool empty (Const "") = True empty _ = False +{- Check if a Format contains a variable with a specified name. -} +formatContainsVar :: String -> Format -> Bool +formatContainsVar v = any go + where + go (Var v' _ _) | v' == v = True + go _ = False + {- Decodes a C-style encoding, where \n is a newline (etc), - \NNN is an octal encoded character, and \xNN is a hex encoded character. -} @@ -144,10 +163,7 @@ decode_c s = unescape ("", s) encode_c :: String -> FormatString encode_c = encode_c' (const False) -{- Encodes more strictly, including whitespace. -} -encode_c_strict :: String -> FormatString -encode_c_strict = encode_c' isSpace - +{- Encodes special characters, as well as any matching the predicate. -} encode_c' :: (Char -> Bool) -> String -> FormatString encode_c' p = concatMap echar where @@ -165,8 +181,8 @@ encode_c' p = concatMap echar | ord c < 0x20 = e_asc c -- low ascii | ord c >= 256 = e_utf c -- unicode | ord c > 0x7E = e_asc c -- high ascii - | p c = e_asc c -- unprintable ascii - | otherwise = [c] -- printable ascii + | p c = e_asc c + | otherwise = [c] -- unicode character is decomposed to individual Word8s, -- and each is shown in octal e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8]) diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs index d90143e..5178531 100644 --- a/Utility/HumanTime.hs +++ b/Utility/HumanTime.hs @@ -19,7 +19,6 @@ module Utility.HumanTime ( import Utility.PartialPrelude import Utility.QuickCheck -import Control.Monad.Fail as Fail (MonadFail(..)) import qualified Data.Map as M import Data.Time.Clock import Data.Time.Clock.POSIX (POSIXTime) @@ -45,8 +44,10 @@ daysToDuration :: Integer -> Duration daysToDuration i = Duration $ i * dsecs {- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -} -parseDuration :: MonadFail m => String -> m Duration -parseDuration = maybe parsefail (return . Duration) . go 0 +parseDuration :: String -> Either String Duration +parseDuration d + | null d = parsefail + | otherwise = maybe parsefail (Right . Duration) $ go 0 d where go n [] = return n go n s = do @@ -56,7 +57,7 @@ parseDuration = maybe parsefail (return . Duration) . go 0 u <- M.lookup c unitmap go (n + num * u) rest _ -> return $ n + num - parsefail = Fail.fail "duration parse error; expected eg \"5m\" or \"1h5m\"" + parsefail = Left $ "failed to parse duration \"" ++ d ++ "\" (expected eg \"5m\" or \"1h5m\")" fromDuration :: Duration -> String fromDuration Duration { durationSeconds = d } @@ -102,4 +103,4 @@ instance Arbitrary Duration where arbitrary = Duration <$> nonNegative arbitrary prop_duration_roundtrips :: Duration -> Bool -prop_duration_roundtrips d = parseDuration (fromDuration d) == Just d +prop_duration_roundtrips d = parseDuration (fromDuration d) == Right d diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs index d890fc7..74c6dff 100644 --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -186,15 +186,15 @@ readInodeCache s = case words s of genInodeCache :: RawFilePath -> TSDelta -> IO (Maybe InodeCache) genInodeCache f delta = catchDefaultIO Nothing $ - toInodeCache delta (fromRawFilePath f) =<< R.getFileStatus f + toInodeCache delta f =<< R.getFileStatus f -toInodeCache :: TSDelta -> FilePath -> FileStatus -> IO (Maybe InodeCache) +toInodeCache :: TSDelta -> RawFilePath -> FileStatus -> IO (Maybe InodeCache) toInodeCache (TSDelta getdelta) f s | isRegularFile s = do delta <- getdelta sz <- getFileSize' f s #ifdef mingw32_HOST_OS - mtime <- utcTimeToPOSIXSeconds <$> getModificationTime f + mtime <- utcTimeToPOSIXSeconds <$> getModificationTime (fromRawFilePath f) #else let mtime = modificationTimeHiRes s #endif diff --git a/Utility/Metered.hs b/Utility/Metered.hs index ec16e33..1715f0b 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -1,6 +1,6 @@ {- Metered IO and actions - - - Copyright 2012-2018 Joey Hess + - Copyright 2012-2020 Joey Hess - - License: BSD-2-clause -} @@ -9,8 +9,10 @@ module Utility.Metered ( MeterUpdate, + MeterState(..), nullMeterUpdate, combineMeterUpdate, + TotalSize(..), BytesProcessed(..), toBytesProcessed, fromBytesProcessed, @@ -29,6 +31,8 @@ module Utility.Metered ( ProgressParser, commandMeter, commandMeter', + commandMeterExitCode, + commandMeterExitCode', demeterCommand, demeterCommandEnv, avoidProgress, @@ -46,6 +50,7 @@ import Common import Utility.Percentage import Utility.DataUnits import Utility.HumanTime +import Utility.SimpleProtocol as Proto import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S @@ -73,7 +78,7 @@ combineMeterUpdate a b = \n -> a n >> b n {- Total number of bytes processed so far. -} newtype BytesProcessed = BytesProcessed Integer - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Read) class AsBytesProcessed a where toBytesProcessed :: a -> BytesProcessed @@ -165,8 +170,9 @@ hGetMetered h wantsize meterupdate = lazyRead zeroBytesProcessed c <- S.hGet h (nextchunksize (fromBytesProcessed sofar)) if S.null c then do - hClose h - return $ L.empty + when (wantsize /= Just 0) $ + hClose h + return L.empty else do let !sofar' = addBytesProcessed sofar (S.length c) meterupdate sofar' @@ -218,7 +224,8 @@ watchFileSize f p a = bracket p sz watcher sz getsz = catchDefaultIO zeroBytesProcessed $ - toBytesProcessed <$> getFileSize f + toBytesProcessed <$> getFileSize f' + f' = toRawFilePath f data OutputHandler = OutputHandler { quietMode :: Bool @@ -226,31 +233,45 @@ data OutputHandler = OutputHandler } {- Parses the String looking for a command's progress output, and returns - - Maybe the number of bytes done so far, and any any remainder of the - - string that could be an incomplete progress output. That remainder - - should be prepended to future output, and fed back in. This interface - - allows the command's output to be read in any desired size chunk, or - - even one character at a time. + - Maybe the number of bytes done so far, optionally a total size, + - and any any remainder of the string that could be an incomplete + - progress output. That remainder should be prepended to future output, + - and fed back in. This interface allows the command's output to be read + - in any desired size chunk, or even one character at a time. -} -type ProgressParser = String -> (Maybe BytesProcessed, String) +type ProgressParser = String -> (Maybe BytesProcessed, Maybe TotalSize, String) + +newtype TotalSize = TotalSize Integer + deriving (Show, Eq) {- Runs a command and runs a ProgressParser on its output, in order - to update a meter. + - + - If the Meter is provided, the ProgressParser can report the total size, + - which allows creating a Meter before the size is known. -} -commandMeter :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool -commandMeter progressparser oh meterupdate cmd params = do - ret <- commandMeter' progressparser oh meterupdate cmd params +commandMeter :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool +commandMeter progressparser oh meter meterupdate cmd params = + commandMeter' progressparser oh meter meterupdate cmd params id + +commandMeter' :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO Bool +commandMeter' progressparser oh meter meterupdate cmd params mkprocess = do + ret <- commandMeterExitCode' progressparser oh meter meterupdate cmd params mkprocess return $ case ret of Just ExitSuccess -> True _ -> False -commandMeter' :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO (Maybe ExitCode) -commandMeter' progressparser oh meterupdate cmd params = - outputFilter cmd params Nothing - (feedprogress zeroBytesProcessed []) +commandMeterExitCode :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> IO (Maybe ExitCode) +commandMeterExitCode progressparser oh meter meterupdate cmd params = + commandMeterExitCode' progressparser oh meter meterupdate cmd params id + +commandMeterExitCode' :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO (Maybe ExitCode) +commandMeterExitCode' progressparser oh mmeter meterupdate cmd params mkprocess = + outputFilter cmd params mkprocess Nothing + (const $ feedprogress mmeter zeroBytesProcessed []) handlestderr where - feedprogress prev buf h = do + feedprogress sendtotalsize prev buf h = do b <- S.hGetSome h 80 if S.null b then return () @@ -259,17 +280,24 @@ commandMeter' progressparser oh meterupdate cmd params = S.hPut stdout b hFlush stdout let s = decodeBS b - let (mbytes, buf') = progressparser (buf++s) + let (mbytes, mtotalsize, buf') = progressparser (buf++s) + sendtotalsize' <- case (sendtotalsize, mtotalsize) of + (Just meter, Just t) -> do + setMeterTotalSize meter t + return Nothing + _ -> return sendtotalsize case mbytes of - Nothing -> feedprogress prev buf' h + Nothing -> feedprogress sendtotalsize' prev buf' h (Just bytes) -> do when (bytes /= prev) $ meterupdate bytes - feedprogress bytes buf' h + feedprogress sendtotalsize' bytes buf' h - handlestderr h = unlessM (hIsEOF h) $ do - stderrHandler oh =<< hGetLine h - handlestderr h + handlestderr ph h = hGetLineUntilExitOrEOF ph h >>= \case + Just l -> do + stderrHandler oh l + handlestderr ph h + Nothing -> return () {- Runs a command, that may display one or more progress meters on - either stdout or stderr, and prevents the meters from being displayed. @@ -281,9 +309,9 @@ demeterCommand oh cmd params = demeterCommandEnv oh cmd params Nothing demeterCommandEnv :: OutputHandler -> FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool demeterCommandEnv oh cmd params environ = do - ret <- outputFilter cmd params environ - (\outh -> avoidProgress True outh stdouthandler) - (\errh -> avoidProgress True errh $ stderrHandler oh) + ret <- outputFilter cmd params id environ + (\ph outh -> avoidProgress True ph outh stdouthandler) + (\ph errh -> avoidProgress True ph errh $ stderrHandler oh) return $ case ret of Just ExitSuccess -> True _ -> False @@ -296,31 +324,39 @@ demeterCommandEnv oh cmd params environ = do - filter out lines that contain \r (typically used to reset to the - beginning of the line when updating a progress display). -} -avoidProgress :: Bool -> Handle -> (String -> IO ()) -> IO () -avoidProgress doavoid h emitter = unlessM (hIsEOF h) $ do - s <- hGetLine h - unless (doavoid && '\r' `elem` s) $ - emitter s - avoidProgress doavoid h emitter +avoidProgress :: Bool -> ProcessHandle -> Handle -> (String -> IO ()) -> IO () +avoidProgress doavoid ph h emitter = hGetLineUntilExitOrEOF ph h >>= \case + Just s -> do + unless (doavoid && '\r' `elem` s) $ + emitter s + avoidProgress doavoid ph h emitter + Nothing -> return () outputFilter :: FilePath -> [CommandParam] + -> (CreateProcess -> CreateProcess) -> Maybe [(String, String)] - -> (Handle -> IO ()) - -> (Handle -> IO ()) + -> (ProcessHandle -> Handle -> IO ()) + -> (ProcessHandle -> Handle -> IO ()) -> IO (Maybe ExitCode) -outputFilter cmd params environ outfilter errfilter = catchMaybeIO $ do - (_, Just outh, Just errh, pid) <- createProcess p - { std_out = CreatePipe +outputFilter cmd params mkprocess environ outfilter errfilter = + catchMaybeIO $ withCreateProcess p go + where + go _ (Just outh) (Just errh) ph = do + outt <- async $ tryIO (outfilter ph outh) >> hClose outh + errt <- async $ tryIO (errfilter ph errh) >> hClose errh + ret <- waitForProcess ph + wait outt + wait errt + return ret + go _ _ _ _ = error "internal" + + p = mkprocess (proc cmd (toCommand params)) + { env = environ + , std_out = CreatePipe , std_err = CreatePipe } - void $ async $ tryIO (outfilter outh) >> hClose outh - void $ async $ tryIO (errfilter errh) >> hClose errh - waitForProcess pid - where - p = (proc cmd (toCommand params)) - { env = environ } -- | Limit a meter to only update once per unit of time. -- @@ -333,7 +369,7 @@ rateLimitMeterUpdate delta (Meter totalsizev _ _ _) meterupdate = do return $ mu lastupdate where mu lastupdate n@(BytesProcessed i) = readMVar totalsizev >>= \case - Just t | i >= t -> meterupdate n + Just (TotalSize t) | i >= t -> meterupdate n _ -> do now <- getPOSIXTime prev <- takeMVar lastupdate @@ -343,33 +379,39 @@ rateLimitMeterUpdate delta (Meter totalsizev _ _ _) meterupdate = do meterupdate n else putMVar lastupdate prev -data Meter = Meter (MVar (Maybe Integer)) (MVar MeterState) (MVar String) DisplayMeter +data Meter = Meter (MVar (Maybe TotalSize)) (MVar MeterState) (MVar String) DisplayMeter -type MeterState = (BytesProcessed, POSIXTime) +data MeterState = MeterState + { meterBytesProcessed :: BytesProcessed + , meterTimeStamp :: POSIXTime + } deriving (Show) -type DisplayMeter = MVar String -> Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> IO () +type DisplayMeter = MVar String -> Maybe TotalSize -> MeterState -> MeterState -> IO () -type RenderMeter = Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> String +type RenderMeter = Maybe TotalSize -> MeterState -> MeterState -> String -- | Make a meter. Pass the total size, if it's known. -mkMeter :: Maybe Integer -> DisplayMeter -> IO Meter -mkMeter totalsize displaymeter = Meter - <$> newMVar totalsize - <*> ((\t -> newMVar (zeroBytesProcessed, t)) =<< getPOSIXTime) - <*> newMVar "" - <*> pure displaymeter - -setMeterTotalSize :: Meter -> Integer -> IO () +mkMeter :: Maybe TotalSize -> DisplayMeter -> IO Meter +mkMeter totalsize displaymeter = do + ts <- getPOSIXTime + Meter + <$> newMVar totalsize + <*> newMVar (MeterState zeroBytesProcessed ts) + <*> newMVar "" + <*> pure displaymeter + +setMeterTotalSize :: Meter -> TotalSize -> IO () setMeterTotalSize (Meter totalsizev _ _ _) = void . swapMVar totalsizev . Just -- | Updates the meter, displaying it if necessary. updateMeter :: Meter -> MeterUpdate updateMeter (Meter totalsizev sv bv displaymeter) new = do now <- getPOSIXTime - (old, before) <- swapMVar sv (new, now) - when (old /= new) $ do + let curms = MeterState new now + oldms <- swapMVar sv curms + when (meterBytesProcessed oldms /= new) $ do totalsize <- readMVar totalsizev - displaymeter bv totalsize (old, before) (new, now) + displaymeter bv totalsize oldms curms -- | Display meter to a Handle. displayMeterHandle :: Handle -> RenderMeter -> DisplayMeter @@ -394,7 +436,7 @@ clearMeterHandle (Meter _ _ v _) h = do -- or when total size is not known: -- 1.3 MiB 300 KiB/s bandwidthMeter :: RenderMeter -bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) = +bandwidthMeter mtotalsize (MeterState (BytesProcessed old) before) (MeterState (BytesProcessed new) now) = unwords $ catMaybes [ Just percentamount -- Pad enough for max width: "100% xxxx.xx KiB xxxx KiB/s" @@ -405,7 +447,7 @@ bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) where amount = roughSize' memoryUnits True 2 new percentamount = case mtotalsize of - Just totalsize -> + Just (TotalSize totalsize) -> let p = showPercentage 0 $ percentage totalsize (min new totalsize) in p ++ replicate (6 - length p) ' ' ++ amount @@ -417,8 +459,12 @@ bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) transferred = max 0 (new - old) duration = max 0 (now - before) estimatedcompletion = case mtotalsize of - Just totalsize + Just (TotalSize totalsize) | bytespersecond > 0 -> Just $ fromDuration $ Duration $ (totalsize - new) `div` bytespersecond _ -> Nothing + +instance Proto.Serializable BytesProcessed where + serialize (BytesProcessed n) = show n + deserialize = BytesProcessed <$$> readish diff --git a/Utility/MoveFile.hs b/Utility/MoveFile.hs new file mode 100644 index 0000000..3ea17e8 --- /dev/null +++ b/Utility/MoveFile.hs @@ -0,0 +1,74 @@ +{- moving files + - + - Copyright 2011-2020 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.MoveFile ( + moveFile, +) where + +import Control.Monad +import System.FilePath +import System.PosixCompat.Files hiding (removeLink) +import System.IO.Error +import Prelude + +#ifndef mingw32_HOST_OS +import Control.Monad.IfElse +import Utility.SafeCommand +#endif + +import Utility.SystemDirectory +import Utility.Tmp +import Utility.Exception +import Utility.Monad + +{- Moves one filename to another. + - First tries a rename, but falls back to moving across devices if needed. -} +moveFile :: FilePath -> FilePath -> IO () +moveFile src dest = tryIO (rename src dest) >>= onrename + where + onrename (Right _) = noop + onrename (Left e) + | isPermissionError e = rethrow + | isDoesNotExistError e = rethrow + | otherwise = viaTmp mv dest () + where + rethrow = throwM e + + mv tmp () = do + -- copyFile is likely not as optimised as + -- the mv command, so we'll use the command. + -- + -- But, while Windows has a "mv", it does not seem very + -- reliable, so use copyFile there. +#ifndef mingw32_HOST_OS + -- If dest is a directory, mv would move the file + -- into it, which is not desired. + whenM (isdir dest) rethrow + ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] + let e' = e +#else + r <- tryIO $ copyFile src tmp + let (ok, e') = case r of + Left err -> (False, err) + Right _ -> (True, e) +#endif + unless ok $ do + -- delete any partial + _ <- tryIO $ removeFile tmp + throwM e' + +#ifndef mingw32_HOST_OS + isdir f = do + r <- tryIO $ getFileStatus f + case r of + (Left _) -> return False + (Right s) -> return $ isDirectory s +#endif diff --git a/Utility/Path.hs b/Utility/Path.hs index a8ab918..6bd407e 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -1,63 +1,59 @@ {- path manipulation - - - Copyright 2010-2014 Joey Hess + - Copyright 2010-2020 Joey Hess - - License: BSD-2-clause -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Path ( simplifyPath, - absPathFrom, parentDir, upFrom, dirContains, - absPath, - relPathCwdToFile, - relPathDirToFile, - relPathDirToFileAbs, segmentPaths, + segmentPaths', runSegmentPaths, - relHome, + runSegmentPaths', inPath, searchPath, dotfile, - sanitizeFilePath, splitShortExtensions, - - prop_upFrom_basics, - prop_relPathDirToFile_basics, - prop_relPathDirToFile_regressionTest, + relPathDirToFileAbs, ) where -import System.FilePath +import System.FilePath.ByteString +import qualified System.FilePath as P +import qualified Data.ByteString as B import Data.List import Data.Maybe -import Data.Char import Control.Applicative import Prelude import Utility.Monad -import Utility.UserInfo import Utility.SystemDirectory -import Utility.Split + +#ifdef mingw32_HOST_OS +import Data.Char import Utility.FileSystemEncoding +#endif {- Simplifies a path, removing any "." component, collapsing "dir/..", - and removing the trailing path separator. - - On Windows, preserves whichever style of path separator might be used in - - the input FilePaths. This is done because some programs in Windows + - the input RawFilePaths. This is done because some programs in Windows - demand a particular path separator -- and which one actually varies! - - This does not guarantee that two paths that refer to the same location, - and are both relative to the same location (or both absolute) will - - yeild the same result. Run both through normalise from System.FilePath + - yeild the same result. Run both through normalise from System.RawFilePath - to ensure that. -} -simplifyPath :: FilePath -> FilePath +simplifyPath :: RawFilePath -> RawFilePath simplifyPath path = dropTrailingPathSeparator $ joinDrive drive $ joinPath $ norm [] $ splitPath path' where @@ -72,134 +68,37 @@ simplifyPath path = dropTrailingPathSeparator $ where p' = dropTrailingPathSeparator p -{- Makes a path absolute. - - - - Also simplifies it using simplifyPath. - - - - The first parameter is a base directory (ie, the cwd) to use if the path - - is not already absolute, and should itsef be absolute. - - - - Does not attempt to deal with edge cases or ensure security with - - untrusted inputs. - -} -absPathFrom :: FilePath -> FilePath -> FilePath -absPathFrom dir path = simplifyPath (combine dir path) - {- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -} -parentDir :: FilePath -> FilePath +parentDir :: RawFilePath -> RawFilePath parentDir = takeDirectory . dropTrailingPathSeparator {- Just the parent directory of a path, or Nothing if the path has no -- parent (ie for "/" or ".") -} -upFrom :: FilePath -> Maybe FilePath +- parent (ie for "/" or "." or "foo") -} +upFrom :: RawFilePath -> Maybe RawFilePath upFrom dir | length dirs < 2 = Nothing - | otherwise = Just $ joinDrive drive $ intercalate s $ init dirs + | otherwise = Just $ joinDrive drive $ + B.intercalate (B.singleton pathSeparator) $ init dirs where -- on Unix, the drive will be "/" when the dir is absolute, -- otherwise "" (drive, path) = splitDrive dir - s = [pathSeparator] - dirs = filter (not . null) $ split s path - -prop_upFrom_basics :: FilePath -> Bool -prop_upFrom_basics dir - | null dir = True - | dir == "/" = p == Nothing - | otherwise = p /= Just dir - where - p = upFrom dir + dirs = filter (not . B.null) $ B.splitWith isPathSeparator path -{- Checks if the first FilePath is, or could be said to contain the second. +{- Checks if the first RawFilePath is, or could be said to contain the second. - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc - are all equivilant. -} -dirContains :: FilePath -> FilePath -> Bool +dirContains :: RawFilePath -> RawFilePath -> Bool dirContains a b = a == b || a' == b' - || (addTrailingPathSeparator a') `isPrefixOf` b' + || (addTrailingPathSeparator a') `B.isPrefixOf` b' || a' == "." && normalise ("." b') == b' where a' = norm a b' = norm b norm = normalise . simplifyPath -{- Converts a filename into an absolute path. - - - - Also simplifies it using simplifyPath. - - - - Unlike Directory.canonicalizePath, this does not require the path - - already exists. -} -absPath :: FilePath -> IO FilePath -absPath file - -- Avoid unncessarily getting the current directory when the path - -- is already absolute. absPathFrom uses simplifyPath - -- so also used here for consistency. - | isAbsolute file = return $ simplifyPath file - | otherwise = do - cwd <- getCurrentDirectory - return $ absPathFrom cwd file - -{- Constructs a relative path from the CWD to a file. - - - - For example, assuming CWD is /tmp/foo/bar: - - relPathCwdToFile "/tmp/foo" == ".." - - relPathCwdToFile "/tmp/foo/bar" == "" - -} -relPathCwdToFile :: FilePath -> IO FilePath -relPathCwdToFile f = do - c <- getCurrentDirectory - relPathDirToFile c f - -{- Constructs a relative path from a directory to a file. -} -relPathDirToFile :: FilePath -> FilePath -> IO FilePath -relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to - -{- This requires the first path to be absolute, and the - - second path cannot contain ../ or ./ - - - - On Windows, if the paths are on different drives, - - a relative path is not possible and the path is simply - - returned as-is. - -} -relPathDirToFileAbs :: FilePath -> FilePath -> FilePath -relPathDirToFileAbs from to -#ifdef mingw32_HOST_OS - | normdrive from /= normdrive to = to -#endif - | otherwise = joinPath $ dotdots ++ uncommon - where - pfrom = sp from - pto = sp to - sp = map dropTrailingPathSeparator . splitPath . dropDrive - common = map fst $ takeWhile same $ zip pfrom pto - same (c,d) = c == d - uncommon = drop numcommon pto - dotdots = replicate (length pfrom - numcommon) ".." - numcommon = length common -#ifdef mingw32_HOST_OS - normdrive = map toLower . takeWhile (/= ':') . takeDrive -#endif - -prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool -prop_relPathDirToFile_basics from to - | null from || null to = True - | from == to = null r - | otherwise = not (null r) - where - r = relPathDirToFileAbs from to - -prop_relPathDirToFile_regressionTest :: Bool -prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference - where - {- Two paths have the same directory component at the same - - location, but it's not really the same directory. - - Code used to get this wrong. -} - same_dir_shortcurcuits_at_difference = - relPathDirToFileAbs (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"]) - (joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]) - == joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"] - {- 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. @@ -213,30 +112,29 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference - we stop preserving ordering at that point. Presumably a user passing - that many paths in doesn't care too much about order of the later ones. -} -segmentPaths :: [RawFilePath] -> [RawFilePath] -> [[RawFilePath]] -segmentPaths [] new = [new] -segmentPaths [_] new = [new] -- optimisation -segmentPaths (l:ls) new = found : segmentPaths ls rest +segmentPaths :: (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[a]] +segmentPaths = segmentPaths' (\_ r -> r) + +segmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[r]] +segmentPaths' f _ [] new = [map (f Nothing) new] +segmentPaths' f _ [i] new = [map (f (Just i)) new] -- optimisation +segmentPaths' f c (i:is) new = + map (f (Just i)) found : segmentPaths' f c is rest where - (found, rest) = if length ls < 100 - then partition inl new - else break (not . inl) new - inl f = fromRawFilePath l `dirContains` fromRawFilePath f + (found, rest) = if length is < 100 + then partition ini new + else break (not . ini) new + ini p = i `dirContains` c p {- This assumes that it's cheaper to call segmentPaths on the result, - than it would be to run the action separately with each path. In - the case of git file list commands, that assumption tends to hold. -} -runSegmentPaths :: ([RawFilePath] -> IO [RawFilePath]) -> [RawFilePath] -> IO [[RawFilePath]] -runSegmentPaths a paths = segmentPaths paths <$> a paths +runSegmentPaths :: (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[a]] +runSegmentPaths c a paths = segmentPaths c paths <$> a paths -{- Converts paths in the home directory to use ~/ -} -relHome :: FilePath -> IO String -relHome path = do - home <- myHomeDir - return $ if dirContains home path - then "~/" ++ relPathDirToFileAbs home path - else path +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. - @@ -254,10 +152,10 @@ inPath command = isJust <$> searchPath command -} searchPath :: String -> IO (Maybe FilePath) searchPath command - | isAbsolute command = check command - | otherwise = getSearchPath >>= getM indir + | P.isAbsolute command = check command + | otherwise = P.getSearchPath >>= getM indir where - indir d = check $ d command + indir d = check $ d P. command check f = firstM doesFileExist #ifdef mingw32_HOST_OS [f, f ++ ".exe"] @@ -267,42 +165,52 @@ searchPath command {- Checks if a filename is a unix dotfile. All files inside dotdirs - count as dotfiles. -} -dotfile :: FilePath -> Bool +dotfile :: RawFilePath -> Bool dotfile file | f == "." = False | f == ".." = False | f == "" = False - | otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file) + | otherwise = "." `B.isPrefixOf` f || dotfile (takeDirectory file) where f = takeFileName file -{- Given a string that we'd like to use as the basis for FilePath, but that - - was provided by a third party and is not to be trusted, returns the closest - - sane FilePath. - - - - All spaces and punctuation and other wacky stuff are replaced - - with '_', except for '.' - - "../" will thus turn into ".._", which is safe. - -} -sanitizeFilePath :: String -> FilePath -sanitizeFilePath = map sanitize - where - sanitize c - | c == '.' = c - | isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_' - | otherwise = c - -{- Similar to splitExtensions, but knows that some things in FilePaths +{- Similar to splitExtensions, but knows that some things in RawFilePaths - after a dot are too long to be extensions. -} -splitShortExtensions :: FilePath -> (FilePath, [String]) +splitShortExtensions :: RawFilePath -> (RawFilePath, [B.ByteString]) splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg" -splitShortExtensions' :: Int -> FilePath -> (FilePath, [String]) +splitShortExtensions' :: Int -> RawFilePath -> (RawFilePath, [B.ByteString]) splitShortExtensions' maxextension = go [] where go c f - | len > 0 && len <= maxextension && not (null base) = + | len > 0 && len <= maxextension && not (B.null base) = go (ext:c) base | otherwise = (f, c) where (base, ext) = splitExtension f - len = length ext + len = B.length ext + +{- This requires the first path to be absolute, and the + - second path cannot contain ../ or ./ + - + - On Windows, if the paths are on different drives, + - a relative path is not possible and the path is simply + - returned as-is. + -} +relPathDirToFileAbs :: RawFilePath -> RawFilePath -> RawFilePath +relPathDirToFileAbs from to +#ifdef mingw32_HOST_OS + | normdrive from /= normdrive to = to +#endif + | otherwise = joinPath $ dotdots ++ uncommon + where + pfrom = sp from + pto = sp to + sp = map dropTrailingPathSeparator . splitPath . dropDrive + common = map fst $ takeWhile same $ zip pfrom pto + same (c,d) = c == d + uncommon = drop numcommon pto + dotdots = replicate (length pfrom - numcommon) ".." + numcommon = length common +#ifdef mingw32_HOST_OS + normdrive = map toLower . takeWhile (/= ':') . fromRawFilePath . takeDrive +#endif diff --git a/Utility/Path/AbsRel.hs b/Utility/Path/AbsRel.hs new file mode 100644 index 0000000..0026bd6 --- /dev/null +++ b/Utility/Path/AbsRel.hs @@ -0,0 +1,93 @@ +{- absolute and relative path manipulation + - + - Copyright 2010-2020 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Path.AbsRel ( + absPathFrom, + absPath, + relPathCwdToFile, + relPathDirToFile, + relPathDirToFileAbs, + relHome, +) where + +import System.FilePath.ByteString +#ifdef mingw32_HOST_OS +import System.Directory (getCurrentDirectory) +#else +import System.Posix.Directory.ByteString (getWorkingDirectory) +#endif +import Control.Applicative +import Prelude + +import Utility.Path +import Utility.UserInfo +import Utility.FileSystemEncoding + +{- Makes a path absolute. + - + - Also simplifies it using simplifyPath. + - + - The first parameter is a base directory (ie, the cwd) to use if the path + - is not already absolute, and should itsef be absolute. + - + - Does not attempt to deal with edge cases or ensure security with + - untrusted inputs. + -} +absPathFrom :: RawFilePath -> RawFilePath -> RawFilePath +absPathFrom dir path = simplifyPath (combine dir path) + +{- Converts a filename into an absolute path. + - + - Also simplifies it using simplifyPath. + - + - Unlike Directory.canonicalizePath, this does not require the path + - already exists. -} +absPath :: RawFilePath -> IO RawFilePath +absPath file + -- Avoid unncessarily getting the current directory when the path + -- is already absolute. absPathFrom uses simplifyPath + -- so also used here for consistency. + | isAbsolute file = return $ simplifyPath file + | otherwise = do +#ifdef mingw32_HOST_OS + cwd <- toRawFilePath <$> getCurrentDirectory +#else + cwd <- getWorkingDirectory +#endif + return $ absPathFrom cwd file + +{- Constructs a relative path from the CWD to a file. + - + - For example, assuming CWD is /tmp/foo/bar: + - relPathCwdToFile "/tmp/foo" == ".." + - relPathCwdToFile "/tmp/foo/bar" == "" + -} +relPathCwdToFile :: RawFilePath -> IO RawFilePath +relPathCwdToFile f = do +#ifdef mingw32_HOST_OS + c <- toRawFilePath <$> getCurrentDirectory +#else + c <- getWorkingDirectory +#endif + relPathDirToFile c f + +{- Constructs a relative path from a directory to a file. -} +relPathDirToFile :: RawFilePath -> RawFilePath -> IO RawFilePath +relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to + +{- Converts paths in the home directory to use ~/ -} +relHome :: FilePath -> IO String +relHome path = do + let path' = toRawFilePath path + home <- toRawFilePath <$> myHomeDir + return $ if dirContains home path' + then fromRawFilePath ("~/" <> relPathDirToFileAbs home path') + else path diff --git a/Utility/Process.hs b/Utility/Process.hs index e7142b9..4a725c8 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -6,12 +6,11 @@ - License: BSD-2-clause -} -{-# LANGUAGE CPP, Rank2Types #-} +{-# LANGUAGE CPP, Rank2Types, LambdaCase #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Process ( module X, - CreateProcess(..), StdHandle(..), readProcess, readProcess', @@ -20,64 +19,55 @@ module Utility.Process ( forceSuccessProcess, forceSuccessProcess', checkSuccessProcess, - ignoreFailureProcess, - createProcessSuccess, - createProcessChecked, - createBackgroundProcess, - withHandle, - withIOHandles, - withOEHandles, withNullHandle, - withQuietOutput, - feedWithQuietOutput, createProcess, + withCreateProcess, waitForProcess, + cleanupProcess, + hGetLineUntilExitOrEOF, startInteractiveProcess, stdinHandle, stdoutHandle, stderrHandle, - ioHandles, processHandle, devNull, ) where import qualified Utility.Process.Shim -import qualified Utility.Process.Shim as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess) -import Utility.Process.Shim hiding (createProcess, readProcess, waitForProcess) +import Utility.Process.Shim as X (CreateProcess(..), ProcessHandle, StdStream(..), CmdSpec(..), proc, getPid, getProcessExitCode, shell, terminateProcess, interruptProcessGroupOf) import Utility.Misc import Utility.Exception +import Utility.Monad import System.Exit import System.IO import System.Log.Logger -import Control.Concurrent -import qualified Control.Exception as E -import Control.Monad +import Control.Monad.IO.Class +import Control.Concurrent.Async import qualified Data.ByteString as S -type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a - data StdHandle = StdinHandle | StdoutHandle | StderrHandle deriving (Eq) -- | Normally, when reading from a process, it does not need to be fed any -- standard input. readProcess :: FilePath -> [String] -> IO String -readProcess cmd args = readProcessEnv cmd args Nothing +readProcess cmd args = readProcess' (proc cmd args) readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String -readProcessEnv cmd args environ = readProcess' p - where - p = (proc cmd args) - { std_out = CreatePipe - , env = environ - } +readProcessEnv cmd args environ = + readProcess' $ (proc cmd args) { env = environ } readProcess' :: CreateProcess -> IO String -readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do - output <- hGetContentsStrict h - hClose h - return output +readProcess' p = withCreateProcess p' go + where + p' = p { std_out = CreatePipe } + go _ (Just h) _ pid = do + output <- hGetContentsStrict h + hClose h + forceSuccessProcess p' pid + return output + go _ _ _ _ = error "internal" -- | Runs an action to write to a process on its stdin, -- returns its output, and also allows specifying the environment. @@ -87,26 +77,7 @@ writeReadProcessEnv -> Maybe [(String, String)] -> (Maybe (Handle -> IO ())) -> IO S.ByteString -writeReadProcessEnv cmd args environ writestdin = do - (Just inh, Just outh, _, pid) <- createProcess p - - -- fork off a thread to start consuming the output - outMVar <- newEmptyMVar - _ <- forkIO $ putMVar outMVar =<< S.hGetContents outh - - -- now write and flush any input - maybe (return ()) (\a -> a inh >> hFlush inh) writestdin - hClose inh -- done with stdin - - -- wait on the output - output <- takeMVar outMVar - hClose outh - - -- wait on the process - forceSuccessProcess p pid - - return output - +writeReadProcessEnv cmd args environ writestdin = withCreateProcess p go where p = (proc cmd args) { std_in = CreatePipe @@ -114,6 +85,18 @@ writeReadProcessEnv cmd args environ writestdin = do , std_err = Inherit , env = environ } + + go (Just inh) (Just outh) _ pid = do + let reader = hClose outh `after` S.hGetContents outh + let writer = do + maybe (return ()) (\a -> a inh >> hFlush inh) writestdin + hClose inh + (output, ()) <- concurrently reader writer + + forceSuccessProcess p pid + + return output + go _ _ _ _ = error "internal" -- | Waits for a ProcessHandle, and throws an IOError if the process -- did not exit successfully. @@ -126,117 +109,15 @@ forceSuccessProcess' p (ExitFailure n) = fail $ showCmd p ++ " exited " ++ show n -- | Waits for a ProcessHandle and returns True if it exited successfully. --- Note that using this with createProcessChecked will throw away --- the Bool, and is only useful to ignore the exit code of a process, --- while still waiting for it. -} checkSuccessProcess :: ProcessHandle -> IO Bool checkSuccessProcess pid = do code <- waitForProcess pid return $ code == ExitSuccess -ignoreFailureProcess :: ProcessHandle -> IO Bool -ignoreFailureProcess pid = do - void $ waitForProcess pid - return True - --- | Runs createProcess, then an action on its handles, and then --- forceSuccessProcess. -createProcessSuccess :: CreateProcessRunner -createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a - --- | Runs createProcess, then an action on its handles, and then --- a checker action on its exit code, which must wait for the process. -createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner -createProcessChecked checker p a = do - t@(_, _, _, pid) <- createProcess p - r <- tryNonAsync $ a t - _ <- checker pid - either E.throw return r - --- | Leaves the process running, suitable for lazy streaming. --- Note: Zombies will result, and must be waited on. -createBackgroundProcess :: CreateProcessRunner -createBackgroundProcess p a = a =<< createProcess p - --- | Runs a CreateProcessRunner, on a CreateProcess structure, that --- is adjusted to pipe only from/to a single StdHandle, and passes --- the resulting Handle to an action. -withHandle - :: StdHandle - -> CreateProcessRunner - -> CreateProcess - -> (Handle -> IO a) - -> IO a -withHandle h creator p a = creator p' $ a . select - where - base = p - { std_in = Inherit - , std_out = Inherit - , std_err = Inherit - } - (select, p') = case h of - StdinHandle -> (stdinHandle, base { std_in = CreatePipe }) - StdoutHandle -> (stdoutHandle, base { std_out = CreatePipe }) - StderrHandle -> (stderrHandle, base { std_err = CreatePipe }) - --- | Like withHandle, but passes (stdin, stdout) handles to the action. -withIOHandles - :: CreateProcessRunner - -> CreateProcess - -> ((Handle, Handle) -> IO a) - -> IO a -withIOHandles creator p a = creator p' $ a . ioHandles - where - p' = p - { std_in = CreatePipe - , std_out = CreatePipe - , std_err = Inherit - } - --- | Like withHandle, but passes (stdout, stderr) handles to the action. -withOEHandles - :: CreateProcessRunner - -> CreateProcess - -> ((Handle, Handle) -> IO a) - -> IO a -withOEHandles creator p a = creator p' $ a . oeHandles - where - p' = p - { std_in = Inherit - , std_out = CreatePipe - , std_err = CreatePipe - } - -withNullHandle :: (Handle -> IO a) -> IO a -withNullHandle = withFile devNull WriteMode - --- | Forces the CreateProcessRunner to run quietly; --- both stdout and stderr are discarded. -withQuietOutput - :: CreateProcessRunner - -> CreateProcess - -> IO () -withQuietOutput creator p = withNullHandle $ \nullh -> do - let p' = p - { std_out = UseHandle nullh - , std_err = UseHandle nullh - } - creator p' $ const $ return () - --- | Stdout and stderr are discarded, while the process is fed stdin --- from the handle. -feedWithQuietOutput - :: CreateProcessRunner - -> CreateProcess - -> (Handle -> IO a) - -> IO a -feedWithQuietOutput creator p a = withFile devNull WriteMode $ \nullh -> do - let p' = p - { std_in = CreatePipe - , std_out = UseHandle nullh - , std_err = UseHandle nullh - } - creator p' $ a . stdinHandle +withNullHandle :: (MonadIO m, MonadMask m) => (Handle -> m a) -> m a +withNullHandle = bracket + (liftIO $ openFile devNull WriteMode) + (liftIO . hClose) devNull :: FilePath #ifndef mingw32_HOST_OS @@ -252,6 +133,7 @@ devNull = "\\\\.\\NUL" -- Get it wrong and the runtime crash will always happen, so should be -- easily noticed. type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle + stdinHandle :: HandleExtractor stdinHandle (Just h, _, _, _) = h stdinHandle _ = error "expected stdinHandle" @@ -261,12 +143,6 @@ stdoutHandle _ = error "expected stdoutHandle" stderrHandle :: HandleExtractor stderrHandle (_, _, Just h, _) = h stderrHandle _ = error "expected stderrHandle" -ioHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) -ioHandles (Just hin, Just hout, _, _) = (hin, hout) -ioHandles _ = error "expected ioHandles" -oeHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) -oeHandles (_, Just hout, Just herr, _) = (hout, herr) -oeHandles _ = error "expected oeHandles" processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle processHandle (_, _, _, pid) = pid @@ -298,15 +174,24 @@ startInteractiveProcess cmd args environ = do -- | Wrapper around 'System.Process.createProcess' that does debug logging. createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do - debugProcess p - Utility.Process.Shim.createProcess p + r@(_, _, _, h) <- Utility.Process.Shim.createProcess p + debugProcess p h + return r + +-- | Wrapper around 'System.Process.withCreateProcess' that does debug logging. +withCreateProcess :: CreateProcess -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) -> IO a +withCreateProcess p action = bracket (createProcess p) cleanupProcess + (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) -- | Debugging trace for a CreateProcess. -debugProcess :: CreateProcess -> IO () -debugProcess p = debugM "Utility.Process" $ unwords - [ action ++ ":" - , showCmd p - ] +debugProcess :: CreateProcess -> ProcessHandle -> IO () +debugProcess p h = do + pid <- getPid h + debugM "Utility.Process" $ unwords + [ describePid pid + , action ++ ":" + , showCmd p + ] where action | piped (std_in p) && piped (std_out p) = "chat" @@ -316,9 +201,121 @@ debugProcess p = debugM "Utility.Process" $ unwords piped Inherit = False piped _ = True +describePid :: Maybe Utility.Process.Shim.Pid -> String +describePid Nothing = "process" +describePid (Just p) = "process [" ++ show p ++ "]" + -- | Wrapper around 'System.Process.waitForProcess' that does debug logging. waitForProcess :: ProcessHandle -> IO ExitCode 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" ("process done " ++ show r) + debugM "Utility.Process" (describePid pid ++ " done " ++ show r) return r + +cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () +#if MIN_VERSION_process(1,6,4) +cleanupProcess = Utility.Process.Shim.cleanupProcess +#else +cleanupProcess (mb_stdin, mb_stdout, mb_stderr, pid) = do + -- Unlike the real cleanupProcess, this does not wait + -- for the process to finish in the background, so if + -- the process ignores SIGTERM, this can block until the process + -- gets around the exiting. + terminateProcess pid + let void _ = return () + maybe (return ()) (void . tryNonAsync . hClose) mb_stdin + maybe (return ()) hClose mb_stdout + maybe (return ()) hClose mb_stderr + void $ waitForProcess pid +#endif + +{- | Like hGetLine, reads a line from the Handle. Returns Nothing if end of + - file is reached, or the handle is closed, or if the process has exited + - and there is nothing more buffered to read from the handle. + - + - This is useful to protect against situations where the process might + - have transferred the handle being read to another process, and so + - the handle could remain open after the process has exited. That is a rare + - situation, but can happen. Consider a the process that started up a + - daemon, and the daemon inherited stderr from it, rather than the more + - usual behavior of closing the file descriptor. Reading from stderr + - would block past the exit of the process. + - + - In that situation, this will detect when the process has exited, + - and avoid blocking forever. But will still return anything the process + - buffered to the handle before exiting. + - + - Note on newline mode: This ignores whatever newline mode is configured + - for the handle, because there is no way to query that. On Windows, + - it will remove any \r coming before the \n. On other platforms, + - it does not treat \r specially. + -} +hGetLineUntilExitOrEOF :: ProcessHandle -> Handle -> IO (Maybe String) +hGetLineUntilExitOrEOF ph h = go [] + where + go buf = do + ready <- waitforinputorerror smalldelay + if ready + then getloop buf go + else getProcessExitCode ph >>= \case + -- Process still running, wait longer. + Nothing -> go buf + -- Process is done. It's possible + -- that it output something and exited + -- since the prior hWaitForInput, + -- so check one more time for any buffered + -- output. + Just _ -> finalcheck buf + + finalcheck buf = do + ready <- waitforinputorerror 0 + if ready + then getloop buf finalcheck + -- No remaining buffered input, though the handle + -- may not be EOF if something else is keeping it + -- open. Treated the same as EOF. + else eofwithnolineend buf + + -- On exception, proceed as if there was input; + -- EOF and any encoding issues are dealt with + -- when reading from the handle. + waitforinputorerror t = hWaitForInput h t + `catchNonAsync` const (pure True) + + getchar = + catcherr EOF $ + -- If the handle is closed, reading from it is + -- an IllegalOperation. + catcherr IllegalOperation $ + Just <$> hGetChar h + where + catcherr t = catchIOErrorType t (const (pure Nothing)) + + getloop buf cont = + getchar >>= \case + Just c + | c == '\n' -> return (Just (gotline buf)) + | otherwise -> cont (c:buf) + Nothing -> eofwithnolineend buf + +#ifndef mingw32_HOST_OS + gotline buf = reverse buf +#else + gotline ('\r':buf) = reverse buf + gotline buf = reverse buf +#endif + + eofwithnolineend buf = return $ + if null buf + then Nothing -- no line read + else Just (reverse buf) + + -- Tenth of a second delay. If the process exits with the FD being + -- held open, will wait up to twice this long before returning. + -- This delay could be made smaller. However, that is an unusual + -- case, and making it too small would cause lots of wakeups while + -- waiting for output. Bearing in mind that this could be run on + -- many processes at the same time. + smalldelay = 100 -- milliseconds diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index b0a39f3..2093670 100644 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -1,6 +1,6 @@ {- QuickCheck with additional instances - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2020 Joey Hess - - License: BSD-2-clause -} @@ -10,16 +10,53 @@ module Utility.QuickCheck ( module X - , module Utility.QuickCheck + , TestableString + , fromTestableString + , TestableFilePath + , fromTestableFilePath + , nonNegative + , positive ) where import Test.QuickCheck as X import Data.Time.Clock.POSIX import Data.Ratio +import Data.Char import System.Posix.Types import Data.List.NonEmpty (NonEmpty(..)) import Prelude +{- A String, but Arbitrary is limited to ascii. + - + - When in a non-utf8 locale, String does not normally contain any non-ascii + - characters, except for ones in surrogate plane. Converting a string that + - does contain other unicode characters to a ByteString using the + - filesystem encoding (see GHC.IO.Encoding) will throw an exception, + - so use this instead to avoid quickcheck tests breaking unncessarily. + -} +newtype TestableString = TestableString + { fromTestableString :: String } + deriving (Show) + +instance Arbitrary TestableString where + arbitrary = TestableString . filter isAscii <$> arbitrary + +{- FilePath constrained to not be the empty string, not contain a NUL, + - and contain only ascii. + - + - No real-world filename can be empty or contain a NUL. So code can + - well be written that assumes that and using this avoids quickcheck + - tests breaking unncessarily. + -} +newtype TestableFilePath = TestableFilePath + { fromTestableFilePath :: FilePath } + deriving (Show) + +instance Arbitrary TestableFilePath where + arbitrary = (TestableFilePath . fromTestableString <$> arbitrary) + `suchThat` (not . null . fromTestableFilePath) + `suchThat` (not . any (== '\NUL') . fromTestableFilePath) + {- Times before the epoch are excluded. Half with decimal and half without. -} instance Arbitrary POSIXTime where arbitrary = do diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs index 6a5f704..f32b226 100644 --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -1,4 +1,4 @@ -{- Portability shim around System.Posix.Files.ByteString +{- Portability shim for basic operations on RawFilePaths. - - On unix, this makes syscalls using RawFilesPaths as efficiently as - possible. @@ -7,38 +7,69 @@ - decoded. So this library will work, but less efficiently than using - FilePath would. - - - Copyright 2019 Joey Hess + - Copyright 2019-2020 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.RawFilePath ( RawFilePath, readSymbolicLink, + createSymbolicLink, + createLink, + removeLink, getFileStatus, getSymbolicLinkStatus, doesPathExist, + getCurrentDirectory, + createDirectory, + setFileMode, ) where #ifndef mingw32_HOST_OS import Utility.FileSystemEncoding (RawFilePath) import System.Posix.Files.ByteString +import qualified System.Posix.Directory.ByteString as D +-- | Checks if a file or directory exists. Note that a dangling symlink +-- will be false. doesPathExist :: RawFilePath -> IO Bool doesPathExist = fileExist +getCurrentDirectory :: IO RawFilePath +getCurrentDirectory = D.getWorkingDirectory + +createDirectory :: RawFilePath -> IO () +createDirectory p = D.createDirectory p 0o777 + #else -import qualified Data.ByteString as B -import System.PosixCompat (FileStatus) +import System.PosixCompat (FileStatus, FileMode) import qualified System.PosixCompat as P +import qualified System.PosixCompat.Files as F import qualified System.Directory as D import Utility.FileSystemEncoding readSymbolicLink :: RawFilePath -> IO RawFilePath readSymbolicLink f = toRawFilePath <$> P.readSymbolicLink (fromRawFilePath f) +createSymbolicLink :: RawFilePath -> RawFilePath -> IO () +createSymbolicLink a b = P.createSymbolicLink + (fromRawFilePath a) + (fromRawFilePath b) + +createLink :: RawFilePath -> RawFilePath -> IO () +createLink a b = P.createLink + (fromRawFilePath a) + (fromRawFilePath b) + +{- On windows, removeLink is not available, so only remove files, + - not symbolic links. -} +removeLink :: RawFilePath -> IO () +removeLink = D.removeFile . fromRawFilePath + getFileStatus :: RawFilePath -> IO FileStatus getFileStatus = P.getFileStatus . fromRawFilePath @@ -47,4 +78,13 @@ getSymbolicLinkStatus = P.getSymbolicLinkStatus . fromRawFilePath doesPathExist :: RawFilePath -> IO Bool doesPathExist = D.doesPathExist . fromRawFilePath + +getCurrentDirectory :: IO RawFilePath +getCurrentDirectory = toRawFilePath <$> D.getCurrentDirectory + +createDirectory :: RawFilePath -> IO () +createDirectory = D.createDirectory . fromRawFilePath + +setFileMode :: RawFilePath -> FileMode -> IO () +setFileMode = F.setFileMode . fromRawFilePath #endif diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index c6881b7..e377eb9 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -114,7 +114,7 @@ rsyncUrlIsPath s -} rsyncProgress :: OutputHandler -> MeterUpdate -> [CommandParam] -> IO Bool rsyncProgress oh meter ps = - commandMeter' parseRsyncProgress oh meter "rsync" (rsyncParamsFixup ps) >>= \case + commandMeterExitCode parseRsyncProgress oh Nothing meter "rsync" (rsyncParamsFixup ps) >>= \case Just ExitSuccess -> return True Just (ExitFailure exitcode) -> do when (exitcode /= 1) $ @@ -136,10 +136,10 @@ rsyncProgress oh meter ps = parseRsyncProgress :: ProgressParser parseRsyncProgress = go [] . reverse . progresschunks where - go remainder [] = (Nothing, remainder) + go remainder [] = (Nothing, Nothing, remainder) go remainder (x:xs) = case parsebytes (findbytesstart x) of Nothing -> go (delim:x++remainder) xs - Just b -> (Just (toBytesProcessed b), remainder) + Just b -> (Just (toBytesProcessed b), Nothing, remainder) delim = '\r' diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs index 19d5f20..6f9419c 100644 --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -16,18 +16,13 @@ module Utility.SafeCommand ( safeSystem, safeSystem', safeSystemEnv, - shellWrap, - shellEscape, - shellUnEscape, segmentXargsOrdered, segmentXargsUnordered, - prop_isomorphic_shellEscape, - prop_isomorphic_shellEscape_multiword, ) where -import System.Exit import Utility.Process -import Utility.Split + +import System.Exit import System.FilePath import Data.Char import Data.List @@ -61,6 +56,8 @@ toCommand' (File s) = s -- | Run a system command, and returns True or False if it succeeded or failed. -- +-- (Throws an exception if the command is not found.) +-- -- This and other command running functions in this module log the commands -- run at debug level, using System.Log.Logger. boolSystem :: FilePath -> [CommandParam] -> IO Bool @@ -81,9 +78,9 @@ safeSystem :: FilePath -> [CommandParam] -> IO ExitCode safeSystem command params = safeSystem' command params id safeSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO ExitCode -safeSystem' command params mkprocess = do - (_, _, _, pid) <- createProcess p - waitForProcess pid +safeSystem' command params mkprocess = + withCreateProcess p $ \_ _ _ pid -> + waitForProcess pid where p = mkprocess $ proc command (toCommand params) @@ -91,44 +88,6 @@ safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Ex safeSystemEnv command params environ = safeSystem' command params $ \p -> p { env = environ } --- | Wraps a shell command line inside sh -c, allowing it to be run in a --- login shell that may not support POSIX shell, eg csh. -shellWrap :: String -> String -shellWrap cmdline = "sh -c " ++ shellEscape cmdline - --- | Escapes a filename or other parameter to be safely able to be exposed to --- the shell. --- --- This method works for POSIX shells, as well as other shells like csh. -shellEscape :: String -> String -shellEscape f = "'" ++ escaped ++ "'" - where - -- replace ' with '"'"' - escaped = intercalate "'\"'\"'" $ splitc '\'' f - --- | Unescapes a set of shellEscaped words or filenames. -shellUnEscape :: String -> [String] -shellUnEscape [] = [] -shellUnEscape s = word : shellUnEscape rest - where - (word, rest) = findword "" s - findword w [] = (w, "") - findword w (c:cs) - | c == ' ' = (w, cs) - | c == '\'' = inquote c w cs - | c == '"' = inquote c w cs - | otherwise = findword (w++[c]) cs - inquote _ w [] = (w, "") - inquote q w (c:cs) - | c == q = findword w cs - | otherwise = inquote q (w++[c]) cs - --- | For quickcheck. -prop_isomorphic_shellEscape :: String -> Bool -prop_isomorphic_shellEscape s = [s] == (shellUnEscape . shellEscape) s -prop_isomorphic_shellEscape_multiword :: [String] -> Bool -prop_isomorphic_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s - -- | Segments a list of filenames into groups that are all below the maximum -- command-line length limit. segmentXargsOrdered :: [FilePath] -> [[FilePath]] diff --git a/Utility/SimpleProtocol.hs b/Utility/SimpleProtocol.hs new file mode 100644 index 0000000..acd2439 --- /dev/null +++ b/Utility/SimpleProtocol.hs @@ -0,0 +1,151 @@ +{- Simple line-based protocols. + - + - Copyright 2013-2020 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Utility.SimpleProtocol ( + Sendable(..), + Receivable(..), + parseMessage, + Serializable(..), + Parser, + parseFail, + parse0, + parse1, + parse2, + parse3, + parse4, + parse5, + dupIoHandles, + getProtocolLine, +) where + +import Data.Char +import GHC.IO.Handle +import Text.Read + +import Common + +-- Messages that can be sent. +class Sendable m where + formatMessage :: m -> [String] + +-- Messages that can be received. +class Receivable m where + -- Passed the first word of the message, returns + -- a Parser that can be be fed the rest of the message to generate + -- the value. + parseCommand :: String -> Parser m + +parseMessage :: (Receivable m) => String -> Maybe m +parseMessage s = parseCommand command rest + where + (command, rest) = splitWord s + +class Serializable a where + serialize :: a -> String + deserialize :: String -> Maybe a + +instance Serializable [Char] where + serialize = id + deserialize = Just + +instance Serializable Integer where + serialize = show + deserialize = readMaybe + +instance Serializable ExitCode where + serialize ExitSuccess = "0" + serialize (ExitFailure n) = show n + deserialize "0" = Just ExitSuccess + deserialize s = ExitFailure <$> readMaybe s + +{- Parsing the parameters of messages. Using the right parseN ensures + - that the string is split into exactly the requested number of words, + - which allows the last parameter of a message to contain arbitrary + - whitespace, etc, without needing any special quoting. + -} +type Parser a = String -> Maybe a + +parseFail :: Parser a +parseFail _ = Nothing + +parse0 :: a -> Parser a +parse0 mk "" = Just mk +parse0 _ _ = Nothing + +parse1 :: Serializable p1 => (p1 -> a) -> Parser a +parse1 mk p1 = mk <$> deserialize p1 + +parse2 :: (Serializable p1, Serializable p2) => (p1 -> p2 -> a) -> Parser a +parse2 mk s = mk <$> deserialize p1 <*> deserialize p2 + where + (p1, p2) = splitWord s + +parse3 :: (Serializable p1, Serializable p2, Serializable p3) => (p1 -> p2 -> p3 -> a) -> Parser a +parse3 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 + where + (p1, rest) = splitWord s + (p2, p3) = splitWord rest + +parse4 :: (Serializable p1, Serializable p2, Serializable p3, Serializable p4) => (p1 -> p2 -> p3 -> p4 -> a) -> Parser a +parse4 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 <*> deserialize p4 + where + (p1, rest) = splitWord s + (p2, rest') = splitWord rest + (p3, p4) = splitWord rest' + +parse5 :: (Serializable p1, Serializable p2, Serializable p3, Serializable p4, Serializable p5) => (p1 -> p2 -> p3 -> p4 -> p5 -> a) -> Parser a +parse5 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 <*> deserialize p4 <*> deserialize p5 + where + (p1, rest) = splitWord s + (p2, rest') = splitWord rest + (p3, rest'') = splitWord rest' + (p4, p5) = splitWord rest'' + +splitWord :: String -> (String, String) +splitWord = separate isSpace + +{- When a program speaks a simple protocol over stdio, any other output + - to stdout (or anything that attempts to read from stdin) + - will mess up the protocol. To avoid that, close stdin, + - and duplicate stderr to stdout. Return two new handles + - that are duplicates of the original (stdin, stdout). -} +dupIoHandles :: IO (Handle, Handle) +dupIoHandles = do + readh <- hDuplicate stdin + writeh <- hDuplicate stdout + nullh <- openFile devNull ReadMode + nullh `hDuplicateTo` stdin + stderr `hDuplicateTo` stdout + return (readh, writeh) + +{- Reads a line, but to avoid super-long lines eating memory, returns + - Nothing if 32 kb have been read without seeing a '\n' + - + - If there is a '\r' before the '\n', it is removed, to support + - systems using "\r\n" at ends of lines + - + - This implementation is not super efficient, but as long as the Handle + - supports buffering, it avoids reading a character at a time at the + - syscall level. + - + - Throws isEOFError when no more input is available. + -} +getProtocolLine :: Handle -> IO (Maybe String) +getProtocolLine h = go (32768 :: Int) [] + where + go 0 _ = return Nothing + go n l = do + c <- hGetChar h + if c == '\n' + then return $ Just $ reverse $ + case l of + ('\r':rest) -> rest + _ -> l + else go (n-1) (c:l) diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index 6ee592b..5877f68 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -1,6 +1,6 @@ {- Temporary files. - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2020 Joey Hess - - License: BSD-2-clause -} @@ -20,16 +20,22 @@ import System.IO import System.FilePath import System.Directory import Control.Monad.IO.Class -import System.PosixCompat.Files +import System.PosixCompat.Files hiding (removeLink) import Utility.Exception import Utility.FileSystemEncoding +import Utility.FileMode type Template = String {- 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. -} + - directory as the final file to avoid cross-device renames. + - + - While this uses a temp file, the file will end up with the same + - mode as it would when using writeFile, unless the writer action changes + - it. + -} viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> v -> m ()) -> FilePath -> v -> m () viaTmp a file content = bracketIO setup cleanup use where @@ -42,6 +48,11 @@ viaTmp a file content = bracketIO setup cleanup use _ <- tryIO $ hClose h tryIO $ removeFile tmpfile use (tmpfile, h) = do + -- Make mode the same as if the file were created usually, + -- not as a temp file. (This may fail on some filesystems + -- that don't support file modes well, so ignore + -- exceptions.) + _ <- liftIO $ tryIO $ setFileMode tmpfile =<< defaultFileMode liftIO $ hClose h a tmpfile content liftIO $ rename tmpfile file @@ -54,7 +65,11 @@ withTmpFile template a = do withTmpFileIn tmpdir template a {- Runs an action with a tmp file located in the specified directory, - - then removes the file. -} + - then removes the file. + - + - Note that the tmp file will have a file mode that only allows the + - current user to access it. + -} withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a withTmpFileIn tmpdir template a = bracket create remove use where diff --git a/git-repair.cabal b/git-repair.cabal index d374f50..13d5c19 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -28,7 +28,7 @@ Extra-Source-Files: custom-setup Setup-Depends: base (>= 4.11.1.0 && < 5.0), hslogger, split, unix-compat, process, unix, filepath, - filepath-bytestring (>= 1.4.2.1.1), + filepath-bytestring (>= 1.4.2.1.1), async, exceptions, bytestring, directory, IfElse, data-default, mtl, Cabal @@ -94,6 +94,7 @@ Executable git-repair Utility.Data Utility.DataUnits Utility.Directory + Utility.Directory.Create Utility.DottedVersion Utility.Env Utility.Env.Basic @@ -109,8 +110,10 @@ Executable git-repair Utility.Metered Utility.Misc Utility.Monad + Utility.MoveFile Utility.PartialPrelude Utility.Path + Utility.Path.AbsRel Utility.Percentage Utility.Process Utility.Process.Shim @@ -118,6 +121,7 @@ Executable git-repair Utility.RawFilePath Utility.Rsync Utility.SafeCommand + Utility.SimpleProtocol Utility.Split Utility.SystemDirectory Utility.ThreadScheduler diff --git a/git-repair.hs b/git-repair.hs index ce4d16a..7ca1854 100644 --- a/git-repair.hs +++ b/git-repair.hs @@ -93,7 +93,7 @@ runTest settings damage = withTmpDir "tmprepo" $ \tmpdir -> do ] unless cloned $ error $ "failed to clone this repo" - g <- Git.Config.read =<< Git.Construct.fromPath cloneloc + g <- Git.Config.read =<< Git.Construct.fromPath (toRawFilePath cloneloc) Git.Destroyer.applyDamage damage g repairstatus <- catchMaybeIO $ Git.Repair.successfulRepair <$> Git.Repair.runRepair Git.Repair.isTrackingBranch (forced settings) g -- cgit v1.2.3 From e3a07e4c806d63893ff9da6283526da5981295b9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 11 Jan 2021 21:56:11 -0400 Subject: Makefile: Support building with cabal 3.0 also update tag generation --- .gitignore | 1 + CHANGELOG | 1 + Makefile | 28 +++++++++++++++++++++++----- 3 files changed, 25 insertions(+), 5 deletions(-) diff --git a/.gitignore b/.gitignore index 720dded..6f21f34 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,4 @@ Build/SysConfig tags git-repair dist +dist-newstyle diff --git a/CHANGELOG b/CHANGELOG index f38d6b2..4aee15d 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,6 +1,7 @@ git-repair (1.20210111) UNRELEASED; urgency=medium * Merge from git-annex. + * Makefile: Support building with cabal 3.0. -- Joey Hess Mon, 11 Jan 2021 21:52:06 -0400 diff --git a/Makefile b/Makefile index d2cd567..339167d 100644 --- a/Makefile +++ b/Makefile @@ -7,9 +7,13 @@ PREFIX=/usr build: Build/SysConfig.hs $(BUILDER) build $(BUILDEROPTIONS) if [ "$(BUILDER)" = stack ]; then \ - ln -sf $$(stack path --dist-dir)/build/git-annex/git-repair git-repair; \ + ln -sf $$(stack path --dist-dir)/build/git-repair/git-repair git-repair; \ else \ - ln -sf dist/build/git-repair/git-repair git-repair; \ + if [ -d dist-newstyle ]; then \ + ln -sf $$(cabal exec -- sh -c 'command -v git-repair') git-repair; \ + else \ + ln -sf dist/build/git-repair/git-repair git-repair; \ + fi; \ fi @$(MAKE) tags >/dev/null 2>&1 & @@ -29,12 +33,26 @@ install: build clean: rm -rf git-repair git-repair-test.log \ - dist configure Build/SysConfig.hs Setup tags + dist dist-newstyle configure Build/SysConfig.hs Setup tags find . -name \*.o -exec rm {} \; find . -name \*.hi -exec rm {} \; -# hothasktags chokes on some template haskell etc, so ignore errors +# tags file for vim tags: - (for f in $$(find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$'); do hothasktags -c --cpp -c -traditional -c --include=dist/build/autogen/cabal_macros.h $$f; done) 2>/dev/null | sort > tags + @$(MAKE) --quiet hothasktags HOTHASKTAGS_OPT= TAGFILE=tags + +# TAGS file for emacs +TAGS: + @$(MAKE) --quiet hothasktags HOTHASKTAGS_OPT=-e TAGFILE=TAGS + +# https://github.com/luqui/hothasktags/issues/18 +HOTHASKTAGS_ARGS=-XLambdaCase -XPackageImports --cpp + +hothasktags: + @if ! cabal exec hothasktags -- $(HOTHASKTAGS_OPT) $(HOTHASKTAGS_ARGS) \ + $$(find . | grep -v /.git/ | grep -v /tmp/ | grep -v dist/ | grep -v /doc/ | egrep '\.hs$$') 2>/dev/null \ + | sort > $(TAGFILE); then \ + echo "** hothasktags failed"; \ + fi .PHONY: tags -- cgit v1.2.3 From a089fba4eaab9ec27b68656e58260c70be26f080 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 11 Jan 2021 21:57:14 -0400 Subject: update --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 6f21f34..c9453f2 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,5 @@ tags git-repair dist dist-newstyle +cabal.project.local +cabal.project.local~ -- cgit v1.2.3 From 526f23761b62ac62ae07a49d79143cf610ce3bae Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 11 Jan 2021 21:58:15 -0400 Subject: Improve output to not give the impression it's stalled running fsck when it's found a problem and is working to repair it. --- CHANGELOG | 2 ++ Git/Repair.hs | 9 +++++++-- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 4aee15d..2982a9e 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,7 @@ git-repair (1.20210111) UNRELEASED; urgency=medium + * Improve output to not give the impression it's stalled running fsck + when it's found a problem and is working to repair it. * Merge from git-annex. * Makefile: Support building with cabal 3.0. diff --git a/Git/Repair.hs b/Git/Repair.hs index ea682a2..034d7e9 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -464,14 +464,19 @@ runRepair removablebranch forced g = do putStrLn "Running git fsck ..." fsckresult <- findBroken False g if foundBroken fsckresult - then runRepair' removablebranch fsckresult forced Nothing g + then do + putStrLn "Fsck found problems, attempting repair." + runRepair' removablebranch fsckresult forced Nothing g else do + putStrLn "Fsck found no problems. Checking for broken branches." bad <- badBranches S.empty g if null bad then do putStrLn "No problems found." return (True, []) - else runRepair' removablebranch fsckresult forced Nothing g + else do + putStrLn "Found problems, attempting repair." + runRepair' removablebranch fsckresult forced Nothing g runRepairOf :: FsckResults -> (Ref -> Bool) -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch]) runRepairOf fsckresult removablebranch forced referencerepo g = do -- cgit v1.2.3 From 79f5157858a67e8312c1f9c502e186ec395dcf98 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 11 Jan 2021 22:00:54 -0400 Subject: releasing package git-repair version 1.20210111 --- CHANGELOG | 4 ++-- git-repair.cabal | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 2982a9e..b845a6b 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,11 +1,11 @@ -git-repair (1.20210111) UNRELEASED; urgency=medium +git-repair (1.20210111) unstable; urgency=medium * Improve output to not give the impression it's stalled running fsck when it's found a problem and is working to repair it. * Merge from git-annex. * Makefile: Support building with cabal 3.0. - -- Joey Hess Mon, 11 Jan 2021 21:52:06 -0400 + -- Joey Hess Mon, 11 Jan 2021 22:00:49 -0400 git-repair (1.20200504) unstable; urgency=medium diff --git a/git-repair.cabal b/git-repair.cabal index 13d5c19..cf01c06 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -1,5 +1,5 @@ Name: git-repair -Version: 1.20200504 +Version: 1.20210111 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess @@ -38,7 +38,7 @@ source-repository head Executable git-repair Main-Is: git-repair.hs - GHC-Options: -threaded -Wall -fno-warn-tabs -O2 + GHC-Options: -threaded -Wall -fno-warn-tabs -Wincomplete-uni-patterns -O2 Default-Language: Haskell2010 Default-Extensions: LambdaCase Build-Depends: split, hslogger, directory, filepath, containers, mtl, -- cgit v1.2.3 From 84db819626232d789864780a52b63a787d49ef52 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 11 Jan 2021 22:01:15 -0400 Subject: add news item for git-repair 1.20210111 --- doc/news/version_1.20161111.mdwn | 10 ---------- doc/news/version_1.20210111.mdwn | 5 +++++ 2 files changed, 5 insertions(+), 10 deletions(-) delete mode 100644 doc/news/version_1.20161111.mdwn create mode 100644 doc/news/version_1.20210111.mdwn diff --git a/doc/news/version_1.20161111.mdwn b/doc/news/version_1.20161111.mdwn deleted file mode 100644 index baba58b..0000000 --- a/doc/news/version_1.20161111.mdwn +++ /dev/null @@ -1,10 +0,0 @@ -git-repair 1.20161111 released with [[!toggle text="these changes"]] -[[!toggleable text=""" - * git-repair.cabal: Add Setup-Depends. - * Updated cabal file explictly lists source files. The tarball - on hackage will include only the files needed for cabal install; - it is NOT the full git-repair source tree. - * debian/changelog: Converted to symlinks to CHANGELOG. - * Merge from git-annex. - * Makefile: Support building with stack as well as cabal. - * Makefile: The CABAL variable has been renamed to BUILDER."""]] \ No newline at end of file diff --git a/doc/news/version_1.20210111.mdwn b/doc/news/version_1.20210111.mdwn new file mode 100644 index 0000000..d32b1c8 --- /dev/null +++ b/doc/news/version_1.20210111.mdwn @@ -0,0 +1,5 @@ +git-repair 1.20210111 released with [[!toggle text="these changes"]] +[[!toggleable text=""" * Improve output to not give the impression it's stalled running fsck + when it's found a problem and is working to repair it. + * Merge from git-annex. + * Makefile: Support building with cabal 3.0."""]] \ No newline at end of file -- cgit v1.2.3 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 From d69479b5e0f6aeb9da388a90f7fb758798ae4a63 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 29 Jun 2021 13:29:51 -0400 Subject: releasing package git-repair version 1.20210629 --- CHANGELOG | 4 ++-- git-repair.cabal | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index af763df..6aa6e05 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,11 +1,11 @@ -git-repair (1.20210112) UNRELEASED; urgency=medium +git-repair (1.20210629) unstable; 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 + -- Joey Hess Tue, 29 Jun 2021 13:29:10 -0400 git-repair (1.20210111) unstable; urgency=medium diff --git a/git-repair.cabal b/git-repair.cabal index 64fb890..ed3d68e 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -1,11 +1,11 @@ Name: git-repair -Version: 1.20210111 +Version: 1.20210629 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess Author: Joey Hess Stability: Stable -Copyright: 2013-2020 Joey Hess +Copyright: 2013-2021 Joey Hess License-File: COPYRIGHT Build-Type: Custom Homepage: http://git-repair.branchable.com/ -- cgit v1.2.3 From 4f9d7fcf3d45b497230758eb098979b74e7b1e58 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 29 Jun 2021 13:30:17 -0400 Subject: add news item for git-repair 1.20210629 --- doc/news/version_1.20161118.mdwn | 3 --- doc/news/version_1.20210629.mdwn | 5 +++++ 2 files changed, 5 insertions(+), 3 deletions(-) delete mode 100644 doc/news/version_1.20161118.mdwn create mode 100644 doc/news/version_1.20210629.mdwn diff --git a/doc/news/version_1.20161118.mdwn b/doc/news/version_1.20161118.mdwn deleted file mode 100644 index c687f46..0000000 --- a/doc/news/version_1.20161118.mdwn +++ /dev/null @@ -1,3 +0,0 @@ -git-repair 1.20161118 released with [[!toggle text="these changes"]] -[[!toggleable text=""" - * Fix build with recent versions of cabal and ghc."""]] \ No newline at end of file diff --git a/doc/news/version_1.20210629.mdwn b/doc/news/version_1.20210629.mdwn new file mode 100644 index 0000000..9f00951 --- /dev/null +++ b/doc/news/version_1.20210629.mdwn @@ -0,0 +1,5 @@ +git-repair 1.20210629 released with [[!toggle text="these changes"]] +[[!toggleable text=""" * 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."""]] \ No newline at end of file -- cgit v1.2.3 From 66bdad7cd2857e108642d2a468d6d4906704d052 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 24 Mar 2022 13:10:11 -0400 Subject: switch from hothasktags to hasktags hothasktags was removed from Debian. And in the meantime hasktags improved so it works well in the source tree. --- Makefile | 19 ++----------------- 1 file changed, 2 insertions(+), 17 deletions(-) diff --git a/Makefile b/Makefile index 339167d..00e2275 100644 --- a/Makefile +++ b/Makefile @@ -15,7 +15,7 @@ build: Build/SysConfig.hs ln -sf dist/build/git-repair/git-repair git-repair; \ fi; \ fi - @$(MAKE) tags >/dev/null 2>&1 & + @$(MAKE) tags Build/SysConfig.hs: Build/TestConfig.hs Build/Configure.hs if [ "$(BUILDER)" = ./Setup ]; then ghc --make Setup; fi @@ -37,22 +37,7 @@ clean: find . -name \*.o -exec rm {} \; find . -name \*.hi -exec rm {} \; -# tags file for vim tags: - @$(MAKE) --quiet hothasktags HOTHASKTAGS_OPT= TAGFILE=tags - -# TAGS file for emacs -TAGS: - @$(MAKE) --quiet hothasktags HOTHASKTAGS_OPT=-e TAGFILE=TAGS - -# https://github.com/luqui/hothasktags/issues/18 -HOTHASKTAGS_ARGS=-XLambdaCase -XPackageImports --cpp - -hothasktags: - @if ! cabal exec hothasktags -- $(HOTHASKTAGS_OPT) $(HOTHASKTAGS_ARGS) \ - $$(find . | grep -v /.git/ | grep -v /tmp/ | grep -v dist/ | grep -v /doc/ | egrep '\.hs$$') 2>/dev/null \ - | sort > $(TAGFILE); then \ - echo "** hothasktags failed"; \ - fi + hasktags . || true .PHONY: tags -- cgit v1.2.3 From e78aedf04f6fdabb948ab91d3b0b670e4765c6a2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 24 Mar 2022 13:30:15 -0400 Subject: avoid generating emacs TAGS --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 00e2275..ddb440b 100644 --- a/Makefile +++ b/Makefile @@ -38,6 +38,6 @@ clean: find . -name \*.hi -exec rm {} \; tags: - hasktags . || true + hasktags . -c || true .PHONY: tags -- cgit v1.2.3 From 3c9630388ab0234df9e13473ac20c147e77074c5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 4 May 2022 11:36:52 -0400 Subject: Avoid treating refs that are not commit objects as evidence of repository corruption merged fix from git-annex, which actually has such a ref, refs/annex/last-index --- CHANGELOG | 7 +++++++ Git/Fsck.hs | 22 +++++++++++++++++----- Git/Repair.hs | 57 ++++++++++++++++++++++++++++++++++----------------------- git-repair.hs | 2 +- 4 files changed, 59 insertions(+), 29 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 6aa6e05..3d0ca96 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,10 @@ +git-repair (1.20210630) UNRELEASED; 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 + git-repair (1.20210629) unstable; urgency=medium * Fixed bug that interrupting the program while it was fixing repository diff --git a/Git/Fsck.hs b/Git/Fsck.hs index 7440b92..4544c13 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -1,4 +1,5 @@ {- git fsck interface +i it is not fully repoducibleI repeated the same steps - - Copyright 2013 Joey Hess - @@ -69,9 +70,17 @@ instance Monoid FsckOutput where - look for anything in its output (both stdout and stderr) that appears - to be a git sha. Not all such shas are of broken objects, so ask git - to try to cat the object, and see if it fails. + - + - Note that there is a possible false positive: When changes are being + - made to the repo while this is running, fsck might complain about a + - missing object that has not made it to disk yet. Catting the object + - then succeeds, so it's not included in the FsckResults. But, fsck then + - exits nonzero, and so FsckFailed is returned. Set ignorenonzeroexit + - to avoid this false positive, at the risk of perhaps missing a problem + - so bad that fsck crashes without outputting any missing shas. -} -findBroken :: Bool -> Repo -> IO FsckResults -findBroken batchmode r = do +findBroken :: Bool -> Bool -> Repo -> IO FsckResults +findBroken batchmode ignorenonzeroexit r = do let (command, params) = ("git", fsckParams r) (command', params') <- if batchmode then toBatchCommand (command, params) @@ -90,10 +99,10 @@ findBroken batchmode r = do fsckok <- checkSuccessProcess pid case mappend o1 o2 of FsckOutput badobjs truncated - | S.null badobjs && not fsckok -> return FsckFailed + | S.null badobjs && not fsckok -> return fsckfailed | otherwise -> return $ FsckFoundMissing badobjs truncated NoFsckOutput - | not fsckok -> return FsckFailed + | not fsckok -> return fsckfailed | otherwise -> return noproblem -- If all fsck output was duplicateEntries warnings, -- the repository is not broken, it just has some @@ -104,6 +113,9 @@ findBroken batchmode r = do maxobjs = 10000 noproblem = FsckFoundMissing S.empty False + fsckfailed + | ignorenonzeroexit = noproblem + | otherwise = FsckFailed foundBroken :: FsckResults -> Bool foundBroken FsckFailed = True @@ -147,7 +159,7 @@ isMissing s r = either (const True) (const False) <$> tryIO dump ] r findShas :: [String] -> [Sha] -findShas = catMaybes . map (extractSha . encodeBS') +findShas = catMaybes . map (extractSha . encodeBS) . concat . map words . filter wanted where wanted l = not ("dangling " `isPrefixOf` l) diff --git a/Git/Repair.hs b/Git/Repair.hs index 144c96f..7d47f84 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -114,7 +114,7 @@ retrieveMissingObjects missing referencerepo r | not (foundBroken missing) = return missing | otherwise = withTmpDir "tmprepo" $ \tmpdir -> do unlessM (boolSystem "git" [Param "init", File tmpdir]) $ - error $ "failed to create temp repository in " ++ tmpdir + giveup $ "failed to create temp repository in " ++ tmpdir tmpr <- Config.read =<< Construct.fromPath (toRawFilePath tmpdir) let repoconfig r' = fromRawFilePath (localGitDir r' P. "config") whenM (doesFileExist (repoconfig r)) $ @@ -252,7 +252,7 @@ getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) "refs") getAllRefs' :: FilePath -> IO [Ref] getAllRefs' refdir = do let topsegs = length (splitPath refdir) - 1 - let toref = Ref . encodeBS' . joinPath . drop topsegs . splitPath + let toref = Ref . encodeBS . joinPath . drop topsegs . splitPath map toref <$> dirContentsRecursive refdir explodePackedRefsFile :: Repo -> IO () @@ -279,8 +279,8 @@ packedRefsFile r = fromRawFilePath (localGitDir r) "packed-refs" parsePacked :: String -> Maybe (Sha, Ref) parsePacked l = case words l of (sha:ref:[]) - | isJust (extractSha (encodeBS' sha)) && Ref.legal True ref -> - Just (Ref (encodeBS' sha), Ref (encodeBS' ref)) + | isJust (extractSha (encodeBS sha)) && Ref.legal True ref -> + Just (Ref (encodeBS sha), Ref (encodeBS ref)) _ -> Nothing {- git-branch -d cannot be used to remove a branch that is directly @@ -325,7 +325,11 @@ findUncorruptedCommit missing goodcommits branch r = do - the commit. Also adds to a set of commit shas that have been verified to - be good, which can be passed into subsequent calls to avoid - redundant work when eg, chasing down branches to find the first - - uncorrupted commit. -} + - uncorrupted commit. + - + - When the sha is not a commit but some other git object, returns + - true, but does not add it to the set. + -} verifyCommit :: MissingObjects -> GoodCommits -> Sha -> Repo -> IO (Bool, GoodCommits) verifyCommit missing goodcommits commit r | checkGoodCommit commit goodcommits = return (True, goodcommits) @@ -337,21 +341,28 @@ verifyCommit missing goodcommits commit r , Param (fromRef commit) ] r let committrees = map (parse . decodeBL) ls - if any isNothing committrees || null committrees - then do - void cleanup - return (False, goodcommits) - else do - let cts = catMaybes committrees - ifM (cleanup <&&> check cts) - ( return (True, addGoodCommits (map fst cts) goodcommits) - , return (False, goodcommits) - ) + -- git log on an object that is not a commit will + -- succeed without any output + if null committrees + then ifM cleanup + ( return (True, goodcommits) + , return (False, goodcommits) + ) + else if any isNothing committrees + then do + void cleanup + return (False, goodcommits) + else do + let cts = catMaybes committrees + ifM (cleanup <&&> check cts) + ( return (True, addGoodCommits (map fst cts) goodcommits) + , return (False, goodcommits) + ) where parse l = case words l of (commitsha:treesha:[]) -> (,) - <$> extractSha (encodeBS' commitsha) - <*> extractSha (encodeBS' treesha) + <$> extractSha (encodeBS commitsha) + <*> extractSha (encodeBS treesha) _ -> Nothing check [] = return True check ((c, t):rest) @@ -469,14 +480,14 @@ preRepair g = do where headfile = localGitDir g P. "HEAD" validhead s = "ref: refs/" `isPrefixOf` s - || isJust (extractSha (encodeBS' s)) + || isJust (extractSha (encodeBS s)) {- Put it all together. -} runRepair :: (Ref -> Bool) -> Bool -> Repo -> IO (Bool, [Branch]) runRepair removablebranch forced g = do preRepair g putStrLn "Running git fsck ..." - fsckresult <- findBroken False g + fsckresult <- findBroken False False g if foundBroken fsckresult then do putStrLn "Fsck found problems, attempting repair." @@ -500,7 +511,7 @@ runRepairOf fsckresult removablebranch forced referencerepo g = do runRepair' :: (Ref -> Bool) -> FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch]) runRepair' removablebranch fsckresult forced referencerepo g = do cleanCorruptObjects fsckresult g - missing <- findBroken False g + missing <- findBroken False False g stillmissing <- retrieveMissingObjects missing referencerepo g case stillmissing of FsckFoundMissing s t @@ -529,7 +540,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do | forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex g) ( do cleanCorruptObjects FsckFailed g - stillmissing' <- findBroken False g + stillmissing' <- findBroken False False g case stillmissing' of FsckFailed -> return (False, []) FsckFoundMissing s t -> forcerepair s t @@ -575,7 +586,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do -- the repair process. if fscktruncated then do - fsckresult' <- findBroken False g + fsckresult' <- findBroken False False g case fsckresult' of FsckFailed -> do putStrLn "git fsck is failing" @@ -597,7 +608,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do removeWhenExistsWith R.removeLink (indexFile g) -- The corrupted index can prevent fsck from finding other -- problems, so re-run repair. - fsckresult' <- findBroken False g + fsckresult' <- findBroken False False g result <- runRepairOf fsckresult' removablebranch forced referencerepo g putStrLn "Removed the corrupted index file. You should look at what files are present in your working tree and git add them back to the index when appropriate." return result diff --git a/git-repair.hs b/git-repair.hs index 7ca1854..18721a9 100644 --- a/git-repair.hs +++ b/git-repair.hs @@ -100,7 +100,7 @@ runTest settings damage = withTmpDir "tmprepo" $ \tmpdir -> do case repairstatus of Just True -> testResult repairstatus . Just . not . Git.Fsck.foundBroken - =<< Git.Fsck.findBroken False g + =<< Git.Fsck.findBroken False False g _ -> testResult repairstatus Nothing -- Pass test result and fsck result -- cgit v1.2.3 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 From bf9dc9cc475353a3adf2f18abb6d19037af7d27f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 4 May 2022 11:44:15 -0400 Subject: add news item for git-repair 1.20220404 --- doc/news/version_1.20170626.mdwn | 5 ----- doc/news/version_1.20220404.mdwn | 3 +++ 2 files changed, 3 insertions(+), 5 deletions(-) delete mode 100644 doc/news/version_1.20170626.mdwn create mode 100644 doc/news/version_1.20220404.mdwn diff --git a/doc/news/version_1.20170626.mdwn b/doc/news/version_1.20170626.mdwn deleted file mode 100644 index 9e9830a..0000000 --- a/doc/news/version_1.20170626.mdwn +++ /dev/null @@ -1,5 +0,0 @@ -git-repair 1.20170626 released with [[!toggle text="these changes"]] -[[!toggleable text=""" - * Merge from git-annex. - * Removes dependency on MissingH, adding a dependency on split instead. - * Fixes build with directory-1.3."""]] \ No newline at end of file diff --git a/doc/news/version_1.20220404.mdwn b/doc/news/version_1.20220404.mdwn new file mode 100644 index 0000000..448e807 --- /dev/null +++ b/doc/news/version_1.20220404.mdwn @@ -0,0 +1,3 @@ +git-repair 1.20220404 released with [[!toggle text="these changes"]] +[[!toggleable text=""" * Avoid treating refs that are not commit objects as evidence of + repository corruption."""]] \ No newline at end of file -- cgit v1.2.3 From af5a1d28db777c5cd6bc02b783e865659e9dba8f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 4 May 2022 11:44:57 -0400 Subject: cabal requires base upper bound --- git-repair.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/git-repair.cabal b/git-repair.cabal index 582821d..c269fe7 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -43,7 +43,7 @@ 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), IfElse, text, process, time, QuickCheck, + base (>= 4.11.1.0 && < 5.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), -- cgit v1.2.3 From f0cd3a2a3758ddcd2f0900c16bdc1fb80bbd6e92 Mon Sep 17 00:00:00 2001 From: "monnier@b84a43244dc969c1e6ebb5acf57140006b376c2d" Date: Mon, 29 Aug 2022 21:32:39 +0000 Subject: Add my own experience of apparent inf-looping --- doc/index/discussion.mdwn | 29 ++++++++++++++++++++++------- 1 file changed, 22 insertions(+), 7 deletions(-) diff --git a/doc/index/discussion.mdwn b/doc/index/discussion.mdwn index dea2ec7..c656c35 100644 --- a/doc/index/discussion.mdwn +++ b/doc/index/discussion.mdwn @@ -1,12 +1,27 @@ -My experience with git repair: +# Experience n°1 -git repair -Running git fsck ... -Stack space overflow: current size 8388608 bytes. -Use `+RTS -Ksize -RTS' to increase it. + % git repair + Running git fsck ... + Stack space overflow: current size 8388608 bytes. + Use `+RTS -Ksize -RTS' to increase it. -git repair +RTS -K32M -RTS -git-repair: Most RTS options are disabled. Link with -rtsopts to enable them. + % git repair +RTS -K32M -RTS + git-repair: Most RTS options are disabled. Link with -rtsopts to enable them. Whats up guys? Are we playing catch 22 here? +# Experience n°2 + +I've been running + + LANG=C TMPDIR=/mnt/1/tmp TMP=/mnt/1/tmp git-repair --force + +on a BUP repository for more than a wekk. The output so far looks like: + + Initialized empty Git repository in /mnt/1/tmp/tmprepo8ymhUQ/.git/ + fatal: /mnt/1/monnier-broken.bup: '/mnt/1/monnier-broken.bup' is outside repository at '/mnt/1/monnier-broken.bup' + Initialized empty Git repository in /mnt/1/tmp/tmprepoz8b3XR/.git/ + fatal: /mnt/1/monnier-broken.bup: '/mnt/1/monnier-broken.bup' is outside repository at '/mnt/1/monnier-broken.bup' + [...] + +where those two lines repeat every few hours. Should I assume it's stuck in some kind of inf-loop, or will it actually end at some point? -- cgit v1.2.3 From edf83982be214f3c839fab9b659f645de53a9100 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 14 Aug 2023 12:06:32 -0400 Subject: merge from git-annex Support building with unix-compat 0.7 --- CHANGELOG | 7 ++ Common.hs | 2 +- Git.hs | 16 ++--- Git/CatFile.hs | 4 +- Git/Config.hs | 95 +++++++++++++++++++++------ Git/Construct.hs | 42 +++++++----- Git/CurrentRepo.hs | 7 +- Git/Destroyer.hs | 14 ++-- Git/FilePath.hs | 10 +-- Git/Filename.hs | 49 -------------- Git/HashObject.hs | 43 ++++++++---- Git/LsFiles.hs | 2 +- Git/LsTree.hs | 4 +- Git/Quote.hs | 122 ++++++++++++++++++++++++++++++++++ Git/Remote.hs | 20 +++--- Git/Repair.hs | 12 ++-- Git/Sha.hs | 2 +- Git/Types.hs | 2 + Git/UpdateIndex.hs | 40 +++++++----- Utility/CopyFile.hs | 13 ++-- Utility/DataUnits.hs | 56 +++++++++++----- Utility/Directory.hs | 10 +-- Utility/Directory/Create.hs | 51 ++++++++------- Utility/Exception.hs | 27 +++++--- Utility/FileMode.hs | 38 ++++++----- Utility/FileSize.hs | 6 +- Utility/Format.hs | 149 ++++++++++++++++++++++++++---------------- Utility/InodeCache.hs | 16 +++-- Utility/Metered.hs | 7 +- Utility/Misc.hs | 10 ++- Utility/Monad.hs | 8 +++ Utility/MoveFile.hs | 25 ++++--- Utility/Path.hs | 5 +- Utility/Path/AbsRel.hs | 2 +- Utility/Process.hs | 7 +- Utility/Process/Transcript.hs | 97 +++++++++++++++++++++++++++ Utility/QuickCheck.hs | 1 + Utility/RawFilePath.hs | 59 +++++++++++++---- Utility/SafeOutput.hs | 36 ++++++++++ Utility/SystemDirectory.hs | 2 +- Utility/Tmp.hs | 7 +- Utility/Url/Parse.hs | 63 ++++++++++++++++++ Utility/UserInfo.hs | 27 ++++---- git-repair.cabal | 7 +- 44 files changed, 882 insertions(+), 340 deletions(-) delete mode 100644 Git/Filename.hs create mode 100644 Git/Quote.hs create mode 100644 Utility/Process/Transcript.hs create mode 100644 Utility/SafeOutput.hs create mode 100644 Utility/Url/Parse.hs diff --git a/CHANGELOG b/CHANGELOG index 737693b..3abf0d8 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,10 @@ +git-repair (1.20230814) UNRELEASED; urgency=medium + + * Merge from git-annex. + * Support building with unix-compat 0.7 + + -- Joey Hess Mon, 14 Aug 2023 12:06:46 -0400 + git-repair (1.20220404) unstable; urgency=medium * Avoid treating refs that are not commit objects as evidence of diff --git a/Common.hs b/Common.hs index 5a658a6..ebe6d3f 100644 --- a/Common.hs +++ b/Common.hs @@ -18,7 +18,7 @@ import System.IO as X hiding (FilePath) import System.Posix.IO as X hiding (createPipe) #endif import System.Exit as X -import System.PosixCompat.Files as X +import System.PosixCompat.Files as X (FileStatus) import Utility.Misc as X import Utility.Exception as X diff --git a/Git.hs b/Git.hs index f8eedc0..e567917 100644 --- a/Git.hs +++ b/Git.hs @@ -1,6 +1,6 @@ {- git repository handling - - - This is written to be completely independant of git-annex and should be + - This is written to be completely independent of git-annex and should be - suitable for other uses. - - Copyright 2010-2021 Joey Hess @@ -68,18 +68,18 @@ 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" +repoLocation Repo { location = Unknown } = giveup "unknown repoLocation" {- Path to a repository. For non-bare, this is the worktree, for bare, - - it's the gitdit, and for URL repositories, is the path on the remote + - it's the gitdir, and for URL repositories, is the path on the remote - host. -} repoPath :: Repo -> RawFilePath repoPath Repo { location = Url u } = toRawFilePath $ unEscapeString $ uriPath u 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" +repoPath Repo { location = Unknown } = giveup "unknown repoPath" +repoPath Repo { location = UnparseableUrl _u } = giveup "unknown repoPath" repoWorkTree :: Repo -> Maybe RawFilePath repoWorkTree Repo { location = Local { worktree = Just d } } = Just d @@ -88,7 +88,7 @@ repoWorkTree _ = Nothing {- Path to a local repository's .git directory. -} localGitDir :: Repo -> RawFilePath localGitDir Repo { location = Local { gitdir = d } } = d -localGitDir _ = error "unknown localGitDir" +localGitDir _ = giveup "unknown localGitDir" {- Some code needs to vary between URL and normal repos, - or bare and non-bare, these functions help with that. -} @@ -129,7 +129,7 @@ repoIsLocalUnknown _ = False assertLocal :: Repo -> a -> a assertLocal repo action - | repoIsUrl repo = error $ unwords + | repoIsUrl repo = giveup $ unwords [ "acting on non-local git repo" , repoDescribe repo , "not supported" @@ -156,7 +156,7 @@ hookPath script repo = do #if mingw32_HOST_OS isexecutable f = doesFileExist f #else - isexecutable f = isExecutable . fileMode <$> getFileStatus f + isexecutable f = isExecutable . fileMode <$> getSymbolicLinkStatus f #endif {- Makes the path to a local Repo be relative to the cwd. -} diff --git a/Git/CatFile.hs b/Git/CatFile.hs index f33ad49..daa41ad 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -120,7 +120,7 @@ catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \f content <- readObjectContent from r return $ Just (content, sha, objtype) Just DNE -> return Nothing - Nothing -> error $ "unknown response from git cat-file " ++ show (header, object) + Nothing -> giveup $ "unknown response from git cat-file " ++ show (header, object) where -- Slow fallback path for filenames containing newlines. newlinefallback = queryObjectType object (catFileGitRepo h) >>= \case @@ -144,7 +144,7 @@ readObjectContent h (ParsedResp _ _ size) = do eatchar expected = do c <- hGetChar h when (c /= expected) $ - error $ "missing " ++ (show expected) ++ " from git cat-file" + giveup $ "missing " ++ (show expected) ++ " from git cat-file" readObjectContent _ DNE = error "internal" {- Gets the size and type of an object, without reading its content. -} diff --git a/Git/Config.hs b/Git/Config.hs index 5deba6b..4ff3454 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -1,6 +1,6 @@ {- git repository configuration handling - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2022 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -22,6 +22,8 @@ import Git.Types import qualified Git.Command import qualified Git.Construct import Utility.UserInfo +import Utility.Process.Transcript +import Utility.Debug {- Returns a single git config setting, or a fallback value if not set. -} get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue @@ -55,12 +57,22 @@ reRead r = read' $ r read' :: Repo -> IO Repo read' repo = go repo where - go Repo { location = Local { gitdir = d } } = git_config d - go Repo { location = LocalUnknown d } = git_config d + -- Passing --git-dir changes git's behavior when run in a + -- repository belonging to another user. When the git directory + -- was explicitly specified, pass that in order to get the local + -- git config. + go Repo { location = Local { gitdir = d } } + | gitDirSpecifiedExplicitly repo = git_config ["--git-dir=."] d + -- Run in worktree when there is one, since running in the .git + -- directory will trigger safe.bareRepository=explicit, even + -- when not in a bare repository. + go Repo { location = Local { worktree = Just d } } = git_config [] d + go Repo { location = Local { gitdir = d } } = git_config [] d + go Repo { location = LocalUnknown d } = git_config [] d go _ = assertLocal repo $ error "internal" - git_config d = withCreateProcess p (git_config' p) + git_config addparams d = withCreateProcess p (git_config' p) where - params = ["config", "--null", "--list"] + params = addparams ++ ["config", "--null", "--list"] p = (proc "git" params) { cwd = Just (fromRawFilePath d) , env = gitEnv repo @@ -94,19 +106,23 @@ global = do hRead :: Repo -> ConfigStyle -> Handle -> IO Repo hRead repo st h = do val <- S.hGetContents h - store val st repo + let c = parse val st + debug (DebugSource "Git.Config") $ "git config read: " ++ + show (map (\(k, v) -> (show k, map show v)) (M.toList c)) + storeParsed c repo {- Stores a git config into a Repo, returning the new version of the Repo. - The git config may be multiple lines, or a single line. - Config settings can be updated incrementally. -} store :: S.ByteString -> ConfigStyle -> Repo -> IO Repo -store s st repo = do - let c = parse s st - updateLocation $ repo - { config = (M.map Prelude.head c) `M.union` config repo - , fullconfig = M.unionWith (++) c (fullconfig repo) - } +store s st = storeParsed (parse s st) + +storeParsed :: M.Map ConfigKey [ConfigValue] -> Repo -> IO Repo +storeParsed c repo = updateLocation $ repo + { config = (M.map Prelude.head c) `M.union` config repo + , fullconfig = M.unionWith (++) c (fullconfig repo) + } {- Stores a single config setting in a Repo, returning the new version of - the Repo. Config settings can be updated incrementally. -} @@ -123,14 +139,28 @@ store' k v repo = repo - based on the core.bare and core.worktree settings. -} updateLocation :: Repo -> IO Repo -updateLocation r@(Repo { location = LocalUnknown d }) - | isBare r = ifM (doesDirectoryExist (fromRawFilePath dotgit)) - ( updateLocation' r $ Local dotgit Nothing - , updateLocation' r $ Local d Nothing - ) - | otherwise = updateLocation' r $ Local dotgit (Just d) +updateLocation r@(Repo { location = LocalUnknown d }) = case isBare r of + Just True -> ifM (doesDirectoryExist (fromRawFilePath dotgit)) + ( updateLocation' r $ Local dotgit Nothing + , updateLocation' r $ Local d Nothing + ) + Just False -> mknonbare + {- core.bare not in config, probably because safe.directory + - did not allow reading the config -} + Nothing -> ifM (Git.Construct.isBareRepo (fromRawFilePath d)) + ( mkbare + , mknonbare + ) where dotgit = d P. ".git" + -- git treats eg ~/foo as a bare git repository located in + -- ~/foo/.git if ~/foo/.git/config has core.bare=true + mkbare = ifM (doesDirectoryExist (fromRawFilePath dotgit)) + ( updateLocation' r $ Local dotgit Nothing + , updateLocation' r $ Local d Nothing + ) + mknonbare = updateLocation' r $ Local dotgit (Just d) + updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l updateLocation r = return r @@ -202,8 +232,9 @@ boolConfig' :: Bool -> S.ByteString boolConfig' True = "true" boolConfig' False = "false" -isBare :: Repo -> Bool -isBare r = fromMaybe False $ isTrueFalse' =<< getMaybe coreBare r +{- Note that repoIsLocalBare is often better to use than this. -} +isBare :: Repo -> Maybe Bool +isBare r = isTrueFalse' =<< getMaybe coreBare r coreBare :: ConfigKey coreBare = "core.bare" @@ -273,3 +304,27 @@ unset ck@(ConfigKey k) r = ifM (Git.Command.runBool ps r) ) where ps = [Param "config", Param "--unset-all", Param (decodeBS k)] + +{- git "fixed" CVE-2022-24765 by preventing git-config from + - listing per-repo configs when the repo is not owned by + - the current user. Detect if this fix is in effect for the + - repo. + -} +checkRepoConfigInaccessible :: Repo -> IO Bool +checkRepoConfigInaccessible r + -- When --git-dir or GIT_DIR is used to specify the git + -- directory, git does not check for CVE-2022-24765. + | gitDirSpecifiedExplicitly r = return False + | otherwise = do + -- Cannot use gitCommandLine here because specifying --git-dir + -- will bypass the git security check. + let p = (proc "git" ["config", "--local", "--list"]) + { cwd = Just (fromRawFilePath (repoPath r)) + , env = gitEnv r + } + (out, ok) <- processTranscript' p Nothing + if not ok + then do + debug (DebugSource "Git.Config") ("config output: " ++ out) + return True + else return False diff --git a/Git/Construct.hs b/Git/Construct.hs index a5e825e..bdab8ed 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -1,6 +1,6 @@ {- Construction of Git Repo objects - - - Copyright 2010-2021 Joey Hess + - Copyright 2010-2023 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -23,6 +23,7 @@ module Git.Construct ( checkForRepo, newFrom, adjustGitDirFile, + isBareRepo, ) where #ifndef mingw32_HOST_OS @@ -38,6 +39,7 @@ import Git.Remote import Git.FilePath import qualified Git.Url as Url import Utility.UserInfo +import Utility.Url.Parse import qualified Data.ByteString as B import qualified System.FilePath.ByteString as P @@ -84,7 +86,7 @@ fromAbsPath :: RawFilePath -> IO Repo fromAbsPath dir | absoluteGitPath dir = fromPath dir | otherwise = - error $ "internal error, " ++ show dir ++ " is not absolute" + giveup $ "internal error, " ++ show dir ++ " is not absolute" {- Construct a Repo for a remote's url. - @@ -103,10 +105,10 @@ fromUrl url fromUrl' :: String -> IO Repo fromUrl' url - | "file://" `isPrefixOf` url = case parseURI url of + | "file://" `isPrefixOf` url = case parseURIPortable url of Just u -> fromAbsPath $ toRawFilePath $ unEscapeString $ uriPath u Nothing -> pure $ newFrom $ UnparseableUrl url - | otherwise = case parseURI url of + | otherwise = case parseURIPortable url of Just u -> pure $ newFrom $ Url u Nothing -> pure $ newFrom $ UnparseableUrl url @@ -128,7 +130,7 @@ localToUrl reference r , auth , fromRawFilePath (repoPath r) ] - in r { location = Url $ fromJust $ parseURI absurl } + in r { location = Url $ fromJust $ parseURIPortable absurl } _ -> r {- Calculates a list of a repo's configured remotes, by parsing its config. -} @@ -139,7 +141,7 @@ fromRemotes repo = catMaybes <$> mapM construct remotepairs filterkeys f = filterconfig (\(k,_) -> f k) remotepairs = filterkeys isRemoteUrlKey construct (k,v) = remoteNamedFromKey k $ - fromRemoteLocation (fromConfigValue v) repo + fromRemoteLocation (fromConfigValue v) False repo {- Sets the name of a remote when constructing the Repo to represent it. -} remoteNamed :: String -> IO Repo -> IO Repo @@ -155,9 +157,15 @@ remoteNamedFromKey k r = case remoteKeyToRemoteName k of Just n -> Just <$> remoteNamed n r {- Constructs a new Repo for one of a Repo's remotes using a given - - location (ie, an url). -} -fromRemoteLocation :: String -> Repo -> IO Repo -fromRemoteLocation s repo = gen $ parseRemoteLocation s repo + - location (ie, an url). + - + - knownurl can be true if the location is known to be an url. This allows + - urls that don't parse as urls to be used, returning UnparseableUrl. + - If knownurl is false, the location may still be an url, if it parses as + - one. + -} +fromRemoteLocation :: String -> Bool -> Repo -> IO Repo +fromRemoteLocation s knownurl repo = gen $ parseRemoteLocation s knownurl repo where gen (RemotePath p) = fromRemotePath p repo gen (RemoteUrl u) = fromUrl u @@ -216,7 +224,7 @@ checkForRepo :: FilePath -> IO (Maybe RepoLocation) checkForRepo dir = check isRepo $ check (checkGitDirFile (toRawFilePath dir)) $ - check isBareRepo $ + check (checkdir (isBareRepo dir)) $ return Nothing where check test cont = maybe cont (return . Just) =<< test @@ -225,16 +233,17 @@ checkForRepo dir = , return Nothing ) isRepo = checkdir $ - gitSignature (".git" "config") + doesFileExist (dir ".git" "config") <||> - -- A git-worktree lacks .git/config, but has .git/commondir. + -- A git-worktree lacks .git/config, but has .git/gitdir. -- (Normally the .git is a file, not a symlink, but it can -- be converted to a symlink and git will still work; -- this handles that case.) - gitSignature (".git" "gitdir") - isBareRepo = checkdir $ gitSignature "config" - <&&> doesDirectoryExist (dir "objects") - gitSignature file = doesFileExist $ dir file + doesFileExist (dir ".git" "gitdir") + +isBareRepo :: FilePath -> IO Bool +isBareRepo dir = doesFileExist (dir "config") + <&&> doesDirectoryExist (dir "objects") -- Check for a .git file. checkGitDirFile :: RawFilePath -> IO (Maybe RepoLocation) @@ -277,5 +286,6 @@ newFrom l = Repo , gitEnv = Nothing , gitEnvOverridesGitDir = False , gitGlobalOpts = [] + , gitDirSpecifiedExplicitly = False } diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs index 9261eab..54e05f4 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -1,6 +1,6 @@ {- The current git repository. - - - Copyright 2012-2020 Joey Hess + - Copyright 2012-2022 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -79,8 +79,9 @@ get = do { gitdir = absd , worktree = Just curr } - r <- Git.Config.read $ newFrom loc - return $ if Git.Config.isBare r + r <- Git.Config.read $ (newFrom loc) + { gitDirSpecifiedExplicitly = True } + return $ if fromMaybe False (Git.Config.isBare r) then r { location = (location r) { worktree = Nothing } } else r configure Nothing Nothing = giveup "Not in a git repository." diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs index 4d84eec..9b75178 100644 --- a/Git/Destroyer.hs +++ b/Git/Destroyer.hs @@ -18,7 +18,9 @@ import Git import Utility.QuickCheck import Utility.FileMode import Utility.Tmp +import qualified Utility.RawFilePath as R +import System.PosixCompat.Files import qualified Data.ByteString as B import Data.Word @@ -95,12 +97,12 @@ applyDamage ds r = do case d of Empty s -> withfile s $ \f -> withSaneMode f $ do - removeWhenExistsWith removeLink f + removeWhenExistsWith R.removeLink (toRawFilePath f) writeFile f "" Reverse s -> withfile s $ \f -> withSaneMode f $ B.writeFile f =<< B.reverse <$> B.readFile f - Delete s -> withfile s $ removeWhenExistsWith removeLink + Delete s -> withfile s $ removeWhenExistsWith R.removeLink . toRawFilePath AppendGarbage s garbage -> withfile s $ \f -> withSaneMode f $ @@ -127,15 +129,15 @@ applyDamage ds r = do ] ScrambleFileMode s mode -> withfile s $ \f -> - setFileMode f mode + R.setFileMode (toRawFilePath f) mode SwapFiles a b -> withfile a $ \fa -> withfile b $ \fb -> unless (fa == fb) $ withTmpFile "swap" $ \tmp _ -> do - moveFile fa tmp - moveFile fb fa - moveFile tmp fa + moveFile (toRawFilePath fa) (toRawFilePath tmp) + moveFile (toRawFilePath fb) (toRawFilePath fa) + moveFile (toRawFilePath tmp) (toRawFilePath fa) where -- A broken .git/config is not recoverable. -- Don't damage hook scripts, to avoid running arbitrary code. ;) diff --git a/Git/FilePath.hs b/Git/FilePath.hs index feed8f6..b27c0c7 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -5,7 +5,7 @@ - top of the repository even when run in a subdirectory. Adding some - types helps keep that straight. - - - Copyright 2012-2019 Joey Hess + - Copyright 2012-2023 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -30,12 +30,12 @@ module Git.FilePath ( import Common import Git +import Git.Quote import qualified System.FilePath.ByteString as P import qualified System.FilePath.Posix.ByteString import GHC.Generics import Control.DeepSeq -import qualified Data.ByteString as S {- A RawFilePath, relative to the top of the git repository. -} newtype TopFilePath = TopFilePath { getTopFilePath :: RawFilePath } @@ -46,11 +46,11 @@ instance NFData TopFilePath {- A file in a branch or other treeish. -} data BranchFilePath = BranchFilePath Ref TopFilePath deriving (Show, Eq, Ord) - + {- Git uses the branch:file form to refer to a BranchFilePath -} -descBranchFilePath :: BranchFilePath -> S.ByteString +descBranchFilePath :: BranchFilePath -> StringContainingQuotedPath descBranchFilePath (BranchFilePath b f) = - fromRef' b <> ":" <> getTopFilePath f + UnquotedByteString (fromRef' b) <> ":" <> QuotedPath (getTopFilePath f) {- Path to a TopFilePath, within the provided git repo. -} fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath diff --git a/Git/Filename.hs b/Git/Filename.hs deleted file mode 100644 index 2fa4c59..0000000 --- a/Git/Filename.hs +++ /dev/null @@ -1,49 +0,0 @@ -{- Some git commands output encoded filenames, in a rather annoyingly complex - - C-style encoding. - - - - Copyright 2010, 2011 Joey Hess - - - - Licensed under the GNU AGPL version 3 or higher. - -} - -module Git.Filename where - -import Common -import Utility.Format (decode_c, encode_c) -import Utility.QuickCheck - -import Data.Char -import Data.Word -import qualified Data.ByteString as S - --- encoded filenames will be inside double quotes -decode :: S.ByteString -> RawFilePath -decode b = case S.uncons b of - Nothing -> b - Just (h, t) - | h /= q -> b - | otherwise -> case S.unsnoc t of - Nothing -> b - Just (i, l) - | l /= q -> b - | otherwise -> - encodeBS $ decode_c $ decodeBS i - where - q :: Word8 - q = fromIntegral (ord '"') - -{- Should not need to use this, except for testing decode. -} -encode :: RawFilePath -> S.ByteString -encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\"" - --- Encoding and then decoding roundtrips only when the string does not --- contain high unicode, because eg, both "\12345" and "\227\128\185" --- are encoded to "\343\200\271". --- --- That is not a real-world problem, and using TestableFilePath --- limits what's tested to ascii, so avoids running into it. -prop_encode_decode_roundtrip :: TestableFilePath -> Bool -prop_encode_decode_roundtrip ts = - s == fromRawFilePath (decode (encode (toRawFilePath s))) - where - s = fromTestableFilePath ts diff --git a/Git/HashObject.hs b/Git/HashObject.hs index 98bd440..1474c57 100644 --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -1,6 +1,6 @@ {- git hash-object interface - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2023 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -21,26 +21,47 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.ByteString.Builder +import Data.Char -type HashObjectHandle = CoProcess.CoProcessHandle +data HashObjectHandle = HashObjectHandle CoProcess.CoProcessHandle Repo [CommandParam] hashObjectStart :: Bool -> Repo -> IO HashObjectHandle -hashObjectStart writeobject = gitCoProcessStart True $ catMaybes - [ Just (Param "hash-object") - , if writeobject then Just (Param "-w") else Nothing - , Just (Param "--stdin-paths") - , Just (Param "--no-filters") - ] +hashObjectStart writeobject repo = do + h <- gitCoProcessStart True (ps ++ [Param "--stdin-paths"]) repo + return (HashObjectHandle h repo ps) + where + ps = catMaybes + [ Just (Param "hash-object") + , if writeobject then Just (Param "-w") else Nothing + , Just (Param "--no-filters") + ] hashObjectStop :: HashObjectHandle -> IO () -hashObjectStop = CoProcess.stop +hashObjectStop (HashObjectHandle h _ _) = CoProcess.stop h {- Injects a file into git, returning the Sha of the object. -} hashFile :: HashObjectHandle -> RawFilePath -> IO Sha -hashFile h file = CoProcess.query h send receive +hashFile hdl@(HashObjectHandle h _ _) file = do + -- git hash-object chdirs to the top of the repository on + -- start, so if the filename is relative, it will + -- not work. This seems likely to be a git bug. + -- So, make the filename absolute, which will work now + -- and also if git's behavior later changes. + file' <- absPath file + if newline `S.elem` file' + then hashFile' hdl file + else CoProcess.query h (send file') receive where - send to = S8.hPutStrLn to =<< absPath file + send file' to = S8.hPutStrLn to file' receive from = getSha "hash-object" $ S8.hGetLine from + newline = fromIntegral (ord '\n') + +{- Runs git hash-object once per call, rather than using a running + - one, so is slower. But, is able to handle newlines in the filepath, + - which --stdin-paths cannot. -} +hashFile' :: HashObjectHandle -> RawFilePath -> IO Sha +hashFile' (HashObjectHandle _ repo ps) file = getSha "hash-object" $ + pipeReadStrict (ps ++ [File (fromRawFilePath file)]) repo class HashableBlob t where hashableBlobToHandle :: Handle -> t -> IO () diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index cc824f2..4eea395 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -325,7 +325,7 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest && isus x || isus y && not (isus x && isus y) -{- Gets the InodeCache equivilant information stored in the git index. +{- Gets the InodeCache equivalent information stored in the git index. - - Note that this uses a --debug option whose output could change at some - point in the future. If the output is not as expected, will use Nothing. diff --git a/Git/LsTree.hs b/Git/LsTree.hs index fb3b3e1..9129d18 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -23,7 +23,7 @@ import Common import Git import Git.Command import Git.FilePath -import qualified Git.Filename +import qualified Git.Quote import Utility.Attoparsec import Numeric @@ -137,7 +137,7 @@ parserLsTree long = case long of -- sha <*> (Ref <$> A8.takeTill A8.isSpace) - fileparser = asTopFilePath . Git.Filename.decode <$> A.takeByteString + fileparser = asTopFilePath . Git.Quote.unquote <$> A.takeByteString sizeparser = fmap Just A8.decimal diff --git a/Git/Quote.hs b/Git/Quote.hs new file mode 100644 index 0000000..2ca442e --- /dev/null +++ b/Git/Quote.hs @@ -0,0 +1,122 @@ +{- Some git commands output quoted filenames, in a rather annoyingly complex + - C-style encoding. + - + - Copyright 2010-2023 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances #-} + +module Git.Quote ( + unquote, + quote, + noquote, + QuotePath(..), + StringContainingQuotedPath(..), + quotedPaths, + prop_quote_unquote_roundtrip, +) where + +import Common +import Utility.Format (decode_c, encode_c, encode_c', isUtf8Byte) +import Utility.QuickCheck +import Utility.SafeOutput + +import Data.Char +import Data.Word +import Data.String +import qualified Data.ByteString as S +import qualified Data.Semigroup as Sem +import Prelude + +unquote :: S.ByteString -> RawFilePath +unquote b = case S.uncons b of + Nothing -> b + Just (h, t) + | h /= q -> b + | otherwise -> case S.unsnoc t of + Nothing -> b + Just (i, l) + | l /= q -> b + | otherwise -> decode_c i + where + q :: Word8 + q = fromIntegral (ord '"') + +-- always encodes and double quotes, even in cases that git does not +quoteAlways :: RawFilePath -> S.ByteString +quoteAlways s = "\"" <> encode_c needencode s <> "\"" + where + needencode c = isUtf8Byte c || c == fromIntegral (ord '"') + +-- git config core.quotePath controls whether to quote unicode characters +newtype QuotePath = QuotePath Bool + +class Quoteable t where + -- double quotes and encodes when git would + quote :: QuotePath -> t -> S.ByteString + + noquote :: t -> S.ByteString + +instance Quoteable RawFilePath where + quote (QuotePath qp) s = case encode_c' needencode s of + Nothing -> s + Just s' -> "\"" <> s' <> "\"" + where + needencode c + | c == fromIntegral (ord '"') = True + | qp = isUtf8Byte c + | otherwise = False + + noquote = id + +-- Allows building up a string that contains paths, which will get quoted. +-- With OverloadedStrings, strings are passed through without quoting. +-- Eg: QuotedPath f <> ": not found" +data StringContainingQuotedPath + = UnquotedString String + | UnquotedByteString S.ByteString + | QuotedPath RawFilePath + | StringContainingQuotedPath :+: StringContainingQuotedPath + deriving (Show, Eq) + +quotedPaths :: [RawFilePath] -> StringContainingQuotedPath +quotedPaths [] = mempty +quotedPaths (p:ps) = QuotedPath p <> if null ps + then mempty + else " " <> quotedPaths ps + +instance Quoteable StringContainingQuotedPath where + quote _ (UnquotedString s) = safeOutput (encodeBS s) + quote _ (UnquotedByteString s) = safeOutput s + quote qp (QuotedPath p) = quote qp p + quote qp (a :+: b) = quote qp a <> quote qp b + + noquote (UnquotedString s) = encodeBS s + noquote (UnquotedByteString s) = s + noquote (QuotedPath p) = p + noquote (a :+: b) = noquote a <> noquote b + +instance IsString StringContainingQuotedPath where + fromString = UnquotedByteString . encodeBS + +instance Sem.Semigroup StringContainingQuotedPath where + UnquotedString a <> UnquotedString b = UnquotedString (a <> b) + UnquotedByteString a <> UnquotedByteString b = UnquotedByteString (a <> b) + a <> b = a :+: b + +instance Monoid StringContainingQuotedPath where + mempty = UnquotedByteString mempty + +-- Encoding and then decoding roundtrips only when the string does not +-- contain high unicode, because eg, both "\12345" and "\227\128\185" +-- are encoded to "\343\200\271". +-- +-- That is not a real-world problem, and using TestableFilePath +-- limits what's tested to ascii, so avoids running into it. +prop_quote_unquote_roundtrip :: TestableFilePath -> Bool +prop_quote_unquote_roundtrip ts = + s == fromRawFilePath (unquote (quoteAlways (toRawFilePath s))) + where + s = fromTestableFilePath ts diff --git a/Git/Remote.hs b/Git/Remote.hs index 80accca..9cdaad6 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -43,7 +43,7 @@ remoteKeyToRemoteName (ConfigKey k) {- Construct a legal git remote name out of an arbitrary input string. - - There seems to be no formal definition of this in the git source, - - just some ad-hoc checks, and some other things that fail with certian + - just some ad-hoc checks, and some other things that fail with certain - types of names (like ones starting with '-'). -} makeLegalName :: String -> RemoteName @@ -63,7 +63,7 @@ makeLegalName s = case filter legal $ replace "/" "_" s of legal c = isAlphaNum c data RemoteLocation = RemoteUrl String | RemotePath FilePath - deriving (Eq) + deriving (Eq, Show) remoteLocationIsUrl :: RemoteLocation -> Bool remoteLocationIsUrl (RemoteUrl _) = True @@ -75,16 +75,18 @@ remoteLocationIsSshUrl _ = False {- Determines if a given remote location is an url, or a local - path. Takes the repository's insteadOf configuration into account. -} -parseRemoteLocation :: String -> Repo -> RemoteLocation -parseRemoteLocation s repo = ret $ calcloc s +parseRemoteLocation :: String -> Bool -> Repo -> RemoteLocation +parseRemoteLocation s knownurl repo = go where - ret v + s' = calcloc s + go #ifdef mingw32_HOST_OS - | dosstyle v = RemotePath (dospath v) + | dosstyle s' = RemotePath (dospath s') #endif - | scpstyle v = RemoteUrl (scptourl v) - | urlstyle v = RemoteUrl v - | otherwise = RemotePath v + | scpstyle s' = RemoteUrl (scptourl s') + | urlstyle s' = RemoteUrl s' + | knownurl && s' == s = RemoteUrl s' + | otherwise = RemotePath s' -- insteadof config can rewrite remote location calcloc l | null insteadofs = l diff --git a/Git/Repair.hs b/Git/Repair.hs index 7d47f84..cea57df 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -30,6 +30,7 @@ import Git.Types import Git.Fsck import Git.Index import Git.Env +import Git.FilePath import qualified Git.Config as Config import qualified Git.Construct as Construct import qualified Git.LsTree as LsTree @@ -95,7 +96,7 @@ explodePacks r = go =<< listPackFiles r let dest = objectsDir r P. f createDirectoryIfMissing True (fromRawFilePath (parentDir dest)) - moveFile objfile (fromRawFilePath dest) + moveFile (toRawFilePath objfile) dest forM_ packs $ \packfile -> do let f = toRawFilePath packfile removeWhenExistsWith R.removeLink f @@ -103,7 +104,7 @@ explodePacks r = go =<< listPackFiles r return True {- Try to retrieve a set of missing objects, from the remotes of a - - repository. Returns any that could not be retreived. + - repository. Returns any that could not be retrieved. - - If another clone of the repository exists locally, which might not be a - remote of the repo being repaired, its path can be passed as a reference @@ -252,7 +253,8 @@ getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) "refs") getAllRefs' :: FilePath -> IO [Ref] getAllRefs' refdir = do let topsegs = length (splitPath refdir) - 1 - let toref = Ref . encodeBS . joinPath . drop topsegs . splitPath + let toref = Ref . toInternalGitPath . encodeBS + . joinPath . drop topsegs . splitPath map toref <$> dirContentsRecursive refdir explodePackedRefsFile :: Repo -> IO () @@ -269,7 +271,7 @@ explodePackedRefsFile r = do let gitd = localGitDir r let dest = gitd P. fromRef' ref let dest' = fromRawFilePath dest - createDirectoryUnder gitd (parentDir dest) + createDirectoryUnder [gitd] (parentDir dest) unlessM (doesFileExist dest') $ writeFile dest' (fromRef sha) @@ -433,7 +435,7 @@ rewriteIndex r reinject (file, sha, mode, _) = case toTreeItemType mode of Nothing -> return Nothing Just treeitemtype -> Just <$> - UpdateIndex.stageFile sha treeitemtype (fromRawFilePath file) r + UpdateIndex.stageFile sha treeitemtype file r newtype GoodCommits = GoodCommits (S.Set Sha) diff --git a/Git/Sha.hs b/Git/Sha.hs index a66c34e..389bcc0 100644 --- a/Git/Sha.hs +++ b/Git/Sha.hs @@ -20,7 +20,7 @@ import Data.Char getSha :: String -> IO S.ByteString -> IO Sha getSha subcommand a = maybe bad return =<< extractSha <$> a where - bad = error $ "failed to read sha from git " ++ subcommand + bad = giveup $ "failed to read sha from git " ++ subcommand {- Extracts the Sha from a ByteString. - diff --git a/Git/Types.hs b/Git/Types.hs index 68045fc..ce1818e 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -51,6 +51,8 @@ data Repo = Repo , gitEnvOverridesGitDir :: Bool -- global options to pass to git when running git commands , gitGlobalOpts :: [CommandParam] + -- True only when --git-dir or GIT_DIR was used + , gitDirSpecifiedExplicitly :: Bool } deriving (Show, Eq, Ord) newtype ConfigKey = ConfigKey S.ByteString diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 74816a6..f56bc86 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -1,6 +1,6 @@ {- git-update-index library - - - Copyright 2011-2020 Joey Hess + - Copyright 2011-2022 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -99,15 +99,15 @@ updateIndexLine sha treeitemtype file = L.fromStrict $ <> "\t" <> indexPath file -stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer +stageFile :: Sha -> TreeItemType -> RawFilePath -> Repo -> IO Streamer stageFile sha treeitemtype file repo = do - p <- toTopFilePath (toRawFilePath file) repo + p <- toTopFilePath file repo return $ pureStreamer $ updateIndexLine sha treeitemtype p {- A streamer that removes a file from the index. -} -unstageFile :: FilePath -> Repo -> IO Streamer +unstageFile :: RawFilePath -> Repo -> IO Streamer unstageFile file repo = do - p <- toTopFilePath (toRawFilePath file) repo + p <- toTopFilePath file repo return $ unstageFile' p unstageFile' :: TopFilePath -> Streamer @@ -135,9 +135,17 @@ stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of indexPath :: TopFilePath -> InternalGitPath indexPath = toInternalGitPath . getTopFilePath -{- Refreshes the index, by checking file stat information. -} -refreshIndex :: Repo -> ((RawFilePath -> IO ()) -> IO ()) -> IO Bool -refreshIndex repo feeder = withCreateProcess p go +{- Refreshes the index, by checking file stat information. + - + - The action is passed a callback that it can use to send filenames to + - update-index. Sending Nothing will wait for update-index to finish + - updating the index. + -} +refreshIndex :: (MonadIO m, MonadMask m) => Repo -> ((Maybe RawFilePath -> IO ()) -> m ()) -> m () +refreshIndex repo feeder = bracket + (liftIO $ createProcess p) + (liftIO . cleanupProcess) + go where params = [ Param "update-index" @@ -150,10 +158,12 @@ refreshIndex repo feeder = withCreateProcess p go p = (gitCreateProcess params repo) { std_in = CreatePipe } - go (Just h) _ _ pid = do - feeder $ \f -> - S.hPut h (S.snoc f 0) - hFlush h - hClose h - checkSuccessProcess pid - go _ _ _ _ = error "internal" + go (Just h, _, _, pid) = do + let closer = do + hClose h + forceSuccessProcess p pid + feeder $ \case + Just f -> S.hPut h (S.snoc f 0) + Nothing -> closer + liftIO $ closer + go _ = error "internal" diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs index 9c93e70..207153d 100644 --- a/Utility/CopyFile.hs +++ b/Utility/CopyFile.hs @@ -14,6 +14,7 @@ module Utility.CopyFile ( import Common import qualified BuildInfo +import qualified Utility.RawFilePath as R data CopyMetaData -- Copy timestamps when possible, but no other metadata, and @@ -60,9 +61,6 @@ copyFileExternal meta src dest = do - - 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 @@ -82,14 +80,17 @@ copyCoW meta src dest return ok | otherwise = return False where + -- Note that in coreutils 9.0, cp uses CoW by default, + -- without needing an option. This s only needed to support + -- older versions. 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 :: RawFilePath -> RawFilePath -> IO Bool createLinkOrCopy src dest = go `catchIO` const fallback where go = do - createLink src dest + R.createLink src dest return True - fallback = copyFileExternal CopyAllMetaData src dest + fallback = copyFileExternal CopyAllMetaData (fromRawFilePath src) (fromRawFilePath dest) diff --git a/Utility/DataUnits.hs b/Utility/DataUnits.hs index a6c9ffc..8d910c6 100644 --- a/Utility/DataUnits.hs +++ b/Utility/DataUnits.hs @@ -1,6 +1,6 @@ {- data size display and parsing - - - Copyright 2011 Joey Hess + - Copyright 2011-2022 Joey Hess - - License: BSD-2-clause - @@ -21,14 +21,20 @@ - error. This was bad. - - So, a committee was formed. And it arrived at a committee-like decision, - - which satisfied noone, confused everyone, and made the world an uglier - - place. As with all committees, this was meh. + - which satisfied no one, confused everyone, and made the world an uglier + - place. As with all committees, this was meh. Or in this case, "mib". - - And the drive manufacturers happily continued selling drives that are - increasingly smaller than you'd expect, if you don't count on your - fingers. But that are increasingly too big for anyone to much notice. - This caused me to need git-annex. - + - Meanwhile, over in telecommunications land, they were using entirely + - different units that differ only in capitalization sometimes. + - (At one point this convinced me that it was a good idea to buy an ISDN + - line because 128 kb/s sounded really fast! But it was really only 128 + - kbit/s...) + - - Thus, I use units here that I loathe. Because if I didn't, people would - be confused that their drives seem the wrong size, and other people would - complain at me for not being standards compliant. And we call this @@ -38,7 +44,7 @@ module Utility.DataUnits ( dataUnits, storageUnits, - memoryUnits, + committeeUnits, bandwidthUnits, oldSchoolUnits, Unit(..), @@ -62,28 +68,30 @@ data Unit = Unit ByteSize Abbrev Name deriving (Ord, Show, Eq) dataUnits :: [Unit] -dataUnits = storageUnits ++ memoryUnits +dataUnits = storageUnits ++ committeeUnits ++ bandwidthUnits {- Storage units are (stupidly) powers of ten. -} storageUnits :: [Unit] storageUnits = - [ Unit (p 8) "YB" "yottabyte" + [ Unit (p 10) "QB" "quettabyte" + , Unit (p 9) "RB" "ronnabyte" + , Unit (p 8) "YB" "yottabyte" , Unit (p 7) "ZB" "zettabyte" , Unit (p 6) "EB" "exabyte" , Unit (p 5) "PB" "petabyte" , Unit (p 4) "TB" "terabyte" , Unit (p 3) "GB" "gigabyte" , Unit (p 2) "MB" "megabyte" - , Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe - , Unit (p 0) "B" "byte" + , Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committee + , Unit 1 "B" "byte" ] where p :: Integer -> Integer p n = 1000^n -{- Memory units are (stupidly named) powers of 2. -} -memoryUnits :: [Unit] -memoryUnits = +{- Committee units are (stupidly named) powers of 2. -} +committeeUnits :: [Unit] +committeeUnits = [ Unit (p 8) "YiB" "yobibyte" , Unit (p 7) "ZiB" "zebibyte" , Unit (p 6) "EiB" "exbibyte" @@ -92,19 +100,37 @@ memoryUnits = , Unit (p 3) "GiB" "gibibyte" , Unit (p 2) "MiB" "mebibyte" , Unit (p 1) "KiB" "kibibyte" - , Unit (p 0) "B" "byte" + , Unit 1 "B" "byte" ] where p :: Integer -> Integer p n = 2^(n*10) -{- Bandwidth units are only measured in bits if you're some crazy telco. -} +{- Bandwidth units are (stupidly) measured in bits, not bytes, and are + - (also stupidly) powers of ten. + - + - While it's fairly common for "Mb", "Gb" etc to be used, that differs + - from "MB", "GB", etc only in case, and readSize is case-insensitive. + - So "Mbit", "Gbit" etc are used instead to avoid parsing ambiguity. + -} bandwidthUnits :: [Unit] -bandwidthUnits = error "stop trying to rip people off" +bandwidthUnits = + [ Unit (p 8) "Ybit" "yottabit" + , Unit (p 7) "Zbit" "zettabit" + , Unit (p 6) "Ebit" "exabit" + , Unit (p 5) "Pbit" "petabit" + , Unit (p 4) "Tbit" "terabit" + , Unit (p 3) "Gbit" "gigabit" + , Unit (p 2) "Mbit" "megabit" + , Unit (p 1) "kbit" "kilobit" -- weird capitalization thanks to committee + ] + where + p :: Integer -> Integer + p n = (1000^n) `div` 8 {- Do you yearn for the days when men were men and megabytes were megabytes? -} oldSchoolUnits :: [Unit] -oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits +oldSchoolUnits = zipWith (curry mingle) storageUnits committeeUnits where mingle (Unit _ a n, Unit s' _ _) = Unit s' a n diff --git a/Utility/Directory.hs b/Utility/Directory.hs index 38adf17..a5c023f 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -16,7 +16,7 @@ module Utility.Directory ( import Control.Monad import System.FilePath -import System.PosixCompat.Files hiding (removeLink) +import System.PosixCompat.Files (isDirectory, isSymbolicLink) import Control.Applicative import System.IO.Unsafe (unsafeInterleaveIO) import Data.Maybe @@ -25,7 +25,8 @@ import Prelude import Utility.SystemDirectory import Utility.Exception import Utility.Monad -import Utility.Applicative +import Utility.FileSystemEncoding +import qualified Utility.RawFilePath as R dirCruft :: FilePath -> Bool dirCruft "." = True @@ -65,7 +66,7 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir] | otherwise = do let skip = collect (entry:files) dirs' entries let recurse = collect files (entry:dirs') entries - ms <- catchMaybeIO $ getSymbolicLinkStatus entry + ms <- catchMaybeIO $ R.getSymbolicLinkStatus (toRawFilePath entry) case ms of (Just s) | isDirectory s -> recurse @@ -87,9 +88,10 @@ dirTreeRecursiveSkipping skipdir topdir = go [] [topdir] | skipdir (takeFileName dir) = go c dirs | otherwise = unsafeInterleaveIO $ do subdirs <- go [] - =<< filterM (isDirectory <$$> getSymbolicLinkStatus) + =<< filterM isdir =<< catchDefaultIO [] (dirContents dir) go (subdirs++dir:c) dirs + isdir p = isDirectory <$> R.getSymbolicLinkStatus (toRawFilePath p) {- Use with an action that removes something, which may or may not exist. - diff --git a/Utility/Directory/Create.hs b/Utility/Directory/Create.hs index 32c0bcf..5650f96 100644 --- a/Utility/Directory/Create.hs +++ b/Utility/Directory/Create.hs @@ -31,10 +31,10 @@ import qualified Utility.RawFilePath as R import Utility.PartialPrelude {- Like createDirectoryIfMissing True, but it will only create - - missing parent directories up to but not including the directory - - in the first parameter. + - missing parent directories up to but not including a directory + - from the first parameter. - - - For example, createDirectoryUnder "/tmp/foo" "/tmp/foo/bar/baz" + - For example, createDirectoryUnder ["/tmp/foo"] "/tmp/foo/bar/baz" - will create /tmp/foo/bar if necessary, but if /tmp/foo does not exist, - it will throw an exception. - @@ -45,40 +45,43 @@ import Utility.PartialPrelude - FilePath (or the same as it), it will fail with an exception - even if the second FilePath's parent directory already exists. - - - Either or both of the FilePaths can be relative, or absolute. + - The FilePaths can be relative, or absolute. - They will be normalized as necessary. - - Note that, the second FilePath, if relative, is relative to the current - - working directory, not to the first FilePath. + - working directory. -} -createDirectoryUnder :: RawFilePath -> RawFilePath -> IO () -createDirectoryUnder topdir dir = - createDirectoryUnder' topdir dir R.createDirectory +createDirectoryUnder :: [RawFilePath] -> RawFilePath -> IO () +createDirectoryUnder topdirs dir = + createDirectoryUnder' topdirs dir R.createDirectory createDirectoryUnder' :: (MonadIO m, MonadCatch m) - => RawFilePath + => [RawFilePath] -> RawFilePath -> (RawFilePath -> m ()) -> m () -createDirectoryUnder' topdir dir0 mkdir = do - p <- liftIO $ relPathDirToFile topdir dir0 - let dirs = P.splitDirectories p - -- Catch cases where the dir is not beneath the topdir. +createDirectoryUnder' topdirs dir0 mkdir = do + relps <- liftIO $ forM topdirs $ \topdir -> relPathDirToFile topdir dir0 + let relparts = map P.splitDirectories relps + -- Catch cases where dir0 is not beneath a topdir. -- If the relative path between them starts with "..", -- it's not. And on Windows, if they are on different drives, -- the path will not be relative. - if headMaybe dirs == Just ".." || P.isAbsolute p - then liftIO $ ioError $ customerror userErrorType - ("createDirectoryFrom: not located in " ++ fromRawFilePath topdir) - -- If dir0 is the same as the topdir, don't try to create - -- it, but make sure it does exist. - else if null dirs - then liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $ - ioError $ customerror doesNotExistErrorType - "createDirectoryFrom: does not exist" - else createdirs $ - map (topdir P.) (reverse (scanl1 (P.) dirs)) + let notbeneath = \(_topdir, (relp, dirs)) -> + headMaybe dirs /= Just ".." && not (P.isAbsolute relp) + case filter notbeneath $ zip topdirs (zip relps relparts) of + ((topdir, (_relp, dirs)):_) + -- If dir0 is the same as the topdir, don't try to + -- create it, but make sure it does exist. + | null dirs -> + liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $ + ioError $ customerror doesNotExistErrorType $ + "createDirectoryFrom: " ++ fromRawFilePath topdir ++ " does not exist" + | otherwise -> createdirs $ + map (topdir P.) (reverse (scanl1 (P.) dirs)) + _ -> liftIO $ ioError $ customerror userErrorType + ("createDirectoryFrom: not located in " ++ unwords (map fromRawFilePath topdirs)) where customerror t s = mkIOError t s Nothing (Just (fromRawFilePath dir0)) diff --git a/Utility/Exception.hs b/Utility/Exception.hs index 4c60eac..cf55c5f 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -1,6 +1,6 @@ {- Simple IO exception handling (and some more) - - - Copyright 2011-2016 Joey Hess + - Copyright 2011-2023 Joey Hess - - License: BSD-2-clause -} @@ -20,6 +20,7 @@ module Utility.Exception ( bracketIO, catchNonAsync, tryNonAsync, + nonAsyncHandler, tryWhenExists, catchIOErrorType, IOErrorType(..), @@ -28,21 +29,24 @@ module Utility.Exception ( import Control.Monad.Catch as X hiding (Handler) import qualified Control.Monad.Catch as M -import Control.Exception (IOException, AsyncException) -import Control.Exception (SomeAsyncException) +import Control.Exception (IOException, AsyncException, SomeAsyncException) import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError, ioeGetErrorType) import GHC.IO.Exception (IOErrorType(..)) import Utility.Data +import Utility.SafeOutput {- 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 expected to see in some - - circumstances. -} + - circumstances. + - + - Also, control characters are filtered out of the message. + -} giveup :: [Char] -> a -giveup = errorWithoutStackTrace +giveup = errorWithoutStackTrace . safeOutput {- Catches IO errors and returns a Bool -} catchBoolIO :: MonadCatch m => m Bool -> m Bool @@ -81,11 +85,7 @@ bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup) - ThreadKilled and UserInterrupt get through. -} catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a -catchNonAsync a onerr = a `catches` - [ M.Handler (\ (e :: AsyncException) -> throwM e) - , M.Handler (\ (e :: SomeAsyncException) -> throwM e) - , M.Handler (\ (e :: SomeException) -> onerr e) - ] +catchNonAsync a onerr = a `catches` (nonAsyncHandler onerr) tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a) tryNonAsync a = go `catchNonAsync` (return . Left) @@ -94,6 +94,13 @@ tryNonAsync a = go `catchNonAsync` (return . Left) v <- a return (Right v) +nonAsyncHandler :: MonadCatch m => (SomeException -> m a) -> [M.Handler m a] +nonAsyncHandler onerr = + [ M.Handler (\ (e :: AsyncException) -> throwM e) + , M.Handler (\ (e :: SomeAsyncException) -> throwM e) + , M.Handler (\ (e :: SomeException) -> onerr e) + ] + {- Catches only DoesNotExist exceptions, and lets all others through. -} tryWhenExists :: MonadCatch m => m a -> m (Maybe a) tryWhenExists a = do diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index 6725601..ecc19d8 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -1,6 +1,6 @@ {- File mode utilities. - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2023 Joey Hess - - License: BSD-2-clause -} @@ -16,7 +16,10 @@ module Utility.FileMode ( import System.IO import Control.Monad import System.PosixCompat.Types -import System.PosixCompat.Files hiding (removeLink) +import System.PosixCompat.Files (unionFileModes, intersectFileModes, stdFileMode, nullFileMode, groupReadMode, ownerReadMode, ownerWriteMode, ownerExecuteMode, groupWriteMode, groupExecuteMode, otherReadMode, otherWriteMode, otherExecuteMode, fileMode) +#ifndef mingw32_HOST_OS +import System.PosixCompat.Files (setFileCreationMask) +#endif import Control.Monad.IO.Class import Foreign (complement) import Control.Monad.Catch @@ -100,16 +103,19 @@ checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor isExecutable :: FileMode -> Bool isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0 -{- Runs an action without that pesky umask influencing it, unless the - - passed FileMode is the standard one. -} -noUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a -#ifndef mingw32_HOST_OS -noUmask mode a - | mode == stdFileMode = a - | otherwise = withUmask nullFileMode a -#else -noUmask _ a = a -#endif +data ModeSetter = ModeSetter FileMode (RawFilePath -> IO ()) + +{- Runs an action which should create the file, passing it the desired + - initial file mode. Then runs the ModeSetter's action on the file, which + - can adjust the initial mode if umask prevented the file from being + - created with the right mode. -} +applyModeSetter :: Maybe ModeSetter -> RawFilePath -> (Maybe FileMode -> IO a) -> IO a +applyModeSetter (Just (ModeSetter mode modeaction)) file a = do + r <- a (Just mode) + void $ tryIO $ modeaction file + return r +applyModeSetter Nothing _ a = + a Nothing withUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a #ifndef mingw32_HOST_OS @@ -169,10 +175,10 @@ writeFileProtected file content = writeFileProtected' file (\h -> hPutStr h content) writeFileProtected' :: RawFilePath -> (Handle -> IO ()) -> IO () -writeFileProtected' file writer = protectedOutput $ - withFile (fromRawFilePath file) WriteMode $ \h -> do - void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes - writer h +writeFileProtected' file writer = do + h <- protectedOutput $ openFile (fromRawFilePath file) WriteMode + void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes + writer h protectedOutput :: IO a -> IO a protectedOutput = withUmask 0o0077 diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs index a503fda..3d216f2 100644 --- a/Utility/FileSize.hs +++ b/Utility/FileSize.hs @@ -14,13 +14,15 @@ module Utility.FileSize ( getFileSize', ) where -import System.PosixCompat.Files hiding (removeLink) -import qualified Utility.RawFilePath as R #ifdef mingw32_HOST_OS import Control.Exception (bracket) import System.IO import Utility.FileSystemEncoding +#else +import System.PosixCompat.Files (fileSize) #endif +import System.PosixCompat.Files (FileStatus) +import qualified Utility.RawFilePath as R type FileSize = Integer diff --git a/Utility/Format.hs b/Utility/Format.hs index 466988c..930b7ee 100644 --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -1,6 +1,6 @@ {- Formatted string handling. - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2023 Joey Hess - - License: BSD-2-clause -} @@ -9,10 +9,12 @@ module Utility.Format ( Format, gen, format, + escapedFormat, formatContainsVar, decode_c, encode_c, encode_c', + isUtf8Byte, prop_encode_c_decode_c_roundtrip ) where @@ -21,12 +23,11 @@ import Data.Char (isAlphaNum, isOctDigit, isHexDigit, isSpace, chr, ord, isAscii import Data.Maybe (fromMaybe) import Data.Word (Word8) import Data.List (isPrefixOf) -import qualified Codec.Binary.UTF8.String import qualified Data.Map as M +import qualified Data.ByteString as S import Utility.PartialPrelude - -type FormatString = String +import Utility.FileSystemEncoding {- A format consists of a list of fragments. -} type Format = [Frag] @@ -53,7 +54,8 @@ format f vars = concatMap expand f where expand (Const s) = s expand (Var name j esc) - | esc = justify j $ encode_c' isSpace $ getvar name + | esc = justify j $ decodeBS $ escapedFormat $ + encodeBS $ getvar name | otherwise = justify j $ getvar name getvar name = fromMaybe "" $ M.lookup name vars justify UnJustified s = s @@ -62,6 +64,13 @@ format f vars = concatMap expand f pad i s = take (i - length s) spaces spaces = repeat ' ' +escapedFormat :: S.ByteString -> S.ByteString +escapedFormat = encode_c needescape + where + needescape c = isUtf8Byte c || + isSpace (chr (fromIntegral c)) || + c == fromIntegral (ord '"') + {- Generates a Format that can be used to expand variables in a - format string, such as "${foo} ${bar;10} ${baz;-10}\n" - @@ -69,8 +78,8 @@ format f vars = concatMap expand f - - Also, "${escaped_foo}" will apply encode_c to the value of variable foo. -} -gen :: FormatString -> Format -gen = filter (not . empty) . fuse [] . scan [] . decode_c +gen :: String -> Format +gen = filter (not . empty) . fuse [] . scan [] . decodeBS . decode_c . encodeBS where -- The Format is built up in reverse, for efficiency, -- and can have many adjacent Consts. Fusing it fixes both @@ -122,33 +131,50 @@ formatContainsVar v = any go {- Decodes a C-style encoding, where \n is a newline (etc), - \NNN is an octal encoded character, and \xNN is a hex encoded character. -} -decode_c :: FormatString -> String -decode_c [] = [] -decode_c s = unescape ("", s) +decode_c :: S.ByteString -> S.ByteString +decode_c s + | S.null s = S.empty + | otherwise = unescape (S.empty, s) where - e = '\\' - unescape (b, []) = b - -- look for escapes starting with '\' - unescape (b, v) = b ++ fst pair ++ unescape (handle $ snd pair) + e = fromIntegral (ord '\\') + x = fromIntegral (ord 'x') + isescape c = c == e + unescape (b, v) + | S.null v = b + | otherwise = b <> fst pair <> unescape (handle $ snd pair) where - pair = span (/= e) v - isescape x = x == e - handle (x:'x':n1:n2:rest) - | isescape x && allhex = (fromhex, rest) + pair = S.span (not . isescape) v + handle b + | S.length b >= 1 && isescape (S.index b 0) = handle' b + | otherwise = (S.empty, b) + + handle' b + | S.length b >= 4 + && S.index b 1 == x + && allhex = (fromhex, rest) where + n1 = chr (fromIntegral (S.index b 2)) + n2 = chr (fromIntegral (S.index b 3)) + rest = S.drop 4 b allhex = isHexDigit n1 && isHexDigit n2 - fromhex = [chr $ readhex [n1, n2]] + fromhex = encodeBS [chr $ readhex [n1, n2]] readhex h = Prelude.read $ "0x" ++ h :: Int - handle (x:n1:n2:n3:rest) - | isescape x && alloctal = (fromoctal, rest) + handle' b + | S.length b >= 4 && alloctal = (fromoctal, rest) where + n1 = chr (fromIntegral (S.index b 1)) + n2 = chr (fromIntegral (S.index b 2)) + n3 = chr (fromIntegral (S.index b 3)) + rest = S.drop 4 b alloctal = isOctDigit n1 && isOctDigit n2 && isOctDigit n3 - fromoctal = [chr $ readoctal [n1, n2, n3]] + fromoctal = encodeBS [chr $ readoctal [n1, n2, n3]] readoctal o = Prelude.read $ "0o" ++ o :: Int - -- \C is used for a few special characters - handle (x:nc:rest) - | isescape x = ([echar nc], rest) + handle' b + | S.length b >= 2 = + (S.singleton (fromIntegral (ord (echar nc))), rest) where + nc = chr (fromIntegral (S.index b 1)) + rest = S.drop 2 b echar 'a' = '\a' echar 'b' = '\b' echar 'f' = '\f' @@ -156,38 +182,50 @@ decode_c s = unescape ("", s) echar 'r' = '\r' echar 't' = '\t' echar 'v' = '\v' - echar a = a - handle n = ("", n) - -{- Inverse of decode_c. -} -encode_c :: String -> FormatString -encode_c = encode_c' (const False) + echar a = a -- \\ decodes to '\', and \" to '"' + handle' b = (S.empty, b) -{- Encodes special characters, as well as any matching the predicate. -} -encode_c' :: (Char -> Bool) -> String -> FormatString -encode_c' p = concatMap echar +{- Inverse of decode_c. Encodes ascii control characters as well as + - bytes that match the predicate. (And also '\' itself.) + -} +encode_c :: (Word8 -> Bool) -> S.ByteString -> S.ByteString +encode_c p s = fromMaybe s (encode_c' p s) + +{- Returns Nothing when nothing needs to be escaped in the input ByteString. -} +encode_c' :: (Word8 -> Bool) -> S.ByteString -> Maybe S.ByteString +encode_c' p s + | S.any needencode s = Just (S.concatMap echar s) + | otherwise = Nothing where - e c = '\\' : [c] - echar '\a' = e 'a' - echar '\b' = e 'b' - echar '\f' = e 'f' - echar '\n' = e 'n' - echar '\r' = e 'r' - echar '\t' = e 't' - echar '\v' = e 'v' - echar '\\' = e '\\' - echar '"' = e '"' + e = fromIntegral (ord '\\') + q = fromIntegral (ord '"') + del = 0x7F + iscontrol c = c < 0x20 + + echar 0x7 = ec 'a' + echar 0x8 = ec 'b' + echar 0x0C = ec 'f' + echar 0x0A = ec 'n' + echar 0x0D = ec 'r' + echar 0x09 = ec 't' + echar 0x0B = ec 'v' echar c - | ord c < 0x20 = e_asc c -- low ascii - | ord c >= 256 = e_utf c -- unicode - | ord c > 0x7E = e_asc c -- high ascii - | p c = e_asc c - | otherwise = [c] - -- unicode character is decomposed to individual Word8s, - -- and each is shown in octal - e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8]) - e_asc c = showoctal $ ord c - showoctal i = '\\' : printf "%03o" i + | iscontrol c = showoctal c -- other control characters + | c == e = ec '\\' -- escape the escape character itself + | c == del = showoctal c + | p c = if c == q + then ec '"' -- escape double quote + else showoctal c + | otherwise = S.singleton c + + needencode c = iscontrol c || c == e || c == del || p c + + ec c = S.pack [e, fromIntegral (ord c)] + + showoctal i = encodeBS ('\\' : printf "%03o" i) + +isUtf8Byte :: Word8 -> Bool +isUtf8Byte c = c >= 0x80 {- For quickcheck. - @@ -198,6 +236,7 @@ encode_c' p = concatMap echar - This property papers over the problem, by only testing ascii. -} prop_encode_c_decode_c_roundtrip :: String -> Bool -prop_encode_c_decode_c_roundtrip s = s' == decode_c (encode_c s') +prop_encode_c_decode_c_roundtrip s = s' == + decodeBS (decode_c (encode_c isUtf8Byte (encodeBS s'))) where s' = filter isAscii s diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs index b697ab3..3828bc6 100644 --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -32,6 +32,7 @@ module Utility.InodeCache ( inodeCacheToMtime, inodeCacheToEpochTime, inodeCacheEpochTimeRange, + replaceInode, SentinalFile(..), SentinalStatus(..), @@ -50,11 +51,10 @@ import Utility.QuickCheck import qualified Utility.RawFilePath as R import System.PosixCompat.Types +import System.PosixCompat.Files (isRegularFile, fileID) import Data.Time.Clock.POSIX -#ifdef mingw32_HOST_OS -import Data.Word (Word64) -#else +#ifndef mingw32_HOST_OS import qualified System.Posix.Files as Posix #endif @@ -125,7 +125,11 @@ inodeCacheEpochTimeRange i = let t = inodeCacheToEpochTime i in (t-1, t+1) -{- For backwards compatability, support low-res mtime with no +replaceInode :: FileID -> InodeCache -> InodeCache +replaceInode inode (InodeCache (InodeCachePrim _ sz mtime)) = + InodeCache (InodeCachePrim inode sz mtime) + +{- For backwards compatibility, support low-res mtime with no - fractional seconds. -} data MTime = MTimeLowRes EpochTime | MTimeHighRes POSIXTime deriving (Show, Ord) @@ -187,7 +191,7 @@ readInodeCache s = case words s of genInodeCache :: RawFilePath -> TSDelta -> IO (Maybe InodeCache) genInodeCache f delta = catchDefaultIO Nothing $ - toInodeCache delta f =<< R.getFileStatus f + toInodeCache delta f =<< R.getSymbolicLinkStatus f toInodeCache :: TSDelta -> RawFilePath -> FileStatus -> IO (Maybe InodeCache) toInodeCache d f s = toInodeCache' d f s (fileID s) @@ -243,7 +247,7 @@ data SentinalStatus = SentinalStatus - On Windows, time stamp differences are ignored, since they change - with the timezone. - - - When the sential file does not exist, InodeCaches canot reliably be + - When the sential file does not exist, InodeCaches cannot reliably be - compared, so the assumption is that there is has been a change. -} checkSentinalFile :: SentinalFile -> IO SentinalStatus diff --git a/Utility/Metered.hs b/Utility/Metered.hs index 8fd9c9b..a8a7111 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -53,6 +53,7 @@ import Utility.DataUnits import Utility.HumanTime import Utility.SimpleProtocol as Proto import Utility.ThreadScheduler +import Utility.SafeOutput import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S @@ -321,7 +322,7 @@ demeterCommandEnv oh cmd params environ = do where stdouthandler l = unless (quietMode oh) $ - putStrLn l + putStrLn (safeOutput l) {- To suppress progress output, while displaying other messages, - filter out lines that contain \r (typically used to reset to the @@ -491,14 +492,14 @@ bandwidthMeter mtotalsize (MeterState (BytesProcessed old) before) (MeterState ( , estimatedcompletion ] where - amount = roughSize' memoryUnits True 2 new + amount = roughSize' committeeUnits True 2 new percentamount = case mtotalsize of Just (TotalSize totalsize) -> let p = showPercentage 0 $ percentage totalsize (min new totalsize) in p ++ replicate (6 - length p) ' ' ++ amount Nothing -> amount - rate = roughSize' memoryUnits True 0 bytespersecond ++ "/s" + rate = roughSize' committeeUnits True 0 bytespersecond ++ "/s" bytespersecond | duration == 0 = fromIntegral transferred | otherwise = floor $ fromIntegral transferred / duration diff --git a/Utility/Misc.hs b/Utility/Misc.hs index 01ae178..3cf5275 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -12,6 +12,7 @@ module Utility.Misc ( readFileStrict, separate, separate', + separateEnd', firstLine, firstLine', segment, @@ -62,6 +63,13 @@ separate' c l = unbreak $ S.break c l | S.null b = r | otherwise = (a, S.tail b) +separateEnd' :: (Word8 -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString) +separateEnd' c l = unbreak $ S.breakEnd c l + where + unbreak r@(a, b) + | S.null a = r + | otherwise = (S.init a, b) + {- Breaks out the first line. -} firstLine :: String -> String firstLine = takeWhile (/= '\n') @@ -86,7 +94,7 @@ prop_segment_regressionTest :: Bool prop_segment_regressionTest = all id -- Even an empty list is a segment. [ segment (== "--") [] == [[]] - -- There are two segements in this list, even though the first is empty. + -- There are two segments in this list, even though the first is empty. , segment (== "--") ["--", "foo", "bar"] == [[],["foo","bar"]] ] diff --git a/Utility/Monad.hs b/Utility/Monad.hs index abe06f3..6cd2c5e 100644 --- a/Utility/Monad.hs +++ b/Utility/Monad.hs @@ -12,6 +12,7 @@ module Utility.Monad ( getM, anyM, allM, + partitionM, untilTrue, ifM, (<||>), @@ -45,6 +46,13 @@ allM :: Monad m => (a -> m Bool) -> [a] -> m Bool allM _ [] = return True allM p (x:xs) = p x <&&> allM p xs +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM _ [] = return ([], []) +partitionM p (x:xs) = do + r <- p x + (as, bs) <- partitionM p xs + return $ if r then (x:as, bs) else (as, x:bs) + {- Runs an action on values from a list until it succeeds. -} untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool untilTrue = flip anyM diff --git a/Utility/MoveFile.hs b/Utility/MoveFile.hs index 3ea17e8..6481b29 100644 --- a/Utility/MoveFile.hs +++ b/Utility/MoveFile.hs @@ -14,12 +14,11 @@ module Utility.MoveFile ( ) where import Control.Monad -import System.FilePath -import System.PosixCompat.Files hiding (removeLink) import System.IO.Error import Prelude #ifndef mingw32_HOST_OS +import System.PosixCompat.Files (isDirectory) import Control.Monad.IfElse import Utility.SafeCommand #endif @@ -28,17 +27,19 @@ import Utility.SystemDirectory import Utility.Tmp import Utility.Exception import Utility.Monad +import Utility.FileSystemEncoding +import qualified Utility.RawFilePath as R {- Moves one filename to another. - First tries a rename, but falls back to moving across devices if needed. -} -moveFile :: FilePath -> FilePath -> IO () -moveFile src dest = tryIO (rename src dest) >>= onrename +moveFile :: RawFilePath -> RawFilePath -> IO () +moveFile src dest = tryIO (R.rename src dest) >>= onrename where onrename (Right _) = noop onrename (Left e) | isPermissionError e = rethrow | isDoesNotExistError e = rethrow - | otherwise = viaTmp mv dest () + | otherwise = viaTmp mv (fromRawFilePath dest) () where rethrow = throwM e @@ -46,16 +47,20 @@ moveFile src dest = tryIO (rename src dest) >>= onrename -- copyFile is likely not as optimised as -- the mv command, so we'll use the command. -- - -- But, while Windows has a "mv", it does not seem very - -- reliable, so use copyFile there. + -- But, while Windows has a "mv", it does not + -- seem very reliable, so use copyFile there. #ifndef mingw32_HOST_OS -- If dest is a directory, mv would move the file -- into it, which is not desired. whenM (isdir dest) rethrow - ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] + ok <- boolSystem "mv" + [ Param "-f" + , Param (fromRawFilePath src) + , Param tmp + ] let e' = e #else - r <- tryIO $ copyFile src tmp + r <- tryIO $ copyFile (fromRawFilePath src) tmp let (ok, e') = case r of Left err -> (False, err) Right _ -> (True, e) @@ -67,7 +72,7 @@ moveFile src dest = tryIO (rename src dest) >>= onrename #ifndef mingw32_HOST_OS isdir f = do - r <- tryIO $ getFileStatus f + r <- tryIO $ R.getSymbolicLinkStatus f case r of (Left _) -> return False (Right s) -> return $ isDirectory s diff --git a/Utility/Path.hs b/Utility/Path.hs index b5aeb16..64ef076 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -20,6 +20,7 @@ module Utility.Path ( runSegmentPaths', dotfile, splitShortExtensions, + splitShortExtensions', relPathDirToFileAbs, inSearchPath, searchPath, @@ -53,7 +54,7 @@ import Utility.FileSystemEncoding - - This does not guarantee that two paths that refer to the same location, - and are both relative to the same location (or both absolute) will - - yeild the same result. Run both through normalise from System.RawFilePath + - yield the same result. Run both through normalise from System.RawFilePath - to ensure that. -} simplifyPath :: RawFilePath -> RawFilePath @@ -90,7 +91,7 @@ upFrom dir {- Checks if the first RawFilePath is, or could be said to contain the second. - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc - - are all equivilant. + - are all equivalent. -} dirContains :: RawFilePath -> RawFilePath -> Bool dirContains a b = a == b diff --git a/Utility/Path/AbsRel.hs b/Utility/Path/AbsRel.hs index 857dd5e..4007fbb 100644 --- a/Utility/Path/AbsRel.hs +++ b/Utility/Path/AbsRel.hs @@ -37,7 +37,7 @@ import Utility.FileSystemEncoding - Also simplifies it using simplifyPath. - - The first parameter is a base directory (ie, the cwd) to use if the path - - is not already absolute, and should itsef be absolute. + - is not already absolute, and should itself be absolute. - - Does not attempt to deal with edge cases or ensure security with - untrusted inputs. diff --git a/Utility/Process.hs b/Utility/Process.hs index 4cf6105..07f035d 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -31,6 +31,7 @@ module Utility.Process ( stdoutHandle, stderrHandle, processHandle, + showCmd, devNull, ) where @@ -188,11 +189,13 @@ withCreateProcess p action = bracket (createProcess p) cleanupProcess debugProcess :: CreateProcess -> ProcessHandle -> IO () debugProcess p h = do pid <- getPid h - debug "Utility.Process" $ unwords + debug "Utility.Process" $ unwords $ [ describePid pid , action ++ ":" , showCmd p - ] + ] ++ case cwd p of + Nothing -> [] + Just c -> ["in", show c] where action | piped (std_in p) && piped (std_out p) = "chat" diff --git a/Utility/Process/Transcript.hs b/Utility/Process/Transcript.hs new file mode 100644 index 0000000..7bf94ff --- /dev/null +++ b/Utility/Process/Transcript.hs @@ -0,0 +1,97 @@ +{- Process transcript + - + - Copyright 2012-2020 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Process.Transcript ( + processTranscript, + processTranscript', + processTranscript'', +) where + +import Utility.Process + +import System.IO +import System.Exit +import Control.Concurrent.Async +import Control.Monad +#ifndef mingw32_HOST_OS +import Control.Exception +import qualified System.Posix.IO +#else +import Control.Applicative +#endif +import Data.Maybe +import Prelude + +-- | Runs a process and returns a transcript combining its stdout and +-- stderr, and whether it succeeded or failed. +processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) +processTranscript cmd opts = processTranscript' (proc cmd opts) + +-- | Also feeds the process some input. +processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool) +processTranscript' cp input = do + (t, c) <- processTranscript'' cp input + return (t, c == ExitSuccess) + +processTranscript'' :: CreateProcess -> Maybe String -> IO (String, ExitCode) +processTranscript'' cp input = do +#ifndef mingw32_HOST_OS +{- This implementation interleves stdout and stderr in exactly the order + - the process writes them. -} + let setup = do + (readf, writef) <- System.Posix.IO.createPipe + System.Posix.IO.setFdOption readf System.Posix.IO.CloseOnExec True + System.Posix.IO.setFdOption writef System.Posix.IO.CloseOnExec True + readh <- System.Posix.IO.fdToHandle readf + writeh <- System.Posix.IO.fdToHandle writef + return (readh, writeh) + let cleanup (readh, writeh) = do + hClose readh + hClose writeh + bracket setup cleanup $ \(readh, writeh) -> do + let cp' = cp + { std_in = if isJust input then CreatePipe else Inherit + , std_out = UseHandle writeh + , std_err = UseHandle writeh + } + withCreateProcess cp' $ \hin hout herr pid -> do + get <- asyncreader pid readh + writeinput input (hin, hout, herr, pid) + code <- waitForProcess pid + transcript <- wait get + return (transcript, code) +#else +{- This implementation for Windows puts stderr after stdout. -} + let cp' = cp + { std_in = if isJust input then CreatePipe else Inherit + , std_out = CreatePipe + , std_err = CreatePipe + } + withCreateProcess cp' $ \hin hout herr pid -> do + let p = (hin, hout, herr, pid) + getout <- asyncreader pid (stdoutHandle p) + geterr <- asyncreader pid (stderrHandle p) + writeinput input p + code <- waitForProcess pid + transcript <- (++) <$> wait getout <*> wait geterr + return (transcript, code) +#endif + where + asyncreader pid h = async $ reader pid h [] + reader pid h c = hGetLineUntilExitOrEOF pid h >>= \case + Nothing -> return (unlines (reverse c)) + Just l -> reader pid h (l:c) + writeinput (Just s) p = do + let inh = stdinHandle p + unless (null s) $ do + hPutStr inh s + hFlush inh + hClose inh + writeinput Nothing _ = return () diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index 650f559..96e31d5 100644 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -6,6 +6,7 @@ -} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} {-# LANGUAGE TypeSynonymInstances #-} module Utility.QuickCheck diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs index f32b226..b39423d 100644 --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -5,9 +5,11 @@ - - On Windows, filenames are in unicode, so RawFilePaths have to be - decoded. So this library will work, but less efficiently than using - - FilePath would. + - FilePath would. However, this library also takes care to support long + - filenames on Windows, by either using other libraries that do, or by + - doing UNC-style conversion itself. - - - Copyright 2019-2020 Joey Hess + - Copyright 2019-2023 Joey Hess - - License: BSD-2-clause -} @@ -27,6 +29,10 @@ module Utility.RawFilePath ( getCurrentDirectory, createDirectory, setFileMode, + setOwnerAndGroup, + rename, + createNamedPipe, + fileAccess, ) where #ifndef mingw32_HOST_OS @@ -47,23 +53,28 @@ createDirectory p = D.createDirectory p 0o777 #else import System.PosixCompat (FileStatus, FileMode) +-- System.PosixCompat does not handle UNC-style conversion itself, +-- so all uses of it library have to be pre-converted below. See +-- https://github.com/jacobstanley/unix-compat/issues/56 import qualified System.PosixCompat as P -import qualified System.PosixCompat.Files as F import qualified System.Directory as D import Utility.FileSystemEncoding +import Utility.Path.Windows readSymbolicLink :: RawFilePath -> IO RawFilePath readSymbolicLink f = toRawFilePath <$> P.readSymbolicLink (fromRawFilePath f) createSymbolicLink :: RawFilePath -> RawFilePath -> IO () -createSymbolicLink a b = P.createSymbolicLink - (fromRawFilePath a) - (fromRawFilePath b) +createSymbolicLink a b = do + a' <- fromRawFilePath <$> convertToWindowsNativeNamespace a + b' <- fromRawFilePath <$> convertToWindowsNativeNamespace b + P.createSymbolicLink a' b' createLink :: RawFilePath -> RawFilePath -> IO () -createLink a b = P.createLink - (fromRawFilePath a) - (fromRawFilePath b) +createLink a b = do + a' <- fromRawFilePath <$> convertToWindowsNativeNamespace a + b' <- fromRawFilePath <$> convertToWindowsNativeNamespace b + P.createLink a' b' {- On windows, removeLink is not available, so only remove files, - not symbolic links. -} @@ -71,10 +82,12 @@ removeLink :: RawFilePath -> IO () removeLink = D.removeFile . fromRawFilePath getFileStatus :: RawFilePath -> IO FileStatus -getFileStatus = P.getFileStatus . fromRawFilePath +getFileStatus p = P.getFileStatus . fromRawFilePath + =<< convertToWindowsNativeNamespace p getSymbolicLinkStatus :: RawFilePath -> IO FileStatus -getSymbolicLinkStatus = P.getSymbolicLinkStatus . fromRawFilePath +getSymbolicLinkStatus p = P.getSymbolicLinkStatus . fromRawFilePath + =<< convertToWindowsNativeNamespace p doesPathExist :: RawFilePath -> IO Bool doesPathExist = D.doesPathExist . fromRawFilePath @@ -86,5 +99,27 @@ createDirectory :: RawFilePath -> IO () createDirectory = D.createDirectory . fromRawFilePath setFileMode :: RawFilePath -> FileMode -> IO () -setFileMode = F.setFileMode . fromRawFilePath +setFileMode p m = do + p' <- fromRawFilePath <$> convertToWindowsNativeNamespace p + P.setFileMode p' m + +{- Using renamePath rather than the rename provided in unix-compat + - because of this bug https://github.com/jacobstanley/unix-compat/issues/56-} +rename :: RawFilePath -> RawFilePath -> IO () +rename a b = D.renamePath (fromRawFilePath a) (fromRawFilePath b) + +setOwnerAndGroup :: RawFilePath -> P.UserID -> P.GroupID -> IO () +setOwnerAndGroup p u g = do + p' <- fromRawFilePath <$> convertToWindowsNativeNamespace p + P.setOwnerAndGroup p' u g + +createNamedPipe :: RawFilePath -> FileMode -> IO () +createNamedPipe p m = do + p' <- fromRawFilePath <$> convertToWindowsNativeNamespace p + P.createNamedPipe p' m + +fileAccess :: RawFilePath -> Bool -> Bool -> Bool -> IO Bool +fileAccess p a b c = do + p' <- fromRawFilePath <$> convertToWindowsNativeNamespace p + P.fileAccess p' a b c #endif diff --git a/Utility/SafeOutput.hs b/Utility/SafeOutput.hs new file mode 100644 index 0000000..d781386 --- /dev/null +++ b/Utility/SafeOutput.hs @@ -0,0 +1,36 @@ +{- Safe output to the terminal of possibly attacker-controlled strings, + - avoiding displaying control characters. + - + - Copyright 2023 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.SafeOutput ( + safeOutput, + safeOutputChar, +) where + +import Data.Char +import qualified Data.ByteString as S + +class SafeOutputtable t where + safeOutput :: t -> t + +instance SafeOutputtable String where + safeOutput = filter safeOutputChar + +instance SafeOutputtable S.ByteString where + safeOutput = S.filter (safeOutputChar . chr . fromIntegral) + +safeOutputChar :: Char -> Bool +safeOutputChar c + | not (isControl c) = True + | c == '\n' = True + | c == '\t' = True + | c == '\DEL' = False + | ord c > 31 = True + | otherwise = False diff --git a/Utility/SystemDirectory.hs b/Utility/SystemDirectory.hs index b9040fe..a7d60f9 100644 --- a/Utility/SystemDirectory.hs +++ b/Utility/SystemDirectory.hs @@ -1,4 +1,4 @@ -{- System.Directory without its conflicting isSymbolicLink +{- System.Directory without its conflicting isSymbolicLink and getFileSize. - - Copyright 2016 Joey Hess - diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index 92bd921..efb15bd 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -21,12 +21,12 @@ import System.IO 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 import Utility.FileMode +import qualified Utility.RawFilePath as R type Template = String @@ -62,14 +62,15 @@ viaTmp a file content = bracketIO setup cleanup use _ <- tryIO $ hClose h tryIO $ removeFile tmpfile use (tmpfile, h) = do + let tmpfile' = toRawFilePath tmpfile -- Make mode the same as if the file were created usually, -- not as a temp file. (This may fail on some filesystems -- that don't support file modes well, so ignore -- exceptions.) - _ <- liftIO $ tryIO $ setFileMode tmpfile =<< defaultFileMode + _ <- liftIO $ tryIO $ R.setFileMode tmpfile' =<< defaultFileMode liftIO $ hClose h a tmpfile content - liftIO $ rename tmpfile file + liftIO $ R.rename tmpfile' (toRawFilePath file) {- Runs an action with a tmp file located in the system's tmp directory - (or in "." if there is none) then removes the file. -} diff --git a/Utility/Url/Parse.hs b/Utility/Url/Parse.hs new file mode 100644 index 0000000..7fc952b --- /dev/null +++ b/Utility/Url/Parse.hs @@ -0,0 +1,63 @@ +{- Url parsing. + - + - Copyright 2011-2023 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} + +module Utility.Url.Parse ( + parseURIPortable, + parseURIRelaxed, +) where + +import Network.URI +#ifdef mingw32_HOST_OS +import qualified System.FilePath.Windows as PW +#endif + +{- On unix this is the same as parseURI. But on Windows, + - it can parse urls such as file:///C:/path/to/file + - parseURI normally parses that as a path /C:/path/to/file + - and this simply removes the excess leading slash when there is a + - drive letter after it. -} +parseURIPortable :: String -> Maybe URI +#ifndef mingw32_HOST_OS +parseURIPortable = parseURI +#else +parseURIPortable s + | "file:" `isPrefixOf` s = do + u <- parseURI s + return $ case PW.splitDirectories (uriPath u) of + (p:d:_) | all PW.isPathSeparator p && PW.isDrive d -> + u { uriPath = dropWhile PW.isPathSeparator (uriPath u) } + _ -> u + | otherwise = parseURI s +#endif + +{- Allows for spaces and other stuff in urls, properly escaping them. -} +parseURIRelaxed :: String -> Maybe URI +parseURIRelaxed s = maybe (parseURIRelaxed' s) Just $ + parseURIPortable $ escapeURIString isAllowedInURI s + +{- Some characters like '[' are allowed in eg, the address of + - an uri, but cannot appear unescaped further along in the uri. + - This handles that, expensively, by successively escaping each character + - from the back of the url until the url parses. + -} +parseURIRelaxed' :: String -> Maybe URI +parseURIRelaxed' s = go [] (reverse s) + where + go back [] = parseURI back + go back (c:cs) = case parseURI (escapeURIString isAllowedInURI (reverse (c:cs)) ++ back) of + Just u -> Just u + Nothing -> go (escapeURIChar escapemore c ++ back) cs + + escapemore '[' = False + escapemore ']' = False + escapemore c = isAllowedInURI c diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index 17ce8db..827229d 100644 --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -19,31 +19,32 @@ import Utility.Exception #ifndef mingw32_HOST_OS import Utility.Data import Control.Applicative +import System.Posix.User +#if MIN_VERSION_unix(2,8,0) +import System.Posix.User.ByteString (UserEntry) +#endif #endif -import System.PosixCompat import Prelude {- Current user's home directory. - - getpwent will fail on LDAP or NIS, so use HOME if set. -} myHomeDir :: IO FilePath -myHomeDir = either giveup return =<< myVal env homeDirectory - where +myHomeDir = either giveup return =<< #ifndef mingw32_HOST_OS - env = ["HOME"] + myVal ["HOME"] homeDirectory #else - env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin + myVal ["USERPROFILE", "HOME"] -- HOME is used in Cygwin #endif {- Current user's user name. -} myUserName :: IO (Either String String) -myUserName = myVal env userName - where +myUserName = #ifndef mingw32_HOST_OS - env = ["USER", "LOGNAME"] + myVal ["USER", "LOGNAME"] userName #else - env = ["USERNAME", "USER", "LOGNAME"] + myVal ["USERNAME", "USER", "LOGNAME"] #endif myUserGecos :: IO (Maybe String) @@ -54,16 +55,20 @@ myUserGecos = return Nothing myUserGecos = eitherToMaybe <$> myVal [] userGecos #endif +#ifndef mingw32_HOST_OS myVal :: [String] -> (UserEntry -> String) -> IO (Either String String) myVal envvars extract = go envvars where go [] = either (const $ envnotset) (Right . extract) <$> get go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v -#ifndef mingw32_HOST_OS -- This may throw an exception if the system doesn't have a -- passwd file etc; don't let it crash. get = tryNonAsync $ getUserEntryForID =<< getEffectiveUserID #else - get = return envnotset +myVal :: [String] -> IO (Either String String) +myVal envvars = go envvars + where + go [] = return envnotset + go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v #endif envnotset = Left ("environment not set: " ++ show envvars) diff --git a/git-repair.cabal b/git-repair.cabal index c269fe7..371072e 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -1,5 +1,5 @@ Name: git-repair -Version: 1.20220404 +Version: 1.20230814 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess @@ -73,13 +73,13 @@ Executable git-repair Git.DiffTreeItem Git.Env Git.FilePath - Git.Filename Git.Fsck Git.HashObject Git.Index Git.LsFiles Git.LsTree Git.Objects + Git.Quote Git.Ref Git.RefLog Git.Remote @@ -120,10 +120,12 @@ Executable git-repair Utility.Percentage Utility.Process Utility.Process.Shim + Utility.Process.Transcript Utility.QuickCheck Utility.RawFilePath Utility.Rsync Utility.SafeCommand + Utility.SafeOutput Utility.SimpleProtocol Utility.Split Utility.SystemDirectory @@ -133,3 +135,4 @@ Executable git-repair Utility.Tmp.Dir Utility.Tuple Utility.UserInfo + Utility.Url.Parse -- cgit v1.2.3 From 0b16009b59539147755ed626786d22a821b2fd24 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 14 Aug 2023 12:29:06 -0400 Subject: merge from git-annex and simplify configure --- Build/Configure.hs | 28 +++++++++++---------- Build/TestConfig.hs | 2 +- Build/Version.hs | 71 ----------------------------------------------------- git-repair.cabal | 1 - 4 files changed, 16 insertions(+), 86 deletions(-) delete mode 100644 Build/Version.hs diff --git a/Build/Configure.hs b/Build/Configure.hs index 3460f04..5682e8f 100644 --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -1,31 +1,33 @@ -{- Checks system configuration and generates SysConfig. -} +{- Checks system configuration and generates Build/SysConfig. -} {-# OPTIONS_GHC -fno-warn-tabs #-} module Build.Configure where -import Control.Monad.IfElse -import Control.Applicative -import Prelude - import Build.TestConfig -import Build.Version -import Git.Version +import Utility.Env.Basic +import qualified Git.Version + +import Control.Monad tests :: [TestCase] tests = - [ TestCase "version" (Config "packageversion" . StringConfig <$> getVersion) - , TestCase "git" $ testCmd "git" "git --version >/dev/null" + [ TestCase "git" $ testCmd "git" "git --version >/dev/null" , TestCase "git version" getGitVersion ] getGitVersion :: Test -getGitVersion = Config "gitversion" . StringConfig . show - <$> Git.Version.installed +getGitVersion = go =<< getEnv "FORCE_GIT_VERSION" + where + go (Just s) = return $ Config "gitversion" $ StringConfig s + go Nothing = do + v <- Git.Version.installed + let oldestallowed = Git.Version.normalize "2.1" + when (v < oldestallowed) $ + error $ "installed git version " ++ show v ++ " is too old! (Need " ++ show oldestallowed ++ " or newer)" + return $ Config "gitversion" $ StringConfig $ show v run :: [TestCase] -> IO () run ts = do config <- runTests ts writeSysConfig config - whenM (isReleaseBuild) $ - cabalSetup "git-repair.cabal" diff --git a/Build/TestConfig.hs b/Build/TestConfig.hs index 988db58..5458612 100644 --- a/Build/TestConfig.hs +++ b/Build/TestConfig.hs @@ -7,7 +7,7 @@ module Build.TestConfig where import Utility.Path import Utility.Monad import Utility.SafeCommand -import Utility.Directory +import Utility.SystemDirectory import System.IO import System.FilePath diff --git a/Build/Version.hs b/Build/Version.hs deleted file mode 100644 index d39a0fe..0000000 --- a/Build/Version.hs +++ /dev/null @@ -1,71 +0,0 @@ -{- Package version determination, for configure script. -} - -{-# OPTIONS_GHC -fno-warn-tabs #-} - -module Build.Version where - -import Data.List -import System.Environment -import Data.Char -import System.Process -import Control.Applicative -import Prelude - -import Utility.Monad -import Utility.Exception -import Utility.Directory - -type Version = String - -{- Set when making an official release. (Distribution vendors should set - - this too.) -} -isReleaseBuild :: IO Bool -isReleaseBuild = (== Just "1") <$> catchMaybeIO (getEnv "RELEASE_BUILD") - -{- Version is usually based on the major version from the changelog, - - plus the date of the last commit, plus the git rev of that commit. - - This works for autobuilds, ad-hoc builds, etc. - - - - If git or a git repo is not available, or something goes wrong, - - or this is a release build, just use the version from the changelog. -} -getVersion :: IO Version -getVersion = do - changelogversion <- getChangelogVersion - ifM (isReleaseBuild) - ( return changelogversion - , catchDefaultIO changelogversion $ do - let major = takeWhile (/= '.') changelogversion - autoversion <- takeWhile (\c -> isAlphaNum c || c == '-') <$> readProcess "sh" - [ "-c" - , "git log -n 1 --format=format:'%ci %h'| sed -e 's/-//g' -e 's/ .* /-g/'" - ] "" - if null autoversion - then return changelogversion - else return $ concat [ major, ".", autoversion ] - ) - -getChangelogVersion :: IO Version -getChangelogVersion = do - changelog <- readFile "CHANGELOG" - let verline = takeWhile (/= '\n') changelog - return $ middle (words verline !! 1) - where - middle = drop 1 . init - -{- Set up cabal file with version. -} -cabalSetup :: FilePath -> IO () -cabalSetup cabalfile = do - version <- takeWhile (\c -> isDigit c || c == '.') - <$> getChangelogVersion - cabal <- readFile cabalfile - writeFile tmpcabalfile $ unlines $ - map (setfield "Version" version) $ - lines cabal - renameFile tmpcabalfile cabalfile - where - tmpcabalfile = cabalfile++".tmp" - setfield field value s - | fullfield `isPrefixOf` s = fullfield ++ value - | otherwise = s - where - fullfield = field ++ ": " diff --git a/git-repair.cabal b/git-repair.cabal index 371072e..d82e60a 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -59,7 +59,6 @@ Executable git-repair BuildInfo Build.Configure Build.TestConfig - Build.Version Common Git Git.Branch -- cgit v1.2.3 From c09f5ea600806352f1c5f08c5b2e4c1bee0edfaa Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 14 Aug 2023 12:29:45 -0400 Subject: releasing package git-repair version 1.20230814 --- CHANGELOG | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 3abf0d8..295b8fc 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,9 +1,9 @@ -git-repair (1.20230814) UNRELEASED; urgency=medium +git-repair (1.20230814) unstable; urgency=medium * Merge from git-annex. * Support building with unix-compat 0.7 - -- Joey Hess Mon, 14 Aug 2023 12:06:46 -0400 + -- Joey Hess Mon, 14 Aug 2023 12:14:40 -0400 git-repair (1.20220404) unstable; urgency=medium -- cgit v1.2.3 From a0d4bc3b9de350cfe36ebb348a661da0321cb8b4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 14 Aug 2023 12:29:51 -0400 Subject: add news item for git-repair 1.20230814 --- doc/news/version_1.20200102.mdwn | 7 ------- doc/news/version_1.20230814.mdwn | 3 +++ 2 files changed, 3 insertions(+), 7 deletions(-) delete mode 100644 doc/news/version_1.20200102.mdwn create mode 100644 doc/news/version_1.20230814.mdwn diff --git a/doc/news/version_1.20200102.mdwn b/doc/news/version_1.20200102.mdwn deleted file mode 100644 index 372a457..0000000 --- a/doc/news/version_1.20200102.mdwn +++ /dev/null @@ -1,7 +0,0 @@ -git-repair 1.20200102 released with [[!toggle text="these changes"]] -[[!toggleable text=""" - * Relicensed AGPL. - * Merge from git-annex. - * Removed the network-uri build flag. - * Increased required version of several dependencies. - * Added dependencies on deepseq, attoparsec and filepath-bytestring."""]] \ No newline at end of file diff --git a/doc/news/version_1.20230814.mdwn b/doc/news/version_1.20230814.mdwn new file mode 100644 index 0000000..e496f83 --- /dev/null +++ b/doc/news/version_1.20230814.mdwn @@ -0,0 +1,3 @@ +git-repair 1.20230814 released with [[!toggle text="these changes"]] +[[!toggleable text=""" * Merge from git-annex. + * Support building with unix-compat 0.7"""]] \ No newline at end of file -- cgit v1.2.3 From 0438d0ae101add2cd9d74ff055b05ccddb3d7910 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 14 Aug 2023 12:31:09 -0400 Subject: version Cabal dep --- git-repair.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/git-repair.cabal b/git-repair.cabal index d82e60a..79633b3 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.4), async, exceptions, bytestring, directory, IfElse, data-default, - mtl, Cabal, time + mtl, Cabal (< 4.0), time source-repository head type: git -- cgit v1.2.3 From 4993eab4a4507d52037ff74c67f6ca04d2401b5e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 14 Aug 2023 12:31:47 -0400 Subject: upper bound on base --- git-repair.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/git-repair.cabal b/git-repair.cabal index 79633b3..7cf0aad 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -26,7 +26,7 @@ Extra-Source-Files: git-repair.1 custom-setup - Setup-Depends: base (>= 4.11.1.0), + Setup-Depends: base (>= 4.11.1.0 && < 5.0), hslogger, split, unix-compat, process, unix, filepath, filepath-bytestring (>= 1.4.2.1.4), async, exceptions, bytestring, directory, IfElse, data-default, -- cgit v1.2.3