diff --git a/Build/make-sdist.sh b/Build/make-sdist.sh new file mode 100644 --- /dev/null +++ b/Build/make-sdist.sh @@ -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 diff --git a/Git/CatFile.hs b/Git/CatFile.hs new file mode 100644 --- /dev/null +++ b/Git/CatFile.hs @@ -0,0 +1,108 @@ +{- git cat-file interface + - + - Copyright 2011, 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.CatFile ( + CatFileHandle, + catFileStart, + catFileStart', + catFileStop, + catFile, + catTree, + catObject, + catObjectDetails, +) where + +import System.IO +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Tuple.Utils +import Numeric +import System.Posix.Types + +import Common +import Git +import Git.Sha +import Git.Command +import Git.Types +import Git.FilePath +import qualified Utility.CoProcess as CoProcess + +data CatFileHandle = CatFileHandle CoProcess.CoProcessHandle Repo + +catFileStart :: Repo -> IO CatFileHandle +catFileStart = catFileStart' True + +catFileStart' :: Bool -> Repo -> IO CatFileHandle +catFileStart' restartable repo = do + coprocess <- CoProcess.rawMode =<< gitCoProcessStart restartable + [ Param "cat-file" + , Param "--batch" + ] repo + return $ CatFileHandle coprocess repo + +catFileStop :: CatFileHandle -> IO () +catFileStop (CatFileHandle p _) = CoProcess.stop p + +{- Reads a file from a specified branch. -} +catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString +catFile h branch file = catObject h $ Ref $ + show branch ++ ":" ++ toInternalGitPath file + +{- Uses a running git cat-file read the content of an object. + - Objects that do not exist will have "" returned. -} +catObject :: CatFileHandle -> Ref -> IO L.ByteString +catObject h object = maybe L.empty fst3 <$> catObjectDetails h object + +catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType)) +catObjectDetails (CatFileHandle hdl _) object = CoProcess.query hdl send receive + where + query = show object + send to = hPutStrLn to query + receive from = do + header <- hGetLine from + case words header of + [sha, objtype, size] + | length sha == shaSize -> + case (readObjectType objtype, reads size) of + (Just t, [(bytes, "")]) -> readcontent t bytes from sha + _ -> dne + | otherwise -> dne + _ + | header == show object ++ " missing" -> dne + | otherwise -> error $ "unknown response from git cat-file " ++ show (header, object) + readcontent objtype bytes from sha = do + content <- S.hGet from bytes + eatchar '\n' from + return $ Just (L.fromChunks [content], Ref sha, objtype) + dne = return Nothing + eatchar expected from = do + c <- hGetChar from + when (c /= expected) $ + error $ "missing " ++ (show expected) ++ " from git cat-file" + +{- Gets a list of files and directories in a tree. (Not recursive.) -} +catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)] +catTree h treeref = go <$> catObjectDetails h treeref + where + go (Just (b, _, TreeObject)) = parsetree [] b + go _ = [] + + parsetree c b = case L.break (== 0) b of + (modefile, rest) + | L.null modefile -> c + | otherwise -> parsetree + (parsemodefile modefile:c) + (dropsha rest) + + -- these 20 bytes after the NUL hold the file's sha + -- TODO: convert from raw form to regular sha + dropsha = L.drop 21 + + parsemodefile b = + let (modestr, file) = separate (== ' ') (encodeW8 $ L.unpack b) + in (file, readmode modestr) + readmode = fst . fromMaybe (0, undefined) . headMaybe . readOct diff --git a/Github/Data/Readable.hs b/Github/Data/Readable.hs --- a/Github/Data/Readable.hs +++ b/Github/Data/Readable.hs @@ -11,3 +11,4 @@ deriving instance Read GithubDate deriving instance Read GithubOwner deriving instance Read Repo +deriving instance Read RepoRef diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -23,7 +23,7 @@ # Upload to hackage. hackage: clean - ./make-sdist.sh + ./Build/make-sdist.sh @cabal upload dist/*.tar.gz # hothasktags chokes on some template haskell etc, so ignore errors diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ 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 branches, tags, other forks, issues, comments, wikis, milestones, -pull requests, and watchers. +pull requests, watchers, and stars. ## Installation @@ -22,10 +22,9 @@ Run `github-backup` with no parameters, inside a git repository cloned from GitHub to back up that repository. - Or, run `github-backup username` to clone and back up all of a GitHub - user's repositories, as well as all the repositories watched by that - user. - (Also works for organization names.) + Or, if you have a GitHub account, run `github-backup username` + to clone and back up your account's repositories, as well + as the repositories you're watching and have starred. ## Why backup GitHub repositories @@ -37,7 +36,7 @@ * In case someone takes down a repository that you were interested in. If you run github-backup with your username, it will back up all - the repositories you have watched. + the repositories you have watched and starred. * So you can keep working on your repository while on a plane, or on a remote beach or mountaintop. Just like Linus intended. @@ -68,12 +67,6 @@ github-backup does not log into GitHub, so it cannot backup private repositories. - -github-backup will find and backup forks of a repository, and all forks -of those forks, etc. However, it cannot go *up* the fork tree. So if -your GitHub repositoriy is a fork of something else, the something else -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. Notes added to commits and lines of code don't get backed up yet. There is only recently API support for this. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} - {- cabal setup file -} import Distribution.Simple diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,17 @@ +github-backup (1.20131203) unstable; urgency=low + + * Now also backs up the repos a user has starred, when run with a user's + name. + * Now finds and backs up the parent repository that a repository got forked + from. + * Uses authentication for all API calls. + * Fairer ordering of requests when backing up many repositories at once. + * Avoid making requests for data that has already been backed up until + after new data has been backed up. Handles API rate limiting much better. + Closes: #723859 + + -- Joey Hess Tue, 03 Dec 2013 12:45:18 -0400 + github-backup (1.20131101) unstable; urgency=low * Now also backs up the repos a user is watching, when run with a user's 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.5.1), + libghc-github-dev (>= 0.7.2), libghc-missingh-dev, libghc-hslogger-dev, libghc-pretty-show-dev, 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.20131101 +Version: 1.20131203 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess @@ -18,9 +18,10 @@ Executable github-backup Main-Is: github-backup.hs + GHC-Options: -Wall Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl, network, extensible-exceptions, unix-compat, bytestring, - base >= 4.5, base < 5, IfElse, pretty-show, text, process, github >= 0.6.0 + base >= 4.5, base < 5, IfElse, pretty-show, text, process, github >= 0.7.2 if (! os(windows)) Build-Depends: unix diff --git a/github-backup.hs b/github-backup.hs --- a/github-backup.hs +++ b/github-backup.hs @@ -25,6 +25,7 @@ import qualified Github.Repos.Forks as Github import qualified Github.PullRequests as Github import qualified Github.Repos.Watching as Github +import qualified Github.Repos.Starring as Github import qualified Github.Data.Definitions as Github () import qualified Github.Issues as Github import qualified Github.Issues.Comments @@ -42,17 +43,25 @@ import qualified Git.UpdateIndex 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) -toGithubUserRepo :: Github.Repo -> GithubUserRepo -toGithubUserRepo r = GithubUserRepo - (Github.githubOwnerLogin $ Github.repoOwner r) - (Github.repoName r) +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" @@ -80,8 +89,11 @@ data BackupState = BackupState { failedRequests :: S.Set Request , retriedRequests :: S.Set Request + , retriedFailed :: S.Set Request , gitRepo :: Git.Repo , gitHubAuth :: Maybe Github.GithubAuth + , deferredBackups :: [Backup ()] + , catFileHandle :: Maybe CatFileHandle } {- Our monad. -} @@ -97,7 +109,7 @@ inRepo :: (Git.Repo -> IO a) -> Backup a inRepo a = liftIO . a =<< getState gitRepo -failedRequest :: Request -> Github.Error-> Backup () +failedRequest :: Request -> Github.Error -> Backup () failedRequest req e = unless ignorable $ do set <- getState failedRequests changeState $ \s -> s { failedRequests = S.insert req set } @@ -115,15 +127,16 @@ type Storer = Request -> Backup () data ApiListItem = ApiListItem ApiName Storer Bool apiList :: [ApiListItem] -apiList = - [ ApiListItem "userrepo" userrepoStore True - , ApiListItem "watchers" watchersStore True +apiList = + [ ApiListItem "watchers" watchersStore True + , ApiListItem "stargazers" stargazersStore True , ApiListItem "pullrequests" pullrequestsStore True , ApiListItem "pullrequest" pullrequestStore False , ApiListItem "milestones" milestonesStore True , ApiListItem "issues" issuesStore True , ApiListItem "issuecomments" issuecommentsStore False - -- comes last because it recurses on to the forks + -- Recursive things last. + , ApiListItem "userrepo" userrepoStore True , ApiListItem "forks" forksStore True ] @@ -131,7 +144,7 @@ api :: M.Map ApiName Storer api = M.fromList $ map (\(ApiListItem n s _) -> (n, s)) apiList -{- List of toplevel api calls that are followed to get all data. -} +{- List of toplevel api calls that are followed to get data. -} toplevelApi :: [ApiName] toplevelApi = map (\(ApiListItem n _ _) -> n) $ filter (\(ApiListItem _ _ toplevel) -> toplevel) apiList @@ -142,35 +155,33 @@ name = requestName req bad = error $ "internal error: bad api call: " ++ name -userrepoStore :: Storer -userrepoStore = simpleHelper (noAuth Github.userRepo) $ \req r -> do - when (Github.repoHasWiki r == Just True) $ - updateWiki $ toGithubUserRepo r - store "repo" req r - watchersStore :: Storer -watchersStore = simpleHelper (noAuth Github.watchersFor) $ +watchersStore = simpleHelper "watchers" Github.watchersFor' $ storeSorted "watchers" +stargazersStore :: Storer +stargazersStore = simpleHelper "stargazers" Github.stargazersFor $ + storeSorted "stargazers" + pullrequestsStore :: Storer -pullrequestsStore = simpleHelper Github.pullRequestsFor' $ +pullrequestsStore = simpleHelper "pullrequest" Github.pullRequestsFor' $ forValues $ \req r -> do let repo = requestRepo req let n = Github.pullRequestNumber r runRequest $ RequestNum "pullrequest" repo n pullrequestStore :: Storer -pullrequestStore = numHelper Github.pullRequest' $ \n -> +pullrequestStore = numHelper "pullrequest" Github.pullRequest' $ \n -> store ("pullrequest" show n) milestonesStore :: Storer -milestonesStore = simpleHelper Github.Issues.Milestones.milestones' $ +milestonesStore = simpleHelper "milestone" Github.Issues.Milestones.milestones' $ forValues $ \req m -> do let n = Github.milestoneNumber m store ("milestone" show n) req m issuesStore :: Storer -issuesStore = withHelper (\a u r y -> +issuesStore = withHelper "issue" (\a u r y -> Github.issuesForRepo' a u r (y <> [Github.Open]) >>= either (return . Left) (\xs -> Github.issuesForRepo' a u r @@ -186,18 +197,23 @@ runRequest (RequestNum "issuecomments" repo n) issuecommentsStore :: Storer -issuecommentsStore = numHelper Github.Issues.Comments.comments' $ \n -> +issuecommentsStore = numHelper "issuecomments" Github.Issues.Comments.comments' $ \n -> forValues $ \req c -> do let i = Github.issueCommentId c store ("issue" show n ++ "_comment" show i) req c +userrepoStore :: Storer +userrepoStore = simpleHelper "repo" Github.userRepo' $ \req r -> do + store "repo" req r + when (Github.repoHasWiki r == Just True) $ + updateWiki $ toGithubUserRepo r + maybe noop addFork $ Github.repoParent r + maybe noop addFork $ Github.repoSource r + forksStore :: Storer -forksStore = simpleHelper (noAuth Github.forksFor) $ \req fs -> do +forksStore = simpleHelper "forks" Github.forksFor' $ \req fs -> do storeSorted "forks" req fs - mapM_ (traverse . toGithubUserRepo) fs - where - traverse fork = whenM (addFork fork) $ - gatherMetaData fork + mapM_ addFork fs forValues :: (Request -> v -> Backup ()) -> Request -> [v] -> Backup () forValues handle req vs = forM_ vs (handle req) @@ -208,39 +224,66 @@ type Handler v = Request -> v -> Backup () type Helper = Request -> Backup () -noAuth :: (String -> String -> IO a) -> Maybe Github.GithubAuth -> String -> String -> IO a -noAuth a _auth user repo = a user repo - -simpleHelper :: ApiCall v -> Handler v -> Helper -simpleHelper call handle req@(RequestSimple _ (GithubUserRepo user repo)) = do - auth <- getState gitHubAuth - either (failedRequest req) (handle req) =<< liftIO (call auth user repo) -simpleHelper _ _ r = badRequest r +simpleHelper :: FilePath -> ApiCall v -> Handler v -> Helper +simpleHelper dest call handle req@(RequestSimple _ (GithubUserRepo user repo)) = + deferOn dest req $ do + auth <- getState gitHubAuth + either (failedRequest req) (handle req) =<< liftIO (call auth user repo) +simpleHelper _ _ _ r = badRequest r -withHelper :: ApiWith v b -> b -> Handler v -> Helper -withHelper call b handle req@(RequestSimple _ (GithubUserRepo user repo)) = do - auth <- getState gitHubAuth - either (failedRequest req) (handle req) =<< liftIO (call auth user repo b) -withHelper _ _ _ r = badRequest r +withHelper :: FilePath -> ApiWith v b -> b -> Handler v -> Helper +withHelper dest call b handle req@(RequestSimple _ (GithubUserRepo user repo)) = + deferOn dest req $ do + auth <- getState gitHubAuth + either (failedRequest req) (handle req) =<< liftIO (call auth user repo b) +withHelper _ _ _ _ r = badRequest r -numHelper :: ApiNum v -> (Int -> Handler v) -> Helper -numHelper call handle req@(RequestNum _ (GithubUserRepo user repo) num) = do - auth <- getState gitHubAuth - either (failedRequest req) (handle num req) =<< liftIO (call auth user repo num) -numHelper _ _ r = badRequest r +numHelper :: FilePath -> ApiNum v -> (Int -> Handler v) -> Helper +numHelper dest call handle req@(RequestNum _ (GithubUserRepo user repo) num) = + deferOn dest req $ do + auth <- getState gitHubAuth + either (failedRequest req) (handle num req) =<< liftIO (call auth user repo num) +numHelper _ _ _ r = badRequest r badRequest :: Request -> a badRequest r = error $ "internal error: bad request type " ++ show r +{- When the specified file or directory already exists in git, the action + - is deferred until later. -} +deferOn :: FilePath -> Request -> Backup () -> Backup () +deferOn f req a = ifM (ingit $ storeLocation f req) + ( changeState $ \s -> s { deferredBackups = a : deferredBackups s } + , a + ) + where + ingit f' = do + h <- getCatFileHandle + liftIO $ isJust <$> catObjectDetails h + (Git.Types.Ref $ show branchname ++ ":" ++ f') + +getCatFileHandle :: Backup CatFileHandle +getCatFileHandle = go =<< getState catFileHandle + where + go (Just h) = return h + go Nothing = do + h <- withIndex $ inRepo catFileStart + changeState $ \s -> s { catFileHandle = Just h } + return h + store :: Show a => FilePath -> Request -> a -> Backup () store filebase req val = do - file <- location (requestRepo req) <$> workDir + file <- () + <$> workDir + <*> pure (storeLocation filebase req) liftIO $ do createDirectoryIfMissing True (parentDir file) writeFile file (ppShow val) + +storeLocation :: FilePath -> Request -> FilePath +storeLocation filebase = location . requestRepo where - location (GithubUserRepo user repo) workdir = - workdir user ++ "_" ++ repo filebase + location (GithubUserRepo user repo) = + user ++ "_" ++ repo filebase workDir :: Backup FilePath workDir = () @@ -307,13 +350,13 @@ -- Stage workDir files into the index. h <- hashObjectStart r Git.UpdateIndex.streamUpdateIndex r - [genstream r dir h] + [genstream dir h] hashObjectStop h -- Commit void $ Git.Branch.commit "github-backup" fullname [branchref] r removeDirectoryRecursive dir where - genstream r dir h streamer = do + genstream dir h streamer = do fs <- filter (not . dirCruft) <$> dirContentsRecursive dir forM_ fs $ \f -> do sha <- hashFile h f @@ -375,16 +418,16 @@ remoteFor (GithubUserRepo user repo) = "github_" ++ user ++ "_" ++ repo ++ ".wiki" -addFork :: GithubUserRepo -> Backup Bool -addFork fork = - ifM (elem fork <$> gitHubRemotes) - ( return False - , do - liftIO $ putStrLn $ "New fork: " ++ repoUrl fork - _ <- addRemote (remoteFor fork) (repoUrl fork) - return True - ) +addFork :: ToGithubUserRepo a => a -> Backup () +addFork forksource = unlessM (elem fork <$> gitHubRemotes) $ do + liftIO $ putStrLn $ "New fork: " ++ repoUrl fork + void $ addRemote (remoteFor fork) (repoUrl fork) + gitRepo' <- inRepo $ Git.Config.reRead + changeState $ \s -> s { gitRepo = gitRepo' } + + gatherMetaData fork where + fork = toGithubUserRepo forksource remoteFor (GithubUserRepo user repo) = "github_" ++ user ++ "_" ++ repo {- Adds a remote, also fetching from it. -} @@ -412,8 +455,6 @@ fetchRepo repo = inRepo $ Git.Command.runBool [Param "fetch", Param $ fromJust $ Git.Types.remoteName repo] -{- Gathers metadata for the repo. Retuns a list of files written - - and a list that may contain requests that need to be retried later. -} gatherMetaData :: GithubUserRepo -> Backup () gatherMetaData repo = do liftIO $ putStrLn $ "Gathering metadata for " ++ repoUrl repo ++ " ..." @@ -433,7 +474,7 @@ retryFile :: Git.Repo -> FilePath retryFile r = Git.localGitDir r "github-backup.todo" -retry :: Backup (S.Set Request) +retry :: Backup () retry = do todo <- inRepo loadRetry unless (null todo) $ do @@ -441,12 +482,11 @@ "Retrying " ++ show (length todo) ++ " requests that failed last time..." mapM_ runRequest todo - retriedfailed <- getState failedRequests changeState $ \s -> s - { failedRequests = S.empty + { retriedFailed = failedRequests s + , failedRequests = S.empty , retriedRequests = S.fromList todo } - return retriedfailed summarizeRequests :: [Request] -> [String] summarizeRequests = go M.empty @@ -460,77 +500,119 @@ - Requests that failed are saved for next time. Requests that were retried - this time and failed are ordered last, to ensure that we don't get stuck - retrying the same requests and not making progress when run again. + - + - Returns any requests that failed. -} -save :: S.Set Request -> Backup () -save retriedfailed = do +save :: Backup [Request] +save = do commitWorkDir failed <- getState failedRequests + retriedfailed <- getState retriedFailed let toretry = S.toList failed ++ S.toList retriedfailed inRepo $ storeRetry toretry - unless (null toretry) $ - error $ unlines $ - ["Backup may be incomplete; " ++ - show (length toretry) ++ " requests failed:" - ] ++ map (" " ++) (summarizeRequests toretry) ++ - [ "Run again later." - ] + endState + return toretry +showFailures :: [Request] -> IO () +showFailures [] = noop +showFailures l = error $ unlines $ + ["Backup may be incomplete; " ++ + show (length l) ++ " requests failed:" + ] ++ map (" " ++) (summarizeRequests l) ++ + [ "Run again later." + ] + newState :: Git.Repo -> IO BackupState newState r = BackupState <$> pure S.empty <*> pure S.empty + <*> pure S.empty <*> pure r - <*> getauth + <*> getAuth + <*> pure [] + <*> pure Nothing + +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 - 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 tobs = encodeUtf8 . T.pack +genBackupState :: Git.Repo -> IO BackupState +genBackupState repo = newState =<< Git.Config.read repo + backupRepo :: (Maybe Git.Repo) -> IO () backupRepo Nothing = error "not in a git repository, and nothing specified to back up" -backupRepo (Just repo) = evalStateT (runBackup go) =<< newState =<< Git.Config.read repo +backupRepo (Just repo) = + genBackupState repo >>= evalStateT (runBackup go) >>= showFailures 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 + retry + mainBackup + runDeferred + save +mainBackup :: Backup () +mainBackup = do + remotes <- gitHubPairs <$> getState gitRepo + when (null remotes) $ + error "no github remotes found" + forM_ remotes $ \(r, remote) -> do + void $ fetchRepo r + gatherMetaData remote + +runDeferred :: Backup () +runDeferred = go =<< getState deferredBackups + where + go [] = noop + go l = do + changeState $ \s -> s { deferredBackups = [] } + void $ sequence l + -- Running the deferred actions could cause + -- more actions to be deferred; run them too. + runDeferred + backupName :: String -> IO () backupName name = do + auth <- getAuth l <- sequence - [ Github.userRepos name Github.All - , Github.reposWatchedBy name - , Github.organizationRepos name + [ Github.userRepos' auth name Github.All + , Github.reposWatchedBy' auth name + , Github.reposStarredBy auth name + , Github.organizationRepos' auth name ] - let repos = concat $ rights l - when (null repos) $ + let nameurls = nub $ map (\repo -> (Github.repoName repo, Github.repoGitUrl repo)) $ concat $ rights l + when (null nameurls) $ if (null $ rights l) then error $ unlines $ "Failed to query github for repos:" : map show (lefts l) else error $ "No GitHub repositories found for " ++ name - status <- forM repos $ \repo -> do - let dir = Github.repoName repo + -- Clone any missing repos, and get a BackupState for each repo + -- that is to be backed up. + states <- forM nameurls $ \(dir, url) -> do unlessM (doesDirectoryExist dir) $ do putStrLn $ "New repository: " ++ dir ok <- boolSystem "git" [ Param "clone" - , Param (Github.repoGitUrl repo) + , Param url , Param dir ] unless ok $ error "clone failed" - try (backupRepo . Just =<< Git.Construct.fromPath dir) - :: IO (Either SomeException ()) - unless (null $ lefts status) $ - error "Failed to successfully back everything up. Run again later." + genBackupState =<< Git.Construct.fromPath dir + -- First pass only retries things that failed before, so the + -- retried actions will run in each repo before too much API is + -- used up. + states' <- forM states (execStateT . runBackup $ retry) + states'' <- forM states' (execStateT . runBackup $ mainBackup) + forM states'' (evalStateT . runBackup $ runDeferred >> save) + >>= showFailures . concat usage :: String usage = "usage: github-backup [username|organization]" diff --git a/make-sdist.sh b/make-sdist.sh deleted file mode 100644 --- a/make-sdist.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/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