github-backup 1.20120627 → 1.20130414

raw patch · 37 files changed

+1587/−598 lines, 37 filesdep +processdep +textdep ~github

Dependencies added: process, text

Dependency ranges changed: github

Files

• .gitattributes +1/−0
• .gitignore +4/−0
• Common.hs +4/−1
• Git.hs +9/−4
• Git/Branch.hs +56/−37
• Git/Command.hs +68/−46
• Git/Config.hs +64/−27
• Git/Construct.hs +128/−105
• Git/Queue.hs +94/−31
• Git/Ref.hs +44/−39
• Git/Sha.hs +9/−9
• Git/Types.hs +40/−7
• Git/Url.hs +11/−11
• Makefile +2/−2
• README.md +4/−6
• Utility/CoProcess.hs +35/−0
• Utility/Directory.hs +61/−44
• Utility/Exception.hs +51/−0
• Utility/FileMode.hs +112/−0
• Utility/FileSystemEncoding.hs +77/−0
• Utility/Misc.hs +80/−5
• Utility/Monad.hs +10/−0
• Utility/Path.hs +73/−59
• Utility/Process.hs +265/−0
• Utility/SafeCommand.hs +33/−60
• Utility/State.hs +3/−1
• Utility/TempFile.hs +27/−10
• Utility/UserInfo.hs +36/−0
• debian/changelog +23/−0
• debian/compat +1/−0
• debian/control +25/−0
• debian/copyright +9/−0
• debian/manpages +1/−0
• debian/rules +7/−0
• github-backup.cabal +2/−8
• github-backup.hs +97/−86
• make-sdist.sh +21/−0

@@ -0,0 +1,1 @@+debian/changelog merge=dpkg-mergechangelogs

@@ -0,0 +1,4 @@+tmp+*.hi+*.o+github-backup

@@ -1,9 +1,11 @@+{-# LANGUAGE PackageImports #-}+ module Common (module X) where  import Control.Monad as X hiding (join) import Control.Monad.IfElse as X import Control.Applicative as X-import Control.Monad.State.Strict as X (liftIO)+import "mtl" Control.Monad.State.Strict as X (liftIO) import Control.Exception.Extensible as X (IOException)  import Data.Maybe as X@@ -23,6 +25,7 @@ import Utility.Misc as X import Utility.Exception as X import Utility.SafeCommand as X+import Utility.Process as X import Utility.Path as X import Utility.Directory as X import Utility.Monad as X

@@ -19,6 +19,7 @@ 	repoIsHttp, 	repoIsLocal, 	repoIsLocalBare,+	repoIsLocalUnknown, 	repoDescribe, 	repoLocation, 	repoPath,@@ -80,8 +81,8 @@ 	| scheme == "git+ssh:" = True 	| scheme == "ssh+git:" = True 	| otherwise = False-	where-		scheme = uriScheme url+  where+	scheme = uriScheme url repoIsSsh _ = False  repoIsHttp :: Repo -> Bool@@ -99,6 +100,10 @@ repoIsLocalBare Repo { location = Local { worktree = Nothing } } = True repoIsLocalBare _ = False +repoIsLocalUnknown :: Repo -> Bool+repoIsLocalUnknown Repo { location = LocalUnknown { } } = True+repoIsLocalUnknown _ = False+ assertLocal :: Repo -> a -> a assertLocal repo action 	| repoIsUrl repo = error $ unwords@@ -121,5 +126,5 @@ 	let hook = localGitDir repo </> "hooks" </> script 	ifM (catchBoolIO $ isexecutable hook) 		( return $ Just hook , return Nothing )-	where-		isexecutable f = isExecutable . fileMode <$> getFileStatus f+  where+	isexecutable f = isExecutable . fileMode <$> getFileStatus f

@@ -5,6 +5,8 @@  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE BangPatterns #-}+ module Git.Branch where  import Common@@ -12,26 +14,45 @@ import Git.Sha import Git.Command -{- The currently checked out branch. -}+{- The currently checked out branch.+ -+ - In a just initialized git repo before the first commit,+ - symbolic-ref will show the master branch, even though that+ - branch is not created yet. So, this also looks at show-ref HEAD+ - to double-check.+ -} current :: Repo -> IO (Maybe Git.Ref)-current r = parse <$> pipeRead [Param "symbolic-ref", Param "HEAD"] r-	where-		parse v-			| null v = Nothing-			| otherwise = Just $ Git.Ref $ firstLine v+current r = do+	v <- currentUnsafe r+	case v of+		Nothing -> return Nothing+		Just branch -> +			ifM (null <$> pipeReadStrict [Param "show-ref", Param $ show branch] r)+				( return Nothing+				, return v+				) +{- The current branch, which may not really exist yet. -}+currentUnsafe :: Repo -> IO (Maybe Git.Ref)+currentUnsafe r = parse . firstLine+	<$> pipeReadStrict [Param "symbolic-ref", Param "HEAD"] r+  where+	parse l+		| null l = Nothing+		| otherwise = Just $ Git.Ref l+ {- Checks if the second branch has any commits not present on the first  - branch. -} changed :: Branch -> Branch -> Repo -> IO Bool changed origbranch newbranch repo 	| origbranch == newbranch = return False 	| otherwise = not . null <$> diffs-	where-		diffs = pipeRead-			[ Param "log"-			, Param (show origbranch ++ ".." ++ show newbranch)-			, Params "--oneline -n1"-			] repo+  where+	diffs = pipeReadStrict+		[ Param "log"+		, Param (show origbranch ++ ".." ++ show newbranch)+		, Params "--oneline -n1"+		] repo  {- Given a set of refs that are all known to have commits not  - on the branch, tries to update the branch by a fast-forward.@@ -49,36 +70,34 @@ 		( no_ff 		, maybe no_ff do_ff =<< findbest first rest 		)-	where-		no_ff = return False-		do_ff to = do-			run "update-ref"-				[Param $ show branch, Param $ show to] repo-			return True-		findbest c [] = return $ Just c-		findbest c (r:rs)-			| c == r = findbest c rs-			| otherwise = do-			better <- changed c r repo-			worse <- changed r c repo-			case (better, worse) of-				(True, True) -> return Nothing -- divergent fail-				(True, False) -> findbest r rs -- better-				(False, True) -> findbest c rs -- worse-				(False, False) -> findbest c rs -- same+  where+	no_ff = return False+	do_ff to = do+		run "update-ref"+			[Param $ show branch, Param $ show to] repo+		return True+	findbest c [] = return $ Just c+	findbest c (r:rs)+		| c == r = findbest c rs+		| otherwise = do+		better <- changed c r repo+		worse <- changed r c repo+		case (better, worse) of+			(True, True) -> return Nothing -- divergent fail+			(True, False) -> findbest r rs -- better+			(False, True) -> findbest c rs -- worse+			(False, False) -> findbest c rs -- same  {- Commits the index into the specified branch (or other ref),   - with the specified parent refs, and returns the committed sha -} commit :: String -> Branch -> [Ref] -> Repo -> IO Sha commit message branch parentrefs repo = do 	tree <- getSha "write-tree" $-		pipeRead [Param "write-tree"] repo-	sha <- getSha "commit-tree" $-		ignorehandle $ pipeWriteRead-			(map Param $ ["commit-tree", show tree] ++ ps)-			message repo+		pipeReadStrict [Param "write-tree"] repo+	sha <- getSha "commit-tree" $ pipeWriteRead+		(map Param $ ["commit-tree", show tree] ++ ps)+		message repo 	run "update-ref" [Param $ show branch, Param $ show sha] repo 	return sha-	where-		ignorehandle a = snd <$> a-		ps = concatMap (\r -> ["-p", show r]) parentrefs+  where+	ps = concatMap (\r -> ["-p", show r]) parentrefs

@@ -7,29 +7,29 @@  module Git.Command where -import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.IO as L-import Control.Concurrent-import Control.Exception (finally)+import System.Process (std_out, env)  import Common import Git import Git.Types+import qualified Utility.CoProcess as CoProcess  {- Constructs a git command line operating on the specified repo. -} gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] gitCommandLine params Repo { location = l@(Local _ _ ) } = setdir : settree ++ params-	where-		setdir = Param $ "--git-dir=" ++ gitdir l-		settree = case worktree l of-			Nothing -> []-			Just t -> [Param $ "--work-tree=" ++ t]+  where+	setdir = Param $ "--git-dir=" ++ gitdir l+	settree = case worktree l of+		Nothing -> []+		Just t -> [Param $ "--work-tree=" ++ t] gitCommandLine _ repo = assertLocal repo $ error "internal"  {- Runs git in the specified repo. -} runBool :: String -> [CommandParam] -> Repo -> IO Bool runBool subcommand params repo = assertLocal repo $-	boolSystem "git" $ gitCommandLine (Param subcommand : params) repo+	boolSystemEnv "git"+		(gitCommandLine (Param subcommand : params) repo)+		(gitEnv repo)  {- Runs git in the specified repo, throwing an error if it fails. -} run :: String -> [CommandParam] -> Repo -> IO ()@@ -37,48 +37,70 @@ 	unlessM (runBool subcommand params repo) $ 		error $ "git " ++ subcommand ++ " " ++ show params ++ " failed" -{- Runs a git subcommand and returns its output, lazily. +{- Runs a git subcommand and returns its output, lazily.  -- - Note that this leaves the git process running, and so zombies will- - result unless reap is called.+ - Also returns an action that should be used when the output is all+ - read (or no more is needed), that will wait on the command, and+ - return True if it succeeded. Failure to wait will result in zombies.  -}-pipeRead :: [CommandParam] -> Repo -> IO String-pipeRead params repo = assertLocal repo $ do-	(_, h) <- hPipeFrom "git" $ toCommand $ gitCommandLine params repo+pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool)+pipeReadLazy params repo = assertLocal repo $ do+	(_, Just h, _, pid) <- createProcess p { std_out = CreatePipe } 	fileEncoding h-	hGetContents h+	c <- hGetContents h+	return (c, checkSuccessProcess pid)+  where+	p  = gitCreateProcess params repo -{- Runs a git subcommand, feeding it input.- - You should call either getProcessStatus or forceSuccess on the PipeHandle. -}-pipeWrite :: [CommandParam] -> L.Text -> Repo -> IO PipeHandle-pipeWrite params s repo = assertLocal repo $ do-	(p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo)-	L.hPutStr h s-	hClose h-	return p+{- Runs a git subcommand, and returns its output, strictly.+ -+ - Nonzero exit status is ignored.+ -}+pipeReadStrict :: [CommandParam] -> Repo -> IO String+pipeReadStrict params repo = assertLocal repo $+	withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do+		fileEncoding h+		output <- hGetContentsStrict h+		hClose h+		return output+  where+	p  = gitCreateProcess params repo -{- Runs a git subcommand, feeding it input, and returning its output.- - You should call either getProcessStatus or forceSuccess on the PipeHandle. -}-pipeWriteRead :: [CommandParam] -> String -> Repo -> IO (PipeHandle, String)-pipeWriteRead params s repo = assertLocal repo $ do-	(p, from, to) <- hPipeBoth "git" (toCommand $ gitCommandLine params repo)-	fileEncoding to-	fileEncoding from-	_ <- forkIO $ finally (hPutStr to s) (hClose to)-	c <- hGetContents from-	return (p, c)+{- Runs a git subcommand, feeding it input, and returning its output,+ - which is expected to be fairly small, since it's all read into memory+ - strictly. -}+pipeWriteRead :: [CommandParam] -> String -> Repo -> IO String+pipeWriteRead params s repo = assertLocal repo $+	writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) +		(gitEnv repo) s (Just fileEncoding) +{- Runs a git subcommand, feeding it input on a handle with an action. -}+pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO ()+pipeWrite params repo = withHandle StdinHandle createProcessSuccess $+	gitCreateProcess params repo+ {- Reads null terminated output of a git command (as enabled by the -z   - parameter), and splits it. -}-pipeNullSplit :: [CommandParam] -> Repo -> IO [String]-pipeNullSplit params repo =-	filter (not . null) . split sep <$> pipeRead params repo-	where-		sep = "\0"+pipeNullSplit :: [CommandParam] -> Repo -> IO ([String], IO Bool)+pipeNullSplit params repo = do+	(s, cleanup) <- pipeReadLazy params repo+	return (filter (not . null) $ split sep s, cleanup)+  where+	sep = "\0" -{- Reaps any zombie git processes. -}-reap :: IO ()-reap = do-	-- throws an exception when there are no child processes-	catchDefaultIO (getAnyProcessStatus False True) Nothing-		>>= maybe noop (const reap)++pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String]+pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo++{- Doesn't run the cleanup action. A zombie results. -}+leaveZombie :: (a, IO Bool) -> a+leaveZombie = fst++{- Runs a git command as a coprocess. -}+gitCoProcessStart :: [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle+gitCoProcessStart params repo = CoProcess.start "git" (toCommand $ gitCommandLine params repo) (gitEnv repo)++gitCreateProcess :: [CommandParam] -> Repo -> CreateProcess+gitCreateProcess params repo =+	(proc "git" $ toCommand $ gitCommandLine params repo)+			{ env = gitEnv repo }

@@ -9,11 +9,13 @@  import qualified Data.Map as M import Data.Char+import System.Process (cwd, env)  import Common import Git import Git.Types import qualified Git.Construct+import Utility.UserInfo  {- Returns a single git config setting, or a default value if not set. -} get :: String -> String -> Repo -> String@@ -36,24 +38,52 @@  {- Reads config even if it was read before. -} reRead :: Repo -> IO Repo-reRead = read'+reRead r = read' $ r+	{ config = M.empty+	, fullconfig = M.empty+	}  {- Cannot use pipeRead because it relies on the config having been already- - read. Instead, chdir to the repo.+ - read. Instead, chdir to the repo and run git config.  -} read' :: Repo -> IO Repo read' repo = go repo-	where-		go Repo { location = Local { gitdir = d } } = git_config d-		go Repo { location = LocalUnknown d } = git_config d-		go _ = assertLocal repo $ error "internal"-		git_config d = bracketCd d $-			pOpen ReadFromPipe "git" ["config", "--null", "--list"] $+  where+	go Repo { location = Local { gitdir = d } } = git_config d+	go Repo { location = LocalUnknown d } = git_config d+	go _ = assertLocal repo $ error "internal"+	git_config d = withHandle StdoutHandle createProcessSuccess p $+		hRead repo+	  where+		params = ["config", "--null", "--list"]+		p = (proc "git" params)+			{ cwd = Just d+			, env = gitEnv repo+			}++{- Gets the global git config, returning a dummy Repo containing it. -}+global :: IO (Maybe Repo)+global = do+	home <- myHomeDir+	ifM (doesFileExist $ home </> ".gitconfig")+		( do+			repo <- Git.Construct.fromUnknown+			repo' <- withHandle StdoutHandle createProcessSuccess p $ 				hRead repo+			return $ Just repo'+		, return Nothing+		)+  where+	params = ["config", "--null", "--list", "--global"]+	p = (proc "git" params)  {- Reads git config from a handle and populates a repo with it. -} hRead :: Repo -> Handle -> IO Repo hRead repo h = do+	-- We use the FileSystemEncoding when reading from git-config,+	-- because it can contain arbitrary filepaths (and other strings)+	-- in any encoding.+	fileEncoding h 	val <- hGetContentsStrict h 	store val repo @@ -64,7 +94,7 @@ store :: String -> Repo -> IO Repo store s repo = do 	let c = parse s-	let repo' = updateLocation $ repo+	repo' <- updateLocation $ repo 		{ config = (M.map Prelude.head c) `M.union` config repo 		, fullconfig = M.unionWith (++) c (fullconfig repo) 		}@@ -77,17 +107,23 @@  - known. Once the config is read, this can be fixed up to a Local repo,   - based on the core.bare and core.worktree settings.  -}-updateLocation :: Repo -> Repo+updateLocation :: Repo -> IO Repo updateLocation r@(Repo { location = LocalUnknown d })-	| isBare r = newloc $ Local d Nothing-	| otherwise = newloc $ Local (d </> ".git") (Just d)-	where-		newloc l = r { location = getworktree l }-		getworktree l = case workTree r of-			Nothing -> l-			wt -> l { worktree = wt }-updateLocation r = r+	| isBare r = updateLocation' r $ Local d Nothing+	| otherwise = updateLocation' r $ Local (d </> ".git") (Just d)+updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l+updateLocation r = return r +updateLocation' :: Repo -> RepoLocation -> IO Repo+updateLocation' r l = do+	l' <- case getMaybe "core.worktree" r of+		Nothing -> return l+		Just d -> do+			{- core.worktree is relative to the gitdir -}+			top <- absPath $ gitdir l+			return $ l { worktree = Just $ absPathFrom top d }+	return $ r { location = l' }+ {- Parses git config --list or git config --null --list output into a  - config map. -} parse :: String -> M.Map String [String]@@ -97,10 +133,10 @@ 	| all ('=' `elem`) (take 1 ls) = sep '=' ls 	-- --null --list output separates keys from values with newlines 	| otherwise = sep '\n' $ split "\0" s-	where-		ls = lines s-		sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .-			map (separate (== c))+  where+	ls = lines s+	sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .+		map (separate (== c))  {- Checks if a string from git config is a true value. -} isTrue :: String -> Maybe Bool@@ -108,11 +144,12 @@ 	| s' == "true" = Just True 	| s' == "false" = Just False 	| otherwise = Nothing-	where-		s' = map toLower s+  where+	s' = map toLower s +boolConfig :: Bool -> String+boolConfig True = "true"+boolConfig False = "false"+ isBare :: Repo -> Bool isBare r = fromMaybe False $ isTrue =<< getMaybe "core.bare" r--workTree :: Repo -> Maybe FilePath-workTree = getMaybe "core.worktree"

