packages feed

git-repair 1.20150106 → 1.20151215

raw patch · 62 files changed

+792/−363 lines, 62 files

Files

+ Build/collect-ghc-options.sh view
@@ -0,0 +1,12 @@+#!/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
CHANGELOG view
@@ -1,6 +1,14 @@+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 Gergely Nagy.+  * Debian package is now maintained by Richard Hartmann.   * Fix build with process 1.2.1.0.   * Merge from git-annex.
Common.hs view
@@ -30,6 +30,7 @@ import Utility.Data as X import Utility.Applicative as X import Utility.FileSystemEncoding as X-import Utility.PosixFiles as X+import Utility.PosixFiles as X hiding (fileSize)+import Utility.FileSize as X  import Utility.PartialPrelude as X
Git.hs view
@@ -3,7 +3,7 @@  - This is written to be completely independant of git-annex and should be  - suitable for other uses.  -- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -60,7 +60,7 @@ repoLocation Repo { location = Local { worktree = Just dir } } = dir repoLocation Repo { location = Local { gitdir = dir } } = dir repoLocation Repo { location = LocalUnknown dir } = dir-repoLocation Repo { location = Unknown } = undefined+repoLocation Repo { location = Unknown } = error "unknown repoLocation"  {- Path to a repository. For non-bare, this is the worktree, for bare,   - it's the gitdir, and for URL repositories, is the path on the remote@@ -70,12 +70,12 @@ 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 } = undefined+repoPath Repo { location = Unknown } = error "unknown repoPath"  {- Path to a local repository's .git directory. -} localGitDir :: Repo -> FilePath localGitDir Repo { location = Local { gitdir = d } } = d-localGitDir _ = undefined+localGitDir _ = error "unknown localGitDir"  {- Some code needs to vary between URL and normal repos,  - or bare and non-bare, these functions help with that. -}
Git/Branch.hs view
@@ -1,6 +1,6 @@ {- git branch stuff  -- - Copyright 2011 Joey Hess <joey@kitenet.net>+ - Copyright 2011 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -37,14 +37,11 @@ {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Git.Ref) currentUnsafe r = parse . firstLine-	<$> pipeReadStrict [Param "symbolic-ref", Param $ fromRef Git.Ref.headRef] r+	<$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r   where 	parse l 		| null l = Nothing 		| otherwise = Just $ Git.Ref l--currentSha :: Repo -> IO (Maybe Git.Sha)-currentSha r = maybe (pure Nothing) (`Git.Ref.sha` r) =<< current r  {- Checks if the second branch has any commits not present on the first  - branch. -}
Git/BuildVersion.hs view
@@ -1,6 +1,6 @@ {- git build version  -- - Copyright 2011 Joey Hess <joey@kitenet.net>+ - Copyright 2011 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}
Git/CatFile.hs view
@@ -1,6 +1,6 @@ {- git cat-file interface  -- - Copyright 2011, 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2011, 2013 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -110,4 +110,4 @@ 	parsemodefile b =  		let (modestr, file) = separate (== ' ') (decodeBS b) 		in (file, readmode modestr)-	readmode = fst . fromMaybe (0, undefined) . headMaybe . readOct+	readmode = fromMaybe 0 . fmap fst . headMaybe . readOct
Git/Command.hs view
@@ -1,6 +1,6 @@ {- running git commands  -- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2013 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -16,7 +16,7 @@  {- Constructs a git command line operating on the specified repo. -} gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]-gitCommandLine params r@(Repo { location = l@(Local _ _ ) }) =+gitCommandLine params r@(Repo { location = l@(Local { } ) }) = 	setdir : settree ++ gitGlobalOpts r ++ params   where 	setdir = Param $ "--git-dir=" ++ gitdir l
Git/Config.hs view
@@ -1,6 +1,6 @@ {- git repository configuration handling  -- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -14,6 +14,7 @@ import Git import Git.Types import qualified Git.Construct+import qualified Git.Command import Utility.UserInfo  {- Returns a single git config setting, or a default value if not set. -}@@ -66,10 +67,9 @@ 	home <- myHomeDir 	ifM (doesFileExist $ home </> ".gitconfig") 		( do-			repo <- Git.Construct.fromUnknown-			repo' <- withHandle StdoutHandle createProcessSuccess p $-				hRead repo-			return $ Just repo'+			repo <- withHandle StdoutHandle createProcessSuccess p $+				hRead (Git.Construct.fromUnknown)+			return $ Just repo 		, return Nothing 		)   where@@ -194,3 +194,17 @@ 	, Param k 	, Param v 	]++{- Unsets a git config setting, in both the git repo,+ - and the cached config in the Repo.+ -+ - If unsetting the config fails, including in a read-only repo, or+ - when the config is not set, returns Nothing.+ -}+unset :: String -> Repo -> IO (Maybe Repo)+unset k r = ifM (Git.Command.runBool ps r)+	( return $ Just $ r { config = M.delete k (config r) }+	, return Nothing+	)+  where+	ps = [Param "config", Param "--unset-all", Param k]
Git/Construct.hs view
@@ -1,6 +1,6 @@ {- Construction of Git Repo objects  -- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -19,8 +19,8 @@ 	fromRemotes, 	fromRemoteLocation, 	repoAbsPath,-	newFrom, 	checkForRepo,+	newFrom, ) where  #ifndef mingw32_HOST_OS@@ -45,10 +45,10 @@ 	seekUp dir = do 		r <- checkForRepo dir 		case r of-			Nothing -> case parentDir dir of+			Nothing -> case upFrom dir of 				Nothing -> return Nothing 				Just d -> seekUp d-			Just loc -> Just <$> newFrom loc+			Just loc -> pure $ Just $ newFrom loc  {- Local Repo constructor, accepts a relative or absolute path. -} fromPath :: FilePath -> IO Repo@@ -58,24 +58,29 @@  - specified. -} fromAbsPath :: FilePath -> IO Repo fromAbsPath dir-	| absoluteGitPath dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt )+	| absoluteGitPath dir = hunt 	| otherwise = 		error $ "internal error, " ++ dir ++ " is not absolute"   where-	ret = newFrom . LocalUnknown-	{- Git always looks for "dir.git" in preference to-	 - to "dir", even if dir ends in a "/". -}+	ret = pure . newFrom . LocalUnknown 	canondir = dropTrailingPathSeparator dir-	dir' = canondir ++ ".git" 	{- When dir == "foo/.git", git looks for "foo/.git/.git", 	 - and failing that, uses "foo" as the repository. -} 	hunt 		| (pathSeparator:".git") `isSuffixOf` canondir = 			ifM (doesDirectoryExist $ dir </> ".git") 				( ret dir-				, ret $ takeDirectory canondir+				, ret (takeDirectory canondir) 				)-		| otherwise = ret dir+		| otherwise = ifM (doesDirectoryExist dir)+			( ret dir+			-- git falls back to dir.git when dir doesn't+			-- exist, as long as dir didn't end with a+			-- path separator+			, if dir == canondir+				then ret (dir ++ ".git")+				else ret dir+			)  {- Remote Repo constructor. Throws exception on invalid url.  -@@ -90,13 +95,13 @@ fromUrlStrict :: String -> IO Repo fromUrlStrict url 	| startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u-	| otherwise = newFrom $ Url u+	| otherwise = pure $ newFrom $ Url u   where 	u = fromMaybe bad $ parseURI url 	bad = error $ "bad url " ++ url  {- Creates a repo that has an unknown location. -}-fromUnknown :: IO Repo+fromUnknown :: Repo fromUnknown = newFrom Unknown  {- Converts a local Repo into a remote repo, using the reference repo@@ -153,7 +158,7 @@ fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do 	dir' <- expandTilde dir-	fromAbsPath $ repoPath repo </> dir'+	fromPath $ repoPath repo </> dir'  {- Git remotes can have a directory that is specified relative  - to the user's home directory, or that contains tilde expansions.@@ -223,8 +228,8 @@ 		gitdirprefix = "gitdir: " 	gitSignature file = doesFileExist $ dir </> file -newFrom :: RepoLocation -> IO Repo-newFrom l = return Repo+newFrom :: RepoLocation -> Repo+newFrom l = Repo 	{ location = l 	, config = M.empty 	, fullconfig = M.empty@@ -233,5 +238,4 @@ 	, gitEnv = Nothing 	, gitGlobalOpts = [] 	}-
Git/CurrentRepo.hs view
@@ -1,6 +1,6 @@ {- The current git repository.  -- - Copyright 2012 Joey Hess <joey@kitenet.net>+ - Copyright 2012 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -50,8 +50,8 @@ 	configure (Just d) _ = do 		absd <- absPath d 		curr <- getCurrentDirectory-		r <- newFrom $ Local { gitdir = absd, worktree = Just curr }-		Git.Config.read r+		Git.Config.read $ newFrom $+			Local { gitdir = absd, worktree = Just curr } 	configure Nothing Nothing = error "Not in a git repository."  	addworktree w r = changelocation r $
Git/Destroyer.hs view
@@ -21,7 +21,6 @@  import qualified Data.ByteString as B import Data.Word-import System.PosixCompat.Types  {- Ways to damange a git repository. -} data Damage
Git/DiffTreeItem.hs view
@@ -1,6 +1,6 @@ {- git diff-tree item  -- - Copyright 2012 Joey Hess <joey@kitenet.net>+ - Copyright 2012 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}
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-2013 Joey Hess <joey@kitenet.net>+ - Copyright 2012-2013 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -39,8 +39,7 @@  {- The input FilePath can be absolute, or relative to the CWD. -} toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath-toTopFilePath file repo = TopFilePath <$>-	relPathDirToFile (repoPath repo) <$> absPath file+toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file  {- The input FilePath must already be relative to the top of the git  - repository -}
Git/Filename.hs view
@@ -1,7 +1,7 @@ {- Some git commands output encoded filenames, in a rather annoyingly complex  - C-style encoding.  -- - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>+ - Copyright 2010, 2011 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -24,5 +24,5 @@ encode s = "\"" ++ encode_c s ++ "\""  {- for quickcheck -}-prop_idempotent_deencode :: String -> Bool-prop_idempotent_deencode s = s == decode (encode s)+prop_isomorphic_deencode :: String -> Bool+prop_isomorphic_deencode s = s == decode (encode s)
Git/Fsck.hs view
@@ -1,6 +1,6 @@ {- git fsck interface  -- - Copyright 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2013 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}
Git/Index.hs view
@@ -1,6 +1,6 @@ {- git index file stuff  -- - Copyright 2011 Joey Hess <joey@kitenet.net>+ - Copyright 2011 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}
Git/LsFiles.hs view
@@ -1,6 +1,6 @@ {- git ls-files interface  -- - Copyright 2010,2012 Joey Hess <joey@kitenet.net>+ - Copyright 2010,2012 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -35,14 +35,23 @@  {- Scans for files that are checked into git at the specified locations. -} inRepo :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)-inRepo l = pipeNullSplit $ Params "ls-files --cached -z --" : map File l+inRepo l = pipeNullSplit $ +	Param "ls-files" :+	Param "--cached" :+	Param "-z" :+	Param "--" :+	map File l  {- Scans for files at the specified locations that are not checked into git. -} notInRepo :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) notInRepo include_ignored l repo = pipeNullSplit params repo   where-	params = [Params "ls-files --others"] ++ exclude ++-		[Params "-z --"] ++ map File l+	params = concat+		[ [ Param "ls-files", Param "--others"]+		, exclude+		, [ Param "-z", Param "--" ]+		, map File l+		] 	exclude 		| include_ignored = [] 		| otherwise = [Param "--exclude-standard"]@@ -50,28 +59,51 @@ {- Finds all files in the specified locations, whether checked into git or  - not. -} allFiles :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)-allFiles l = pipeNullSplit $ Params "ls-files --cached --others -z --" : map File l+allFiles l = pipeNullSplit $+	Param "ls-files" :+	Param "--cached" :+	Param "--others" :+	Param "-z" :+	Param "--" :+	map File l  {- Returns a list of files in the specified locations that have been  - deleted. -} deleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) deleted l repo = pipeNullSplit params repo   where-	params = [Params "ls-files --deleted -z --"] ++ map File l+	params =+		Param "ls-files" :+		Param "--deleted" :+		Param "-z" :+		Param "--" :+		map File l  {- Returns a list of files in the specified locations that have been  - modified. -} modified :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) modified l repo = pipeNullSplit params repo   where-	params = [Params "ls-files --modified -z --"] ++ map File l+	params = +		Param "ls-files" :+		Param "--modified" :+		Param "-z" :+		Param "--" :+		map File l  {- Files that have been modified or are not checked into git (and are not  - ignored). -} modifiedOthers :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) modifiedOthers l repo = pipeNullSplit params repo   where-	params = [Params "ls-files --modified --others --exclude-standard -z --"] ++ map File l+	params = +		Param "ls-files" :+		Param "--modified" :+		Param "--others" :+		Param "--exclude-standard" :+		Param "-z" :+		Param "--" :+		map File l  {- Returns a list of all files that are staged for commit. -} staged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)@@ -85,7 +117,7 @@ staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix   where-	prefix = [Params "diff --cached --name-only -z"]+	prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] 	suffix = Param "--" : map File l  type StagedDetails = (FilePath, Maybe Sha, Maybe FileMode)@@ -93,7 +125,7 @@ {- Returns details about files that are staged in the index,  - as well as files not yet in git. Skips ignored files. -} stagedOthersDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)-stagedOthersDetails = stagedDetails' [Params "--others --exclude-standard"]+stagedOthersDetails = stagedDetails' [Param "--others", Param "--exclude-standard"]  {- Returns details about all files that are staged in the index. -} stagedDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)@@ -106,7 +138,7 @@ 	(ls, cleanup) <- pipeNullSplit params repo 	return (map parse ls, cleanup)   where-	params = Params "ls-files --stage -z" : ps ++ +	params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++  		Param "--" : map File l 	parse s 		| null file = (s, Nothing, Nothing)@@ -131,11 +163,16 @@ 	(fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo 	-- git diff returns filenames relative to the top of the git repo; 	-- convert to filenames relative to the cwd, like git ls-files.-	let top = repoPath repo+	top <- absPath (repoPath repo) 	currdir <- getCurrentDirectory-	return (map (\f -> relPathDirToFile currdir $ top </> f) fs, cleanup)+	return (map (\f -> relPathDirToFileAbs currdir $ top </> f) fs, cleanup)   where-	prefix = [Params "diff --name-only --diff-filter=T -z"]+	prefix = +		[ Param "diff"+		, Param "--name-only"+		, Param "--diff-filter=T"+		, Param "-z"+		] 	suffix = Param "--" : (if null l then [File "."] else map File l)  {- A item in conflict has two possible values.@@ -166,7 +203,12 @@ 	(fs, cleanup) <- pipeNullSplit params repo 	return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup)   where-	params = Params "ls-files --unmerged -z --" : map File l+	params = +		Param "ls-files" :+		Param "--unmerged" :+		Param "-z" :+		Param "--" :+		map File l  data InternalUnmerged = InternalUnmerged 	{ isus :: Bool@@ -181,12 +223,13 @@ 	| otherwise = case words metadata of 		(rawblobtype:rawsha:rawstage:_) -> do 			stage <- readish rawstage :: Maybe Int-			unless (stage == 2 || stage == 3) $-				fail undefined -- skip stage 1-			blobtype <- readBlobType rawblobtype-			sha <- extractSha rawsha-			return $ InternalUnmerged (stage == 2) file-				(Just blobtype) (Just sha)+			if stage /= 2 && stage /= 3+				then Nothing+				else do+					blobtype <- readBlobType rawblobtype+					sha <- extractSha rawsha+					return $ InternalUnmerged (stage == 2) file+						(Just blobtype) (Just sha) 		_ -> Nothing   where 	(metadata, file) = separate (== '\t') s
Git/LsTree.hs view
@@ -1,6 +1,6 @@ {- git ls-tree interface  -- - Copyright 2011 Joey Hess <joey@kitenet.net>+ - Copyright 2011 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -13,10 +13,6 @@ 	parseLsTree ) where -import Numeric-import Control.Applicative-import System.Posix.Types- import Common import Git import Git.Command@@ -24,6 +20,9 @@ import Git.FilePath import qualified Git.Filename +import Numeric+import System.Posix.Types+ data TreeItem = TreeItem 	{ mode :: FileMode 	, typeobj :: String@@ -35,16 +34,30 @@  - with lazy output. -} lsTree :: Ref -> Repo -> IO [TreeItem] lsTree t repo = map parseLsTree-	<$> pipeNullSplitZombie (lsTreeParams t) repo+	<$> pipeNullSplitZombie (lsTreeParams t []) repo -lsTreeParams :: Ref -> [CommandParam]-lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ fromRef t ]+lsTreeParams :: Ref -> [CommandParam] -> [CommandParam]+lsTreeParams r ps =+	[ Param "ls-tree"+	, Param "--full-tree"+	, Param "-z"+	, Param "-r"+	] ++ ps +++	[ Param "--"+	, File $ fromRef r+	]  {- Lists specified files in a tree. -} lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem] lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo   where-	ps = [Params "ls-tree --full-tree -z --", File $ fromRef t] ++ map File fs+	ps =+		[ Param "ls-tree"+		, Param "--full-tree"+		, Param "-z"+		, Param "--"+		, File $ fromRef t+		] ++ map File fs  {- Parses a line of ls-tree output.  - (The --long format is not currently supported.) -}
Git/Objects.hs view
@@ -1,6 +1,6 @@ {- .git/objects  -- - Copyright 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2013 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}
Git/Ref.hs view
@@ -1,6 +1,6 @@ {- git ref stuff  -- - Copyright 2011-2013 Joey Hess <joey@kitenet.net>+ - Copyright 2011-2013 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -87,6 +87,9 @@ 		Param $ fromRef branch] 	process [] = Nothing 	process s = Just $ Ref $ firstLine s++headSha :: Repo -> IO (Maybe Sha)+headSha = sha headRef  {- List of (shas, branches) matching a given ref or refs. -} matching :: [Ref] -> Repo -> IO [(Sha, Branch)]
Git/RefLog.hs view
@@ -1,6 +1,6 @@ {- git reflog interface  -- - Copyright 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2013 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -14,9 +14,17 @@  {- Gets the reflog for a given branch. -} get :: Branch -> Repo -> IO [Sha]-get b = mapMaybe extractSha . lines <$$> pipeReadStrict-	[ Param "log"-	, Param "-g"-	, Param "--format=%H"-	, Param (fromRef b)-	]+get b = getMulti [b]++{- Gets reflogs for multiple branches. -}+getMulti :: [Branch] -> Repo -> IO [Sha]+getMulti bs = get' (map (Param . fromRef) bs)++get' :: [CommandParam] -> Repo -> IO [Sha]+get' ps = mapMaybe extractSha . lines <$$> pipeReadStrict ps'+  where+	ps' = catMaybes+		[ Just $ Param "log"+		, Just $ Param "-g"+		, Just $ Param "--format=%H"+		] ++ ps
Git/Remote.hs view
@@ -1,6 +1,6 @@ {- git remote stuff  -- - Copyright 2012 Joey Hess <joey@kitenet.net>+ - Copyright 2012 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}
Git/Repair.hs view
@@ -1,6 +1,6 @@ {- git repository recovery  -- - Copyright 2013-2014 Joey Hess <joey@kitenet.net>+ - Copyright 2013-2014 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -99,7 +99,7 @@ retrieveMissingObjects missing referencerepo r 	| not (foundBroken missing) = return missing 	| otherwise = withTmpDir "tmprepo" $ \tmpdir -> do-		unlessM (boolSystem "git" [Params "init", File tmpdir]) $+		unlessM (boolSystem "git" [Param "init", File tmpdir]) $ 			error $ "failed to create temp repository in " ++ tmpdir 		tmpr <- Config.read =<< Construct.fromAbsPath tmpdir 		stillmissing <- pullremotes tmpr (remotes r) fetchrefstags missing@@ -140,7 +140,9 @@ 		ps' =  			[ Param "fetch" 			, Param fetchurl-			, Params "--force --update-head-ok --quiet"+			, Param "--force"+			, Param "--update-head-ok"+			, Param "--quiet" 			] ++ ps 		fetchr' = fetchr { gitGlobalOpts = gitGlobalOpts fetchr ++ nogc } 		nogc = [ Param "-c", Param "gc.auto=0" ]@@ -225,11 +227,14 @@  - Relies on packed refs being exploded before it's called.  -} getAllRefs :: Repo -> IO [Ref]-getAllRefs r = map toref <$> dirContentsRecursive refdir-  where-	refdir = localGitDir r </> "refs"-	toref = Ref . relPathDirToFile (localGitDir r)+getAllRefs r = getAllRefs' (localGitDir r </> "refs") +getAllRefs' :: FilePath -> IO [Ref]+getAllRefs' refdir = do+	let topsegs = length (splitPath refdir) - 1+	let toref = Ref . joinPath . drop topsegs . splitPath+	map toref <$> dirContentsRecursive refdir+ explodePackedRefsFile :: Repo -> IO () explodePackedRefsFile r = do 	let f = packedRefsFile r@@ -241,7 +246,7 @@   where 	makeref (sha, ref) = do 		let dest = localGitDir r </> fromRef ref-		createDirectoryIfMissing True (takeDirectory dest)+		createDirectoryIfMissing True (parentDir dest) 		unlessM (doesFileExist dest) $ 			writeFile dest (fromRef sha) @@ -336,7 +341,7 @@ verifyTree missing treesha r 	| S.member treesha missing = return False 	| otherwise = do-		(ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams treesha) r+		(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) 			then do
Git/Sha.hs view
@@ -1,6 +1,6 @@ {- git SHA stuff  -- - Copyright 2011 Joey Hess <joey@kitenet.net>+ - Copyright 2011 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}
Git/Types.hs view
@@ -1,6 +1,6 @@ {- git data types  -- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}
Git/UpdateIndex.hs view
@@ -1,6 +1,6 @@ {- git-update-index library  -- - Copyright 2011-2013 Joey Hess <joey@kitenet.net>+ - Copyright 2011-2013 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}
Git/Url.hs view
@@ -1,6 +1,6 @@ {- git repository urls  -- - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>+ - Copyright 2010, 2011 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}
Git/Version.hs view
@@ -1,9 +1,11 @@ {- git versions  -- - Copyright 2011, 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2011, 2013 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}++{-# OPTIONS_GHC -fno-warn-tabs #-}  module Git.Version ( 	installed,
Makefile view
@@ -8,7 +8,7 @@  Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs 	if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi-	$(CABAL) configure+	$(CABAL) configure --ghc-options="$(shell Build/collect-ghc-options.sh)"  install: build 	install -d $(DESTDIR)$(PREFIX)/bin
Utility/Applicative.hs view
@@ -1,6 +1,6 @@ {- applicative stuff  -- - Copyright 2012 Joey Hess <joey@kitenet.net>+ - Copyright 2012 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}
Utility/Batch.hs view
@@ -1,6 +1,6 @@ {- Running a long or expensive batch operation niced.  -- - Copyright 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2013 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}
Utility/CoProcess.hs view
@@ -1,7 +1,7 @@ {- Interface for running a shell command as a coprocess,  - sending it queries and getting back results.  -- - Copyright 2012-2013 Joey Hess <joey@kitenet.net>+ - Copyright 2012-2013 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}
Utility/Data.hs view
@@ -1,9 +1,11 @@ {- utilities for simple data types  -- - Copyright 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2013 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}++{-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Data where
Utility/Directory.hs view
@@ -1,32 +1,34 @@ {- directory traversal and manipulation  -- - Copyright 2011-2014 Joey Hess <joey@kitenet.net>+ - Copyright 2011-2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}  {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Directory where  import System.IO.Error import System.Directory import Control.Monad-import Control.Monad.IfElse import System.FilePath import Control.Applicative import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO) import Data.Maybe+import Prelude  #ifdef mingw32_HOST_OS import qualified System.Win32 as Win32 #else import qualified System.Posix as Posix+import Utility.SafeCommand+import Control.Monad.IfElse #endif  import Utility.PosixFiles-import Utility.SafeCommand import Utility.Tmp import Utility.Exception import Utility.Monad@@ -105,21 +107,32 @@ 	onrename (Left e) 		| isPermissionError e = rethrow 		| isDoesNotExistError e = rethrow-		| otherwise = do-			-- copyFile is likely not as optimised as-			-- the mv command, so we'll use the latter.-			-- But, mv will move into a directory if-			-- dest is one, which is not desired.-			whenM (isdir dest) rethrow-			viaTmp mv dest undefined+		| otherwise = viaTmp mv dest "" 	  where 		rethrow = throwM e+ 		mv tmp _ = do+		-- copyFile is likely not as optimised as+		-- the mv command, so we'll use the command.+		--+		-- But, while Windows has a "mv", it does not seem very+		-- reliable, so use copyFile there.+#ifndef mingw32_HOST_OS	+			-- If dest is a directory, mv would move the file+			-- into it, which is not desired.+			whenM (isdir dest) rethrow 			ok <- boolSystem "mv" [Param "-f", Param src, Param tmp]+			let e' = e+#else+			r <- tryIO $ copyFile src tmp+			let (ok, e') = case r of+				Left err -> (False, err)+				Right _ -> (True, e)+#endif 			unless ok $ do 				-- delete any partial 				_ <- tryIO $ removeFile tmp-				rethrow+				throwM e'  	isdir f = do 		r <- tryIO $ getFileStatus f
Utility/DottedVersion.hs view
@@ -1,9 +1,11 @@ {- dotted versions, such as 1.0.1  -- - Copyright 2011-2014 Joey Hess <joey@kitenet.net>+ - Copyright 2011-2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}++{-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.DottedVersion where
Utility/Env.hs view
@@ -1,11 +1,12 @@ {- portable environment variables  -- - Copyright 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2013 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}  {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Env where @@ -13,6 +14,7 @@ import Utility.Exception import Control.Applicative import Data.Maybe+import Prelude import qualified System.Environment as E import qualified System.SetEnv #else
Utility/Exception.hs view
@@ -1,11 +1,12 @@ {- Simple IO exception handling (and some more)  -- - Copyright 2011-2014 Joey Hess <joey@kitenet.net>+ - Copyright 2011-2015 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}  {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Exception ( 	module X,@@ -19,6 +20,8 @@ 	catchNonAsync, 	tryNonAsync, 	tryWhenExists,+	catchIOErrorType,+	IOErrorType(..) ) where  import Control.Monad.Catch as X hiding (Handler)@@ -26,7 +29,9 @@ import Control.Exception (IOException, AsyncException) import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO)-import System.IO.Error (isDoesNotExistError)+import System.IO.Error (isDoesNotExistError, ioeGetErrorType)+import GHC.IO.Exception (IOErrorType(..))+ import Utility.Data  {- Catches IO errors and returns a Bool -}@@ -35,10 +40,7 @@  {- Catches IO errors and returns a Maybe -} catchMaybeIO :: MonadCatch m => m a -> m (Maybe a)-catchMaybeIO a = do-	catchDefaultIO Nothing $ do-		v <- a-		return (Just v)+catchMaybeIO a = catchDefaultIO Nothing $ a >>= (return . Just)  {- Catches IO errors and returns a default value. -} catchDefaultIO :: MonadCatch m => a -> m a -> m a@@ -86,3 +88,12 @@ tryWhenExists a = do 	v <- tryJust (guard . isDoesNotExistError) a 	return (eitherToMaybe v)++{- Catches only IO exceptions of a particular type.+ - Ie, use HardwareFault to catch disk IO errors. -}+catchIOErrorType :: MonadCatch m => IOErrorType -> (IOException -> m a) -> m a -> m a+catchIOErrorType errtype onmatchingerr a = catchIO a onlymatching+  where+	onlymatching e+		| ioeGetErrorType e == errtype = onmatchingerr e+		| otherwise = throwM e
Utility/FileMode.hs view
@@ -1,13 +1,16 @@ {- File mode utilities.  -- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}  {-# LANGUAGE CPP #-} -module Utility.FileMode where+module Utility.FileMode (+	module Utility.FileMode,+	FileMode,+) where  import System.IO import Control.Monad@@ -17,12 +20,15 @@ import System.Posix.Files #endif import Foreign (complement)+import Control.Monad.IO.Class (liftIO, MonadIO)+import Control.Monad.Catch  import Utility.Exception  {- Applies a conversion function to a file's mode. -} modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO () modifyFileMode f convert = void $ modifyFileMode' f convert+ modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode modifyFileMode' f convert = do 	s <- getFileStatus f@@ -32,6 +38,14 @@ 		setFileMode f new 	return old +{- Runs an action after changing a file's mode, then restores the old mode. -}+withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a+withModifiedFileMode file convert a = bracket setup cleanup go+  where+	setup = modifyFileMode' file convert+	cleanup oldmode = modifyFileMode file (const oldmode)+	go _ = a+ {- Adds the specified FileModes to the input mode, leaving the rest  - unchanged. -} addModes :: [FileMode] -> FileMode -> FileMode@@ -41,14 +55,6 @@ removeModes :: [FileMode] -> FileMode -> FileMode removeModes ms m = m `intersectFileModes` complement (combineModes ms) -{- Runs an action after changing a file's mode, then restores the old mode. -}-withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a-withModifiedFileMode file convert a = bracket setup cleanup go-  where-	setup = modifyFileMode' file convert-	cleanup oldmode = modifyFileMode file (const oldmode)-	go _ = a- writeModes :: [FileMode] writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode] @@ -103,7 +109,7 @@  {- Runs an action without that pesky umask influencing it, unless the  - passed FileMode is the standard one. -}-noUmask :: FileMode -> IO a -> IO a+noUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a #ifndef mingw32_HOST_OS noUmask mode a 	| mode == stdFileMode = a@@ -112,19 +118,19 @@ noUmask _ a = a #endif -withUmask :: FileMode -> IO a -> IO a+withUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a #ifndef mingw32_HOST_OS withUmask umask a = bracket setup cleanup go   where-	setup = setFileCreationMask umask-	cleanup = setFileCreationMask+	setup = liftIO $ setFileCreationMask umask+	cleanup = liftIO . setFileCreationMask 	go _ = a #else withUmask _ a = a #endif  combineModes :: [FileMode] -> FileMode-combineModes [] = undefined+combineModes [] = 0 combineModes [m] = m combineModes (m:ms) = foldl unionFileModes m ms @@ -151,7 +157,11 @@  - as writeFile.  -} writeFileProtected :: FilePath -> String -> IO ()-writeFileProtected file content = withUmask 0o0077 $+writeFileProtected file content = writeFileProtected' file +	(\h -> hPutStr h content)++writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO ()+writeFileProtected' file writer = withUmask 0o0077 $ 	withFile file WriteMode $ \h -> do 		void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes-		hPutStr h content+		writer h
+ Utility/FileSize.hs view
@@ -0,0 +1,35 @@+{- File size.+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}++module Utility.FileSize where++import System.PosixCompat.Files+#ifdef mingw32_HOST_OS+import Control.Exception (bracket)+import System.IO+#endif++{- 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+#ifndef mingw32_HOST_OS+getFileSize f = fmap (fromIntegral . fileSize) (getFileStatus f)+#else+getFileSize f = bracket (openFile f ReadMode) hClose hFileSize+#endif++{- Gets the size of the file, when its FileStatus is already known. -}+getFileSize' :: FilePath -> FileStatus -> IO Integer+#ifndef mingw32_HOST_OS+getFileSize' _ s = return $ fromIntegral $ fileSize s+#else+getFileSize' f _ = getFileSize f+#endif
Utility/FileSystemEncoding.hs view
@@ -1,19 +1,23 @@ {- GHC File system encoding handling.  -- - Copyright 2012-2014 Joey Hess <joey@kitenet.net>+ - Copyright 2012-2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}  {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.FileSystemEncoding ( 	fileEncoding, 	withFilePath, 	md5FilePath, 	decodeBS,+	encodeBS, 	decodeW8, 	encodeW8,+	encodeW8NUL,+	decodeW8NUL, 	truncateFilePath, ) where @@ -25,11 +29,15 @@ import qualified Data.Hash.MD5 as MD5 import Data.Word import Data.Bits.Utils+import Data.List+import Data.List.Utils import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS import qualified Data.ByteString.Lazy.UTF8 as L8 #endif +import Utility.Exception+ {- Sets a Handle to use the filesystem encoding. This causes data  - written or read from it to be encoded/decoded the same  - as ghc 7.4 does to filenames etc. This special encoding@@ -63,12 +71,16 @@  - only allows doing this conversion with CStrings, and the CString buffer  - is allocated, used, and deallocated within the call, with no side  - effects.+ -+ - If the FilePath contains a value that is not legal in the filesystem+ - encoding, rather than thowing an exception, it will be returned as-is.  -} {-# NOINLINE _encodeFilePath #-} _encodeFilePath :: FilePath -> String _encodeFilePath fp = unsafePerformIO $ do 	enc <- Encoding.getFileSystemEncoding-	GHC.withCString enc fp $ GHC.peekCString Encoding.char8+	GHC.withCString enc fp (GHC.peekCString Encoding.char8)+		`catchNonAsync` (\_ -> return fp)  {- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -} md5FilePath :: FilePath -> MD5.Str@@ -77,18 +89,29 @@ {- Decodes a ByteString into a FilePath, applying the filesystem encoding. -} decodeBS :: L.ByteString -> FilePath #ifndef mingw32_HOST_OS-decodeBS = encodeW8 . L.unpack+decodeBS = encodeW8NUL . L.unpack #else {- On Windows, we assume that the ByteString is utf-8, since Windows  - only uses unicode for filenames. -} decodeBS = L8.toString #endif +{- Encodes a FilePath into a ByteString, applying the filesystem encoding. -}+encodeBS :: FilePath -> L.ByteString+#ifndef mingw32_HOST_OS+encodeBS = L.pack . decodeW8NUL+#else+encodeBS = L8.fromString+#endif+ {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.  -  - w82c produces a String, which may contain Chars that are invalid  - unicode. From there, this is really a simple matter of applying the  - file system encoding, only complicated by GHC's interface to doing so.+ -+ - Note that the encoding stops at any NUL in the input. FilePaths+ - do not normally contain embedded NUL, but Haskell Strings may.  -} {-# NOINLINE encodeW8 #-} encodeW8 :: [Word8] -> FilePath@@ -100,6 +123,17 @@  - represent the FilePath on disk. -} decodeW8 :: FilePath -> [Word8] decodeW8 = s2w8 . _encodeFilePath++{- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -}+encodeW8NUL :: [Word8] -> FilePath+encodeW8NUL = intercalate nul . map encodeW8 . split (s2w8 nul)+  where+	nul = ['\NUL']++decodeW8NUL :: FilePath -> [Word8]+decodeW8NUL = intercalate (s2w8 nul) . map decodeW8 . split nul+  where+	nul = ['\NUL']  {- Truncates a FilePath to the given number of bytes (or less),  - as represented on disk.
Utility/Format.hs view
@@ -1,6 +1,6 @@ {- Formatted string handling.  -- - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>+ - Copyright 2010, 2011 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -11,7 +11,7 @@ 	format, 	decode_c, 	encode_c,-	prop_idempotent_deencode+	prop_isomorphic_deencode ) where  import Text.Printf (printf)@@ -174,5 +174,5 @@ 	showoctal i = '\\' : printf "%03o" i  {- for quickcheck -}-prop_idempotent_deencode :: String -> Bool-prop_idempotent_deencode s = s == decode_c (encode_c s)+prop_isomorphic_deencode :: String -> Bool+prop_isomorphic_deencode s = s == decode_c (encode_c s)
Utility/Metered.hs view
@@ -1,6 +1,6 @@-{- Metered IO+{- Metered IO and actions  -- - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2012-2105 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -17,6 +17,10 @@ import Foreign.Storable (Storable(sizeOf)) import System.Posix.Types import Data.Int+import Data.Bits.Utils+import Control.Concurrent+import Control.Concurrent.Async+import Control.Monad.IO.Class (MonadIO)  {- An action that can be run repeatedly, updating it on the bytes processed.  -@@ -27,6 +31,9 @@ nullMeterUpdate :: MeterUpdate nullMeterUpdate _ = return () +combineMeterUpdate :: MeterUpdate -> MeterUpdate -> MeterUpdate+combineMeterUpdate a b = \n -> a n >> b n+ {- Total number of bytes processed so far. -} newtype BytesProcessed = BytesProcessed Integer 	deriving (Eq, Ord, Show)@@ -142,10 +149,32 @@ defaultChunkSize = 32 * k - chunkOverhead   where 	k = 1024-	chunkOverhead = 2 * sizeOf (undefined :: Int) -- GHC specific+	chunkOverhead = 2 * sizeOf (1 :: Int) -- GHC specific +{- Runs an action, watching a file as it grows and updating the meter. -}+watchFileSize :: (MonadIO m, MonadMask m) => FilePath -> MeterUpdate -> m a -> m a+watchFileSize f p a = bracket +	(liftIO $ forkIO $ watcher zeroBytesProcessed)+	(liftIO . void . tryIO . killThread)+	(const a)+  where+	watcher oldsz = do+		v <- catchMaybeIO $ toBytesProcessed <$> getFileSize f+		newsz <- case v of+			Just sz | sz /= oldsz -> do+				p sz+				return sz+			_ -> return oldsz+		threadDelay 500000 -- 0.5 seconds+		watcher newsz++data OutputHandler = OutputHandler+	{ quietMode :: Bool+	, stderrHandler :: String -> IO ()+	}+ {- Parses the String looking for a command's progress output, and returns- - Maybe the number of bytes rsynced so far, and any any remainder of the+ - Maybe the number of bytes done so far, and any any remainder of the  - string that could be an incomplete progress output. That remainder  - should be prepended to future output, and fed back in. This interface  - allows the command's output to be read in any desired size chunk, or@@ -154,21 +183,23 @@ type ProgressParser = String -> (Maybe BytesProcessed, String)  {- Runs a command and runs a ProgressParser on its output, in order- - to update the meter. The command's output is also sent to stdout. -}-commandMeter :: ProgressParser -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool-commandMeter progressparser meterupdate cmd params = liftIO $ catchBoolIO $-	withHandle StdoutHandle createProcessSuccess p $-		feedprogress zeroBytesProcessed []+ - to update a meter.+ -}+commandMeter :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool+commandMeter progressparser oh meterupdate cmd params = +	outputFilter cmd params Nothing+		(feedprogress zeroBytesProcessed [])+		handlestderr   where-	p = proc cmd (toCommand params)- 	feedprogress prev buf h = do-		s <- hGetSomeString h 80-		if null s-			then return True+		b <- S.hGetSome h 80+		if S.null b+			then return () 			else do-				putStr s-				hFlush stdout+				unless (quietMode oh) $ do+					S.hPut stdout b+					hFlush stdout+				let s = w82s (S.unpack b) 				let (mbytes, buf') = progressparser (buf++s) 				case mbytes of 					Nothing -> feedprogress prev buf' h@@ -176,3 +207,55 @@ 						when (bytes /= prev) $ 							meterupdate bytes 						feedprogress bytes buf' h++	handlestderr h = unlessM (hIsEOF h) $ do+		stderrHandler oh =<< hGetLine h+		handlestderr h++{- Runs a command, that may display one or more progress meters on+ - either stdout or stderr, and prevents the meters from being displayed.+ -+ - The other command output is handled as configured by the OutputHandler.+ -}+demeterCommand :: OutputHandler -> FilePath -> [CommandParam] -> IO Bool+demeterCommand oh cmd params = demeterCommandEnv oh cmd params Nothing++demeterCommandEnv :: OutputHandler -> FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool+demeterCommandEnv oh cmd params environ = outputFilter cmd params environ+	(\outh -> avoidProgress True outh stdouthandler)+	(\errh -> avoidProgress True errh $ stderrHandler oh)+  where+	stdouthandler l = +		unless (quietMode oh) $+			putStrLn l++{- To suppress progress output, while displaying other messages,+ - filter out lines that contain \r (typically used to reset to the+ - beginning of the line when updating a progress display).+ -}+avoidProgress :: Bool -> Handle -> (String -> IO ()) -> IO ()+avoidProgress doavoid h emitter = unlessM (hIsEOF h) $ do+	s <- hGetLine h+	unless (doavoid && '\r' `elem` s) $+		emitter s+	avoidProgress doavoid h emitter++outputFilter+	:: FilePath+	-> [CommandParam]+	-> Maybe [(String, String)]+	-> (Handle -> IO ())+	-> (Handle -> IO ())+	-> IO Bool+outputFilter cmd params environ outfilter errfilter = catchBoolIO $ do+	(_, Just outh, Just errh, pid) <- createProcess p+		{ std_out = CreatePipe+		, std_err = CreatePipe+		}+	void $ async $ tryIO (outfilter outh) >> hClose outh+	void $ async $ tryIO (errfilter errh) >> hClose errh+	ret <- checkSuccessProcess pid+	return ret+  where+	p = (proc cmd (toCommand params))+		{ env = environ }
Utility/Misc.hs view
@@ -1,28 +1,30 @@ {- misc utility functions  -- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2011 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}  {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Misc where +import Utility.FileSystemEncoding+import Utility.Monad+ import System.IO import Control.Monad import Foreign import Data.Char import Data.List-import Control.Applicative import System.Exit #ifndef mingw32_HOST_OS import System.Posix.Process (getAnyProcessStatus) import Utility.Exception #endif--import Utility.FileSystemEncoding-import Utility.Monad+import Control.Applicative+import Prelude  {- A version of hgetContents that is not lazy. Ensures file is   - all read before it gets closed. -}@@ -134,7 +136,7 @@  - if this reap gets there first. -} reapZombies :: IO () #ifndef mingw32_HOST_OS-reapZombies = do+reapZombies = 	-- throws an exception when there are no child processes 	catchDefaultIO Nothing (getAnyProcessStatus False True) 		>>= maybe (return ()) (const reapZombies)
Utility/Monad.hs view
@@ -1,9 +1,11 @@ {- monadic stuff  -- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}++{-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Monad where
Utility/PartialPrelude.hs view
@@ -5,6 +5,8 @@  - them being accidentially used.  -} +{-# OPTIONS_GHC -fno-warn-tabs #-}+ module Utility.PartialPrelude where  import qualified Data.Maybe
Utility/Path.hs view
@@ -1,11 +1,12 @@ {- path manipulation  -- - Copyright 2010-2014 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}  {-# LANGUAGE PackageImports, CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Path where @@ -16,6 +17,7 @@ import Data.Maybe import Data.Char import Control.Applicative+import Prelude  #ifdef mingw32_HOST_OS import qualified System.FilePath.Posix as Posix@@ -28,8 +30,8 @@ import Utility.Monad import Utility.UserInfo -{- Simplifies a path, removing any ".." or ".", and removing the trailing- - path separator.+{- Simplifies a path, removing any "." component, collapsing "dir/..", + - and removing the trailing path separator.  -  - On Windows, preserves whichever style of path separator might be used in  - the input FilePaths. This is done because some programs in Windows@@ -48,7 +50,8 @@  	norm c [] = reverse c 	norm c (p:ps)-		| p' == ".." = norm (drop 1 c) ps+		| p' == ".." && not (null c) && dropTrailingPathSeparator (c !! 0) /= ".." = +			norm (drop 1 c) ps 		| p' == "." = norm c ps 		| otherwise = norm (p:c) ps 	  where@@ -66,7 +69,7 @@ absPathFrom dir path = simplifyPath (combine dir path)  {- On Windows, this converts the paths to unix-style, in order to run- - MissingH's absNormPath on them. Resulting path will use / separators. -}+ - MissingH's absNormPath on them. -} absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath #ifndef mingw32_HOST_OS absNormPathUnix dir path = MissingH.absNormPath dir path@@ -77,25 +80,29 @@ 	todos = replace "/" "\\" #endif +{- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -}+parentDir :: FilePath -> FilePath+parentDir = takeDirectory . dropTrailingPathSeparator+ {- Just the parent directory of a path, or Nothing if the path has no- - parent (ie for "/") -}-parentDir :: FilePath -> Maybe FilePath-parentDir dir-	| null dirs = Nothing-	| otherwise = Just $ joinDrive drive (join s $ init dirs)+- parent (ie for "/" or ".") -}+upFrom :: FilePath -> Maybe FilePath+upFrom dir+	| length dirs < 2 = Nothing+	| otherwise = Just $ joinDrive drive (intercalate s $ init dirs)   where 	-- on Unix, the drive will be "/" when the dir is absolute, otherwise "" 	(drive, path) = splitDrive dir 	dirs = filter (not . null) $ split s path 	s = [pathSeparator] -prop_parentDir_basics :: FilePath -> Bool-prop_parentDir_basics dir+prop_upFrom_basics :: FilePath -> Bool+prop_upFrom_basics dir 	| null dir = True-	| dir == "/" = parentDir dir == Nothing+	| dir == "/" = p == Nothing 	| otherwise = p /= Just dir   where-	p = parentDir dir+	p = upFrom dir  {- Checks if the first FilePath is, or could be said to contain the second.  - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc@@ -124,14 +131,25 @@  -    relPathCwdToFile "/tmp/foo/bar" == ""   -} relPathCwdToFile :: FilePath -> IO FilePath-relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f+relPathCwdToFile f = do+	c <- getCurrentDirectory+	relPathDirToFile c f -{- Constructs a relative path from a directory to a file.+{- Constructs a relative path from a directory to a file. -}+relPathDirToFile :: FilePath -> FilePath -> IO FilePath+relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to++{- This requires the first path to be absolute, and the+ - second path cannot contain ../ or ./  -- - Both must be absolute, and cannot contain .. etc. (eg use absPath first).+ - On Windows, if the paths are on different drives,+ - a relative path is not possible and the path is simply+ - returned as-is.  -}-relPathDirToFile :: FilePath -> FilePath -> FilePath-relPathDirToFile from to = join s $ dotdots ++ uncommon+relPathDirToFileAbs :: FilePath -> FilePath -> FilePath+relPathDirToFileAbs from to+	| takeDrive from /= takeDrive to = to+	| otherwise = intercalate s $ dotdots ++ uncommon   where 	s = [pathSeparator] 	pfrom = split s from@@ -144,10 +162,11 @@  prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool prop_relPathDirToFile_basics from to+	| null from || null to = True 	| from == to = null r 	| otherwise = not (null r)   where-	r = relPathDirToFile from to +	r = relPathDirToFileAbs from to   prop_relPathDirToFile_regressionTest :: Bool prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference@@ -156,22 +175,31 @@ 	 - location, but it's not really the same directory. 	 - Code used to get this wrong. -} 	same_dir_shortcurcuits_at_difference =-		relPathDirToFile (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])+		relPathDirToFileAbs (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"]) 			(joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]) 				== joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]  {- Given an original list of paths, and an expanded list derived from it,- - generates a list of lists, where each sublist corresponds to one of the- - original paths. When the original path is a directory, any items- - in the expanded list that are contained in that directory will appear in- - its segment.+ - which may be arbitrarily reordered, generates a list of lists, where+ - each sublist corresponds to one of the original paths.+ -+ - When the original path is a directory, any items in the expanded list+ - that are contained in that directory will appear in its segment.+ -+ - The order of the original list of paths is attempted to be preserved in+ - the order of the returned segments. However, doing so has a O^NM+ - growth factor. So, if the original list has more than 100 paths on it,+ - we stop preserving ordering at that point. Presumably a user passing+ - that many paths in doesn't care too much about order of the later ones.  -} segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]] segmentPaths [] new = [new] segmentPaths [_] new = [new] -- optimisation-segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest+segmentPaths (l:ls) new = found : segmentPaths ls rest   where-	(found, rest)=partition (l `dirContains`) new+	(found, rest) = if length ls < 100+		then partition (l `dirContains`) new+		else break (\p -> not (l `dirContains` p)) new  {- This assumes that it's cheaper to call segmentPaths on the result,  - than it would be to run the action separately with each path. In@@ -185,7 +213,7 @@ relHome path = do 	home <- myHomeDir 	return $ if dirContains home path-		then "~/" ++ relPathDirToFile home path+		then "~/" ++ relPathDirToFileAbs home path 		else path  {- Checks if a command is available in PATH.@@ -260,7 +288,6 @@ 	if l <= 0 		then return 255 		else return $ minimum [l, 255]-  where #endif  {- Given a string that we'd like to use as the basis for FilePath, but that
Utility/PosixFiles.hs view
@@ -2,12 +2,13 @@  -  - This is like System.PosixCompat.Files, except with a fixed rename.  -- - Copyright 2014 Joey Hess <joey@kitenet.net>+ - Copyright 2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}  {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.PosixFiles ( 	module X,
Utility/Process.hs view
@@ -1,12 +1,13 @@ {- System.Process enhancements, including additional ways of running  - processes, and logging.  -- - Copyright 2012 Joey Hess <id@joeyh.name>+ - Copyright 2012-2015 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}  {-# LANGUAGE CPP, Rank2Types #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Process ( 	module X,@@ -25,21 +26,27 @@ 	processTranscript, 	processTranscript', 	withHandle,-	withBothHandles,+	withIOHandles,+	withOEHandles, 	withQuietOutput,+	feedWithQuietOutput, 	createProcess,+	waitForProcess, 	startInteractiveProcess, 	stdinHandle, 	stdoutHandle, 	stderrHandle,-	bothHandles,+	ioHandles, 	processHandle, 	devNull, ) where -import qualified System.Process-import qualified System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)-import System.Process hiding (createProcess, readProcess)+import qualified Utility.Process.Shim+import qualified Utility.Process.Shim as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)+import Utility.Process.Shim hiding (createProcess, readProcess, waitForProcess)+import Utility.Misc+import Utility.Exception+ import System.Exit import System.IO import System.Log.Logger@@ -52,17 +59,15 @@ import Control.Applicative #endif import Data.Maybe--import Utility.Misc-import Utility.Exception+import Prelude  type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a  data StdHandle = StdinHandle | StdoutHandle | StderrHandle 	deriving (Eq) -{- Normally, when reading from a process, it does not need to be fed any- - standard input. -}+-- | Normally, when reading from a process, it does not need to be fed any+-- standard input. readProcess :: FilePath	-> [String] -> IO String readProcess cmd args = readProcessEnv cmd args Nothing @@ -80,9 +85,8 @@ 	hClose h 	return output -{- Runs an action to write to a process on its stdin, - - returns its output, and also allows specifying the environment.- -}+-- | Runs an action to write to a process on its stdin, +-- returns its output, and also allows specifying the environment. writeReadProcessEnv 	:: FilePath 	-> [String]@@ -122,8 +126,8 @@ 		, env = environ 		} -{- Waits for a ProcessHandle, and throws an IOError if the process- - did not exit successfully. -}+-- | 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@@ -131,10 +135,10 @@ 		ExitSuccess -> return () 		ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n -{- Waits for a ProcessHandle and returns True if it exited successfully.- - Note that using this with createProcessChecked will throw away- - the Bool, and is only useful to ignore the exit code of a process,- - while still waiting for it. -}+-- | Waits for a ProcessHandle and returns True if it exited successfully.+-- Note that using this with createProcessChecked will throw away+-- the Bool, and is only useful to ignore the exit code of a process,+-- while still waiting for it. -} checkSuccessProcess :: ProcessHandle -> IO Bool checkSuccessProcess pid = do 	code <- waitForProcess pid@@ -145,13 +149,13 @@ 	void $ waitForProcess pid 	return True -{- Runs createProcess, then an action on its handles, and then- - forceSuccessProcess. -}+-- | Runs createProcess, then an action on its handles, and then+-- forceSuccessProcess. createProcessSuccess :: CreateProcessRunner createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a -{- Runs createProcess, then an action on its handles, and then- - a checker action on its exit code, which must wait for the process. -}+-- | Runs createProcess, then an action on its handles, and then+-- a checker action on its exit code, which must wait for the process. createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner createProcessChecked checker p a = do 	t@(_, _, _, pid) <- createProcess p@@ -159,31 +163,30 @@ 	_ <- checker pid 	either E.throw return r -{- Leaves the process running, suitable for lazy streaming.- - Note: Zombies will result, and must be waited on. -}+-- | Leaves the process running, suitable for lazy streaming.+-- Note: Zombies will result, and must be waited on. createBackgroundProcess :: CreateProcessRunner createBackgroundProcess p a = a =<< createProcess p -{- Runs a process, optionally feeding it some input, and- - returns a transcript combining its stdout and stderr, and- - whether it succeeded or failed. -}+-- | Runs a process, optionally feeding it some input, 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 input = processTranscript' cmd opts Nothing input+processTranscript = processTranscript' id -processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool)-processTranscript' cmd opts environ input = do+processTranscript' :: (CreateProcess -> CreateProcess) -> String -> [String] -> Maybe String -> IO (String, Bool)+processTranscript' modproc cmd opts input = do #ifndef mingw32_HOST_OS {- This implementation interleves stdout and stderr in exactly the order  - the process writes them. -} 	(readf, writef) <- System.Posix.IO.createPipe 	readh <- System.Posix.IO.fdToHandle readf 	writeh <- System.Posix.IO.fdToHandle writef-	p@(_, _, _, pid) <- createProcess $+	p@(_, _, _, pid) <- createProcess $ modproc $ 		(proc cmd opts) 			{ std_in = if isJust input then CreatePipe else Inherit 			, std_out = UseHandle writeh 			, std_err = UseHandle writeh-			, env = environ 			} 	hClose writeh @@ -195,12 +198,11 @@ 	return (transcript, ok) #else {- This implementation for Windows puts stderr after stdout. -}-	p@(_, _, _, pid) <- createProcess $+	p@(_, _, _, pid) <- createProcess $ modproc $ 		(proc cmd opts) 			{ std_in = if isJust input then CreatePipe else Inherit 			, std_out = CreatePipe 			, std_err = CreatePipe-			, env = environ 			}  	getout <- mkreader (stdoutHandle p)@@ -230,9 +232,9 @@ 		hClose inh 	writeinput Nothing _ = return () -{- Runs a CreateProcessRunner, on a CreateProcess structure, that- - is adjusted to pipe only from/to a single StdHandle, and passes- - the resulting Handle to an action. -}+-- | Runs a CreateProcessRunner, on a CreateProcess structure, that+-- is adjusted to pipe only from/to a single StdHandle, and passes+-- the resulting Handle to an action. withHandle 	:: StdHandle 	-> CreateProcessRunner@@ -254,13 +256,13 @@ 		| h == StderrHandle = 			(stderrHandle, base { std_err = CreatePipe }) -{- Like withHandle, but passes (stdin, stdout) handles to the action. -}-withBothHandles+-- | Like withHandle, but passes (stdin, stdout) handles to the action.+withIOHandles 	:: CreateProcessRunner 	-> CreateProcess 	-> ((Handle, Handle) -> IO a) 	-> IO a-withBothHandles creator p a = creator p' $ a . bothHandles+withIOHandles creator p a = creator p' $ a . ioHandles   where 	p' = p 		{ std_in = CreatePipe@@ -268,8 +270,22 @@ 		, std_err = Inherit 		} -{- Forces the CreateProcessRunner to run quietly;- - both stdout and stderr are discarded. -}+-- | Like withHandle, but passes (stdout, stderr) handles to the action.+withOEHandles+	:: CreateProcessRunner+	-> CreateProcess+	-> ((Handle, Handle) -> IO a)+	-> IO a+withOEHandles creator p a = creator p' $ a . oeHandles+  where+	p' = p+		{ std_in = Inherit+		, std_out = CreatePipe+		, std_err = CreatePipe+		}++-- | Forces the CreateProcessRunner to run quietly;+-- both stdout and stderr are discarded. withQuietOutput 	:: CreateProcessRunner 	-> CreateProcess@@ -281,6 +297,21 @@ 		} 	creator p' $ const $ return () +-- | Stdout and stderr are discarded, while the process is fed stdin+-- from the handle.+feedWithQuietOutput+	:: CreateProcessRunner+	-> CreateProcess+	-> (Handle -> IO a)+	-> IO a+feedWithQuietOutput creator p a = withFile devNull WriteMode $ \nullh -> do+	let p' = p+		{ std_in = CreatePipe+		, std_out = UseHandle nullh+		, std_err = UseHandle nullh+		}+	creator p' $ a . stdinHandle+ devNull :: FilePath #ifndef mingw32_HOST_OS devNull = "/dev/null"@@ -288,11 +319,11 @@ devNull = "NUL" #endif -{- Extract a desired handle from createProcess's tuple.- - These partial functions are safe as long as createProcess is run- - with appropriate parameters to set up the desired handle.- - Get it wrong and the runtime crash will always happen, so should be- - easily noticed. -}+-- | Extract a desired handle from createProcess's tuple.+-- These partial functions are safe as long as createProcess is run+-- with appropriate parameters to set up the desired handle.+-- Get it wrong and the runtime crash will always happen, so should be+-- easily noticed. type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle stdinHandle :: HandleExtractor stdinHandle (Just h, _, _, _) = h@@ -303,38 +334,25 @@ stderrHandle :: HandleExtractor stderrHandle (_, _, Just h, _) = h stderrHandle _ = error "expected stderrHandle"-bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)-bothHandles (Just hin, Just hout, _, _) = (hin, hout)-bothHandles _ = error "expected bothHandles"+ioHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)+ioHandles (Just hin, Just hout, _, _) = (hin, hout)+ioHandles _ = error "expected ioHandles"+oeHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)+oeHandles (_, Just hout, Just herr, _) = (hout, herr)+oeHandles _ = error "expected oeHandles"  processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle processHandle (_, _, _, pid) = pid -{- Debugging trace for a CreateProcess. -}-debugProcess :: CreateProcess -> IO ()-debugProcess p = do-	debugM "Utility.Process" $ unwords-		[ action ++ ":"-		, showCmd p-		]-  where-	action-		| piped (std_in p) && piped (std_out p) = "chat"-		| piped (std_in p)                      = "feed"-		| piped (std_out p)                     = "read"-		| otherwise                             = "call"-	piped Inherit = False-	piped _ = True--{- Shows the command that a CreateProcess will run. -}+-- | Shows the command that a CreateProcess will run. showCmd :: CreateProcess -> String showCmd = go . cmdspec   where 	go (ShellCommand s) = s 	go (RawCommand c ps) = c ++ " " ++ show ps -{- Starts an interactive process. Unlike runInteractiveProcess in- - System.Process, stderr is inherited. -}+-- | Starts an interactive process. Unlike runInteractiveProcess in+-- System.Process, stderr is inherited. startInteractiveProcess 	:: FilePath 	-> [String]@@ -350,8 +368,30 @@ 	(Just from, Just to, _, pid) <- createProcess p 	return (pid, to, from) -{- Wrapper around System.Process function that does debug logging. -}+-- | Wrapper around 'System.Process.createProcess' that does debug logging. createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do 	debugProcess p-	System.Process.createProcess p+	Utility.Process.Shim.createProcess p++-- | Debugging trace for a CreateProcess.+debugProcess :: CreateProcess -> IO ()+debugProcess p = debugM "Utility.Process" $ unwords+	[ action ++ ":"+	, showCmd p+	]+  where+	action+		| piped (std_in p) && piped (std_out p) = "chat"+		| piped (std_in p)                      = "feed"+		| piped (std_out p)                     = "read"+		| otherwise                             = "call"+	piped Inherit = False+	piped _ = True++-- | Wrapper around 'System.Process.waitForProcess' that does debug logging.+waitForProcess ::  ProcessHandle -> IO ExitCode+waitForProcess h = do+	r <- Utility.Process.Shim.waitForProcess h+	debugM "Utility.Process" ("process done " ++ show r)+	return r
+ Utility/Process/Shim.hs view
@@ -0,0 +1,3 @@+module Utility.Process.Shim (module X) where++import System.Process as X
Utility/QuickCheck.hs view
@@ -1,6 +1,6 @@ {- QuickCheck with additional instances  -- - Copyright 2012-2014 Joey Hess <joey@kitenet.net>+ - Copyright 2012-2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -19,6 +19,7 @@ import qualified Data.Map as M import qualified Data.Set as S import Control.Applicative+import Prelude  instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where 	arbitrary = M.fromList <$> arbitrary
Utility/Rsync.hs view
@@ -1,6 +1,6 @@ {- various rsync stuff  -- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2013 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -44,7 +44,8 @@ 	-- allow resuming of transfers of big files 	, Param "--inplace" 	-- other options rsync normally uses in server mode-	, Params "-e.Lsf ."+	, Param "-e.Lsf"+	, Param "." 	]  rsyncUseDestinationPermissions :: CommandParam@@ -92,13 +93,13 @@ 	| rsyncUrlIsShell s = False 	| otherwise = ':' `notElem` s -{- Runs rsync, but intercepts its progress output and updates a meter.- - The progress output is also output to stdout. +{- Runs rsync, but intercepts its progress output and updates a progress+ - meter.  -  - The params must enable rsync's --progress mode for this to work.  -}-rsyncProgress :: MeterUpdate -> [CommandParam] -> IO Bool-rsyncProgress meterupdate = commandMeter parseRsyncProgress meterupdate "rsync" . rsyncParamsFixup+rsyncProgress :: OutputHandler -> MeterUpdate -> [CommandParam] -> IO Bool+rsyncProgress oh meter = commandMeter parseRsyncProgress oh meter "rsync" . rsyncParamsFixup  {- Strategy: Look for chunks prefixed with \r (rsync writes a \r before  - the first progress output, and each thereafter). The first number
Utility/SafeCommand.hs view
@@ -1,84 +1,94 @@ {- safely running shell commands  -- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2015 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -} +{-# OPTIONS_GHC -fno-warn-tabs #-}+ module Utility.SafeCommand where  import System.Exit import Utility.Process import Data.String.Utils-import Control.Applicative import System.FilePath import Data.Char+import Data.List+import Control.Applicative+import Prelude -{- A type for parameters passed to a shell command. A command can- - be passed either some Params (multiple parameters can be included,- - whitespace-separated, or a single Param (for when parameters contain- - whitespace), or a File.- -}-data CommandParam = Params String | Param String | File FilePath+-- | Parameters that can be passed to a shell command.+data CommandParam+	= Param String -- ^ A parameter+	| File FilePath -- ^ The name of a file 	deriving (Eq, Show, Ord) -{- Used to pass a list of CommandParams to a function that runs- - a command and expects Strings. -}+-- | Used to pass a list of CommandParams to a function that runs+-- a command and expects Strings. -} toCommand :: [CommandParam] -> [String]-toCommand = concatMap unwrap+toCommand = map unwrap   where-	unwrap (Param s) = [s]-	unwrap (Params s) = filter (not . null) (split " " s)+	unwrap (Param s) = s 	-- Files that start with a non-alphanumeric that is not a path 	-- separator are modified to avoid the command interpreting them as 	-- options or other special constructs. 	unwrap (File s@(h:_))-		| isAlphaNum h || h `elem` pathseps = [s]-		| otherwise = ["./" ++ s]-	unwrap (File s) = [s]+		| isAlphaNum h || h `elem` pathseps = s+		| otherwise = "./" ++ s+	unwrap (File s) = s 	-- '/' is explicitly included because it's an alternative 	-- path separator on Windows. 	pathseps = pathSeparator:"./" -{- Run a system command, and returns True or False- - if it succeeded or failed.- -}+-- | Run a system command, and returns True or False if it succeeded or failed.+--+-- This and other command running functions in this module log the commands+-- run at debug level, using System.Log.Logger. boolSystem :: FilePath -> [CommandParam] -> IO Bool-boolSystem command params = boolSystemEnv command params Nothing+boolSystem command params = boolSystem' command params id -boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool-boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ+boolSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO Bool+boolSystem' command params mkprocess = dispatch <$> safeSystem' command params mkprocess   where 	dispatch ExitSuccess = True 	dispatch _ = False -{- Runs a system command, returning the exit status. -}+boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool+boolSystemEnv command params environ = boolSystem' command params $+	\p -> p { env = environ }++-- | Runs a system command, returning the exit status. safeSystem :: FilePath -> [CommandParam] -> IO ExitCode-safeSystem command params = safeSystemEnv command params Nothing+safeSystem command params = safeSystem' command params id -safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode-safeSystemEnv command params environ = do-	(_, _, _, pid) <- createProcess (proc command $ toCommand params)-		{ env = environ }+safeSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO ExitCode+safeSystem' command params mkprocess = do+	(_, _, _, pid) <- createProcess p 	waitForProcess pid+  where+	p = mkprocess $ proc command (toCommand params) -{- Wraps a shell command line inside sh -c, allowing it to be run in a- - login shell that may not support POSIX shell, eg csh. -}+safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode+safeSystemEnv command params environ = safeSystem' command params $ +	\p -> p { env = environ }++-- | Wraps a shell command line inside sh -c, allowing it to be run in a+-- login shell that may not support POSIX shell, eg csh. shellWrap :: String -> String shellWrap cmdline = "sh -c " ++ shellEscape cmdline -{- Escapes a filename or other parameter to be safely able to be exposed to- - the shell.- -- - This method works for POSIX shells, as well as other shells like csh.- -}+-- | Escapes a filename or other parameter to be safely able to be exposed to+-- the shell.+--+-- This method works for POSIX shells, as well as other shells like csh. shellEscape :: String -> String shellEscape f = "'" ++ escaped ++ "'"   where 	-- replace ' with '"'"'-	escaped = join "'\"'\"'" $ split "'" f+	escaped = intercalate "'\"'\"'" $ split "'" f -{- Unescapes a set of shellEscaped words or filenames. -}+-- | Unescapes a set of shellEscaped words or filenames. shellUnEscape :: String -> [String] shellUnEscape [] = [] shellUnEscape s = word : shellUnEscape rest@@ -95,25 +105,32 @@ 		| c == q = findword w cs 		| otherwise = inquote q (w++[c]) cs -{- For quickcheck. -}-prop_idempotent_shellEscape :: String -> Bool-prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s-prop_idempotent_shellEscape_multiword :: [String] -> Bool-prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s+-- | For quickcheck.+prop_isomorphic_shellEscape :: String -> Bool+prop_isomorphic_shellEscape s = [s] == (shellUnEscape . shellEscape) s+prop_isomorphic_shellEscape_multiword :: [String] -> Bool+prop_isomorphic_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s -{- Segements a list of filenames into groups that are all below the manximum- - command-line length limit. Does not preserve order. -}-segmentXargs :: [FilePath] -> [[FilePath]]-segmentXargs l = go l [] 0 []+-- | Segments a list of filenames into groups that are all below the maximum+--  command-line length limit.+segmentXargsOrdered :: [FilePath] -> [[FilePath]]+segmentXargsOrdered = reverse . map reverse . segmentXargsUnordered++-- | Not preserving order is a little faster, and streams better when+-- there are a great many filenames.+segmentXargsUnordered :: [FilePath] -> [[FilePath]]+segmentXargsUnordered l = go l [] 0 []   where-	go [] c _ r = c:r+	go [] c _ r = (c:r) 	go (f:fs) c accumlen r-		| len < maxlen && newlen > maxlen = go (f:fs) [] 0 (c:r)+		| newlen > maxlen && len < maxlen = go (f:fs) [] 0 (c:r) 		| otherwise = go fs (f:c) newlen r 	  where 		len = length f 		newlen = accumlen + len -	{- 10k of filenames per command, well under Linux's 20k limit;-	 - allows room for other parameters etc. -}+	{- 10k of filenames per command, well under 100k limit+	 - of Linux (and OSX has a similar limit);+	 - allows room for other parameters etc. Also allows for+	 - eg, multibyte characters. -} 	maxlen = 10240
Utility/ThreadScheduler.hs view
@@ -1,6 +1,6 @@ {- thread scheduling  -- - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2012, 2013 Joey Hess <id@joeyh.name>  - Copyright 2011 Bas van Dijk & Roel van Dijk  -  - License: BSD-2-clause
Utility/Tmp.hs view
@@ -1,11 +1,12 @@ {- Temporary files and directories.  -- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2013 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}  {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Tmp where @@ -14,6 +15,9 @@ import Control.Monad.IfElse import System.FilePath import Control.Monad.IO.Class+#ifndef mingw32_HOST_OS+import System.Posix.Temp (mkdtemp)+#endif  import Utility.Exception import Utility.FileSystemEncoding@@ -63,32 +67,45 @@  - directory and all its contents. -} withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a withTmpDir template a = do-	tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory-	withTmpDirIn tmpdir template a+	topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory+#ifndef mingw32_HOST_OS+	-- Use mkdtemp to create a temp directory securely in /tmp.+	bracket+		(liftIO $ mkdtemp $ topleveltmpdir </> template)+		removeTmpDir+		a+#else+	withTmpDirIn topleveltmpdir template a+#endif  {- Runs an action with a tmp directory located within a specified directory,  - then removes the tmp directory and all its contents. -} withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a-withTmpDirIn tmpdir template = bracketIO create remove+withTmpDirIn tmpdir template = bracketIO create removeTmpDir   where-	remove d = whenM (doesDirectoryExist d) $ do-#if mingw32_HOST_OS-		-- Windows will often refuse to delete a file-		-- after a process has just written to it and exited.-		-- Because it's crap, presumably. So, ignore failure-		-- to delete the temp directory.-		_ <- tryIO $ removeDirectoryRecursive d-		return ()-#else-		removeDirectoryRecursive d-#endif 	create = do 		createDirectoryIfMissing True tmpdir 		makenewdir (tmpdir </> template) (0 :: Int) 	makenewdir t n = do 		let dir = t ++ "." ++ show n-		either (const $ makenewdir t $ n + 1) (const $ return dir)-			=<< tryIO (createDirectory dir)+		catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do+			createDirectory dir+			return dir++{- Deletes the entire contents of the the temporary directory, if it+ - exists. -}+removeTmpDir :: MonadIO m => FilePath -> m ()+removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do+#if mingw32_HOST_OS+	-- Windows will often refuse to delete a file+	-- after a process has just written to it and exited.+	-- Because it's crap, presumably. So, ignore failure+	-- to delete the temp directory.+	_ <- tryIO $ removeDirectoryRecursive tmpdir+	return ()+#else+	removeDirectoryRecursive tmpdir+#endif  {- It's not safe to use a FilePath of an existing file as the template  - for openTempFile, because if the FilePath is really long, the tmpfile
Utility/URI.hs view
@@ -1,6 +1,6 @@ {- Network.URI  -- - Copyright 2014 Joey Hess <joey@kitenet.net>+ - Copyright 2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}
Utility/UserInfo.hs view
@@ -1,11 +1,12 @@ {- user info  -- - Copyright 2012 Joey Hess <joey@kitenet.net>+ - Copyright 2012 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}  {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.UserInfo ( 	myHomeDir,@@ -13,12 +14,13 @@ 	myUserGecos, ) where +import Utility.Env+ import System.PosixCompat #ifndef mingw32_HOST_OS import Control.Applicative #endif--import Utility.Env+import Prelude  {- Current user's home directory.  -
debian/changelog view
@@ -1,6 +1,14 @@+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 Gergely Nagy.+  * Debian package is now maintained by Richard Hartmann.   * Fix build with process 1.2.1.0.   * Merge from git-annex.
debian/control view
@@ -17,7 +17,7 @@ 	libghc-utf8-string-dev, 	libghc-async-dev, 	libghc-optparse-applicative-dev (>= 0.10.0)-Maintainer: Gergely Nagy <algernon@madhouse-project.org>+Maintainer: Richard Hartmann <richih@debian.org> Standards-Version: 3.9.5 Vcs-Git: git://git-repair.branchable.com/ Homepage: http://git-repair.branchable.com/@@ -26,7 +26,7 @@ Architecture: any Section: utils Depends: ${misc:Depends}, ${shlibs:Depends}, git, rsync-Description: repair various forms of damage to git repositorie+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.
+ debian/git-repair.lintian-overrides view
@@ -0,0 +1,1 @@+binary-or-shlib-defines-rpath
+ doc/news/version_1.20151215.mdwn view
@@ -0,0 +1,5 @@+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.20150106+Version: 1.20151215 Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess <joey@kitenet.net>@@ -28,7 +28,7 @@  Executable git-repair   Main-Is: git-repair.hs-  GHC-Options: -Wall -threaded+  GHC-Options: -threaded -Wall -fno-warn-tabs   Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl,    unix-compat, bytestring, exceptions (>= 0.6), transformers,    base >= 4.5, base < 5, IfElse, text, process, time, QuickCheck,