packages feed

github-backup 1.20141204 → 1.20141222

raw patch · 18 files changed

+319/−114 lines, 18 filesdep ~basedep ~githubdep ~networknew-component:exe:gitriddance

Dependency ranges changed: base, github, network

Files

Git/Branch.hs view
@@ -43,6 +43,9 @@ 		| 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. -} changed :: Branch -> Branch -> Repo -> IO Bool
+ Git/DiffTreeItem.hs view
@@ -0,0 +1,24 @@+{- git diff-tree item+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.DiffTreeItem (+	DiffTreeItem(..),+) where++import System.Posix.Types++import Git.FilePath+import Git.Types++data DiffTreeItem = DiffTreeItem+	{ srcmode :: FileMode+	, dstmode :: FileMode+	, srcsha :: Sha -- nullSha if file was added+	, dstsha :: Sha -- nullSha if file was deleted+	, status :: String+	, file :: TopFilePath+	} deriving Show
Git/UpdateIndex.hs view
@@ -19,7 +19,8 @@ 	updateIndexLine, 	stageFile, 	unstageFile,-	stageSymlink+	stageSymlink,+	stageDiffTreeItem, ) where  import Common@@ -28,6 +29,7 @@ import Git.Command import Git.FilePath import Git.Sha+import qualified Git.DiffTreeItem as Diff  {- Streamers are passed a callback and should feed it lines in the form  - read by update-index, and generated by ls-tree. -}@@ -95,8 +97,11 @@ unstageFile :: FilePath -> Repo -> IO Streamer unstageFile file repo = do 	p <- toTopFilePath file repo-	return $ pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p+	return $ unstageFile' p +unstageFile' :: TopFilePath -> Streamer+unstageFile' p = pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p+ {- A streamer that adds a symlink to the index. -} stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer stageSymlink file sha repo = do@@ -105,6 +110,12 @@ 		<*> pure SymlinkBlob 		<*> toTopFilePath file repo 	return $ pureStreamer line++{- A streamer that applies a DiffTreeItem to the index. -}+stageDiffTreeItem :: Diff.DiffTreeItem -> Streamer+stageDiffTreeItem d = case toBlobType (Diff.dstmode d) of+	Nothing -> unstageFile' (Diff.file d)+	Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d)  indexPath :: TopFilePath -> InternalGitPath indexPath = toInternalGitPath . getTopFilePath
Git/Version.hs view
@@ -5,18 +5,16 @@  - Licensed under the GNU GPL version 3 or higher.  -} -module Git.Version where+module Git.Version (+	installed,+	normalize,+	GitVersion,+) where  import Common--data GitVersion = GitVersion String Integer-	deriving (Eq)--instance Ord GitVersion where-	compare (GitVersion _ x) (GitVersion _ y) = compare x y+import Utility.DottedVersion -instance Show GitVersion where-	show (GitVersion s _) = s+type GitVersion = DottedVersion  installed :: IO GitVersion installed = normalize . extract <$> readProcess "git" ["--version"]@@ -24,20 +22,3 @@ 	extract s = case lines s of 		[] -> "" 		(l:_) -> unwords $ drop 2 $ words l--{- To compare dotted versions like 1.7.7 and 1.8, they are normalized to- - a somewhat arbitrary integer representation. -}-normalize :: String -> GitVersion-normalize v = GitVersion v $ -	sum $ mult 1 $ reverse $ extend precision $ take precision $-		map readi $ split "." v-  where-	extend n l = l ++ replicate (n - length l) 0-	mult _ [] = []-	mult n (x:xs) = (n*x) : mult (n*10^width) xs-	readi :: String -> Integer-	readi s = case reads s of-		((x,_):_) -> x-		_ -> 0-	precision = 10 -- number of segments of the version to compare-	width = length "yyyymmddhhmmss" -- maximum width of a segment
+ Github/EnumRepos.hs view
@@ -0,0 +1,63 @@+module Github.EnumRepos where++import qualified Github.Repos as Github+import Data.List+import Data.List.Utils+import Data.Maybe++import Utility.PartialPrelude+import qualified Git+import qualified Git.Types++-- A github user and repo.+data GithubUserRepo = GithubUserRepo String String+	deriving (Eq, Show, Read, Ord)++class ToGithubUserRepo a where+	toGithubUserRepo :: a -> GithubUserRepo++instance ToGithubUserRepo Github.Repo where+	toGithubUserRepo r = GithubUserRepo +		(Github.githubOwnerLogin $ Github.repoOwner r)+		(Github.repoName r)++instance ToGithubUserRepo Github.RepoRef where+	toGithubUserRepo (Github.RepoRef owner name) = +		GithubUserRepo (Github.githubOwnerLogin owner) name++gitHubRepos :: Git.Repo -> [Git.Repo]+gitHubRepos = fst . unzip . gitHubPairs++gitHubRemotes :: Git.Repo -> [GithubUserRepo]+gitHubRemotes = snd . unzip . gitHubPairs++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 = filter (not . null) $ 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]+gitHubUrlPrefixes = +	[ "git@github.com:"+	, "git://github.com/"+	, "https://github.com/"+	, "http://github.com/"+	, "ssh://git@github.com/~/"+	]+
+ Github/GetAuth.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE CPP #-}++module Github.GetAuth where++import Utility.Env++#if MIN_VERSION_github(0,9,0)+import qualified Github.Auth as Github+#else+import qualified Github.Issues as Github+#endif+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Text as T++getAuth :: IO (Maybe Github.GithubAuth)+getAuth = do+	user <- getEnv "GITHUB_USER"+	password <- getEnv "GITHUB_PASSWORD"+	return $ case (user, password) of+		(Just u, Just p) -> Just $ +			Github.GithubBasicAuth (tobs u) (tobs p)+		_ -> Nothing+  where+	tobs = encodeUtf8 . T.pack
Makefile view
@@ -4,6 +4,7 @@ build: Build/SysConfig.hs 	$(CABAL) build 	ln -sf dist/build/github-backup/github-backup github-backup+	ln -sf dist/build/gitriddance/gitriddance gitriddance 	@$(MAKE) tags >/dev/null 2>&1 &  Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs@@ -12,12 +13,12 @@  install: build 	install -d $(DESTDIR)$(PREFIX)/bin-	install github-backup $(DESTDIR)$(PREFIX)/bin+	install github-backup gitriddance $(DESTDIR)$(PREFIX)/bin 	install -d $(DESTDIR)$(PREFIX)/share/man/man1-	install -m 0644 github-backup.1 $(DESTDIR)$(PREFIX)/share/man/man1+	install -m 0644 github-backup.1 gitriddance.1 $(DESTDIR)$(PREFIX)/share/man/man1  clean:-	rm -rf github-backup dist configure Build/SysConfig.hs Setup tags+	rm -rf github-backup gitriddance dist configure Build/SysConfig.hs Setup tags 	find -name \*.o -exec rm {} \; 	find -name \*.hi -exec rm {} \;
+ Utility/DottedVersion.hs view
@@ -0,0 +1,36 @@+{- dotted versions, such as 1.0.1+ -+ - Copyright 2011-2014 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++module Utility.DottedVersion where++import Common++data DottedVersion = DottedVersion String Integer+	deriving (Eq)++instance Ord DottedVersion where+	compare (DottedVersion _ x) (DottedVersion _ y) = compare x y++instance Show DottedVersion where+	show (DottedVersion s _) = s++{- To compare dotted versions like 1.7.7 and 1.8, they are normalized to+ - a somewhat arbitrary integer representation. -}+normalize :: String -> DottedVersion+normalize v = DottedVersion v $ +	sum $ mult 1 $ reverse $ extend precision $ take precision $+		map readi $ split "." v+  where+	extend n l = l ++ replicate (n - length l) 0+	mult _ [] = []+	mult n (x:xs) = (n*x) : mult (n*10^width) xs+	readi :: String -> Integer+	readi s = case reads s of+		((x,_):_) -> x+		_ -> 0+	precision = 10 -- number of segments of the version to compare+	width = length "yyyymmddhhmmss" -- maximum width of a segment
Utility/Path.hs view
@@ -267,7 +267,8 @@  - sane FilePath.  -  - All spaces and punctuation and other wacky stuff are replaced- - with '_', except for '.' "../" will thus turn into ".._", which is safe.+ - with '_', except for '.'+ - "../" will thus turn into ".._", which is safe.  -} sanitizeFilePath :: String -> FilePath sanitizeFilePath = map sanitize
Utility/Process.hs view
@@ -13,6 +13,7 @@ 	CreateProcess(..), 	StdHandle(..), 	readProcess,+	readProcess', 	readProcessEnv, 	writeReadProcessEnv, 	forceSuccessProcess,@@ -66,16 +67,18 @@ 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+readProcessEnv cmd args environ = readProcess' p   where 	p = (proc cmd args) 		{ std_out = CreatePipe 		, env = environ 		}++readProcess' :: CreateProcess -> IO String+readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do+	output  <- hGetContentsStrict h+	hClose h+	return output  {- Runs an action to write to a process on its stdin,   - returns its output, and also allows specifying the environment.
Utility/Tmp.hs view
@@ -24,8 +24,8 @@ {- 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  - directory as the final file to avoid cross-device renames. -}-viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO ()-viaTmp a file content = bracket setup cleanup use+viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> String -> m ()) -> FilePath -> String -> m ()+viaTmp a file content = bracketIO setup cleanup use   where 	(dir, base) = splitFileName file 	template = base ++ ".tmp"@@ -36,9 +36,9 @@ 		_ <- tryIO $ hClose h 		tryIO $ removeFile tmpfile 	use (tmpfile, h) = do-		hClose h+		liftIO $ hClose h 		a tmpfile content-		rename tmpfile file+		liftIO $ rename tmpfile file  {- Runs an action with a tmp file located in the system's tmp directory  - (or in "." if there is none) then removes the file. -}@@ -61,15 +61,15 @@ {- Runs an action with a tmp directory located within the system's tmp  - directory (or within "." if there is none), then removes the tmp  - directory and all its contents. -}-withTmpDir :: Template -> (FilePath -> IO a) -> IO a+withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a withTmpDir template a = do-	tmpdir <- catchDefaultIO "." getTemporaryDirectory+	tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory 	withTmpDirIn tmpdir template a  {- Runs an action with a tmp directory located within a specified directory,  - then removes the tmp directory and all its contents. -}-withTmpDirIn :: FilePath -> Template -> (FilePath -> IO a) -> IO a-withTmpDirIn tmpdir template = bracket create remove+withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a+withTmpDirIn tmpdir template = bracketIO create remove   where 	remove d = whenM (doesDirectoryExist d) $ do #if mingw32_HOST_OS
debian/changelog view
@@ -1,3 +1,14 @@+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.
debian/control view
@@ -5,7 +5,7 @@ 	debhelper (>= 9), 	ghc, 	git,-	libghc-github-dev (>= 0.7.2),+	libghc-github-dev (>= 0.13.1), 	libghc-missingh-dev, 	libghc-hslogger-dev, 	libghc-pretty-show-dev,@@ -28,3 +28,6 @@  GitHub. It backs up everything GitHub publishes about the repository,  including other forks, issues, comments, wikis, milestones, pull requests,  and watchers.+ .+ Also includes gitriddance, which can be used to close all open issues and+ pull requests.
debian/copyright view
@@ -2,7 +2,7 @@ Source: native package  Files: *-Copyright: © 2010-2013 Joey Hess <joey@kitenet.net>+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
github-backup.cabal view
@@ -1,5 +1,5 @@ Name: github-backup-Version: 1.20141204+Version: 1.20141222 Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess <joey@kitenet.net>@@ -16,6 +16,9 @@  Github. It backs up everything Github knows about the repository, including  other forks, issues, comments, milestones, pull requests, and watchers. + Also includes gitriddance, which can be used to close all open issues and+ pull requests.+ Flag network-uri   Description: Get Network.URI from the network-uri package   Default: True@@ -28,7 +31,22 @@    IfElse, pretty-show, text, process, optparse-applicative,    github >= 0.7.2,    base >= 4.5, base < 5+  +  if (! os(windows))+    Build-Depends: unix+  +  if flag(network-uri)+    Build-Depends: network-uri (>= 2.6), network (>= 2.6)+  else+    Build-Depends: network (< 2.6), network (>= 2.0) +Executable gitriddance+  Main-Is: gitriddance.hs+  GHC-Options: -Wall+  Build-Depends: github >= 0.13.1, base >= 4.5, base < 5, text, filepath,+    MissingH, exceptions, transformers, bytestring, hslogger, process,+    containers, unix-compat, IfElse, directory, mtl+     if (! os(windows))     Build-Depends: unix
github-backup.hs view
@@ -13,8 +13,6 @@  import qualified Data.Map as M import qualified Data.Set as S-import qualified Data.Text as T-import Data.Text.Encoding (encodeUtf8) import Data.Either import Data.Monoid import Options.Applicative@@ -43,27 +41,13 @@ import qualified Git.Ref import qualified Git.Branch import qualified Git.UpdateIndex+import Github.GetAuth+import Github.EnumRepos import Git.HashObject import Git.FilePath import Git.CatFile import Utility.Env --- A github user and repo.-data GithubUserRepo = GithubUserRepo String String-	deriving (Eq, Show, Read, Ord)--class ToGithubUserRepo a where-	toGithubUserRepo :: a -> GithubUserRepo--instance ToGithubUserRepo Github.Repo where-	toGithubUserRepo r = GithubUserRepo -		(Github.githubOwnerLogin $ Github.repoOwner r)-		(Github.repoName r)--instance ToGithubUserRepo Github.RepoRef where-	toGithubUserRepo (Github.RepoRef owner name) = -		GithubUserRepo (Github.githubOwnerLogin owner) name- repoUrl :: GithubUserRepo -> String repoUrl (GithubUserRepo user remote) = 	"git://github.com/" ++ user ++ "/" ++ remote ++ ".git"@@ -295,42 +279,6 @@ storeSorted :: Ord a => Show a => FilePath -> Request -> [a] -> Backup () storeSorted file req val = store file req (sort val) -gitHubRepos :: Backup [Git.Repo]-gitHubRepos = fst . unzip . gitHubPairs <$> getState gitRepo--gitHubRemotes :: Backup [GithubUserRepo]-gitHubRemotes = snd . unzip . gitHubPairs <$> getState gitRepo--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 = filter (not . null) $ 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]-gitHubUrlPrefixes = -	[ "git@github.com:"-	, "git://github.com/"-	, "https://github.com/"-	, "http://github.com/"-	, "ssh://git@github.com/~/"-	]- {- Commits all files in the workDir into the github branch, and deletes the  - workDir.  -@@ -421,7 +369,7 @@ 		"github_" ++ user ++ "_" ++ repo ++ ".wiki"  addFork :: ToGithubUserRepo a => a -> Backup ()-addFork forksource = unlessM (elem fork <$> gitHubRemotes) $ do+addFork forksource = unlessM (elem fork . gitHubRemotes <$> getState gitRepo) $ do 	liftIO $ putStrLn $ "New fork: " ++ repoUrl fork 	void $ addRemote (remoteFor fork) (repoUrl fork) 	gitRepo' <- inRepo $ Git.Config.reRead@@ -536,17 +484,6 @@  endState :: Backup () endState = liftIO . maybe noop catFileStop =<< getState catFileHandle--getAuth :: IO (Maybe Github.GithubAuth)-getAuth = do-	user <- getEnv "GITHUB_USER"-	password <- getEnv "GITHUB_PASSWORD"-	return $ case (user, password) of-		(Just u, Just p) -> Just $ -			Github.GithubBasicAuth (tobs u) (tobs p)-		_ -> Nothing-  where-	tobs = encodeUtf8 . T.pack  genBackupState :: Git.Repo -> IO BackupState genBackupState repo = newState =<< Git.Config.read repo
+ gitriddance.1 view
@@ -0,0 +1,26 @@+.\" -*- nroff -*-+.TH gitriddance 1 "Commands"+.SH NAME+gitriddance \- closes all open issues and pull requests+.SH SYNOPSIS+.B gitriddance [comment]+.SH DESCRIPTION+.I gitriddance+closes all open issues and pull requests on GitHub. This is useful for+projects that have their own issue trackers, patch submission systems etc,+rather than relying on GitHub's, which many of us find to be clumsy,+slow, proprietary, and encouraging of drive-by pull requests of poor quality.+.PP+It should be run in a git repository that was cloned from GitHub. It+looks at the origin remote to find the repository on GitHub. All open+issues and pull requests will have a comment posted to them, and be closed.+.PP+The text of the comment is either passed as a command-line parameter,+or can be configured by setting core.gitriddance. For example:+.IP+git config core.gitriddance "Please submit patches to http://ikiwiki.info/todo/"+.PP+In order for gitriddance to log into GitHub, you need to set +the GITHUB_USER and GITHUB_PASSWORD environment variables.+.SH AUTHOR +Joey Hess <joey@kitenet.net>
+ gitriddance.hs view
@@ -0,0 +1,63 @@+{- gitriddance - close all open issues and pull requests+ -+ - Copyright 2014 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Main where++import qualified Github.Repos as Github+#if MIN_VERSION_github(0,9,0)+import qualified Github.Auth as Github+#endif+import qualified Github.Issues as Github+import qualified Github.Issues.Comments as Github+import System.Environment++import Common+import qualified Git+import qualified Git.Construct+import qualified Git.Config+import Github.GetAuth+import Github.EnumRepos++main :: IO ()+main = do+	auth <- fromMaybe (error "Must set GITHUB_USER and GITHUB_PASSWORD")+		<$> getAuth+	r <- maybe (error "not in a git repository") Git.Config.read+		=<< Git.Construct.fromCwd+	msg <- maybe (getMsg r) id <$> (headMaybe <$> getArgs)+	case gitHubRemotes (onlyOriginRemote r) of+		[] -> error "origin does not seem to be a github repository"+		[origin] -> closeall auth origin msg+		_ -> error "somehow found multiple origin repos; this should be impossible!"++getMsg :: Git.Repo -> String+getMsg r = fromMaybe (error "core.gitriddance needs to be set to a message to use when closing issues/pull requests (or pass the message on the command line)")+	(Git.Config.getMaybe "core.gitriddance" r)++{- Limit to only having the origin remote; we don't want to affect any+ - other remotes that might be on github. -}+onlyOriginRemote :: Git.Repo -> Git.Repo+onlyOriginRemote r = r { Git.remotes = filter isorigin (Git.remotes r) }+  where+	isorigin rmt = Git.remoteName rmt == Just "origin"++closeall :: Github.GithubAuth -> GithubUserRepo -> String -> IO ()+closeall auth (GithubUserRepo user repo) msg =+	either (oops "getting issue list") (mapM_ close)+		=<< Github.issuesForRepo' (Just auth) user repo [Github.Open]+  where+	oops action err = error $ "failed " ++ action ++ ": " ++ show err+	close issue = do+		let i = Github.issueNumber issue+		putStrLn $ "closing issue: " ++ Github.issueTitle issue+		either (oops "posting comment") (const $ return ())+			=<< Github.createComment auth user repo i msg+		either (oops "closing issue/pull") (const $ return ())+			=<< Github.editIssue auth user repo i+				(Github.editOfIssue { Github.editIssueState = Just "closed" } )