packages feed

github-backup 1.20150106 → 1.20150617

raw patch · 45 files changed

+612/−211 lines, 45 filesdep +Win32dep +setenvdep +utf8-string

Dependencies added: Win32, setenv, utf8-string

Files

Build/TestConfig.hs view
@@ -1,5 +1,7 @@ {- Tests the system and generates Build.SysConfig.hs. -} +{-# OPTIONS_GHC -fno-warn-tabs #-}+ module Build.TestConfig where  import Utility.Path
Build/Version.hs view
@@ -1,5 +1,7 @@ {- Package version determination, for configure script. -} +{-# OPTIONS_GHC -fno-warn-tabs #-}+ module Build.Version where  import Data.Maybe@@ -10,14 +12,15 @@ import Data.Char import System.Process -import Build.TestConfig import Utility.Monad import Utility.Exception +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.@@ -25,14 +28,14 @@  -  - If git or a git repo is not available, or something goes wrong,  - or this is a release build, just use the version from the changelog. -}-getVersion :: Test+getVersion :: IO Version getVersion = do 	changelogversion <- getChangelogVersion-	version <- ifM (isReleaseBuild)+	ifM (isReleaseBuild) 		( return changelogversion 		, catchDefaultIO changelogversion $ do 			let major = takeWhile (/= '.') changelogversion-			autoversion <- readProcess "sh"+			autoversion <- takeWhile (\c -> isAlphaNum c || c == '-') <$> readProcess "sh" 				[ "-c" 				, "git log -n 1 --format=format:'%ci %h'| sed -e 's/-//g' -e 's/ .* /-g/'" 				] ""@@ -40,9 +43,8 @@ 				then return changelogversion 				else return $ concat [ major, ".", autoversion ] 		)-	return $ Config "packageversion" (StringConfig version) 	-getChangelogVersion :: IO String+getChangelogVersion :: IO Version getChangelogVersion = do 	changelog <- readFile "debian/changelog" 	let verline = takeWhile (/= '\n') changelog
+ CHANGELOG view
@@ -0,0 +1,189 @@+github-backup (1.20150617) unstable; urgency=medium++  * Add missing build deps for windows to cabal file.+    Thanks, Jeff Segal.+  * Various updates to internal git and utility libraries shared+    with git-annex.++ -- Joey Hess <id@joeyh.name>  Wed, 17 Jun 2015 14:44:14 -0400++github-backup (1.20150106) unstable; urgency=medium++  * Fix build with process 1.2.1.0.+  * Various updates to internal git and utility libraries shared+    with git-annex.++ -- Joey Hess <id@joeyh.name>  Tue, 06 Jan 2015 19:08:08 -0400++github-backup (1.20141222) unstable; urgency=medium++  * Added gitriddance(1), a utility to close all issues and pull requests,+    for repos that don't want to be bothered with GitHub's proprietary+    issue tracker.+  * gitriddance depends on github 0.13.1, which has bug fixes+    for posting comments.+  * Various updates to internal git and utility libraries shared+    with git-annex.++ -- Joey Hess <id@joeyh.name>  Mon, 22 Dec 2014 15:30:08 -0400++github-backup (1.20141204) unstable; urgency=high++  * Fix broken argument parser for the username|organization parameter.+    Closes: #772043++ -- Joey Hess <id@joeyh.name>  Thu, 04 Dec 2014 12:29:06 -0400++github-backup (1.20141110) unstable; urgency=medium++  * Orphaned the Debian package.+    (I continue to maintain github-backup upstream.)++ -- Joey Hess <joeyh@debian.org>  Mon, 10 Nov 2014 12:19:59 -0400++github-backup (1.20141031) unstable; urgency=medium++  * Adjust cabal file for network-uri split.+  * Avoid using optparse-applicate's argument combinator, so it will build+    with 0.11 and older too.+  * Various updates to internal git and utility libraries shared with+    git-annex.++ -- Joey Hess <joeyh@debian.org>  Fri, 31 Oct 2014 11:17:49 -0400++github-backup (1.20140831) unstable; urgency=medium++  * Fix build with github 0.10.++ -- Joey Hess <joeyh@debian.org>  Sun, 31 Aug 2014 15:31:26 -0700++github-backup (1.20140807) unstable; urgency=medium++  * Fix build with github 0.9.+  * Fix creation of github branch.++ -- Joey Hess <joeyh@debian.org>  Thu, 07 Aug 2014 22:17:22 -0400++github-backup (1.20140721) unstable; urgency=medium++  * Fix typo in fix for url parsing. Closes: #755261++ -- Joey Hess <joeyh@debian.org>  Mon, 21 Jul 2014 13:10:49 -0400++github-backup (1.20140720) unstable; urgency=medium++  * Deal with trailing slashes on github repo urls. Closes: #755261+  * Fix bug introduced by change to embedded git libraries+    in last release. Closes: #755262++ -- Joey Hess <joeyh@debian.org>  Sun, 20 Jul 2014 17:20:26 -0400++github-backup (1.20140707) unstable; urgency=medium++  * Add --exclude to skip backing up a specific repository+    when backing up a user or organization's repositories.+    Closes: #754072+  * Converted to using optparse-applicative.+  * Multiple usernames can now be specified to back up at once.++ -- Joey Hess <joeyh@debian.org>  Mon, 07 Jul 2014 23:01:03 -0400++github-backup (1.20140704) unstable; urgency=medium++  * Avoid making signed commits when committing to the github-backup branch+    and the user has commit.gpgsign=true.+    Closes: #753720+  * Various updates to internal git and utility libraries shared with git-annex.++ -- Joey Hess <joeyh@debian.org>  Fri, 04 Jul 2014 12:01:11 -0400++github-backup (1.20131203) unstable; urgency=low++  * Now also backs up the repos a user has starred, when run with a user's+    name.+  * Now finds and backs up the parent repository that a repository got forked+    from.+  * Uses authentication for all API calls.+  * Fairer ordering of requests when backing up many repositories at once.+  * Avoid making requests for data that has already been backed up until+    after new data has been backed up. Handles API rate limiting much better.+    Closes: #723859++ -- Joey Hess <joeyh@debian.org>  Tue, 03 Dec 2013 12:45:18 -0400++github-backup (1.20131101) unstable; urgency=low++  * Now also backs up the repos a user is watching, when run with a user's+    name. Useful if you want to back up repositories that you have not forked;+    just watch them and run github-backup.+  * Can now log in to github, to avoid increasingly small API rate limits.+    Set GITHUB_USER and GITHUB_PASSWORD environment to enable.+    Note that a few api calls don't use authentication; see+    https://github.com/fpco/github/issues/40+  * Build-Depend on git. Closes: #728481+  * Don't include tmp directory in files stored in the github branch.++ -- Joey Hess <joeyh@debian.org>  Fri, 01 Nov 2013 18:00:16 -0400++github-backup (1.20131006) unstable; urgency=low++  * Ported to Windows.+  * Improve error message when it fails to query github for repositories+    belonging to a user. Closes: #705084+  * Various updates to internal git and utility libraries shared with git-annex.+  * Makefile now uses cabal to build.++ -- Joey Hess <joeyh@debian.org>  Sun, 06 Oct 2013 18:04:56 -0400++github-backup (1.20130622) unstable; urgency=low++  * Add missing unix-compat build dependency. Closes: #713279++ -- Joey Hess <joeyh@debian.org>  Sat, 22 Jun 2013 13:08:57 -0400++github-backup (1.20130618) unstable; urgency=low++  * Much better creation and committing to the github branch. ++ -- Joey Hess <joeyh@debian.org>  Mon, 17 Jun 2013 17:40:02 -0400++github-backup (1.20130617) unstable; urgency=low++  * Build-Depend on libghc-extensible-exceptions-dev. Closes: #712549+  * Various updates to internal git and utility libraries shared with+    git-annex, including some Windows portability.+  * Fixed to never touch the git work tree or index file, instead using+    its own to commit to the github branch.++ -- Joey Hess <joeyh@debian.org>  Mon, 17 Jun 2013 12:28:30 -0400++github-backup (1.20130614) unstable; urgency=low++  * Pass --ignore-removal to git-add, in preparation for a future change+    to its default behavior. Requires git 1.8.3. Closes: #711287++ -- Joey Hess <joeyh@debian.org>  Fri, 14 Jun 2013 15:50:49 -0400++github-backup (1.20130414) experimental; urgency=low++  * Updated to use haskell-github 0.6.0, which supports pagination of queries+    Thanks to John Wiegley for making those changes.+  * Also backup closed issues. Thanks, John Wiegley.+  * cabal file no longer tries to list every source file, as that was+    error-prone, and I left some out.++ -- Joey Hess <joeyh@debian.org>  Fri, 12 Apr 2013 18:33:11 -0400++github-backup (1.20120627) unstable; urgency=low++  * Rebuilt with new haskell-github, that works with the new version+    of http-conduit in Debian. Closes: #678787+  * Various updates to internal git and utility libraries shared with git-annex.++ -- Joey Hess <joeyh@debian.org>  Wed, 27 Jun 2012 22:21:01 -0400++github-backup (1.20120314) unstable; urgency=low++  * First release.++ -- Joey Hess <joeyh@debian.org>  Tue, 13 Mar 2012 20:22:43 -0400
@@ -0,0 +1,35 @@+Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/+Source: native package++Files: *+Copyright: © 2010-2014 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.
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.  -}@@ -30,6 +30,8 @@ 	attributes, 	hookPath, 	assertLocal,+	adjustPath,+	relPath, ) where  import Network.URI (uriPath, uriScheme, unEscapeString)@@ -58,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@@ -68,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. -}@@ -139,3 +141,29 @@ #else 	isexecutable f = isExecutable . fileMode <$> getFileStatus f #endif++{- Makes the path to a local Repo be relative to the cwd. -}+relPath :: Repo -> IO Repo+relPath = adjustPath torel+  where+	torel p = do+		p' <- relPathCwdToFile p+		if null p'+			then return "."+			else return p'++{- Adusts the path to a local Repo using the provided function. -}+adjustPath :: (FilePath -> IO FilePath) -> Repo -> IO Repo+adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do+	d' <- f d+	w' <- maybe (pure Nothing) (Just <$$> f) w+	return $ r +		{ location = l +			{ gitdir = d'+			, worktree = w'+			}+		}+adjustPath f r@(Repo { location = LocalUnknown d }) = do+	d' <- f d+	return $ r { location = LocalUnknown d' }+adjustPath _ r = pure r
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@@ -62,7 +62,7 @@ 	| otherwise = 		error $ "internal error, " ++ dir ++ " is not absolute"   where-	ret = newFrom . LocalUnknown+	ret = pure . newFrom . LocalUnknown 	{- Git always looks for "dir.git" in preference to 	 - to "dir", even if dir ends in a "/". -} 	canondir = dropTrailingPathSeparator dir@@ -90,13 +90,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 +153,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 +223,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 +233,4 @@ 	, gitEnv = Nothing 	, gitGlobalOpts = [] 	}-
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/HashObject.hs view
@@ -1,6 +1,6 @@ {- git hash-object interface  -- - Copyright 2011-2014 Joey Hess <joey@kitenet.net>+ - Copyright 2011-2014 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -32,7 +32,7 @@ hashFile :: HashObjectHandle -> FilePath -> IO Sha hashFile h file = CoProcess.query h send receive   where-	send to = hPutStrLn to file+	send to = hPutStrLn to =<< absPath file 	receive from = getSha "hash-object" $ hGetLine from  {- Injects a blob into git. Unfortunately, the current git-hash-object
Git/Queue.hs view
@@ -1,6 +1,6 @@ {- git repository command queue  -- - 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/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/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/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,
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/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,11 +1,12 @@ {- 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 @@ -18,6 +19,7 @@ import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO) import Data.Maybe+import Prelude  #ifdef mingw32_HOST_OS import qualified System.Win32 as Win32@@ -111,7 +113,7 @@ 			-- But, mv will move into a directory if 			-- dest is one, which is not desired. 			whenM (isdir dest) rethrow-			viaTmp mv dest undefined+			viaTmp mv dest "" 	  where 		rethrow = throwM e 		mv tmp _ = do
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,7 @@ 	catchNonAsync, 	tryNonAsync, 	tryWhenExists,+	catchHardwareFault, ) where  import Control.Monad.Catch as X hiding (Handler)@@ -26,7 +28,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 -}@@ -86,3 +90,12 @@ tryWhenExists a = do 	v <- tryJust (guard . isDoesNotExistError) a 	return (eitherToMaybe v)++{- Catches only exceptions caused by hardware faults.+ - Ie, disk IO error. -}+catchHardwareFault :: MonadCatch m => m a -> (IOException -> m a) -> m a+catchHardwareFault a onhardwareerr = catchIO a onlyhw+  where+	onlyhw e+		| ioeGetErrorType e == HardwareFault = onhardwareerr e+		| otherwise = throwM e
Utility/FileMode.hs view
@@ -1,6 +1,6 @@ {- File mode utilities.  -- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -22,15 +22,12 @@  {- 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+modifyFileMode f convert = do 	s <- getFileStatus f 	let old = fileMode s 	let new = convert old 	when (new /= old) $ 		setFileMode f new-	return old  {- Adds the specified FileModes to the input mode, leaving the rest  - unchanged. -}@@ -41,14 +38,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] @@ -124,7 +113,7 @@ #endif  combineModes :: [FileMode] -> FileMode-combineModes [] = undefined+combineModes [] = 0 combineModes [m] = m combineModes (m:ms) = foldl unionFileModes m ms @@ -151,7 +140,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/FileSystemEncoding.hs view
@@ -1,11 +1,12 @@ {- 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,@@ -14,6 +15,8 @@ 	decodeBS, 	decodeW8, 	encodeW8,+	encodeW8NUL,+	decodeW8NUL, 	truncateFilePath, ) where @@ -25,6 +28,7 @@ import qualified Data.Hash.MD5 as MD5 import Data.Word import Data.Bits.Utils+import Data.List.Utils import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS import qualified Data.ByteString.Lazy.UTF8 as L8@@ -89,6 +93,9 @@  - 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 +107,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 = join nul . map encodeW8 . split (s2w8 nul)+  where+	nul = ['\NUL']++decodeW8NUL :: FilePath -> [Word8]+decodeW8NUL = join (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/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. -}
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@@ -66,7 +68,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,11 +79,15 @@ 	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+- parent (ie for "/" or ".") -}+upFrom :: FilePath -> Maybe FilePath+upFrom dir+	| length dirs < 2 = Nothing 	| otherwise = Just $ joinDrive drive (join s $ init dirs)   where 	-- on Unix, the drive will be "/" when the dir is absolute, otherwise ""@@ -89,13 +95,13 @@ 	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 +130,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 = join s $ dotdots ++ uncommon   where 	s = [pathSeparator] 	pfrom = split s from@@ -144,10 +161,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 +174,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 +212,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.
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,14 +26,16 @@ 	processTranscript, 	processTranscript', 	withHandle,-	withBothHandles,+	withIOHandles,+	withOEHandles, 	withQuietOutput,+	feedWithQuietOutput, 	createProcess, 	startInteractiveProcess, 	stdinHandle, 	stdoutHandle, 	stderrHandle,-	bothHandles,+	ioHandles, 	processHandle, 	devNull, ) where@@ -52,6 +55,7 @@ import Control.Applicative #endif import Data.Maybe+import Prelude  import Utility.Misc import Utility.Exception@@ -61,8 +65,8 @@ 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 +84,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 +125,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 +134,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 +148,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,14 +162,14 @@ 	_ <- 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 @@ -230,9 +233,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 +257,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 +271,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 +298,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 +320,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,14 +335,17 @@ 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. -}+-- | Debugging trace for a CreateProcess. debugProcess :: CreateProcess -> IO () debugProcess p = do 	debugM "Utility.Process" $ unwords@@ -326,15 +361,15 @@ 	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,7 +385,8 @@ 	(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' from System.Process,+-- that does debug logging. createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do 	debugProcess p
Utility/SafeCommand.hs view
@@ -1,84 +1,93 @@ {- 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 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 -{- 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 +104,32 @@ 		| c == q = findword w cs 		| otherwise = inquote q (w++[c]) cs -{- For quickcheck. -}+-- | 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 -{- 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/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
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,3 +1,12 @@+github-backup (1.20150617) unstable; urgency=medium++  * Add missing build deps for windows to cabal file.+    Thanks, Jeff Segal.+  * Various updates to internal git and utility libraries shared+    with git-annex.++ -- Joey Hess <id@joeyh.name>  Wed, 17 Jun 2015 14:44:14 -0400+ github-backup (1.20150106) unstable; urgency=medium    * Fix build with process 1.2.1.0.
debian/rules view
@@ -8,7 +8,3 @@  %: 	dh $@--# Not intended for use by anyone except the author.-announcedir:-	@echo ${HOME}/src/joeywiki/code/github-backup/news
github-backup.cabal view
@@ -1,13 +1,14 @@ Name: github-backup-Version: 1.20150106+Version: 1.20150617 Cabal-Version: >= 1.8-License: GPL Maintainer: Joey Hess <joey@kitenet.net> Author: Joey Hess Stability: Stable Copyright: 2012 Joey Hess-License-File: GPL+License: GPL-3+License-File: COPYRIGHT Build-Type: Custom+Extra-Source-Files: CHANGELOG Homepage: https://github.com/joeyh/github-backup Category: Utility Synopsis: backs up everything github knows about a repository, to the repository@@ -25,7 +26,7 @@  Executable github-backup   Main-Is: github-backup.hs-  GHC-Options: -Wall+  GHC-Options: -Wall -fno-warn-tabs   Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl,    network, exceptions, transformers, unix-compat, bytestring,    IfElse, pretty-show, text, process, optparse-applicative,@@ -34,6 +35,8 @@      if (! os(windows))     Build-Depends: unix+  else+    Build-Depends: Win32, setenv, utf8-string      if flag(network-uri)     Build-Depends: network-uri (>= 2.6), network (>= 2.6)@@ -49,6 +52,8 @@      if (! os(windows))     Build-Depends: unix+  else+    Build-Depends: Win32, setenv, utf8-string      if flag(network-uri)     Build-Depends: network-uri (>= 2.6), network (>= 2.6)
github-backup.hs view
@@ -310,7 +310,7 @@ 		fs <- filter (not . dirCruft) <$> dirContentsRecursive dir 		forM_ fs $ \f -> do 			sha <- hashFile h f-			let path = asTopFilePath (relPathDirToFile dir f)+			path <- asTopFilePath <$> relPathDirToFile dir f 			streamer $ Git.UpdateIndex.updateIndexLine 				sha Git.Types.FileBlob path