@@ -27,14 +27,21 @@ import Git.Types import Git import qualified Git.Url as Url+import Utility.UserInfo -{- Finds the git repository used for the Cwd, which may be in a parent+{- Finds the git repository used for the cwd, which may be in a parent  - directory. -} fromCwd :: IO Repo-fromCwd = getCurrentDirectory >>= seekUp isRepoTop >>= maybe norepo makerepo-	where-		makerepo = newFrom . LocalUnknown-		norepo = error "Not in a git repository."+fromCwd = getCurrentDirectory >>= seekUp checkForRepo+  where+	norepo = error "Not in a git repository."+	seekUp check dir = do+		r <- check dir+		case r of+			Nothing -> case parentDir dir of+				"" -> norepo+				d -> seekUp check d+			Just loc -> newFrom loc  {- Local Repo constructor, accepts a relative or absolute path. -} fromPath :: FilePath -> IO Repo@@ -48,21 +55,21 @@ 		ifM (doesDirectoryExist dir') ( ret 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 "/". -}-		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-			| "/.git" `isSuffixOf` canondir =-				ifM (doesDirectoryExist $ dir </> ".git")-					( ret dir-					, ret $ takeDirectory canondir-					)-			| otherwise = ret dir+  where+	ret = newFrom . LocalUnknown+	{- Git always looks for "dir.git" in preference to+	 - to "dir", even if dir ends in a "/". -}+	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+		| "/.git" `isSuffixOf` canondir =+			ifM (doesDirectoryExist $ dir </> ".git")+				( ret dir+				, ret $ takeDirectory canondir+				)+		| otherwise = ret dir  {- Remote Repo constructor. Throws exception on invalid url.  -@@ -78,9 +85,9 @@ fromUrlStrict url 	| startswith "file://" url = fromAbsPath $ uriPath u 	| otherwise = newFrom $ Url u-	where-		u = fromMaybe bad $ parseURI url-		bad = error $ "bad url " ++ url+  where+	u = fromMaybe bad $ parseURI url+	bad = error $ "bad url " ++ url  {- Creates a repo that has an unknown location. -} fromUnknown :: IO Repo@@ -93,21 +100,23 @@ 	| not $ repoIsUrl reference = error "internal error; reference repo not url" 	| repoIsUrl r = r 	| otherwise = r { location = Url $ fromJust $ parseURI absurl }-	where-		absurl =-			Url.scheme reference ++ "//" ++-			Url.authority reference ++-			repoPath r+  where+	absurl = concat+		[ Url.scheme reference+		, "//"+		, Url.authority reference+		, repoPath r+		]  {- Calculates a list of a repo's configured remotes, by parsing its config. -} fromRemotes :: Repo -> IO [Repo] fromRemotes repo = mapM construct remotepairs-	where-		filterconfig f = filter f $ M.toList $ config repo-		filterkeys f = filterconfig (\(k,_) -> f k)-		remotepairs = filterkeys isremote-		isremote k = startswith "remote." k && endswith ".url" k-		construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo+  where+	filterconfig f = filter f $ M.toList $ config repo+	filterkeys f = filterconfig (\(k,_) -> f k)+	remotepairs = filterkeys isremote+	isremote k = startswith "remote." k && endswith ".url" k+	construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo  {- Sets the name of a remote when constructing the Repo to represent it. -} remoteNamed :: String -> IO Repo -> IO Repo@@ -116,50 +125,51 @@ 	return $ r { remoteName = Just n }  {- Sets the name of a remote based on the git config key, such as-   "remote.foo.url". -}+ - "remote.foo.url". -} remoteNamedFromKey :: String -> IO Repo -> IO Repo remoteNamedFromKey k = remoteNamed basename-	where-		basename = join "." $ reverse $ drop 1 $-				reverse $ drop 1 $ split "." k+  where+	basename = join "." $ reverse $ drop 1 $ reverse $ drop 1 $ split "." k  {- Constructs a new Repo for one of a Repo's remotes using a given  - location (ie, an url). -} fromRemoteLocation :: String -> Repo -> IO Repo fromRemoteLocation s repo = gen $ calcloc s-	where-		gen v	-			| scpstyle v = fromUrl $ scptourl v-			| urlstyle v = fromUrl v-			| otherwise = fromRemotePath v repo-		-- insteadof config can rewrite remote location-		calcloc l-			| null insteadofs = l-			| otherwise = replacement ++ drop (length bestvalue) l-			where-				replacement = drop (length prefix) $-					take (length bestkey - length suffix) bestkey-				(bestkey, bestvalue) = maximumBy longestvalue insteadofs-				longestvalue (_, a) (_, b) = compare b a-				insteadofs = filterconfig $ \(k, v) -> -					startswith prefix k &&-					endswith suffix k &&-					startswith v l-				filterconfig f = filter f $-					concatMap splitconfigs $-						M.toList $ fullconfig repo-				splitconfigs (k, vs) = map (\v -> (k, v)) vs-				(prefix, suffix) = ("url." , ".insteadof")-		urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v-		-- git remotes can be written scp style -- [user@]host:dir-		scpstyle v = ":" `isInfixOf` v && not ("//" `isInfixOf` v)-		scptourl v = "ssh://" ++ host ++ slash dir-			where-				(host, dir) = separate (== ':') v-				slash d	| d == "" = "/~/" ++ d-					| "/" `isPrefixOf` d = d-					| "~" `isPrefixOf` d = '/':d-					| otherwise = "/~/" ++ d+  where+	gen v	+		| scpstyle v = fromUrl $ scptourl v+		| urlstyle v = fromUrl v+		| otherwise = fromRemotePath v repo+	-- insteadof config can rewrite remote location+	calcloc l+		| null insteadofs = l+		| otherwise = replacement ++ drop (length bestvalue) l+	  where+		replacement = drop (length prefix) $+			take (length bestkey - length suffix) bestkey+		(bestkey, bestvalue) = maximumBy longestvalue insteadofs+		longestvalue (_, a) (_, b) = compare b a+		insteadofs = filterconfig $ \(k, v) -> +			startswith prefix k &&+			endswith suffix k &&+			startswith v l+		filterconfig f = filter f $+			concatMap splitconfigs $ M.toList $ fullconfig repo+		splitconfigs (k, vs) = map (\v -> (k, v)) vs+		(prefix, suffix) = ("url." , ".insteadof")+	urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v+	-- git remotes can be written scp style -- [user@]host:dir+	-- but foo::bar is a git-remote-helper location instead+	scpstyle v = ":" `isInfixOf` v +		&& not ("//" `isInfixOf` v)+		&& not ("::" `isInfixOf` v)+	scptourl v = "ssh://" ++ host ++ slash dir+	  where+		(host, dir) = separate (== ':') v+		slash d	| d == "" = "/~/" ++ d+			| "/" `isPrefixOf` d = d+			| "~" `isPrefixOf` d = '/':d+			| otherwise = "/~/" ++ d  {- Constructs a Repo from the path specified in the git remotes of  - another Repo. -}@@ -181,42 +191,54 @@  expandTilde :: FilePath -> IO FilePath expandTilde = expandt True-	where-		expandt _ [] = return ""-		expandt _ ('/':cs) = do-			v <- expandt True cs-			return ('/':v)-		expandt True ('~':'/':cs) = do-			h <- myHomeDir-			return $ h </> cs-		expandt True ('~':cs) = do-			let (name, rest) = findname "" cs-			u <- getUserEntryForName name-			return $ homeDirectory u </> rest-		expandt _ (c:cs) = do-			v <- expandt False cs-			return (c:v)-		findname n [] = (n, "")-		findname n (c:cs)-			| c == '/' = (n, cs)-			| otherwise = findname (n++[c]) cs+  where+	expandt _ [] = return ""+	expandt _ ('/':cs) = do+		v <- expandt True cs+		return ('/':v)+	expandt True ('~':'/':cs) = do+		h <- myHomeDir+		return $ h </> cs+	expandt True ('~':cs) = do+		let (name, rest) = findname "" cs+		u <- getUserEntryForName name+		return $ homeDirectory u </> rest+	expandt _ (c:cs) = do+		v <- expandt False cs+		return (c:v)+	findname n [] = (n, "")+	findname n (c:cs)+		| c == '/' = (n, cs)+		| otherwise = findname (n++[c]) cs -seekUp :: (FilePath -> IO Bool) -> FilePath -> IO (Maybe FilePath)-seekUp want dir =-	ifM (want dir)-		( return $ Just dir-		, case parentDir dir of-			"" -> return Nothing-			d -> seekUp want d+checkForRepo :: FilePath -> IO (Maybe RepoLocation)+checkForRepo dir = +	check isRepo $+		check gitDirFile $+			check isBareRepo $+				return Nothing+  where+	check test cont = maybe cont (return . Just) =<< test+	checkdir c = ifM c+		( return $ Just $ LocalUnknown dir+		, return Nothing 		)--isRepoTop :: FilePath -> IO Bool-isRepoTop dir = ifM isRepo ( return True , isBareRepo )-	where-		isRepo = gitSignature (".git" </> "config")-		isBareRepo = ifM (doesDirectoryExist $ dir </> "objects")-			( gitSignature "config" , return False )-		gitSignature file = doesFileExist (dir </> file)+	isRepo = checkdir $ gitSignature $ ".git" </> "config"+	isBareRepo = checkdir $ gitSignature "config"+		<&&> doesDirectoryExist (dir </> "objects")+	gitDirFile = do+		c <- firstLine <$>+			catchDefaultIO "" (readFile $ dir </> ".git")+		return $ if gitdirprefix `isPrefixOf` c+			then Just $ Local +				{ gitdir = absPathFrom dir $+					drop (length gitdirprefix) c+				, worktree = Just dir+				}+			else Nothing+	  where+		gitdirprefix = "gitdir: "+	gitSignature file = doesFileExist $ dir </> file  newFrom :: RepoLocation -> IO Repo newFrom l = return Repo@@ -225,6 +247,7 @@ 	, fullconfig = M.empty 	, remotes = [] 	, remoteName = Nothing+	, gitEnv = Nothing 	}  

@@ -1,6 +1,6 @@ {- git repository command queue  -- - Copyright 2010 Joey Hess <joey@kitenet.net>+ - Copyright 2010,2012 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -10,7 +10,8 @@ module Git.Queue ( 	Queue, 	new,-	add,+	addCommand,+	addUpdateIndex, 	size, 	full, 	flush,@@ -18,30 +19,47 @@  import qualified Data.Map as M import System.IO-import System.Cmd.Utils+import System.Process import Data.String.Utils  import Utility.SafeCommand import Common import Git import Git.Command+import qualified Git.UpdateIndex+	+{- Queable actions that can be performed in a git repository.+ -}+data Action+	{- Updating the index file, using a list of streamers that can+	 - be added to as the queue grows. -}+	= UpdateIndexAction+		{ getStreamers :: [Git.UpdateIndex.Streamer] -- in reverse order+		}+	{- A git command to run, on a list of files that can be added to+	 - as the queue grows. -}+	| CommandAction +		{ getSubcommand :: String+		, getParams :: [CommandParam]+		, getFiles :: [FilePath]+		}  -{- An action to perform in a git repository. The file to act on- - is not included, and must be able to be appended after the params. -}-data Action = Action-	{ getSubcommand :: String-	, getParams :: [CommandParam]-	} deriving (Show, Eq, Ord)+{- A key that can uniquely represent an action in a Map. -}+data ActionKey = UpdateIndexActionKey | CommandActionKey String+	deriving (Eq, Ord) +actionKey :: Action -> ActionKey+actionKey (UpdateIndexAction _) = UpdateIndexActionKey+actionKey CommandAction { getSubcommand = s } = CommandActionKey s+ {- A queue of actions to perform (in any order) on a git repository,  - with lists of files to perform them on. This allows coalescing   - similar git commands. -} data Queue = Queue 	{ size :: Int 	, _limit :: Int-	, _items :: M.Map Action [FilePath]+	, items :: M.Map ActionKey Action 	}-	deriving (Show, Eq)  {- A recommended maximum size for the queue, after which it should be  - run.@@ -59,17 +77,57 @@ new :: Maybe Int -> Queue new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty -{- Adds an action to a queue. -}-add :: Queue -> String -> [CommandParam] -> [FilePath] -> Queue-add (Queue cur lim m) subcommand params files = Queue (cur + 1) lim m'-	where-		action = Action subcommand params-		-- There are probably few items in the map, but there-		-- can be a lot of files per item. So, optimise adding-		-- files.-		m' = M.insertWith' const action fs m-		!fs = files ++ M.findWithDefault [] action m+{- Adds an git command to the queue.+ -+ - Git commands with the same subcommand but different parameters are+ - assumed to be equivilant enough to perform in any order with the same+ - result.+ -}+addCommand :: String -> [CommandParam] -> [FilePath] -> Queue -> Repo -> IO Queue+addCommand subcommand params files q repo =+	updateQueue action different (length newfiles) q repo+  where+	key = actionKey action+	action = CommandAction+		{ getSubcommand = subcommand+		, getParams = params+		, getFiles = newfiles+		}+	newfiles = files ++ maybe [] getFiles (M.lookup key $ items q)+		+	different (CommandAction { getSubcommand = s }) = s /= subcommand+	different _ = True +{- Adds an update-index streamer to the queue. -}+addUpdateIndex :: Git.UpdateIndex.Streamer -> Queue -> Repo -> IO Queue+addUpdateIndex streamer q repo =+	updateQueue action different 1 q repo+  where+	key = actionKey action+	-- the list is built in reverse order+	action = UpdateIndexAction $ streamer : streamers+	streamers = maybe [] getStreamers $ M.lookup key $ items q++	different (UpdateIndexAction _) = False+	different _ = True++{- Updates or adds an action in the queue. If the queue already contains a+ - different action, it will be flushed; this is to ensure that conflicting+ - actions, like add and rm, are run in the right order.-}+updateQueue :: Action -> (Action -> Bool) -> Int -> Queue -> Repo -> IO Queue+updateQueue !action different sizeincrease q repo+	| null (filter different (M.elems (items q))) = return $ go q+	| otherwise = go <$> flush q repo+  where+	go q' = newq+	  where		+		!newq = q'+			{ size = newsize+			, items = newitems+			}+		!newsize = size q' + sizeincrease+		!newitems = M.insertWith' const (actionKey action) action (items q')+ {- Is a queue large enough that it should be flushed? -} full :: Queue -> Bool full (Queue cur lim  _) = cur > lim@@ -77,7 +135,7 @@ {- Runs a queue on a git repository. -} flush :: Queue -> Repo -> IO Queue flush (Queue _ lim m) repo = do-	forM_ (M.toList m) $ uncurry $ runAction repo+	forM_ (M.elems m) $ runAction repo 	return $ Queue 0 lim M.empty  {- Runs an Action on a list of files in a git repository.@@ -86,12 +144,17 @@  -  - Intentionally runs the command even if the list of files is empty;  - this allows queueing commands that do not need a list of files. -}-runAction :: Repo -> Action -> [FilePath] -> IO ()-runAction repo action files =-	pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs-	where-		params = toCommand $ gitCommandLine-			(Param (getSubcommand action):getParams action) repo-		feedxargs h = do-			fileEncoding h-			hPutStr h $ join "\0" files+runAction :: Repo -> Action -> IO ()+runAction repo (UpdateIndexAction streamers) =+	-- list is stored in reverse order+	Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers+runAction repo action@(CommandAction {}) =+	withHandle StdinHandle createProcessSuccess p $ \h -> do+		fileEncoding h+		hPutStr h $ join "\0" $ getFiles action+		hClose h+  where+	p = (proc "xargs" params) { env = gitEnv repo }+	params = "-0":"git":baseparams+	baseparams = toCommand $ gitCommandLine+		(Param (getSubcommand action):getParams action) repo

@@ -21,11 +21,10 @@  - Converts such a fully qualified ref into a base ref (eg: master). -} base :: Ref -> Ref base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show-	where-		remove prefix s-			| prefix `isPrefixOf` s = drop (length prefix) s-			| otherwise = s-+  where+	remove prefix s+		| prefix `isPrefixOf` s = drop (length prefix) s+		| otherwise = s  {- Given a directory such as "refs/remotes/origin", and a ref such as  - refs/heads/master, yields a version of that ref under the directory,@@ -38,55 +37,61 @@ exists ref = runBool "show-ref"  	[Param "--verify", Param "-q", Param $ show ref] +{- Checks if HEAD exists. It generally will, except for in a repository+ - that was just created. -}+headExists :: Repo -> IO Bool+headExists repo = do+	ls <- lines <$> pipeReadStrict [Param "show-ref", Param "--head"] repo+	return $ any (" HEAD" `isSuffixOf`) ls+ {- Get the sha of a fully qualified git ref, if it exists. -} sha :: Branch -> Repo -> IO (Maybe Sha) sha branch repo = process <$> showref repo-	where-		showref = pipeRead [Param "show-ref",-			Param "--hash", -- get the hash-			Param $ show branch]-		process [] = Nothing-		process s = Just $ Ref $ firstLine s+  where+	showref = pipeReadStrict [Param "show-ref",+		Param "--hash", -- get the hash+		Param $ show branch]+	process [] = Nothing+	process s = Just $ Ref $ firstLine s  {- List of (refs, branches) matching a given ref spec. -} matching :: Ref -> Repo -> IO [(Ref, Branch)]-matching ref repo = do-	r <- pipeRead [Param "show-ref", Param $ show ref] repo-	return $ map gen (lines r)-	where-		gen l = let (r, b) = separate (== ' ') l in-			(Ref r, Ref b)+matching ref repo = map gen . lines <$> +	pipeReadStrict [Param "show-ref", Param $ show ref] repo+  where+	gen l = let (r, b) = separate (== ' ') l+		in (Ref r, Ref b)  {- List of (refs, branches) matching a given ref spec.  - Duplicate refs are filtered out. -} matchingUniq :: Ref -> Repo -> IO [(Ref, Branch)] matchingUniq ref repo = nubBy uniqref <$> matching ref repo-	where-		uniqref (a, _) (b, _) = a == b+  where+	uniqref (a, _) (b, _) = a == b  {- Checks if a String is a legal git ref name.  -  - The rules for this are complex; see git-check-ref-format(1) -} legal :: Bool -> String -> Bool legal allowonelevel s = all (== False) illegal-	where-		illegal =-			[ any ("." `isPrefixOf`) pathbits-			, any (".lock" `isSuffixOf`) pathbits-			, not allowonelevel && length pathbits < 2-			, contains ".."-			, any (\c -> contains [c]) illegalchars-			, begins "/"-			, ends "/"-			, contains "//"-			, ends "."-			, contains "@{"-			, null s-			]-		contains v = v `isInfixOf` s-		ends v = v `isSuffixOf` s-		begins v = v `isPrefixOf` s+  where+	illegal =+		[ any ("." `isPrefixOf`) pathbits+		, any (".lock" `isSuffixOf`) pathbits+		, not allowonelevel && length pathbits < 2+		, contains ".."+		, any (\c -> contains [c]) illegalchars+		, begins "/"+		, ends "/"+		, contains "//"+		, ends "."+		, contains "@{"+		, null s+		]+	contains v = v `isInfixOf` s+	ends v = v `isSuffixOf` s+	begins v = v `isPrefixOf` s -		pathbits = split "/" s-		illegalchars = " ~^:?*[\\" ++ controlchars-		controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)]+	pathbits = split "/" s+	illegalchars = " ~^:?*[\\" ++ controlchars+	controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)]

