packages feed

git-repair 1.20151215 → 1.20161111

raw patch · 49 files changed

+550/−494 lines, 49 filessetup-changed

Files

− .gitignore 
@@ -1,3 +0,0 @@-Build/SysConfig.hs-tags-git-repair
Build/Configure.hs view
@@ -1,5 +1,7 @@ {- Checks system configuration and generates SysConfig.hs. -} +{-# OPTIONS_GHC -fno-warn-tabs #-}+ module Build.Configure where  import System.Environment
Build/TestConfig.hs view
@@ -1,14 +1,16 @@ {- Tests the system and generates Build.SysConfig.hs. -} +{-# OPTIONS_GHC -fno-warn-tabs #-}+ module Build.TestConfig where  import Utility.Path import Utility.Monad import Utility.SafeCommand+import Utility.Directory  import System.IO import System.FilePath-import System.Directory  type ConfigKey = String data ConfigValue =
Build/Version.hs view
@@ -1,24 +1,26 @@ {- Package version determination, for configure script. -} +{-# OPTIONS_GHC -fno-warn-tabs #-}+ module Build.Version where -import Data.Maybe-import Control.Applicative import Data.List import System.Environment-import System.Directory 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 = isJust <$> catchMaybeIO (getEnv "RELEASE_BUILD")+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.@@ -44,7 +46,7 @@ 	 getChangelogVersion :: IO Version getChangelogVersion = do-	changelog <- readFile "debian/changelog"+	changelog <- readFile "CHANGELOG" 	let verline = takeWhile (/= '\n') changelog 	return $ middle (words verline !! 1)   where
− Build/collect-ghc-options.sh 
@@ -1,12 +0,0 @@-#!/bin/sh-# Generate --ghc-options to pass LDFLAGS, CFLAGS, and CPPFLAGS through ghc-# and on to ld, cc, and cpp.-for w in $LDFLAGS; do-	printf -- "-optl%s\n" "$w"-done-for w in $CFLAGS; do-	printf -- "-optc%s\n" "$w"-done-for w in $CPPFLAGS; do-	printf -- "-optc-Wp,%s\n" "$w"-done
− Build/make-sdist.sh 
@@ -1,21 +0,0 @@-#!/bin/sh-#-# Workaround for `cabal sdist` requiring all included files to be listed-# in .cabal.--# Create target directory-sdist_dir=git-repair-$(grep '^Version:' git-repair.cabal | sed -re 's/Version: *//')-mkdir --parents dist/$sdist_dir--find . \( -name .git -or -name dist -or -name cabal-dev \) -prune \-	-or -not -name \\*.orig -not -type d -print \-| perl -ne "print unless length >= 100 - length q{$sdist_dir}" \-| xargs cp --parents --target-directory dist/$sdist_dir--cd dist-tar --format=ustar -caf $sdist_dir.tar.gz $sdist_dir--# Check that tarball can be unpacked by cabal.-# It's picky about tar longlinks etc.-rm -rf $sdist_dir-cabal unpack $sdist_dir.tar.gz
CHANGELOG view
@@ -1,3 +1,16 @@+git-repair (1.20161111) unstable; urgency=medium++  * 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.++ -- Joey Hess <id@joeyh.name>  Fri, 11 Nov 2016 14:56:14 -0400+ git-repair (1.20151215) unstable; urgency=medium    * Fix insecure temporary permissions and potential denial of
Git.hs view
@@ -26,8 +26,10 @@ 	repoDescribe, 	repoLocation, 	repoPath,+	repoWorkTree, 	localGitDir, 	attributes,+	attributesLocal, 	hookPath, 	assertLocal, 	adjustPath,@@ -72,6 +74,10 @@ repoPath Repo { location = LocalUnknown dir } = dir repoPath Repo { location = Unknown } = error "unknown repoPath" +repoWorkTree :: Repo -> Maybe FilePath+repoWorkTree Repo { location = Local { worktree = Just d } } = Just d+repoWorkTree _ = Nothing+ {- Path to a local repository's .git directory. -} localGitDir :: Repo -> FilePath localGitDir Repo { location = Local { gitdir = d } } = d@@ -125,8 +131,11 @@ {- Path to a repository's gitattributes file. -} attributes :: Repo -> FilePath attributes repo-	| repoIsLocalBare repo = repoPath repo ++ "/info/.gitattributes"-	| otherwise = repoPath repo ++ "/.gitattributes"+	| repoIsLocalBare repo = attributesLocal repo+	| otherwise = repoPath repo </> ".gitattributes"++attributesLocal :: Repo -> FilePath+attributesLocal repo = localGitDir repo </> "info" </> "attributes"  {- Path to a given hook script in a repository, only if the hook exists  - and is executable. -}
Git/Branch.hs view
@@ -13,6 +13,7 @@ import Git import Git.Sha import Git.Command+import qualified Git.Config import qualified Git.Ref import qualified Git.BuildVersion @@ -23,7 +24,7 @@  - branch is not created yet. So, this also looks at show-ref HEAD  - to double-check.  -}-current :: Repo -> IO (Maybe Git.Ref)+current :: Repo -> IO (Maybe Branch) current r = do 	v <- currentUnsafe r 	case v of@@ -35,7 +36,7 @@ 				)  {- The current branch, which may not really exist yet. -}-currentUnsafe :: Repo -> IO (Maybe Git.Ref)+currentUnsafe :: Repo -> IO (Maybe Branch) currentUnsafe r = parse . firstLine 	<$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r   where@@ -48,15 +49,25 @@ changed :: Branch -> Branch -> Repo -> IO Bool changed origbranch newbranch repo 	| origbranch == newbranch = return False-	| otherwise = not . null <$> diffs+	| otherwise = not . null+		<$> changed' origbranch newbranch [Param "-n1"] repo   where-	diffs = pipeReadStrict++changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String+changed' origbranch newbranch extraps repo = pipeReadStrict ps repo+  where+	ps = 		[ Param "log" 		, Param (fromRef origbranch ++ ".." ++ fromRef newbranch)-		, Param "-n1" 		, Param "--pretty=%H"-		] repo+		] ++ extraps +{- 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+		<$> changed' origbranch newbranch extraps repo+	 {- Check if it's possible to fast-forward from the old  - ref to the new ref.  -@@ -90,7 +101,7 @@   where 	no_ff = return False 	do_ff to = do-		update branch to repo+		update' branch to repo 		return True 	findbest c [] = return $ Just c 	findbest c (r:rs)@@ -104,27 +115,37 @@ 			(False, True) -> findbest c rs -- worse 			(False, False) -> findbest c rs -- same -{- The user may have set commit.gpgsign, indending all their manual+{- 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.  -} data CommitMode = ManualCommit | AutomaticCommit 	deriving (Eq) +{- Prevent signing automatic commits. -} applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam] applyCommitMode commitmode ps 	| commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") = 		Param "--no-gpg-sign" : ps 	| otherwise = ps +{- Some versions of git commit-tree honor commit.gpgsign themselves,+ - but others need -S to be passed to enable gpg signing of manual commits. -}+applyCommitModeForCommitTree :: CommitMode -> [CommandParam] -> Repo -> [CommandParam]+applyCommitModeForCommitTree commitmode ps r+	| commitmode == ManualCommit =+		case (Git.Config.getMaybe "commit.gpgsign" r) of+			Just s | Git.Config.isTrue s == Just True ->+				Param "-S":ps+			_ -> ps'+	| otherwise = ps'+  where+	ps' = applyCommitMode commitmode ps+ {- Commit via the usual git command. -} commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool commitCommand = commitCommand' runBool -{- Commit will fail when the tree is clean. This suppresses that error. -}-commitQuiet :: CommitMode -> [CommandParam] -> Repo -> IO ()-commitQuiet commitmode ps = void . tryIO . commitCommand' runQuiet commitmode ps- commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> [CommandParam] -> Repo -> IO a commitCommand' runner commitmode ps = runner $ 	Param "commit" : applyCommitMode commitmode ps@@ -144,36 +165,51 @@ 		pipeReadStrict [Param "write-tree"] repo 	ifM (cancommit tree) 		( do-			sha <- getSha "commit-tree" $-				pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) sendmsg repo-			update branch sha repo+			sha <- commitTree commitmode message parentrefs tree repo+			update' branch sha repo 			return $ Just sha 		, return Nothing 		)   where-	ps = applyCommitMode commitmode $-		map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs 	cancommit tree 		| allowempty = return True 		| otherwise = case parentrefs of 			[p] -> maybe False (tree /=) <$> Git.Ref.tree p repo 			_ -> return True-	sendmsg = Just $ flip hPutStr message  commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha commitAlways commitmode message branch parentrefs repo = fromJust 	<$> commit commitmode True message branch parentrefs repo +commitTree :: CommitMode -> String -> [Ref] -> Ref -> Repo -> IO Sha+commitTree commitmode message parentrefs tree repo =+	getSha "commit-tree" $+		pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps)+			sendmsg repo+  where+	sendmsg = Just $ flip hPutStr message+	ps = applyCommitModeForCommitTree commitmode parentparams repo+	parentparams = map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs+ {- A leading + makes git-push force pushing a branch. -} forcePush :: String -> String forcePush b = "+" ++ b -{- Updates a branch (or other ref) to a new Sha. -}-update :: Branch -> Sha -> Repo -> IO ()-update branch sha = run +{- Updates a branch (or other ref) to a new Sha or branch Ref. -}+update :: String -> Branch -> Ref -> Repo -> IO ()+update message branch r = run 	[ Param "update-ref"+	, Param "-m"+	, Param message 	, Param $ fromRef branch-	, Param $ fromRef sha+	, Param $ fromRef r+	]++update' :: Branch -> Ref -> Repo -> IO ()+update' branch r = run+	[ Param "update-ref"+	, Param $ fromRef branch+	, Param $ fromRef r 	]  {- Checks out a branch, creating it if necessary. -}
Git/CatFile.hs view
@@ -1,6 +1,6 @@ {- git cat-file interface  -- - Copyright 2011, 2013 Joey Hess <id@joeyh.name>+ - Copyright 2011-2016 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -13,13 +13,19 @@ 	catFile, 	catFileDetails, 	catTree,+	catCommit, 	catObject, 	catObjectDetails,+	catObjectMetaData, ) where  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.Map as M+import Data.String+import Data.Char import Data.Tuple.Utils import Numeric import System.Posix.Types@@ -32,21 +38,28 @@ import Git.FilePath import qualified Utility.CoProcess as CoProcess -data CatFileHandle = CatFileHandle CoProcess.CoProcessHandle Repo+data CatFileHandle = CatFileHandle +	{ catFileProcess :: CoProcess.CoProcessHandle+	, checkFileProcess :: CoProcess.CoProcessHandle+	}  catFileStart :: Repo -> IO CatFileHandle catFileStart = catFileStart' True  catFileStart' :: Bool -> Repo -> IO CatFileHandle-catFileStart' restartable repo = do-	coprocess <- CoProcess.rawMode =<< gitCoProcessStart restartable+catFileStart' restartable repo = CatFileHandle+	<$> startp "--batch"+	<*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)"+  where+	startp p = gitCoProcessStart restartable 		[ Param "cat-file"-		, Param "--batch"+		, Param p 		] repo-	return $ CatFileHandle coprocess repo  catFileStop :: CatFileHandle -> IO ()-catFileStop (CatFileHandle p _) = CoProcess.stop p+catFileStop h = do+	CoProcess.stop (catFileProcess h)+	CoProcess.stop (checkFileProcess h)  {- Reads a file from a specified branch. -} catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString@@ -63,32 +76,52 @@ catObject h object = maybe L.empty fst3 <$> catObjectDetails h object  catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType))-catObjectDetails (CatFileHandle hdl _) object = CoProcess.query hdl send receive+catObjectDetails h object = query (catFileProcess h) object $ \from -> do+	header <- hGetLine from+	case parseResp object header of+		Just (ParsedResp sha size objtype) -> do+			content <- S.hGet from (fromIntegral size)+			eatchar '\n' from+			return $ Just (L.fromChunks [content], sha, objtype)+		Just DNE -> return Nothing+		Nothing -> error $ "unknown response from git cat-file " ++ show (header, object)   where-	query = fromRef object-	send to = hPutStrLn to query-	receive from = do-		header <- hGetLine from-		case words header of-			[sha, objtype, size]-				| length sha == shaSize ->-					case (readObjectType objtype, reads size) of-						(Just t, [(bytes, "")]) -> readcontent t bytes from sha-						_ -> dne-				| otherwise -> dne-			_-				| header == fromRef object ++ " missing" -> dne-				| otherwise -> error $ "unknown response from git cat-file " ++ show (header, query)-	readcontent objtype bytes from sha = do-		content <- S.hGet from bytes-		eatchar '\n' from-		return $ Just (L.fromChunks [content], Ref sha, objtype)-	dne = return Nothing 	eatchar expected from = do 		c <- hGetChar from 		when (c /= expected) $ 			error $ "missing " ++ (show expected) ++ " from git cat-file" +{- Gets the size and type of an object, without reading its content. -}+catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Integer, ObjectType))+catObjectMetaData h object = query (checkFileProcess h) object $ \from -> do+	resp <- hGetLine from+	case parseResp object resp of+		Just (ParsedResp _ size objtype) ->+			return $ Just (size, objtype)+		Just DNE -> return Nothing+		Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object)++data ParsedResp = ParsedResp Sha Integer ObjectType | DNE++query :: CoProcess.CoProcessHandle -> Ref -> (Handle -> IO a) -> IO a+query hdl object receive = CoProcess.query hdl send receive+  where+	send to = hPutStrLn to (fromRef object)++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 objtype, reads size) of+					(Just t, [(bytes, "")]) -> +						Just $ ParsedResp (Ref sha) bytes t+					_ -> Nothing+			| otherwise -> Nothing+		_ -> Nothing+ {- Gets a list of files and directories in a tree. (Not recursive.) -} catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)] catTree h treeref = go <$> catObjectDetails h treeref@@ -104,10 +137,51 @@ 				(dropsha rest)  	-- these 20 bytes after the NUL hold the file's sha-	-- TODO: convert from raw form to regular sha 	dropsha = L.drop 21  	parsemodefile b =  		let (modestr, file) = separate (== ' ') (decodeBS b) 		in (file, readmode modestr) 	readmode = fromMaybe 0 . fmap fst . headMaybe . readOct++catCommit :: CatFileHandle -> Ref -> IO (Maybe Commit)+catCommit h commitref = go <$> catObjectDetails h commitref+  where+	go (Just (b, _, CommitObject)) = parseCommit b+	go _ = Nothing++parseCommit :: L.ByteString -> Maybe Commit+parseCommit b = Commit+	<$> (extractSha . L8.unpack =<< field "tree")+	<*> Just (maybe [] (mapMaybe (extractSha . L8.unpack)) (fields "parent"))+	<*> (parsemetadata <$> field "author")+	<*> (parsemetadata <$> field "committer")+	<*> Just (L8.unpack $ L.intercalate (L.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++	-- author and committer lines have the form: "name <email> date"+	-- The email is always present, even if empty "<>"+	parsemetadata l = CommitMetaData+		{ commitName = whenset $ L.init name_sp+		, commitEmail = whenset email+		, commitDate = whenset $ L.drop 2 gt_sp_date+		}+	  where+		(name_sp, rest) = L.break (== lt) l+		(email, gt_sp_date) = L.break (== gt) (L.drop 1 rest)+		whenset v+			| L.null v = Nothing+			| otherwise = Just (L8.unpack v)++	nl = fromIntegral (ord '\n')+	sp = fromIntegral (ord ' ')+	lt = fromIntegral (ord '<')+	gt = fromIntegral (ord '>')
Git/Command.hs view
@@ -17,9 +17,11 @@ {- Constructs a git command line operating on the specified repo. -} gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] gitCommandLine params r@(Repo { location = l@(Local { } ) }) =-	setdir : settree ++ gitGlobalOpts r ++ params+	setdir ++ settree ++ gitGlobalOpts r ++ params   where-	setdir = Param $ "--git-dir=" ++ gitdir l+	setdir+		| gitEnvOverridesGitDir r = []+		| otherwise = [Param $ "--git-dir=" ++ gitdir l] 	settree = case worktree l of 		Nothing -> [] 		Just t -> [Param $ "--work-tree=" ++ t]
Git/Construct.hs view
@@ -236,6 +236,7 @@ 	, remotes = [] 	, remoteName = Nothing 	, gitEnv = Nothing+	, gitEnvOverridesGitDir = False 	, gitGlobalOpts = [] 	}
Git/FilePath.hs view
@@ -14,8 +14,10 @@  module Git.FilePath ( 	TopFilePath,-	fromTopFilePath,+	BranchFilePath(..),+	descBranchFilePath, 	getTopFilePath,+	fromTopFilePath, 	toTopFilePath, 	asTopFilePath, 	InternalGitPath,@@ -31,11 +33,18 @@  {- A FilePath, relative to the top of the git repository. -} newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }-	deriving (Show)+	deriving (Show, Eq, Ord) -{- Returns an absolute FilePath. -}+{- A file in a branch or other treeish. -}+data BranchFilePath = BranchFilePath Ref TopFilePath++{- Git uses the branch:file form to refer to a BranchFilePath -}+descBranchFilePath :: BranchFilePath -> String+descBranchFilePath (BranchFilePath b f) = fromRef b ++ ':' : getTopFilePath f++{- Path to a TopFilePath, within the provided git repo. -} fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath-fromTopFilePath p repo = absPathFrom (repoPath repo) (getTopFilePath p)+fromTopFilePath p repo = combine (repoPath repo) (getTopFilePath p)  {- The input FilePath can be absolute, or relative to the CWD. -} toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath
Git/Fsck.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE BangPatterns #-}+ module Git.Fsck ( 	FsckResults(..), 	MissingObjects,@@ -25,8 +27,6 @@ import qualified Data.Set as S import Control.Concurrent.Async -type MissingObjects = S.Set Sha- data FsckResults  	= FsckFoundMissing 		{ missingObjects :: MissingObjects@@ -35,6 +35,25 @@ 	| FsckFailed 	deriving (Show) +data FsckOutput +	= FsckOutput MissingObjects Truncated+	| NoFsckOutput+	| AllDuplicateEntriesWarning++type MissingObjects = S.Set Sha++type Truncated = Bool++instance Monoid FsckOutput where+	mempty = NoFsckOutput+	mappend (FsckOutput s1 t1) (FsckOutput s2 t2) = FsckOutput (S.union s1 s2) (t1 || t2)+	mappend (FsckOutput s t) _ = FsckOutput s t+	mappend _ (FsckOutput s t) = FsckOutput s t+	mappend NoFsckOutput NoFsckOutput = NoFsckOutput+	mappend AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning+	mappend AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning+	mappend NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning+ {- Runs fsck to find some of the broken objects in the repository.  - May not find all broken objects, if fsck fails on bad data in some of  - the broken objects it does find.@@ -58,18 +77,24 @@ 			{ std_out = CreatePipe 			, std_err = CreatePipe 			}-	(bad1, bad2) <- concurrently-		(readMissingObjs maxobjs r supportsNoDangling (stdoutHandle p))-		(readMissingObjs maxobjs r supportsNoDangling (stderrHandle p))+	(o1, o2) <- concurrently+		(parseFsckOutput maxobjs r supportsNoDangling (stdoutHandle p))+		(parseFsckOutput maxobjs r supportsNoDangling (stderrHandle p)) 	fsckok <- checkSuccessProcess pid-	let truncated = S.size bad1 == maxobjs || S.size bad1 == maxobjs-	let badobjs = S.union bad1 bad2--	if S.null badobjs && not fsckok-		then return FsckFailed-		else return $ FsckFoundMissing badobjs truncated+	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   where 	maxobjs = 10000+	noproblem = FsckFoundMissing S.empty False  foundBroken :: FsckResults -> Bool foundBroken FsckFailed = True@@ -87,10 +112,18 @@ findMissing :: [Sha] -> Repo -> IO MissingObjects findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs -readMissingObjs :: Int -> Repo -> Bool -> Handle -> IO MissingObjects-readMissingObjs maxobjs r supportsNoDangling h = do-	objs <- take maxobjs . findShas supportsNoDangling <$> hGetContents h-	findMissing objs r+parseFsckOutput :: Int -> Repo -> Bool -> Handle -> IO FsckOutput+parseFsckOutput maxobjs r supportsNoDangling h = do+	ls <- lines <$> hGetContents h+	if null ls+		then return NoFsckOutput+		else if all ("duplicateEntries" `isInfixOf`) ls+			then return AllDuplicateEntriesWarning+			else do+				let shas = findShas supportsNoDangling ls+				let !truncated = length shas > maxobjs+				missingobjs <- findMissing (take maxobjs shas) r+				return $ FsckOutput missingobjs truncated  isMissing :: Sha -> Repo -> IO Bool isMissing s r = either (const True) (const False) <$> tryIO dump@@ -100,8 +133,8 @@ 		, Param (fromRef s) 		] r -findShas :: Bool -> String -> [Sha]-findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted . lines+findShas :: Bool -> [String] -> [Sha]+findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted   where 	wanted l 		| supportsNoDangling = True
Git/Index.hs view
@@ -14,6 +14,20 @@ indexEnv :: String indexEnv = "GIT_INDEX_FILE" +{- Gets value to set GIT_INDEX_FILE to. Input should be absolute path,+ - or relative to the CWD.+ -+ - When relative, GIT_INDEX_FILE is interpreted by git as being + - relative to the top of the work tree of the git repository,+ - not to the CWD. Worse, other environment variables (GIT_WORK_TREE)+ - or git options (--work-tree) or configuration (core.worktree)+ - can change what the relative path is interpreted relative to.+ -+ - So, an absolute path is the only safe option for this to return.+ -}+indexEnvVal :: FilePath -> IO String+indexEnvVal = absPath+ {- Forces git to use the specified index file.  -  - Returns an action that will reset back to the default@@ -21,10 +35,11 @@  -  - Warning: Not thread safe.  -}-override :: FilePath -> IO (IO ())-override index = do+override :: FilePath -> Repo -> IO (IO ())+override index _r = do 	res <- getEnv var-	setEnv var index True+	val <- indexEnvVal index+	setEnv var val True 	return $ reset res   where 	var = "GIT_INDEX_FILE"
Git/LsTree.hs view
@@ -1,16 +1,19 @@ {- git ls-tree interface  -- - Copyright 2011 Joey Hess <id@joeyh.name>+ - Copyright 2011-2016 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE BangPatterns #-}+ module Git.LsTree ( 	TreeItem(..), 	lsTree,+	lsTree', 	lsTreeParams, 	lsTreeFiles,-	parseLsTree+	parseLsTree, ) where  import Common@@ -26,16 +29,20 @@ data TreeItem = TreeItem 	{ mode :: FileMode 	, typeobj :: String-	, sha :: String+	, sha :: Ref 	, file :: TopFilePath 	} deriving Show  {- Lists the complete contents of a tree, recursing into sub-trees,  - with lazy output. -}-lsTree :: Ref -> Repo -> IO [TreeItem]-lsTree t repo = map parseLsTree-	<$> pipeNullSplitZombie (lsTreeParams t []) repo+lsTree :: Ref -> Repo -> IO ([TreeItem], IO Bool)+lsTree = lsTree' [] +lsTree' :: [CommandParam] -> Ref -> Repo -> IO ([TreeItem], IO Bool)+lsTree' ps t repo = do+	(l, cleanup) <- pipeNullSplit (lsTreeParams t ps) repo+	return (map parseLsTree l, cleanup)+ lsTreeParams :: Ref -> [CommandParam] -> [CommandParam] lsTreeParams r ps = 	[ Param "ls-tree"@@ -63,16 +70,18 @@  - (The --long format is not currently supported.) -} parseLsTree :: String -> TreeItem parseLsTree l = TreeItem -	{ mode = fst $ Prelude.head $ readOct m+	{ mode = smode 	, typeobj = t-	, sha = s-	, file = asTopFilePath $ Git.Filename.decode f+	, sha = Ref s+	, file = sfile 	}   where 	-- l = <mode> SP <type> SP <sha> TAB <file> 	-- All fields are fixed, so we can pull them out of 	-- specific positions in the line. 	(m, past_m) = splitAt 7 l-	(t, past_t) = splitAt 4 past_m-	(s, past_s) = splitAt shaSize $ Prelude.tail past_t-	f = Prelude.tail past_s+	(!t, past_t) = splitAt 4 past_m+	(!s, past_s) = splitAt shaSize $ Prelude.tail past_t+	!f = Prelude.tail past_s+	!smode = fst $ Prelude.head $ readOct m+	!sfile = asTopFilePath $ Git.Filename.decode f
Git/Ref.hs view
@@ -18,24 +18,26 @@ headRef :: Ref headRef = Ref "HEAD" +headFile :: Repo -> FilePath+headFile r = localGitDir r </> "HEAD"++setHeadRef :: Ref -> Repo -> IO ()+setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref)+ {- Converts a fully qualified git ref into a user-visible string. -} describe :: Ref -> String describe = fromRef . base -{- Often git refs are fully qualified (eg: refs/heads/master).- - Converts such a fully qualified ref into a base ref (eg: master). -}+{- Often git refs are fully qualified + - (eg refs/heads/master or refs/remotes/origin/master).+ - Converts such a fully qualified ref into a base ref+ - (eg: master or origin/master). -} base :: Ref -> Ref base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef   where 	remove prefix s 		| prefix `isPrefixOf` s = drop (length prefix) s 		| otherwise = s--{- Given a directory and any ref, takes the basename of the ref and puts- - it under the directory. -}-under :: String -> Ref -> Ref-under dir r = Ref $ dir ++ "/" ++-	(reverse $ takeWhile (/= '/') $ reverse $ fromRef r)  {- Given a directory such as "refs/remotes/origin", and a ref such as  - refs/heads/master, yields a version of that ref under the directory,
Git/Repair.hs view
@@ -342,8 +342,8 @@ 	| S.member treesha missing = return False 	| otherwise = do 		(ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams treesha []) r-		let objshas = map (extractSha . LsTree.sha . LsTree.parseLsTree) ls-		if any isNothing objshas || any (`S.member` missing) (catMaybes objshas)+		let objshas = map (LsTree.sha . LsTree.parseLsTree) ls+		if any (`S.member` missing) objshas 			then do 				void cleanup 				return False
Git/Types.hs view
@@ -11,7 +11,6 @@ import qualified Data.Map as M import System.Posix.Types import Utility.SafeCommand-import Utility.URI ()  {- Support repositories on local disk, and repositories accessed via an URL.  -@@ -40,6 +39,7 @@ 	, remoteName :: Maybe RemoteName 	-- alternate environment to use when running git commands 	, gitEnv :: Maybe [(String, String)]+	, gitEnvOverridesGitDir :: Bool 	-- global options to pass to git when running git commands 	, gitGlobalOpts :: [CommandParam] 	} deriving (Show, Eq, Ord)@@ -98,3 +98,24 @@ toBlobType 0o100755 = Just ExecutableBlob toBlobType 0o120000 = Just SymlinkBlob toBlobType _ = Nothing++fromBlobType :: BlobType -> FileMode+fromBlobType FileBlob = 0o100644+fromBlobType ExecutableBlob = 0o100755+fromBlobType SymlinkBlob = 0o120000++data Commit = Commit+	{ commitTree :: Sha+	, commitParent :: [Sha]+	, commitAuthorMetaData :: CommitMetaData+	, commitCommitterMetaData :: CommitMetaData+	, commitMessage :: String+	}+	deriving (Show)++data CommitMetaData = CommitMetaData+	{ commitName :: Maybe String+	, commitEmail :: Maybe String+	, commitDate :: Maybe String -- In raw git form, "epoch -tzoffset"+	}+	deriving (Show)
− Makefile 
@@ -1,34 +0,0 @@-PREFIX=/usr-CABAL?=cabal # set to "./Setup" if you lack a cabal program--build: Build/SysConfig.hs-	$(CABAL) build-	ln -sf dist/build/git-repair/git-repair git-repair-	@$(MAKE) tags >/dev/null 2>&1 &--Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs-	if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi-	$(CABAL) configure --ghc-options="$(shell Build/collect-ghc-options.sh)"--install: build-	install -d $(DESTDIR)$(PREFIX)/bin-	install git-repair $(DESTDIR)$(PREFIX)/bin-	install -d $(DESTDIR)$(PREFIX)/share/man/man1-	install -m 0644 git-repair.1 $(DESTDIR)$(PREFIX)/share/man/man1--clean:-	rm -rf git-repair git-repair-test.log \-		dist configure Build/SysConfig.hs Setup tags-	find . -name \*.o -exec rm {} \;-	find . -name \*.hi -exec rm {} \;--# Upload to hackage.-hackage: clean-	./Build/make-sdist.sh-	@cabal upload dist/*.tar.gz--# hothasktags chokes on some template haskell etc, so ignore errors-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--.PHONY: tags
Setup.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fno-warn-tabs #-}+ {- cabal setup file -}  import Distribution.Simple
Utility/CoProcess.hs view
@@ -13,7 +13,6 @@ 	start, 	stop, 	query,-	rawMode ) where  import Common@@ -44,7 +43,15 @@ start' :: CoProcessSpec -> IO CoProcessState start' s = do 	(pid, from, to) <- startInteractiveProcess (coProcessCmd s) (coProcessParams s) (coProcessEnv s)+	rawMode from+	rawMode to 	return $ CoProcessState pid to from s+  where+	rawMode h = do+		fileEncoding h+#ifdef mingw32_HOST_OS+		hSetNewlineMode h noNewlineTranslation+#endif  stop :: CoProcessHandle -> IO () stop ch = do@@ -79,16 +86,3 @@ 			{ coProcessNumRestarts = coProcessNumRestarts (coProcessSpec s) - 1 } 		putMVar ch s' 		query ch send receive--rawMode :: CoProcessHandle -> IO CoProcessHandle-rawMode ch = do-	s <- readMVar ch-	raw $ coProcessFrom s-	raw $ coProcessTo s-	return ch-  where-	raw h = do-		fileEncoding h-#ifdef mingw32_HOST_OS-		hSetNewlineMode h noNewlineTranslation-#endif
Utility/Directory.hs view
@@ -8,10 +8,12 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Directory where+module Utility.Directory (+	module Utility.Directory,+	module Utility.SystemDirectory+) where  import System.IO.Error-import System.Directory import Control.Monad import System.FilePath import Control.Applicative@@ -28,6 +30,7 @@ import Control.Monad.IfElse #endif +import Utility.SystemDirectory import Utility.PosixFiles import Utility.Tmp import Utility.Exception@@ -134,11 +137,13 @@ 				_ <- 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.
Utility/Exception.hs view
@@ -5,7 +5,7 @@  - License: BSD-2-clause  -} -{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Exception (@@ -21,12 +21,18 @@ 	tryNonAsync, 	tryWhenExists, 	catchIOErrorType,-	IOErrorType(..)+	IOErrorType(..),+	catchPermissionDenied, ) where  import Control.Monad.Catch as X hiding (Handler) import qualified Control.Monad.Catch as M import Control.Exception (IOException, AsyncException)+#ifdef MIN_VERSION_GLASGOW_HASKELL+#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)+import Control.Exception (SomeAsyncException)+#endif+#endif import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError, ioeGetErrorType)@@ -73,6 +79,11 @@ catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchNonAsync a onerr = a `catches` 	[ M.Handler (\ (e :: AsyncException) -> throwM e)+#ifdef MIN_VERSION_GLASGOW_HASKELL+#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)+	, M.Handler (\ (e :: SomeAsyncException) -> throwM e)+#endif+#endif 	, M.Handler (\ (e :: SomeException) -> onerr e) 	] @@ -97,3 +108,6 @@ 	onlymatching e 		| ioeGetErrorType e == errtype = onmatchingerr e 		| otherwise = throwM e++catchPermissionDenied :: MonadCatch m => (IOException -> m a) -> m a -> m a+catchPermissionDenied = catchIOErrorType PermissionDenied
Utility/FileMode.hs view
@@ -18,9 +18,10 @@ import Utility.PosixFiles #ifndef mingw32_HOST_OS import System.Posix.Files+import Control.Monad.IO.Class (liftIO) #endif+import Control.Monad.IO.Class (MonadIO) import Foreign (complement)-import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Catch  import Utility.Exception
Utility/FileSize.hs view
@@ -13,13 +13,15 @@ import System.IO #endif +type FileSize = Integer+ {- Gets the size of a file.  -  - This is better than using fileSize, because on Windows that returns a  - FileOffset which maxes out at 2 gb.  - See https://github.com/jystic/unix-compat/issues/16  -}-getFileSize :: FilePath -> IO Integer+getFileSize :: FilePath -> IO FileSize #ifndef mingw32_HOST_OS getFileSize f = fmap (fromIntegral . fileSize) (getFileStatus f) #else@@ -27,7 +29,7 @@ #endif  {- Gets the size of the file, when its FileStatus is already known. -}-getFileSize' :: FilePath -> FileStatus -> IO Integer+getFileSize' :: FilePath -> FileStatus -> IO FileSize #ifndef mingw32_HOST_OS getFileSize' _ s = return $ fromIntegral $ fileSize s #else
Utility/FileSystemEncoding.hs view
@@ -19,6 +19,7 @@ 	encodeW8NUL, 	decodeW8NUL, 	truncateFilePath,+	setConsoleEncoding, ) where  import qualified GHC.Foreign as GHC@@ -164,3 +165,10 @@ 					else go (c:coll) (cnt - x') (L8.drop 1 bs) 			_ -> coll #endif++{- This avoids ghc's output layer crashing on invalid encoded characters in+ - filenames when printing them out. -}+setConsoleEncoding :: IO ()+setConsoleEncoding = do+	fileEncoding stdout+	fileEncoding stderr
Utility/Format.hs view
@@ -103,7 +103,7 @@ {- Decodes a C-style encoding, where \n is a newline, \NNN is an octal  - encoded character, and \xNN is a hex encoded character.  -}-decode_c :: FormatString -> FormatString+decode_c :: FormatString -> String decode_c [] = [] decode_c s = unescape ("", s)   where@@ -141,14 +141,14 @@ 	handle n = ("", n)  {- Inverse of decode_c. -}-encode_c :: FormatString -> FormatString+encode_c :: String -> FormatString encode_c = encode_c' (const False)  {- Encodes more strictly, including whitespace. -}-encode_c_strict :: FormatString -> FormatString+encode_c_strict :: String -> FormatString encode_c_strict = encode_c' isSpace -encode_c' :: (Char -> Bool) -> FormatString -> FormatString+encode_c' :: (Char -> Bool) -> String -> FormatString encode_c' p = concatMap echar   where 	e c = '\\' : [c]
Utility/Metered.hs view
@@ -1,6 +1,6 @@ {- Metered IO and actions  -- - Copyright 2012-2105 Joey Hess <id@joeyh.name>+ - Copyright 2012-2106 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -21,6 +21,8 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Monad.IO.Class (MonadIO)+import Data.Time.Clock+import Data.Time.Clock.POSIX  {- An action that can be run repeatedly, updating it on the bytes processed.  -@@ -259,3 +261,24 @@   where 	p = (proc cmd (toCommand params)) 		{ env = environ }++-- | Limit a meter to only update once per unit of time.+--+-- It's nice to display the final update to 100%, even if it comes soon+-- after a previous update. To make that happen, a total size has to be+-- provided.+rateLimitMeterUpdate :: NominalDiffTime -> Maybe Integer -> MeterUpdate -> IO MeterUpdate+rateLimitMeterUpdate delta totalsize meterupdate = do+	lastupdate <- newMVar (toEnum 0 :: POSIXTime)+	return $ mu lastupdate+  where+	mu lastupdate n@(BytesProcessed i) = case totalsize of+		Just t | i >= t -> meterupdate n+		_ -> do+			now <- getPOSIXTime+			prev <- takeMVar lastupdate+			if now - prev >= delta+				then do+					putMVar lastupdate now+					meterupdate n+				else putMVar lastupdate prev
Utility/Path.hs view
@@ -12,7 +12,6 @@  import Data.String.Utils import System.FilePath-import System.Directory import Data.List import Data.Maybe import Data.Char@@ -29,6 +28,7 @@ import qualified "MissingH" System.Path as MissingH import Utility.Monad import Utility.UserInfo+import Utility.Directory  {- Simplifies a path, removing any "." component, collapsing "dir/..",   - and removing the trailing path separator.@@ -60,7 +60,7 @@ {- Makes a path absolute.  -  - The first parameter is a base directory (ie, the cwd) to use if the path- - is not already absolute.+ - is not already absolute, and should itsef be absolute.  -  - Does not attempt to deal with edge cases or ensure security with  - untrusted inputs.@@ -252,15 +252,21 @@   where 	f = takeFileName file -{- Converts a DOS style path to a Cygwin style path. Only on Windows.- - Any trailing '\' is preserved as a trailing '/' -}-toCygPath :: FilePath -> FilePath+{- Converts a DOS style path to a msys2 style path. Only on Windows.+ - Any trailing '\' is preserved as a trailing '/' + - + - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i+ -+ - The virtual filesystem contains:+ -  /c, /d, ...	mount points for Windows drives+ -}+toMSYS2Path :: FilePath -> FilePath #ifndef mingw32_HOST_OS-toCygPath = id+toMSYS2Path = id #else-toCygPath p+toMSYS2Path p 	| null drive = recombine parts-	| otherwise = recombine $ "/cygdrive" : driveletter drive : parts+	| otherwise = recombine $ "/" : driveletter drive : parts   where 	(drive, p') = splitDrive p 	parts = splitDirectories p'
Utility/PosixFiles.hs view
@@ -1,6 +1,6 @@ {- POSIX files (and compatablity wrappers).  -- - This is like System.PosixCompat.Files, except with a fixed rename.+ - This is like System.PosixCompat.Files, but with a few fixes.  -  - Copyright 2014 Joey Hess <id@joeyh.name>  -@@ -21,6 +21,7 @@ import System.Posix.Files (rename) #else import qualified System.Win32.File as Win32+import qualified System.Win32.HardLink as Win32 #endif  {- System.PosixCompat.Files.rename on Windows calls renameFile,@@ -31,4 +32,11 @@ #ifdef mingw32_HOST_OS rename :: FilePath -> FilePath -> IO () rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING+#endif++{- System.PosixCompat.Files.createLink throws an error, but windows+ - does support hard links. -}+#ifdef mingw32_HOST_OS+createLink :: FilePath -> FilePath -> IO ()+createLink = Win32.createHardLink #endif
Utility/Process.hs view
@@ -18,6 +18,7 @@ 	readProcessEnv, 	writeReadProcessEnv, 	forceSuccessProcess,+	forceSuccessProcess', 	checkSuccessProcess, 	ignoreFailureProcess, 	createProcessSuccess,@@ -129,11 +130,12 @@ -- | Waits for a ProcessHandle, and throws an IOError if the process -- did not exit successfully. forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO ()-forceSuccessProcess p pid = do-	code <- waitForProcess pid-	case code of-		ExitSuccess -> return ()-		ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n+forceSuccessProcess p pid = waitForProcess pid >>= forceSuccessProcess' p++forceSuccessProcess' :: CreateProcess -> ExitCode -> IO ()+forceSuccessProcess' _ ExitSuccess = return ()+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
Utility/QuickCheck.hs view
@@ -6,7 +6,7 @@  -}  {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeSynonymInstances, CPP #-}  module Utility.QuickCheck 	( module X@@ -16,16 +16,20 @@ import Test.QuickCheck as X import Data.Time.Clock.POSIX import System.Posix.Types+#if ! MIN_VERSION_QuickCheck(2,8,2) import qualified Data.Map as M import qualified Data.Set as S+#endif import Control.Applicative import Prelude -instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where+#if ! MIN_VERSION_QuickCheck(2,8,2)+instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) where 	arbitrary = M.fromList <$> arbitrary -instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where+instance (Arbitrary v, Ord v) => Arbitrary (S.Set v) where 	arbitrary = S.fromList <$> arbitrary+#endif  {- Times before the epoch are excluded. -} instance Arbitrary POSIXTime where
Utility/Rsync.hs view
@@ -54,16 +54,16 @@ rsync :: [CommandParam] -> IO Bool rsync = boolSystem "rsync" . rsyncParamsFixup -{- On Windows, rsync is from Cygwin, and expects to get Cygwin formatted+{- On Windows, rsync is from msys2, and expects to get msys2 formatted  - paths to files. (It thinks that C:foo refers to a host named "C").  - Fix up the Params appropriately. -} rsyncParamsFixup :: [CommandParam] -> [CommandParam] #ifdef mingw32_HOST_OS rsyncParamsFixup = map fixup   where-	fixup (File f) = File (toCygPath f)+	fixup (File f) = File (toMSYS2Path f) 	fixup (Param s)-		| rsyncUrlIsPath s = Param (toCygPath s)+		| rsyncUrlIsPath s = Param (toMSYS2Path s) 	fixup p = p #else rsyncParamsFixup = id
+ Utility/SystemDirectory.hs view
@@ -0,0 +1,16 @@+{- System.Directory without its conflicting isSymbolicLink+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++-- Disable warnings because only some versions of System.Directory export+-- isSymbolicLink.+{-# OPTIONS_GHC -fno-warn-tabs -w #-}++module Utility.SystemDirectory (+	module System.Directory+) where++import System.Directory hiding (isSymbolicLink)
Utility/Tmp.hs view
@@ -11,9 +11,9 @@ module Utility.Tmp where  import System.IO-import System.Directory import Control.Monad.IfElse import System.FilePath+import System.Directory import Control.Monad.IO.Class #ifndef mingw32_HOST_OS import System.Posix.Temp (mkdtemp)
Utility/UserInfo.hs view
@@ -15,18 +15,17 @@ ) where  import Utility.Env+import Utility.Data  import System.PosixCompat-#ifndef mingw32_HOST_OS import Control.Applicative-#endif import Prelude  {- Current user's home directory.  -  - getpwent will fail on LDAP or NIS, so use HOME if set. -} myHomeDir :: IO FilePath-myHomeDir = myVal env homeDirectory+myHomeDir = either error return =<< myVal env homeDirectory   where #ifndef mingw32_HOST_OS 	env = ["HOME"]@@ -35,7 +34,7 @@ #endif  {- Current user's user name. -}-myUserName :: IO String+myUserName :: IO (Either String String) myUserName = myVal env userName   where #ifndef mingw32_HOST_OS@@ -49,15 +48,15 @@ #if defined(__ANDROID__) || defined(mingw32_HOST_OS) myUserGecos = return Nothing #else-myUserGecos = Just <$> myVal [] userGecos+myUserGecos = eitherToMaybe <$> myVal [] userGecos #endif -myVal :: [String] -> (UserEntry -> String) -> IO String+myVal :: [String] -> (UserEntry -> String) -> IO (Either String String) myVal envvars extract = go envvars   where #ifndef mingw32_HOST_OS-	go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID)+	go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID) #else-	go [] = error $ "environment not set: " ++ show envvars+	go [] = return $ Left ("environment not set: " ++ show envvars) #endif-	go (v:vs) = maybe (go vs) return =<< getEnv v+	go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v
− configure.hs 
@@ -1,6 +0,0 @@-{- configure program -}--import Build.Configure--main :: IO ()-main = run tests
− debian/changelog 
@@ -1,105 +0,0 @@-git-repair (1.20151215) unstable; urgency=medium--  * Fix insecure temporary permissions and potential denial of-    service attack when creating temp dirs. Closes: #807341-  * Merge from git-annex.-- -- Joey Hess <id@joeyh.name>  Tue, 15 Dec 2015 20:47:59 -0400--git-repair (1.20150106) unstable; urgency=medium--  * Debian package is now maintained by Richard Hartmann.-  * Fix build with process 1.2.1.0.-  * Merge from git-annex.-- -- Joey Hess <id@joeyh.name>  Tue, 06 Jan 2015 19:09:23 -0400--git-repair (1.20141027) unstable; urgency=medium--  * Adjust cabal file to support network-uri split.-  * Merge Build/ from git-annex, including removing a use of deprecated-    System.Cmd.-- -- Joey Hess <joeyh@debian.org>  Mon, 27 Oct 2014 11:09:56 -0400--git-repair (1.20141026) unstable; urgency=medium--  * Prevent auto gc from happening when fetching from a remote.-  * Merge from git-annex.-- -- Joey Hess <joeyh@debian.org>  Sun, 26 Oct 2014 13:37:30 -0400--git-repair (1.20140914) unstable; urgency=medium--  * Update to build with optparse-applicative 0.10. Closes: #761552-- -- Joey Hess <joeyh@debian.org>  Sun, 14 Sep 2014 12:48:27 -0400--git-repair (1.20140815) unstable; urgency=medium--  * Removing bad objects could leave fsck finding no more unreachable objects,-    but some branches no longer accessible. Fix this, including support for-    fixing up repositories that were incompletely repaired before.-  * Merge from git-annex.-- -- Joey Hess <joeyh@debian.org>  Fri, 15 Aug 2014 13:49:09 -0400--git-repair (1.20140423) unstable; urgency=medium--  * Improve memory usage when git fsck finds a great many broken objects.-  * Merge from git-annex.-- -- Joey Hess <joeyh@debian.org>  Wed, 23 Apr 2014 14:01:30 -0400--git-repair (1.20140227) unstable; urgency=medium--  * Optimise unpacking of pack files, and avoid repeated error-    messages about corrupt pack files.-  * Add swapping 2 files test case.-- -- Joey Hess <joeyh@debian.org>  Thu, 27 Feb 2014 11:56:27 -0400--git-repair (1.20140115) unstable; urgency=medium--  * Support old git versions from before git fsck --no-dangling was-    implemented.-  * Fix bug in packed refs file exploding code that caused a .gitrefs-    directory to be created instead of .git/refs-  * Check git version at run time.-- -- Joey Hess <joeyh@debian.org>  Wed, 15 Jan 2014 16:53:30 -0400--git-repair (1.20131213) unstable; urgency=low--  * Improve repair of index files in some situations.-- -- Joey Hess <joeyh@debian.org>  Fri, 13 Dec 2013 14:51:51 -0400--git-repair (1.20131203) unstable; urgency=low--  * Fix build deps. Closes: #731179-- -- Joey Hess <joeyh@debian.org>  Tue, 03 Dec 2013 15:02:21 -0400--git-repair (1.20131122) unstable; urgency=low--  * Added test mode, which can be used to randomly corrupt test -    repositories, in reproducible ways, which allows easy-    corruption-driven-development.-  * Improve repair code in the case where the index file is corrupt,-    and this hides other problems.-  * Write a dummy .git/HEAD if the file is missing or corrupt, as-    git otherwise will not treat the repository as a git repo.-  * Improve fsck code to find badly corrupted objects that crash git fsck-    before it can complain about them.-  * Fixed crashes on bad file encodings.-  * Can now run 10000 tests (git-repair --test -n 10000 --force)-    with 0 failures.-- -- Joey Hess <joeyh@debian.org>  Fri, 22 Nov 2013 11:16:03 -0400--git-repair (1.20131118) unstable; urgency=low--  * First release-- -- Joey Hess <joeyh@debian.org>  Mon, 18 Nov 2013 13:38:12 -0400
− debian/compat 
@@ -1,1 +0,0 @@-9
− debian/control 
@@ -1,36 +0,0 @@-Source: git-repair-Section: utils-Priority: optional-Build-Depends: -	debhelper (>= 9),-	ghc,-	git,-	libghc-missingh-dev,-	libghc-hslogger-dev,-	libghc-network-dev,-	libghc-exceptions-dev (>= 0.6),-	libghc-transformers-dev,-	libghc-unix-compat-dev,-	libghc-ifelse-dev,-	libghc-text-dev,-	libghc-quickcheck2-dev,-	libghc-utf8-string-dev,-	libghc-async-dev,-	libghc-optparse-applicative-dev (>= 0.10.0)-Maintainer: Richard Hartmann <richih@debian.org>-Standards-Version: 3.9.5-Vcs-Git: git://git-repair.branchable.com/-Homepage: http://git-repair.branchable.com/--Package: git-repair-Architecture: any-Section: utils-Depends: ${misc:Depends}, ${shlibs:Depends}, git, rsync-Description: repair various forms of damage to git repositories- git-repair can repair various forms of damage to git repositories.- .- It is a complement to git fsck, which finds problems, but does not fix them.- .- As well as avoiding the need to rm -rf a damaged repository and re-clone,- using git-repair can help rescue commits you've made to the damaged- repository and not yet pushed out.
− debian/copyright 
@@ -1,35 +0,0 @@-Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/-Source: native package--Files: *-Copyright: © 2013 Joey Hess <joey@kitenet.net>-License: GPL-3+- The full text of version 3 of the GPL is distributed as doc/GPL in- this package's source, or in /usr/share/common-licenses/GPL-3 on- Debian systems.--Files: Utility/*-Copyright: 2012-2014 Joey Hess <joey@kitenet.net>-License: BSD-2-clause--License: BSD-2-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.- .- THIS SOFTWARE IS PROVIDED BY AUTHORS AND 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.
− debian/git-repair.lintian-overrides 
@@ -1,1 +0,0 @@-binary-or-shlib-defines-rpath
− debian/manpages 
@@ -1,1 +0,0 @@-git-repair.1
− debian/rules 
@@ -1,10 +0,0 @@-#!/usr/bin/make -f--# Avoid using cabal, as it writes to $HOME-export CABAL=./Setup--# Do use the changelog's version number, rather than making one up.-export RELEASE_BUILD=1--%:-	dh $@
− doc/index.mdwn 
@@ -1,55 +0,0 @@-`git-repair` can repair various forms of damage to git repositories.--It is a complement to `git fsck`, which finds problems, but does not fix-them.--As well as avoiding the need to rm -rf a damaged repository and re-clone,-using git-repair can help rescue commits you've made to the damaged-repository and not yet pushed out.--## download--* `git clone git://git-repair.branchable.com/ git-repair`-* from [Hackage](http://hackage.haskell.org/package/git-repair)--## install--This is a Haskell program, developed as a spinoff of-[git-annex](http://git-annex.branchable.com/).--To build it, you will need to install the-[Haskell Platform](http://www.haskell.org/platform/).--Then to install it:--	cabal update; cabal install git-repair --bindir=$HOME/bin--## how it works--`git-repair` starts by deleting all corrupt objects, and-retreiving 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-reset branches back to commits before the corruption happened, delete-branches that are no longer available due to the lost data, and remove any-missing files from the index. It will only do this if run with the-`--force` option, since that rewrites history and throws out missing data.--After running this command, you will probably want to run `git fsck` to-verify it fixed the repository.--Note that fsck may still complain about objects referenced by the reflog,-or the stash, if they were unable to be recovered. This command does not-try to clean up either the reflog or the stash. --Also note that the `--force` option never touches tags, even if they are no-longer usable due to missing data, so fsck may also find problems with-tags.--Since this command unpacks all packs in the repository, you may want to-run `git gc` afterwards.--## news--[[!inline pages="news/* and !*/Discussion" show="4" archive=yes]]
− doc/news/version_1.20141027.mdwn 
@@ -1,1 +0,0 @@-git-repair 1.20140613 released
− doc/news/version_1.20151215.mdwn 
@@ -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."""]]
git-repair.cabal view
@@ -1,5 +1,5 @@ Name: git-repair-Version: 1.20151215+Version: 1.20161111 Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess <joey@kitenet.net>@@ -7,7 +7,6 @@ Stability: Stable Copyright: 2013 Joey Hess License-File: GPL-Extra-Source-Files: CHANGELOG Build-Type: Custom Homepage: http://git-repair.branchable.com/ Category: Utility@@ -21,11 +20,24 @@  As well as avoiding the need to rm -rf a damaged repository and re-clone,  using git-repair can help rescue commits you've made to the damaged  repository and not yet pushed out.+Extra-Source-Files:+  CHANGELOG+  TODO+  git-repair.1  Flag network-uri   Description: Get Network.URI from the network-uri package   Default: True +custom-setup+  Setup-Depends: base (>= 4.5), hslogger, MissingH, unix-compat, process,+    unix, filepath, exceptions, bytestring, directory, IfElse, data-default,+    Cabal++source-repository head+  type: git+  location: git://git-repair.branchable.com/+ Executable git-repair   Main-Is: git-repair.hs   GHC-Options: -threaded -Wall -fno-warn-tabs@@ -44,6 +56,62 @@   else     Build-Depends: unix -source-repository head-  type: git-  location: git://git-repair.branchable.com/+  Other-Modules:+    Build.Configure+    Build.TestConfig+    Build.Version+    Common+    Git+    Git.Branch+    Git.BuildVersion+    Git.CatFile+    Git.Command+    Git.Config+    Git.Construct+    Git.CurrentRepo+    Git.Destroyer+    Git.DiffTreeItem+    Git.FilePath+    Git.Filename+    Git.Fsck+    Git.Index+    Git.LsFiles+    Git.LsTree+    Git.Objects+    Git.Ref+    Git.RefLog+    Git.Remote+    Git.Repair+    Git.Sha+    Git.Types+    Git.UpdateIndex+    Git.Url+    Git.Version+    Utility.Applicative+    Utility.Batch+    Utility.CoProcess+    Utility.Data+    Utility.Directory+    Utility.DottedVersion+    Utility.Env+    Utility.Exception+    Utility.FileMode+    Utility.FileSize+    Utility.FileSystemEncoding+    Utility.Format+    Utility.Metered+    Utility.Misc+    Utility.Monad+    Utility.PartialPrelude+    Utility.Path+    Utility.PosixFiles+    Utility.Process+    Utility.Process.Shim+    Utility.QuickCheck+    Utility.Rsync+    Utility.SafeCommand+    Utility.SystemDirectory+    Utility.ThreadScheduler+    Utility.Tmp+    Utility.URI+    Utility.UserInfo