diff --git a/Git/Branch.hs b/Git/Branch.hs --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -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 diff --git a/Git/DiffTreeItem.hs b/Git/DiffTreeItem.hs new file mode 100644 --- /dev/null +++ b/Git/DiffTreeItem.hs @@ -0,0 +1,24 @@ +{- git diff-tree item + - + - Copyright 2012 Joey Hess + - + - 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 diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -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 diff --git a/Git/Version.hs b/Git/Version.hs --- a/Git/Version.hs +++ b/Git/Version.hs @@ -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 diff --git a/Github/EnumRepos.hs b/Github/EnumRepos.hs new file mode 100644 --- /dev/null +++ b/Github/EnumRepos.hs @@ -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/~/" + ] + diff --git a/Github/GetAuth.hs b/Github/GetAuth.hs new file mode 100644 --- /dev/null +++ b/Github/GetAuth.hs @@ -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 diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 {} \; diff --git a/Utility/DottedVersion.hs b/Utility/DottedVersion.hs new file mode 100644 --- /dev/null +++ b/Utility/DottedVersion.hs @@ -0,0 +1,36 @@ +{- dotted versions, such as 1.0.1 + - + - Copyright 2011-2014 Joey Hess + - + - 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 diff --git a/Utility/Path.hs b/Utility/Path.hs --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -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 diff --git a/Utility/Process.hs b/Utility/Process.hs --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -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. diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -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 diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -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 Mon, 22 Dec 2014 15:30:08 -0400 + github-backup (1.20141204) unstable; urgency=high * Fix broken argument parser for the username|organization parameter. diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -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. diff --git a/debian/copyright b/debian/copyright --- a/debian/copyright +++ b/debian/copyright @@ -2,7 +2,7 @@ Source: native package Files: * -Copyright: © 2010-2013 Joey Hess +Copyright: © 2010-2014 Joey Hess 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 diff --git a/github-backup.cabal b/github-backup.cabal --- a/github-backup.cabal +++ b/github-backup.cabal @@ -1,5 +1,5 @@ Name: github-backup -Version: 1.20141204 +Version: 1.20141222 Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess @@ -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 diff --git a/github-backup.hs b/github-backup.hs --- a/github-backup.hs +++ b/github-backup.hs @@ -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 diff --git a/gitriddance.1 b/gitriddance.1 new file mode 100644 --- /dev/null +++ b/gitriddance.1 @@ -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 diff --git a/gitriddance.hs b/gitriddance.hs new file mode 100644 --- /dev/null +++ b/gitriddance.hs @@ -0,0 +1,63 @@ +{- gitriddance - close all open issues and pull requests + - + - Copyright 2014 Joey Hess + - + - 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" } )