@@ -11,11 +11,11 @@ import Git.Types  {- Runs an action that causes a git subcommand to emit a Sha, and strips-   any trailing newline, returning the sha. -}+ - any trailing newline, returning the sha. -} getSha :: String -> IO String -> IO Sha getSha subcommand a = maybe bad return =<< extractSha <$> a-	where-		bad = error $ "failed to read sha from git " ++ subcommand+  where+	bad = error $ "failed to read sha from git " ++ subcommand  {- Extracts the Sha from a string. There can be a trailing newline after  - it, but nothing else. -}@@ -24,12 +24,12 @@ 	| len == shaSize = val s 	| len == shaSize + 1 && length s' == shaSize = val s' 	| otherwise = Nothing-	where-		len = length s-		s' = firstLine s-		val v-			| all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v-			| otherwise = Nothing+  where+	len = length s+	s' = firstLine s+	val v+		| all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v+		| otherwise = Nothing  {- Size of a git sha. -} shaSize :: Int

@@ -27,15 +27,17 @@ 	| Unknown 	deriving (Show, Eq) -data Repo = Repo {-	location :: RepoLocation,-	config :: M.Map String String,+data Repo = Repo+	{ location :: RepoLocation+	, config :: M.Map String String 	-- a given git config key can actually have multiple values-	fullconfig :: M.Map String [String],-	remotes :: [Repo],+	, fullconfig :: M.Map String [String]+	, remotes :: [Repo] 	-- remoteName holds the name used for this repo in remotes-	remoteName :: Maybe String -} deriving (Show, Eq)+	, remoteName :: Maybe String+	-- alternate environment to use when running git commands+	, gitEnv :: Maybe [(String, String)]+	} deriving (Show, Eq)  {- A git ref. Can be a sha1, or a branch or tag name. -} newtype Ref = Ref String@@ -48,3 +50,34 @@ type Branch = Ref type Sha = Ref type Tag = Ref++{- Types of objects that can be stored in git. -}+data ObjectType = BlobObject | CommitObject | TreeObject+	deriving (Eq)++instance Show ObjectType where+	show BlobObject = "blob"+	show CommitObject = "commit"+	show TreeObject = "tree"++readObjectType :: String -> Maybe ObjectType+readObjectType "blob" = Just BlobObject+readObjectType "commit" = Just CommitObject+readObjectType "tree" = Just TreeObject+readObjectType _ = Nothing++{- Types of blobs. -}+data BlobType = FileBlob | ExecutableBlob | SymlinkBlob+	deriving (Eq)++{- Git uses magic numbers to denote the type of a blob. -}+instance Show BlobType where+	show FileBlob = "100644"+	show ExecutableBlob = "100755"+	show SymlinkBlob = "120000"++readBlobType :: String -> Maybe BlobType+readBlobType "100644" = Just FileBlob+readBlobType "100755" = Just ExecutableBlob+readBlobType "120000" = Just SymlinkBlob+readBlobType _ = Nothing

