packages feed

git-repair 1.20220404 → 1.20230814

raw patch · 46 files changed

+892/−421 lines, 46 files

Files

Build/Configure.hs view
@@ -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"
Build/TestConfig.hs view
@@ -7,7 +7,7 @@ import Utility.Path import Utility.Monad import Utility.SafeCommand-import Utility.Directory+import Utility.SystemDirectory  import System.IO import System.FilePath
− Build/Version.hs 
@@ -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 ++ ": "
CHANGELOG view
@@ -1,3 +1,10 @@+git-repair (1.20230814) unstable; urgency=medium++  * Merge from git-annex.+  * Support building with unix-compat 0.7++ -- Joey Hess <id@joeyh.name>  Mon, 14 Aug 2023 12:14:40 -0400+ git-repair (1.20220404) unstable; urgency=medium    * Avoid treating refs that are not commit objects as evidence of
Common.hs view
@@ -18,7 +18,7 @@ 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
Git.hs view
@@ -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 <id@joeyh.name>@@ -68,18 +68,18 @@ 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 @@ {- 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 @@  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 @@ #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. -}
Git/CatFile.hs view
@@ -120,7 +120,7 @@ 			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 @@ 	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. -}
Git/Config.hs view
@@ -1,6 +1,6 @@ {- git repository configuration handling  -- - Copyright 2010-2020 Joey Hess <id@joeyh.name>+ - Copyright 2010-2022 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -22,6 +22,8 @@ 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 @@ 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,20 +106,24 @@ 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. -} store' :: ConfigKey -> ConfigValue -> Repo -> Repo@@ -123,14 +139,28 @@  - 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' 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 @@ 	)   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
Git/Construct.hs view
@@ -1,6 +1,6 @@ {- Construction of Git Repo objects  -- - Copyright 2010-2021 Joey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -23,6 +23,7 @@ 	checkForRepo, 	newFrom, 	adjustGitDirFile,+	isBareRepo, ) where  #ifndef mingw32_HOST_OS@@ -38,6 +39,7 @@ 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 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' :: 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 @@ 				, 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 @@ 	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 @@ 	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 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,17 +233,18 @@ 		, 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) checkGitDirFile dir = adjustGitDirFile' $ Local @@ -277,5 +286,6 @@ 	, gitEnv = Nothing 	, gitEnvOverridesGitDir = False 	, gitGlobalOpts = []+	, gitDirSpecifiedExplicitly = False 	}
Git/CurrentRepo.hs view
@@ -1,6 +1,6 @@ {- The current git repository.  -- - Copyright 2012-2020 Joey Hess <id@joeyh.name>+ - Copyright 2012-2022 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -79,8 +79,9 @@ 			{ 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."
Git/Destroyer.hs view
@@ -18,7 +18,9 @@ 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 @@ 		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 @@ 								] 			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. ;)
Git/FilePath.hs view
@@ -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 <id@joeyh.name>+ - Copyright 2012-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -30,12 +30,12 @@  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 @@ {- 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
− Git/Filename.hs 
@@ -1,49 +0,0 @@-{- Some git commands output encoded filenames, in a rather annoyingly complex- - C-style encoding.- -- - Copyright 2010, 2011 Joey Hess <id@joeyh.name>- -- - 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
Git/HashObject.hs view
@@ -1,6 +1,6 @@ {- git hash-object interface  -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -21,26 +21,47 @@ 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 ()
Git/LsFiles.hs view
@@ -325,7 +325,7 @@ 		&& 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.
Git/LsTree.hs view
@@ -23,7 +23,7 @@ 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 @@ 		-- 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
+ Git/Quote.hs view
@@ -0,0 +1,122 @@+{- Some git commands output quoted filenames, in a rather annoyingly complex+ - C-style encoding.+ -+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>+ -+ - 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
Git/Remote.hs view
@@ -43,7 +43,7 @@ {- 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 @@ 	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 @@  {- 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
Git/Repair.hs view
@@ -30,6 +30,7 @@ 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 @@ 			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 @@ 		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' :: 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 @@ 		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 @@ 	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)
Git/Sha.hs view
@@ -20,7 +20,7 @@ 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.   -
Git/Types.hs view
@@ -51,6 +51,8 @@ 	, 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
Git/UpdateIndex.hs view
@@ -1,6 +1,6 @@ {- git-update-index library  -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2022 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -99,15 +99,15 @@ 	<> "\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 @@ 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 @@ 	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"
Utility/DataUnits.hs view
@@ -1,6 +1,6 @@ {- data size display and parsing  -- - Copyright 2011 Joey Hess <id@joeyh.name>+ - Copyright 2011-2022 Joey Hess <id@joeyh.name>  -  - 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 @@ 	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 @@ 	, 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
Utility/Directory.hs view
@@ -16,7 +16,7 @@  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 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 @@ 		| 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 @@ 		| 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.  -
Utility/Directory/Create.hs view
@@ -31,10 +31,10 @@ 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 @@  - 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))
Utility/Exception.hs view
@@ -1,6 +1,6 @@ {- Simple IO exception handling (and some more)  -- - Copyright 2011-2016 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -20,6 +20,7 @@ 	bracketIO, 	catchNonAsync, 	tryNonAsync,+	nonAsyncHandler, 	tryWhenExists, 	catchIOErrorType, 	IOErrorType(..),@@ -28,21 +29,24 @@  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 @@  - 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)@@ -93,6 +93,13 @@ 	go = do 		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)
Utility/FileMode.hs view
@@ -1,6 +1,6 @@ {- File mode utilities.  -- - Copyright 2010-2020 Joey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -16,7 +16,10 @@ 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,17 +103,20 @@ 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 withUmask umask a = bracket setup cleanup go@@ -169,10 +175,10 @@ 	(\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
Utility/FileSize.hs view
@@ -14,13 +14,15 @@ 	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
Utility/Format.hs view
@@ -1,6 +1,6 @@ {- Formatted string handling.  -- - Copyright 2010-2020 Joey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -9,10 +9,12 @@ 	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.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 @@   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 @@ 	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 @@  -  - 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 @@ {- 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,39 +182,51 @@ 		echar 'r' = '\r' 		echar 't' = '\t' 		echar 'v' = '\v'-		echar a = a-	handle n = ("", n)+		echar a = a -- \\ decodes to '\', and \" to '"'+	handle' b = (S.empty, b) -{- Inverse of decode_c. -}-encode_c :: String -> FormatString-encode_c = encode_c' (const False)+{- 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) -{- Encodes special characters, as well as any matching the predicate. -}-encode_c' :: (Char -> Bool) -> String -> FormatString-encode_c' p = concatMap echar+{- 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.   -  - Encoding and then decoding roundtrips only when@@ -198,6 +236,7 @@  - 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
Utility/InodeCache.hs view
@@ -32,6 +32,7 @@ 	inodeCacheToMtime, 	inodeCacheToEpochTime, 	inodeCacheEpochTimeRange,+	replaceInode,  	SentinalFile(..), 	SentinalStatus(..),@@ -50,11 +51,10 @@ 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 @@ 	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 @@  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 @@  - 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
Utility/Metered.hs view
@@ -53,6 +53,7 @@ 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 @@   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 @@ 		, 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
Utility/Misc.hs view
@@ -12,6 +12,7 @@ 	readFileStrict, 	separate, 	separate',+	separateEnd', 	firstLine, 	firstLine', 	segment,@@ -62,6 +63,13 @@ 		| 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 = 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"]] 	]
Utility/Monad.hs view
@@ -12,6 +12,7 @@ 	getM, 	anyM, 	allM,+	partitionM, 	untilTrue, 	ifM, 	(<||>),@@ -44,6 +45,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
Utility/MoveFile.hs view
@@ -14,12 +14,11 @@ ) 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.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 @@ 			-- 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 @@  #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
Utility/Path.hs view
@@ -20,6 +20,7 @@ 	runSegmentPaths', 	dotfile, 	splitShortExtensions,+	splitShortExtensions', 	relPathDirToFileAbs, 	inSearchPath, 	searchPath,@@ -53,7 +54,7 @@  -  - 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 @@  {- 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
Utility/Path/AbsRel.hs view
@@ -37,7 +37,7 @@  - 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.
Utility/Process.hs view
@@ -31,6 +31,7 @@ 	stdoutHandle, 	stderrHandle, 	processHandle,+	showCmd, 	devNull, ) where @@ -188,11 +189,13 @@ 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"
+ Utility/Process/Transcript.hs view
@@ -0,0 +1,97 @@+{- Process transcript+ -+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>+ -+ - 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 ()
Utility/QuickCheck.hs view
@@ -6,6 +6,7 @@  -}  {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-tabs #-} {-# LANGUAGE TypeSynonymInstances #-}  module Utility.QuickCheck
Utility/RawFilePath.hs view
@@ -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 <id@joeyh.name>+ - Copyright 2019-2023 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -27,6 +29,10 @@ 	getCurrentDirectory, 	createDirectory, 	setFileMode,+	setOwnerAndGroup,+	rename,+	createNamedPipe,+	fileAccess, ) where  #ifndef mingw32_HOST_OS@@ -47,23 +53,28 @@  #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 = 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 = 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
+ Utility/SafeOutput.hs view
@@ -0,0 +1,36 @@+{- Safe output to the terminal of possibly attacker-controlled strings,+ - avoiding displaying control characters.+ -+ - Copyright 2023 Joey Hess <id@joeyh.name>+ -+ - 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
Utility/SystemDirectory.hs view
@@ -1,4 +1,4 @@-{- System.Directory without its conflicting isSymbolicLink+{- System.Directory without its conflicting isSymbolicLink and getFileSize.  -  - Copyright 2016 Joey Hess <id@joeyh.name>  -
Utility/Tmp.hs view
@@ -21,12 +21,12 @@ 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 @@ 		_ <- 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. -}
+ Utility/Url/Parse.hs view
@@ -0,0 +1,63 @@+{- Url parsing.+ -+ - Copyright 2011-2023 Joey Hess <id@joeyh.name>+ -+ - 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
Utility/UserInfo.hs view
@@ -19,31 +19,32 @@ #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 = 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)
git-repair.cabal view
@@ -1,5 +1,5 @@ Name: git-repair-Version: 1.20220404+Version: 1.20230814 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <joey@kitenet.net>@@ -26,11 +26,11 @@   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,-    mtl, Cabal, time+    mtl, Cabal (< 4.0), time  source-repository head   type: git@@ -59,7 +59,6 @@     BuildInfo     Build.Configure     Build.TestConfig-    Build.Version     Common     Git     Git.Branch@@ -73,13 +72,13 @@     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 +119,12 @@     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 +134,4 @@     Utility.Tmp.Dir     Utility.Tuple     Utility.UserInfo+    Utility.Url.Parse