@@ -28,13 +28,13 @@  - <http://trac.haskell.org/network/ticket/40> -} uriRegName' :: URIAuth -> String uriRegName' a = fixup $ uriRegName a-	where-		fixup x@('[':rest)-			| rest !! len == ']' = take len rest-			| otherwise = x-			where-				len  = length rest - 1-		fixup x = x+  where+	fixup x@('[':rest)+		| rest !! len == ']' = take len rest+		| otherwise = x+	  where+		len  = length rest - 1+	fixup x = x  {- Hostname of an URL repo. -} host :: Repo -> String@@ -55,14 +55,14 @@ {- The full authority portion an URL repo. (ie, "user@host:port") -} authority :: Repo -> String authority = authpart assemble-	where-		assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a+  where+	assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a  {- Applies a function to extract part of the uriAuthority of an URL repo. -} authpart :: (URIAuth -> a) -> Repo -> a authpart a Repo { location = Url u } = a auth-	where-		auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)+  where+	auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u) authpart _ repo = notUrl repo  notUrl :: Repo -> a

@@ -32,11 +32,11 @@ 	install -m 0644 $(mans) $(DESTDIR)$(PREFIX)/share/man/man1  clean:-	rm -rf $(bins) tmp+	rm -rf $(bins) tmp dist  # Upload to hackage. hackage: clean-	@cabal sdist+	./make-sdist.sh 	@cabal upload dist/*.tar.gz  .PHONY: $(bins)

@@ -9,6 +9,8 @@     cd github-backup     make +(You will need ghc, hslogger, and MissingH installed first.)+ Or use cabal:      cabal install github-backup --bindir=$HOME/bin@@ -65,12 +67,8 @@ won't be backed up. There is an easy solution though. Just add the parent as a git remote. Then github-backup will find it, and back it up. -Currently, only 30 of each thing will be returned. This is a bug in -the haskell github library I'm using. Hope to get it fixed soon.--Currently, the GitHub API does not seem to provide a way to access notes-added to commits and notes added to lines of code. So those notes won't get-backed up. The GitHub folks have been told about this limitation of their API.+Notes added to commits and lines of code don't get backed up yet.+There is only recently API support for this.  The labels that can be added to issues and milestones are not backed up. Neither are the hooks. They could be, but don't seem important

@@ -0,0 +1,35 @@+{- Interface for running a shell command as a coprocess,+ - sending it queries and getting back results.+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.CoProcess (+	CoProcessHandle,+	start,+	stop,+	query+) where++import Common++type CoProcessHandle = (ProcessHandle, Handle, Handle, CreateProcess)++start :: FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle+start command params env = do+	(from, to, _err, pid) <- runInteractiveProcess command params Nothing env+	return (pid, to, from, proc command params)++stop :: CoProcessHandle -> IO ()+stop (pid, from, to, p) = do+	hClose to+	hClose from+	forceSuccessProcess p pid++query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b+query (_, from, to, _) send receive = do+	_ <- send to+	hFlush to+	receive from

@@ -15,62 +15,79 @@ import Control.Monad.IfElse import System.FilePath import Control.Applicative-import Control.Exception (bracket_)-import System.Posix.Directory+import System.IO.Unsafe (unsafeInterleaveIO)  import Utility.SafeCommand import Utility.TempFile import Utility.Exception import Utility.Monad-import Utility.Path +dirCruft :: FilePath -> Bool+dirCruft "." = True+dirCruft ".." = True+dirCruft _ = False+ {- Lists the contents of a directory.  - Unlike getDirectoryContents, paths are not relative to the directory. -} dirContents :: FilePath -> IO [FilePath]-dirContents d = map (d </>) . filter notcruft <$> getDirectoryContents d-	where-		notcruft "." = False-		notcruft ".." = False-		notcruft _ = True+dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d +{- Gets files in a directory, and then its subdirectories, recursively,+ - and lazily. If the directory does not exist, no exception is thrown,+ - instead, [] is returned. -}+dirContentsRecursive :: FilePath -> IO [FilePath]+dirContentsRecursive topdir = dirContentsRecursive' [topdir]++dirContentsRecursive' :: [FilePath] -> IO [FilePath]+dirContentsRecursive' [] = return []+dirContentsRecursive' (dir:dirs) = unsafeInterleaveIO $ do+	(files, dirs') <- collect [] [] =<< catchDefaultIO [] (dirContents dir)+	files' <- dirContentsRecursive' (dirs' ++ dirs)+	return (files ++ files')+  where+	collect files dirs' [] = return (reverse files, reverse dirs')+	collect files dirs' (entry:entries)+		| dirCruft entry = collect files dirs' entries+		| otherwise = do+			ifM (doesDirectoryExist entry)+				( collect files (entry:dirs') entries+				, collect (entry:files) dirs' entries+				)			+ {- Moves one filename to another.  - First tries a rename, but falls back to moving across devices if needed. -} moveFile :: FilePath -> FilePath -> IO () moveFile src dest = tryIO (rename src dest) >>= onrename-	where-		onrename (Right _) = noop-		onrename (Left e)-			| isPermissionError e = rethrow-			| isDoesNotExistError e = rethrow-			| otherwise = 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-			where-				rethrow = throw e-				mv tmp _ = do-					ok <- boolSystem "mv" [Param "-f",-						Param src, Param tmp]-					unless ok $ do-						-- delete any partial-						_ <- tryIO $ removeFile tmp-						rethrow-		isdir f = do-			r <- tryIO $ getFileStatus f-			case r of-				(Left _) -> return False-				(Right s) -> return $ isDirectory s+  where+	onrename (Right _) = noop+	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+	  where+		rethrow = throw e+		mv tmp _ = do+			ok <- boolSystem "mv" [Param "-f", Param src, Param tmp]+			unless ok $ do+				-- delete any partial+				_ <- tryIO $ removeFile tmp+				rethrow -{- Runs an action in another directory. -}-bracketCd :: FilePath -> IO a -> IO a-bracketCd dir a = go =<< getCurrentDirectory-	where-		go cwd-			| dirContains dir cwd = a-			| otherwise = bracket_-				(changeWorkingDirectory dir)-				(changeWorkingDirectory cwd)-				a+	isdir f = do+		r <- tryIO $ getFileStatus f+		case r of+			(Left _) -> return False+			(Right s) -> return $ isDirectory s++{- Removes a file, which may or may not exist.+ -+ - Note that an exception is thrown if the file exists but+ - cannot be removed. -}+nukeFile :: FilePath -> IO ()+nukeFile file = whenM (doesFileExist file) $ removeFile file

@@ -0,0 +1,51 @@+{- Simple IO exception handling (and some more)+ -+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE ScopedTypeVariables #-}++module Utility.Exception where++import Prelude hiding (catch)+import Control.Exception+import Control.Applicative++{- Catches IO errors and returns a Bool -}+catchBoolIO :: IO Bool -> IO Bool+catchBoolIO a = catchDefaultIO False a++{- Catches IO errors and returns a Maybe -}+catchMaybeIO :: IO a -> IO (Maybe a)+catchMaybeIO a = catchDefaultIO Nothing $ Just <$> a++{- Catches IO errors and returns a default value. -}+catchDefaultIO :: a -> IO a -> IO a+catchDefaultIO def a = catchIO a (const $ return def)++{- Catches IO errors and returns the error message. -}+catchMsgIO :: IO a -> IO (Either String a)+catchMsgIO a = either (Left . show) Right <$> tryIO a++{- catch specialized for IO errors only -}+catchIO :: IO a -> (IOException -> IO a) -> IO a+catchIO = catch++{- try specialized for IO errors only -}+tryIO :: IO a -> IO (Either IOException a)+tryIO = try++{- Catches all exceptions except for async exceptions.+ - This is often better to use than catching them all, so that+ - ThreadKilled and UserInterrupt get through.+ -}+catchNonAsync :: IO a -> (SomeException -> IO a) -> IO a+catchNonAsync a onerr = a `catches`+	[ Handler (\ (e :: AsyncException) -> throw e)+	, Handler (\ (e :: SomeException) -> onerr e)+	]++tryNonAsync :: IO a -> IO (Either SomeException a)+tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left)

@@ -0,0 +1,112 @@+{- File mode utilities.+ -+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.FileMode where++import Common++import Control.Exception (bracket)+import System.Posix.Types+import Foreign (complement)++{- 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+	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. -}+addModes :: [FileMode] -> FileMode -> FileMode+addModes ms m = combineModes (m:ms)++{- Removes the specified FileModes from the input mode. -}+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]++readModes :: [FileMode]+readModes = [ownerReadMode, groupReadMode, otherReadMode]++executeModes :: [FileMode]+executeModes = [ownerExecuteMode, groupExecuteMode, otherExecuteMode]++{- Removes the write bits from a file. -}+preventWrite :: FilePath -> IO ()+preventWrite f = modifyFileMode f $ removeModes writeModes++{- Turns a file's owner write bit back on. -}+allowWrite :: FilePath -> IO ()+allowWrite f = modifyFileMode f $ addModes [ownerWriteMode]++{- Allows owner and group to read and write to a file. -}+groupWriteRead :: FilePath -> IO ()+groupWriteRead f = modifyFileMode f $ addModes+	[ ownerWriteMode, groupWriteMode+	, ownerReadMode, groupReadMode+	]++checkMode :: FileMode -> FileMode -> Bool+checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor++{- Checks if a file mode indicates it's a symlink. -}+isSymLink :: FileMode -> Bool+isSymLink = checkMode symbolicLinkMode++{- Checks if a file has any executable bits set. -}+isExecutable :: FileMode -> Bool+isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0++{- Runs an action without that pesky umask influencing it, unless the+ - passed FileMode is the standard one. -}+noUmask :: FileMode -> IO a -> IO a+noUmask mode a+	| mode == stdFileMode = a+	| otherwise = bracket setup cleanup go+  where+	setup = setFileCreationMask nullFileMode+	cleanup = setFileCreationMask+	go _ = a++combineModes :: [FileMode] -> FileMode+combineModes [] = undefined+combineModes [m] = m+combineModes (m:ms) = foldl unionFileModes m ms++stickyMode :: FileMode+stickyMode = 512++isSticky :: FileMode -> Bool+isSticky = checkMode stickyMode++setSticky :: FilePath -> IO ()+setSticky f = modifyFileMode f $ addModes [stickyMode]++{- Writes a file, ensuring that its modes do not allow it to be read+ - by anyone other than the current user, before any content is written. -}+writeFileProtected :: FilePath -> String -> IO ()+writeFileProtected file content = do+	h <- openFile file WriteMode+	modifyFileMode file $ removeModes [groupReadMode, otherReadMode]+	hPutStr h content+	hClose h

@@ -0,0 +1,77 @@+{- GHC File system encoding handling.+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.FileSystemEncoding (+	fileEncoding,+	withFilePath,+	md5FilePath,+	decodeW8,+	encodeW8	+) where++import qualified GHC.Foreign as GHC+import qualified GHC.IO.Encoding as Encoding+import Foreign.C+import System.IO+import System.IO.Unsafe+import qualified Data.Hash.MD5 as MD5+import Data.Word+import Data.Bits.Utils++{- 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+ - allows "arbitrary undecodable bytes to be round-tripped through it". -}+fileEncoding :: Handle -> IO ()+fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding++{- Marshal a Haskell FilePath into a NUL terminated C string using temporary+ - storage. The FilePath is encoded using the filesystem encoding,+ - reversing the decoding that should have been done when the FilePath+ - was obtained. -}+withFilePath :: FilePath -> (CString -> IO a) -> IO a+withFilePath fp f = Encoding.getFileSystemEncoding+	>>= \enc -> GHC.withCString enc fp f++{- Encodes a FilePath into a String, applying the filesystem encoding.+ -+ - There are very few things it makes sense to do with such an encoded+ - string. It's not a legal filename; it should not be displayed.+ - So this function is not exported, but instead used by the few functions+ - that can usefully consume it.+ -+ - This use of unsafePerformIO is belived to be safe; GHC's interface+ - only allows doing this conversion with CStrings, and the CString buffer+ - is allocated, used, and deallocated within the call, with no side+ - effects.+ -}+{-# NOINLINE _encodeFilePath #-}+_encodeFilePath :: FilePath -> String+_encodeFilePath fp = unsafePerformIO $ do+	enc <- Encoding.getFileSystemEncoding+	GHC.withCString enc fp $ GHC.peekCString Encoding.char8++{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -}+md5FilePath :: FilePath -> MD5.Str+md5FilePath = MD5.Str . _encodeFilePath++{- 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.+ -}+{-# NOINLINE encodeW8 #-}+encodeW8 :: [Word8] -> FilePath+encodeW8 w8 = unsafePerformIO $ do+	enc <- Encoding.getFileSystemEncoding+	GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc++{- Useful when you want the actual number of bytes that will be used to+ - represent the FilePath on disk. -}+decodeW8 :: FilePath -> [Word8]+decodeW8 = s2w8 . _encodeFilePath

@@ -9,7 +9,13 @@  import System.IO import Control.Monad+import Foreign+import Data.Char+import Control.Applicative+import System.Posix.Process (getAnyProcessStatus) +import Utility.Exception+ {- A version of hgetContents that is not lazy. Ensures file is   - all read before it gets closed. -} hGetContentsStrict :: Handle -> IO String@@ -27,11 +33,80 @@  -} separate :: (a -> Bool) -> [a] -> ([a], [a]) separate c l = unbreak $ break c l-	where-		unbreak r@(a, b)-			| null b = r-			| otherwise = (a, tail b)+  where+	unbreak r@(a, b)+		| null b = r+		| otherwise = (a, tail b)  {- Breaks out the first line. -}-firstLine :: String-> String+firstLine :: String -> String firstLine = takeWhile (/= '\n')++{- Splits a list into segments that are delimited by items matching+ - a predicate. (The delimiters are not included in the segments.)+ - Segments may be empty. -}+segment :: (a -> Bool) -> [a] -> [[a]]+segment p l = map reverse $ go [] [] l+  where+	go c r [] = reverse $ c:r+	go c r (i:is)+		| p i = go [] (c:r) is+		| otherwise = go (i:c) r is++prop_segment_regressionTest :: Bool+prop_segment_regressionTest = all id+	-- Even an empty list is a segment.+	[ segment (== "--") [] == [[]]+	-- There are two segements in this list, even though the first is empty.+	, segment (== "--") ["--", "foo", "bar"] == [[],["foo","bar"]]+	]++{- Includes the delimiters as segments of their own. -}+segmentDelim :: (a -> Bool) -> [a] -> [[a]]+segmentDelim p l = map reverse $ go [] [] l+  where+	go c r [] = reverse $ c:r+	go c r (i:is)+		| p i = go [] ([i]:c:r) is+		| otherwise = go (i:c) r is++{- Given two orderings, returns the second if the first is EQ and returns+ - the first otherwise.+ -+ - Example use:+ -+ - compare lname1 lname2 `thenOrd` compare fname1 fname2+ -}+thenOrd :: Ordering -> Ordering -> Ordering+thenOrd EQ x = x+thenOrd x _ = x+{-# INLINE thenOrd #-}++{- Wrapper around hGetBufSome that returns a String.+ -+ - The null string is returned on eof, otherwise returns whatever+ - data is currently available to read from the handle, or waits for+ - data to be written to it if none is currently available.+ - + - Note on encodings: The normal encoding of the Handle is ignored;+ - each byte is converted to a Char. Not unicode clean!+ -}+hGetSomeString :: Handle -> Int -> IO String+hGetSomeString h sz = do+	fp <- mallocForeignPtrBytes sz+	len <- withForeignPtr fp $ \buf -> hGetBufSome h buf sz+	map (chr . fromIntegral) <$> withForeignPtr fp (peekbytes len)+  where+	peekbytes :: Int -> Ptr Word8 -> IO [Word8]+	peekbytes len buf = mapM (peekElemOff buf) [0..pred len]++{- Reaps any zombie git processes. + -+ - Warning: Not thread safe. Anything that was expecting to wait+ - on a process and get back an exit status is going to be confused+ - if this reap gets there first. -}+reapZombies :: IO ()+reapZombies = do+	-- throws an exception when there are no child processes+	catchDefaultIO Nothing (getAnyProcessStatus False True)+		>>= maybe (return ()) (const reapZombies)

@@ -16,6 +16,12 @@ firstM _ [] = return Nothing firstM p (x:xs) = ifM (p x) (return $ Just x , firstM p xs) +{- Runs the action on values from the list until it succeeds, returning+ - its result. -}+getM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)+getM _ [] = return Nothing+getM p (x:xs) = maybe (getM p xs) (return . Just) =<< p x+ {- Returns true if any value in the list satisfies the predicate,  - stopping once one is found. -} anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool@@ -38,6 +44,10 @@ {- short-circuiting monadic && -} (<&&>) :: Monad m => m Bool -> m Bool -> m Bool ma <&&> mb = ifM ma ( mb , return False )++{- Same fixity as && and || -}+infixr 3 <&&>+infixr 2 <||>  {- Runs an action, passing its value to an observer before returning it. -} observe :: Monad m => (a -> m b) -> m a -> m a

@@ -14,27 +14,27 @@ import Data.List import Data.Maybe import Control.Applicative-import System.Posix.User  import Utility.Monad+import Utility.UserInfo  {- Returns the parent directory of a path. Parent of / is "" -} parentDir :: FilePath -> FilePath parentDir dir 	| not $ null dirs = slash ++ join s (init dirs) 	| otherwise = ""-		where-			dirs = filter (not . null) $ split s dir-			slash = if isAbsolute dir then s else ""-			s = [pathSeparator]+  where+	dirs = filter (not . null) $ split s dir+	slash = if isAbsolute dir then s else ""+	s = [pathSeparator]  prop_parentDir_basics :: FilePath -> Bool prop_parentDir_basics dir 	| null dir = True 	| dir == "/" = parentDir dir == "" 	| otherwise = p /= dir-	where-		p = parentDir dir+  where+	p = parentDir 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@@ -42,10 +42,10 @@  -} dirContains :: FilePath -> FilePath -> Bool dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b'-	where-		norm p = fromMaybe "" $ absNormPath p "."-		a' = norm a-		b' = norm b+  where+	norm p = fromMaybe "" $ absNormPath p "."+	a' = norm a+	b' = norm b  {- Converts a filename into a normalized, absolute path.  -@@ -60,8 +60,8 @@  - from the specified cwd. -} absPathFrom :: FilePath -> FilePath -> FilePath absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file-	where-		bad = error $ "unable to normalize " ++ file+  where+	bad = error $ "unable to normalize " ++ file  {- Constructs a relative path from the CWD to a file.  -@@ -78,66 +78,80 @@  -} relPathDirToFile :: FilePath -> FilePath -> FilePath relPathDirToFile from to = join s $ dotdots ++ uncommon-	where-		s = [pathSeparator]-		pfrom = split s from-		pto = split s to-		common = map fst $ takeWhile same $ zip pfrom pto-		same (c,d) = c == d-		uncommon = drop numcommon pto-		dotdots = replicate (length pfrom - numcommon) ".."-		numcommon = length common+  where+	s = [pathSeparator]+	pfrom = split s from+	pto = split s to+	common = map fst $ takeWhile same $ zip pfrom pto+	same (c,d) = c == d+	uncommon = drop numcommon pto+	dotdots = replicate (length pfrom - numcommon) ".."+	numcommon = length common  prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool prop_relPathDirToFile_basics from to 	| from == to = null r 	| otherwise = not (null r)-	where-		r = relPathDirToFile from to +  where+	r = relPathDirToFile from to   prop_relPathDirToFile_regressionTest :: Bool prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference-	where-		{- Two paths have the same directory component at the same-		 - location, but it's not really the same directory.-		 - Code used to get this wrong. -}-		same_dir_shortcurcuits_at_difference =-			relPathDirToFile "/tmp/r/lll/xxx/yyy/18" "/tmp/r/.git/annex/objects/18/gk/SHA256-foo/SHA256-foo" == "../../../../.git/annex/objects/18/gk/SHA256-foo/SHA256-foo"+  where+	{- Two paths have the same directory component at the same+	 - location, but it's not really the same directory.+	 - Code used to get this wrong. -}+	same_dir_shortcurcuits_at_difference =+		relPathDirToFile "/tmp/r/lll/xxx/yyy/18" "/tmp/r/.git/annex/objects/18/gk/SHA256-foo/SHA256-foo" == "../../../../.git/annex/objects/18/gk/SHA256-foo/SHA256-foo" -{- Given an original list of files, and an expanded list derived from it,- - ensures that the original list's ordering is preserved. - -- - The input list may contain a directory, like "dir" or "dir/". Any- - items in the expanded list that are contained in that directory will- - appear at the same position as it did in the input list.+{- 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 direcotry, any items+ - in the expanded list that are contained in that directory will appear in+ - its segment.  -}-preserveOrder :: [FilePath] -> [FilePath] -> [FilePath]-preserveOrder [] new = new-preserveOrder [_] new = new -- optimisation-preserveOrder (l:ls) new = found ++ preserveOrder ls rest-	where-		(found, rest)=partition (l `dirContains`) new+segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]]+segmentPaths [] new = [new]+segmentPaths [_] new = [new] -- optimisation+segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest+  where+	(found, rest)=partition (l `dirContains`) new -{- Runs an action that takes a list of FilePaths, and ensures that - - its return list preserves order.- -- - This assumes that it's cheaper to call preserveOrder on the result,- - than it would be to run the action separately with each param. In the case- - of git file list commands, that assumption tends to hold.+{- This assumes that it's cheaper to call segmentPaths on the result,+ - than it would be to run the action separately with each path. In+ - the case of git file list commands, that assumption tends to hold.  -}-runPreserveOrder :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]-runPreserveOrder a files = preserveOrder files <$> a files+runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]+runSegmentPaths a paths = segmentPaths paths <$> a paths -{- Current user's home directory. -}-myHomeDir :: IO FilePath-myHomeDir = homeDirectory <$> (getUserEntryForID =<< getEffectiveUserID)+{- Converts paths in the home directory to use ~/ -}+relHome :: FilePath -> IO String+relHome path = do+	home <- myHomeDir+	return $ if dirContains home path+		then "~/" ++ relPathDirToFile home path+		else path -{- Checks if a command is available in PATH. -}+{- Checks if a command is available in PATH.+ -+ - The command may be fully-qualified, in which case, this succeeds as+ - long as it exists. -} inPath :: String -> IO Bool-inPath command = getSearchPath >>= anyM indir-	where-		indir d = doesFileExist $ d </> command+inPath command = isJust <$> searchPath command +{- Finds a command in PATH and returns the full path to it.+ -+ - The command may be fully qualified already, in which case it will+ - be returned if it exists.+ -}+searchPath :: String -> IO (Maybe FilePath)+searchPath command+	| isAbsolute command = check command+	| otherwise = getSearchPath >>= getM indir+  where+	indir d = check $ d </> command+	check f = ifM (doesFileExist f) ( return (Just f), return Nothing )+ {- Checks if a filename is a unix dotfile. All files inside dotdirs  - count as dotfiles. -} dotfile :: FilePath -> Bool@@ -146,5 +160,5 @@ 	| f == ".." = False 	| f == "" = False 	| otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)-	where-		f = takeFileName file+  where+	f = takeFileName file

@@ -0,0 +1,265 @@+{- System.Process enhancements, including additional ways of running+ - processes, and logging.+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE Rank2Types #-}++module Utility.Process (+	module X,+	CreateProcess,+	StdHandle(..),+	readProcess,+	readProcessEnv,+	writeReadProcessEnv,+	forceSuccessProcess,+	checkSuccessProcess,+	ignoreFailureProcess,+	createProcessSuccess,+	createProcessChecked,+	createBackgroundProcess,+	withHandle,+	withBothHandles,+	withQuietOutput,+	createProcess,+	runInteractiveProcess,+	stdinHandle,+	stdoutHandle,+	stderrHandle,+) where++import qualified System.Process+import System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)+import System.Process hiding (createProcess, runInteractiveProcess, readProcess)+import System.Exit+import System.IO+import System.Log.Logger+import Control.Concurrent+import qualified Control.Exception as E+import Control.Monad++import Utility.Misc++type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a++data StdHandle = StdinHandle | StdoutHandle | StderrHandle+	deriving (Eq)++{- Normally, when reading from a process, it does not need to be fed any+ - standard input. -}+readProcess :: FilePath	-> [String] -> IO String+readProcess cmd args = readProcessEnv cmd args Nothing++readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String+readProcessEnv cmd args environ =+	withHandle StdoutHandle createProcessSuccess p $ \h -> do+		output  <- hGetContentsStrict h+		hClose h+		return output+  where+	p = (proc cmd args)+		{ std_out = CreatePipe+		, env = environ+		}++{- Writes a string to a process on its stdin, + - returns its output, and also allows specifying the environment.+ -}+writeReadProcessEnv+	:: FilePath+	-> [String]+	-> Maybe [(String, String)]+	-> String+	-> (Maybe (Handle -> IO ()))+	-> IO String+writeReadProcessEnv cmd args environ input adjusthandle = do+	(Just inh, Just outh, _, pid) <- createProcess p++	maybe (return ()) (\a -> a inh) adjusthandle+	maybe (return ()) (\a -> a outh) adjusthandle++	-- fork off a thread to start consuming the output+	output  <- hGetContents outh+	outMVar <- newEmptyMVar+	_ <- forkIO $ E.evaluate (length output) >> putMVar outMVar ()++	-- now write and flush any input+	when (not (null input)) $ do hPutStr inh input; hFlush inh+	hClose inh -- done with stdin++	-- wait on the output+	takeMVar outMVar+	hClose outh++	-- wait on the process+	forceSuccessProcess p pid++	return output++  where+	p = (proc cmd args)+		{ std_in = CreatePipe+		, std_out = CreatePipe+		, std_err = Inherit+		, env = environ+		}++{- Waits for a ProcessHandle, and throws an IOError if the process+ - did not exit successfully. -}+forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO ()+forceSuccessProcess p pid = do+	code <- waitForProcess pid+	case code of+		ExitSuccess -> return ()+		ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n++{- Waits for a ProcessHandle and returns True if it exited successfully. -}+checkSuccessProcess :: ProcessHandle -> IO Bool+checkSuccessProcess pid = do+	code <- waitForProcess pid+	return $ code == ExitSuccess++ignoreFailureProcess :: ProcessHandle -> IO Bool+ignoreFailureProcess pid = do+	void $ waitForProcess pid+	return True++{- Runs createProcess, then an action on its handles, and then+ - forceSuccessProcess. -}+createProcessSuccess :: CreateProcessRunner+createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a++{- Runs createProcess, then an action on its handles, and then+ - an action on its exit code. -}+createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner+createProcessChecked checker p a = do+	t@(_, _, _, pid) <- createProcess p+	r <- a t+	_ <- checker pid+	return r++{- Leaves the process running, suitable for lazy streaming.+ - Note: Zombies will result, and must be waited on. -}+createBackgroundProcess :: CreateProcessRunner+createBackgroundProcess p a = a =<< createProcess p++{- Runs a CreateProcessRunner, on a CreateProcess structure, that+ - is adjusted to pipe only from/to a single StdHandle, and passes+ - the resulting Handle to an action. -}+withHandle+	:: StdHandle+	-> CreateProcessRunner+	-> CreateProcess+	-> (Handle -> IO a)+	-> IO a+withHandle h creator p a = creator p' $ a . select+  where+	base = p+		{ std_in = Inherit+		, std_out = Inherit+		, std_err = Inherit+		}+	(select, p')+		| h == StdinHandle  =+			(stdinHandle, base { std_in = CreatePipe })+		| h == StdoutHandle =+			(stdoutHandle, base { std_out = CreatePipe })+		| h == StderrHandle =+			(stderrHandle, base { std_err = CreatePipe })++{- Like withHandle, but passes (stdin, stdout) handles to the action. -}+withBothHandles+	:: CreateProcessRunner+	-> CreateProcess+	-> ((Handle, Handle) -> IO a)+	-> IO a+withBothHandles creator p a = creator p' $ a . bothHandles+  where+	p' = p+		{ std_in = CreatePipe+		, std_out = CreatePipe+		, std_err = Inherit+		}++{- Forces the CreateProcessRunner to run quietly;+ - both stdout and stderr are discarded. -}+withQuietOutput+	:: CreateProcessRunner+	-> CreateProcess+	-> IO ()+withQuietOutput creator p = withFile "/dev/null" WriteMode $ \devnull -> do+	let p' = p+		{ std_out = UseHandle devnull+		, std_err = UseHandle devnull+		}+	creator p' $ const $ return ()++{- 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+stdinHandle _ = error "expected stdinHandle"+stdoutHandle :: HandleExtractor+stdoutHandle (_, Just h, _, _) = h+stdoutHandle _ = error "expected stdoutHandle"+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"++{- 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. -}+showCmd :: CreateProcess -> String+showCmd = go . cmdspec+  where+	go (ShellCommand s) = s+	go (RawCommand c ps) = c ++ " " ++ show ps++{- Wrappers for System.Process functions that do debug logging.+ - + - More could be added, but these are the only ones I usually need.+ -}++createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)+createProcess p = do+	debugProcess p+	System.Process.createProcess p++runInteractiveProcess+	:: FilePath	+	-> [String]	+	-> Maybe FilePath	+	-> Maybe [(String, String)]	+	-> IO (Handle, Handle, Handle, ProcessHandle)+runInteractiveProcess f args c e = do+	debugProcess $ (proc f args)+			{ std_in = CreatePipe+			, std_out = CreatePipe+			, std_err = CreatePipe+			, env = e+			}+	System.Process.runInteractiveProcess f args c e

@@ -1,6 +1,6 @@ {- safely running shell commands  -- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -8,11 +8,9 @@ module Utility.SafeCommand where  import System.Exit-import qualified System.Posix.Process-import System.Posix.Process hiding (executeFile)-import System.Posix.Signals+import Utility.Process+import System.Process (env) import Data.String.Utils-import System.Log.Logger import Control.Applicative  {- A type for parameters passed to a shell command. A command can@@ -27,13 +25,13 @@  - a command and expects Strings. -} toCommand :: [CommandParam] -> [String] toCommand = (>>= unwrap)-	where-		unwrap (Param s) = [s]-		unwrap (Params s) = filter (not . null) (split " " s)-		-- Files that start with a dash are modified to avoid-		-- the command interpreting them as options.-		unwrap (File s@('-':_)) = ["./" ++ s]-		unwrap (File s) = [s]+  where+	unwrap (Param s) = [s]+	unwrap (Params s) = filter (not . null) (split " " s)+	-- Files that start with a dash are modified to avoid+	-- the command interpreting them as options.+	unwrap (File s@('-':_)) = ["./" ++ s]+	unwrap (File s) = [s]  {- Run a system command, and returns True or False  - if it succeeded or failed.@@ -42,70 +40,45 @@ boolSystem command params = boolSystemEnv command params Nothing  boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool-boolSystemEnv command params env = dispatch <$> safeSystemEnv command params env-	where-		dispatch ExitSuccess = True-		dispatch _ = False+boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ+  where+	dispatch ExitSuccess = True+	dispatch _ = False  {- Runs a system command, returning the exit status. -} safeSystem :: FilePath -> [CommandParam] -> IO ExitCode safeSystem command params = safeSystemEnv command params Nothing -{- SIGINT(ctrl-c) is allowed to propigate and will terminate the program. -} safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode-safeSystemEnv command params env = do-	-- Going low-level because all the high-level system functions-	-- block SIGINT etc. We need to block SIGCHLD, but allow-	-- SIGINT to do its default program termination.-	let sigset = addSignal sigCHLD emptySignalSet-	oldint <- installHandler sigINT Default Nothing-	oldset <- getSignalMask-	blockSignals sigset-	childpid <- forkProcess $ childaction oldint oldset-	mps <- getProcessStatus True False childpid-	restoresignals oldint oldset-	case mps of-		Just (Exited code) -> return code-		_ -> error $ "unknown error running " ++ command-	where-		restoresignals oldint oldset = do-			_ <- installHandler sigINT oldint Nothing-			setSignalMask oldset-		childaction oldint oldset = do-			restoresignals oldint oldset-			executeFile command True (toCommand params) env--{- executeFile with debug logging -}-executeFile :: FilePath -> Bool -> [String] -> Maybe [(String, String)] -> IO ()-executeFile c path p e = do-	debugM "Utility.SafeCommand.executeFile" $-		"Running: " ++ c ++ " " ++ show p ++ " " ++ maybe "" show e-	System.Posix.Process.executeFile c path p e+safeSystemEnv command params environ = do+	(_, _, _, pid) <- createProcess (proc command $ toCommand params)+		{ env = environ }+	waitForProcess pid  {- Escapes a filename or other parameter to be safely able to be exposed to  - the shell. -} shellEscape :: String -> String shellEscape f = "'" ++ escaped ++ "'"-	where-		-- replace ' with '"'"'-		escaped = join "'\"'\"'" $ split "'" f+  where+	-- replace ' with '"'"'+	escaped = join "'\"'\"'" $ split "'" f  {- Unescapes a set of shellEscaped words or filenames. -} shellUnEscape :: String -> [String] shellUnEscape [] = [] shellUnEscape s = word : shellUnEscape rest-	where-		(word, rest) = findword "" s-		findword w [] = (w, "")-		findword w (c:cs)-			| c == ' ' = (w, cs)-			| c == '\'' = inquote c w cs-			| c == '"' = inquote c w cs-			| otherwise = findword (w++[c]) cs-		inquote _ w [] = (w, "")-		inquote q w (c:cs)-			| c == q = findword w cs-			| otherwise = inquote q (w++[c]) cs+  where+	(word, rest) = findword "" s+	findword w [] = (w, "")+	findword w (c:cs)+		| c == ' ' = (w, cs)+		| c == '\'' = inquote c w cs+		| c == '"' = inquote c w cs+		| otherwise = findword (w++[c]) cs+	inquote _ w [] = (w, "")+	inquote q w (c:cs)+		| c == q = findword w cs+		| otherwise = inquote q (w++[c]) cs  {- For quickcheck. -} prop_idempotent_shellEscape :: String -> Bool

@@ -5,9 +5,11 @@  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE PackageImports #-}+ module Utility.State where -import Control.Monad.State.Strict+import "mtl" Control.Monad.State.Strict  {- Modifies Control.Monad.State's state, forcing a strict update.  - This avoids building thunks in the state and leaking.

@@ -9,11 +9,12 @@  import Control.Exception (bracket) import System.IO-import System.Posix.Process hiding (executeFile)+import System.Posix.Process import System.Directory  import Utility.Exception import Utility.Path+import System.FilePath  {- Runs an action like writeFile, writing to a temp file first and  - then moving it into place. The temp file is stored in the same@@ -21,7 +22,7 @@ viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO () viaTmp a file content = do 	pid <- getProcessID-        let tmpfile = file ++ ".tmp" ++ show pid+	let tmpfile = file ++ ".tmp" ++ show pid 	createDirectoryIfMissing True (parentDir file) 	a tmpfile content 	renameFile tmpfile file@@ -31,11 +32,27 @@ {- Runs an action with a temp file, then removes the file. -} withTempFile :: Template -> (FilePath -> Handle -> IO a) -> IO a withTempFile template a = bracket create remove use-	where-		create = do-			tmpdir <- catchDefaultIO getTemporaryDirectory "."-			openTempFile tmpdir template-		remove (name, handle) = do-			hClose handle-			catchBoolIO (removeFile name >> return True)-		use (name, handle) = a name handle+  where+	create = do+		tmpdir <- catchDefaultIO "." getTemporaryDirectory+		openTempFile tmpdir template+	remove (name, handle) = do+		hClose handle+		catchBoolIO (removeFile name >> return True)+	use (name, handle) = a name handle++{- Runs an action with a temp directory, then removes the directory and+ - all its contents. -}+withTempDir :: Template -> (FilePath -> IO a) -> IO a+withTempDir template = bracket create remove+  where+	remove = removeDirectoryRecursive+	create = do+		tmpdir <- catchDefaultIO "." getTemporaryDirectory+		createDirectoryIfMissing True tmpdir+		pid <- getProcessID+		makedir tmpdir (template ++ show pid) (0 :: Int)+	makedir tmpdir t n = do+		let dir = tmpdir </> t ++ "." ++ show n+		r <- tryIO $ createDirectory dir+		either (const $ makedir tmpdir t $ n + 1) (const $ return dir) r

@@ -0,0 +1,36 @@+{- user info+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.UserInfo (+	myHomeDir,+	myUserName,+	myUserGecos,+) where++import Control.Applicative+import System.Posix.User+import System.Posix.Env++{- Current user's home directory.+ -+ - getpwent will fail on LDAP or NIS, so use HOME if set. -}+myHomeDir :: IO FilePath+myHomeDir = myVal ["HOME"] homeDirectory++{- Current user's user name. -}+myUserName :: IO String+myUserName = myVal ["USER", "LOGNAME"] userName++myUserGecos :: IO String+myUserGecos = myVal [] userGecos++myVal :: [String] -> (UserEntry -> String) -> IO String+myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars+  where+	check [] = return Nothing+	check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v+	getpwent = getUserEntryForID =<< getEffectiveUserID

@@ -0,0 +1,23 @@+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,1 @@+9

@@ -0,0 +1,25 @@+Source: github-backup+Section: utils+Priority: optional+Build-Depends: +	debhelper (>= 9),+	ghc,+	libghc-github-dev (>= 0.5.1),+	libghc-missingh-dev,+	libghc-hslogger-dev,+	libghc-pretty-show-dev,+	libghc-ifelse-dev,+Maintainer: Joey Hess <joeyh@debian.org>+Standards-Version: 3.9.3+Vcs-Git: git://github.com/joeyh/github-backup.git+Homepage: http://github.com/joeyh/github-backup++Package: github-backup+Architecture: any+Section: utils+Depends: ${misc:Depends}, ${shlibs:Depends}+Description: backs up data from GitHub+ github-backup is a simple tool you run in a git repository you cloned from+ GitHub. It backs up everything GitHub publishes about the repository,+ including other forks, issues, comments, wikis, milestones, pull requests,+ and watchers.

@@ -0,0 +1,9 @@+Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/+Source: native package++Files: *+Copyright: © 2010-2012 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.

@@ -0,0 +1,1 @@+github-backup.1

@@ -0,0 +1,7 @@+#!/usr/bin/make -f+%:+	dh $@++# Not intended for use by anyone except the author.+announcedir:+	@echo ${HOME}/src/joeywiki/code/github-backup/news

@@ -1,5 +1,5 @@ Name: github-backup-Version: 1.20120627+Version: 1.20130414 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess <joey@kitenet.net>@@ -8,12 +8,6 @@ Copyright: 2012 Joey Hess License-File: GPL Build-Type: Simple-Extra-Source-Files: README.md Makefile github-backup.1- Common.hs github-backup.hs Git/Url.hs Git/Types.hs Git/Queue.hs Git/Ref.hs- Git/Branch.hs Git/Sha.hs Git/Config.hs Git/Command.hs Git/Construct.hs- Setup.hs Github/Data/Readable.hs Utility/Path.hs Utility/TempFile.hs- Utility/State.hs Utility/Monad.hs Utility/Misc.hs Utility/SafeCommand.hs- Utility/Directory.hs Utility/PartialPrelude.hs Git.hs Homepage: https://github.com/joeyh/github-backup Category: Utility Synopsis: backs up everything github knows about a repository, to the repository@@ -26,7 +20,7 @@   Main-Is: github-backup.hs   Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl,    network, extensible-exceptions, unix, bytestring, base >= 4.5, base < 5,-   IfElse, pretty-show, github >= 0.2.1+   IfElse, pretty-show, text, process, github >= 0.6.0  source-repository head   type: git

@@ -6,16 +6,18 @@  -}  {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PackageImports #-}  module Main where  import qualified Data.Map as M import qualified Data.Set as S import Data.Either+import Data.Monoid import System.Environment import Control.Exception (bracket, try, SomeException) import Text.Show.Pretty-import Control.Monad.State.Strict+import "mtl" Control.Monad.State.Strict import qualified Github.Data.Readable as Github import qualified Github.Repos as Github import qualified Github.Repos.Forks as Github@@ -92,10 +94,9 @@ failedRequest req e = unless ignorable $ do 	set <- getState failedRequests 	changeState $ \s -> s { failedRequests = S.insert req set }-	where-		-- "410 Gone" is used for repos that have issues etc-		-- disabled.-		ignorable = "410 Gone" `isInfixOf` show e+  where+	-- "410 Gone" is used for repos that have issues etc disabled.+	ignorable = "410 Gone" `isInfixOf` show e  runRequest :: Request -> Backup () runRequest req = do@@ -130,9 +131,9 @@  lookupApi :: Request -> Storer lookupApi req = fromMaybe bad $ M.lookup name api-	where-		name = requestName req-		bad = error $ "internal error: bad api call: " ++ name+  where+	name = requestName req+	bad = error $ "internal error: bad api call: " ++ name  userrepoStore :: Storer userrepoStore = simpleHelper Github.userRepo $ \req r -> do@@ -161,11 +162,20 @@ 		store ("milestone" </> show n) req m  issuesStore :: Storer-issuesStore = withHelper Github.issuesForRepo [] $ forValues $ \req i -> do-	let repo = requestRepo req-	let n = Github.issueNumber i-	store ("issue" </> show n) req i-	runRequest (RequestNum "issuecomments" repo n)+issuesStore = withHelper (\u r y ->+	Github.issuesForRepo u r (y <> [Github.Open])+		>>= either (return . Left)+			(\xs -> Github.issuesForRepo u r+				(y <> [Github.OnlyClosed])+					>>= either (return . Left)+						(\ys -> return (Right (xs <> ys)))))+	[Github.PerPage 100] go+  where+	go = forValues $ \req i -> do+		let repo = requestRepo req+		let n = Github.issueNumber i+		store ("issue" </> show n) req i+		runRequest (RequestNum "issuecomments" repo n)  issuecommentsStore :: Storer issuecommentsStore = numHelper Github.Issues.Comments.comments $ \n ->@@ -177,9 +187,9 @@ forksStore = simpleHelper Github.forksFor $ \req fs -> do 	storeSorted "forks" req fs 	mapM_ (traverse . toGithubUserRepo) fs-	where-		traverse fork = whenM (addFork fork) $-			gatherMetaData fork+  where+	traverse fork = whenM (addFork fork) $+		gatherMetaData fork  forValues :: (Request -> v -> Backup ()) -> Request -> [v] -> Backup () forValues handle req vs = forM_ vs (handle req)@@ -214,9 +224,9 @@ 	liftIO $ do 		createDirectoryIfMissing True (parentDir file) 		writeFile file (ppShow val)-	where-		location (GithubUserRepo user repo) workdir =-			workdir </> user ++ "_" ++ repo </> filebase+  where+	location (GithubUserRepo user repo) workdir =+		workdir </> user ++ "_" ++ repo </> filebase  workDir :: Backup FilePath workDir = (</>)@@ -234,23 +244,23 @@  gitHubPairs :: Git.Repo -> [(Git.Repo, GithubUserRepo)] gitHubPairs = filter (not . wiki ) . mapMaybe check . Git.Types.remotes-	where-		check r@Git.Repo { Git.Types.location = Git.Types.Url u } =-			headMaybe $ mapMaybe (checkurl r $ show u) gitHubUrlPrefixes-		check _ = Nothing-		checkurl r u prefix-			| prefix `isPrefixOf` u && length bits == 2 =-				Just (r,-					GithubUserRepo (bits !! 0)-						(dropdotgit $ bits !! 1))-			| otherwise = Nothing-			where-				rest = drop (length prefix) u-				bits = split "/" rest-		dropdotgit s-			| ".git" `isSuffixOf` s = take (length s - length ".git") s-			| otherwise = s-		wiki (_, GithubUserRepo _ u) = ".wiki" `isSuffixOf` u+  where+	check r@Git.Repo { Git.Types.location = Git.Types.Url u } =+		headMaybe $ mapMaybe (checkurl r $ show u) gitHubUrlPrefixes+	check _ = Nothing+	checkurl r u prefix+		| prefix `isPrefixOf` u && length bits == 2 =+			Just (r,+				GithubUserRepo (bits !! 0)+					(dropdotgit $ bits !! 1))+		| otherwise = Nothing+	  where+		rest = drop (length prefix) u+		bits = split "/" rest+	dropdotgit s+		| ".git" `isSuffixOf` s = take (length s - length ".git") s+		| otherwise = s+	wiki (_, GithubUserRepo _ u) = ".wiki" `isSuffixOf` u  {- All known prefixes for urls to github repos. -} gitHubUrlPrefixes :: [String]@@ -264,26 +274,26 @@  onGithubBranch :: Git.Repo -> IO () -> IO () onGithubBranch r a = bracket prep cleanup (const a)-	where-		prep = do-			oldbranch <- Git.Branch.current r-			when (oldbranch == Just branchref) $-				error $ "it's not currently safe to run github-backup while the " ++-					branchname ++ " branch is checked out!"-			ifM (null <$> Git.Ref.matching branchref r)-				( checkout [Param "--orphan", Param branchname]-				, checkout [Param branchname]-				)-			return oldbranch-		cleanup Nothing = noop-		cleanup (Just oldbranch)-			| name == branchname = noop-			| otherwise = checkout [Param "--force", Param name]-			where-				name = show $ Git.Ref.base oldbranch-		checkout params = Git.Command.run "checkout" (Param "-q" : params) r-		branchname = "github"-		branchref = Git.Ref $ "refs/heads/" ++ branchname+  where+	prep = do+		oldbranch <- Git.Branch.current r+		when (oldbranch == Just branchref) $+			error $ "it's not currently safe to run github-backup while the " +++				branchname ++ " branch is checked out!"+		ifM (null <$> Git.Ref.matching branchref r)+			( checkout [Param "--orphan", Param branchname]+			, checkout [Param branchname]+			)+		return oldbranch+	cleanup Nothing = noop+	cleanup (Just oldbranch)+		| name == branchname = noop+		| otherwise = checkout [Param "--force", Param name]+	  where+		name = show $ Git.Ref.base oldbranch+	checkout params = Git.Command.run "checkout" (Param "-q" : params) r+	branchname = "github"+	branchref = Git.Ref $ "refs/heads/" ++ branchname  {- Commits all files in the workDir into git, and deletes it. -} commitWorkDir :: Backup ()@@ -310,12 +320,12 @@ 			unlessM (addRemote remote $ repoWikiUrl fork) $ 				removeRemote remote 		)-	where-		fetchwiki = inRepo $ Git.Command.runBool "fetch" [Param remote]-		remotes = Git.remotes <$> getState gitRepo-		remote = remoteFor fork-		remoteFor (GithubUserRepo user repo) =-			"github_" ++ user ++ "_" ++ repo ++ ".wiki"+  where+	fetchwiki = inRepo $ Git.Command.runBool "fetch" [Param remote]+	remotes = Git.remotes <$> getState gitRepo+	remote = remoteFor fork+	remoteFor (GithubUserRepo user repo) =+		"github_" ++ user ++ "_" ++ repo ++ ".wiki"  addFork :: GithubUserRepo -> Backup Bool addFork fork =@@ -326,9 +336,8 @@ 			_ <- addRemote (remoteFor fork) (repoUrl fork) 			return True 		)-	where-		remoteFor (GithubUserRepo user repo) =-			"github_" ++ user ++ "_" ++ repo+  where+	remoteFor (GithubUserRepo user repo) = "github_" ++ user ++ "_" ++ repo  {- Adds a remote, also fetching from it. -} addRemote :: String -> String -> Backup Bool@@ -360,8 +369,8 @@ gatherMetaData repo = do 	liftIO $ putStrLn $ "Gathering metadata for " ++ repoUrl repo ++ " ..." 	mapM_ call toplevelApi-	where-		call name = runRequest $ RequestSimple name repo+  where+	call name = runRequest $ RequestSimple name repo  storeRetry :: [Request] -> Git.Repo -> IO () storeRetry [] r = void $ do@@ -392,11 +401,11 @@  summarizeRequests :: [Request] -> [String] summarizeRequests = go M.empty-	where-		go m [] = map format $ sort $ map swap $ M.toList m-		go m (r:rs) = go (M.insertWith (+) (requestName r) (1 :: Integer) m) rs-		format (num, name) = show num ++ "\t" ++ name-		swap (a, b) = (b, a)+  where+	go m [] = map format $ sort $ map swap $ M.toList m+	go m (r:rs) = go (M.insertWith (+) (requestName r) (1 :: Integer) m) rs+	format (num, name) = show num ++ "\t" ++ name+	swap (a, b) = (b, a)  {- Save all backup data. Files that were written to the workDir are committed.  - Requests that failed are saved for next time. Requests that were retried@@ -422,16 +431,16 @@  backupRepo :: Git.Repo -> IO () backupRepo repo = evalStateT (runBackup go) . newState =<< Git.Config.read repo-	where-		go = do-			retriedfailed <- retry-			remotes <- gitHubPairs <$> getState gitRepo-			when (null remotes) $-				error "no github remotes found"-			forM_ remotes $ \(r, remote) -> do-				_ <- fetchRepo r-				gatherMetaData remote-			save retriedfailed+  where+	go = do+		retriedfailed <- retry+		remotes <- gitHubPairs <$> getState gitRepo+		when (null remotes) $+			error "no github remotes found"+		forM_ remotes $ \(r, remote) -> do+			_ <- fetchRepo r+			gatherMetaData remote+		save retriedfailed  backupName :: String -> IO () backupName name = do@@ -462,7 +471,9 @@  main :: IO () main = getArgs >>= go-	where-		go [] = backupRepo =<< Git.Construct.fromCwd-		go (name:[]) = backupName name-		go _= error usage+  where+	go (('-':_):_) = error usage+	go [] = backupRepo =<< Git.Construct.fromCwd+	go (name:[]) = backupName name+	go _= error usage+

@@ -0,0 +1,21 @@+#!/bin/sh+#+# Workaround for `cabal sdist` requiring all included files to be listed+# in .cabal.++# Create target directory+sdist_dir=github-backup-$(grep '^Version:' github-backup.cabal | sed -re 's/Version: *//')+mkdir --parents dist/$sdist_dir++find . \( -name .git -or -name dist -or -name cabal-dev \) -prune \+	-or -not -name \\*.orig -not -type d -print \+| perl -ne "print unless length >= 100 - length q{$sdist_dir}" \+| xargs cp --parents --target-directory dist/$sdist_dir++cd dist+tar -caf $sdist_dir.tar.gz $sdist_dir++# Check that tarball can be unpacked by cabal.+# It's picky about tar longlinks etc.+rm -rf $sdist_dir+cabal unpack $sdist_dir.tar.gz