github-backup/0000755000000000000000000000000012247423516010477 5ustar github-backup/configure.hs0000644000000000000000000000012012235007306012775 0ustar {- configure program -} import Build.Configure main :: IO () main = run tests github-backup/Common.hs0000644000000000000000000000165312235007306012260 0ustar {-# LANGUAGE PackageImports, CPP #-} module Common (module X) where import Control.Monad as X import Control.Monad.IfElse as X import Control.Applicative as X import "mtl" Control.Monad.State.Strict as X (liftIO) import Control.Exception.Extensible as X (IOException) import Data.Maybe as X import Data.List as X hiding (head, tail, init, last) import Data.String.Utils as X hiding (join) import System.FilePath as X import System.Directory as X import System.IO as X hiding (FilePath) import System.PosixCompat.Files as X #ifndef mingw32_HOST_OS import System.Posix.IO as X #endif import System.Exit as X 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 import Utility.Data as X import Utility.Applicative as X import Utility.FileSystemEncoding as X import Utility.PartialPrelude as X github-backup/Git.hs0000644000000000000000000000765412235007306011562 0ustar {- git repository handling - - This is written to be completely independant of git-annex and should be - suitable for other uses. - - Copyright 2010-2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE CPP #-} module Git ( Repo(..), Ref(..), Branch, Sha, Tag, repoIsUrl, repoIsSsh, repoIsHttp, repoIsLocal, repoIsLocalBare, repoIsLocalUnknown, repoDescribe, repoLocation, repoPath, localGitDir, attributes, hookPath, assertLocal, ) where import Network.URI (uriPath, uriScheme, unEscapeString) #ifndef mingw32_HOST_OS import System.Posix.Files #endif import Common import Git.Types #ifndef mingw32_HOST_OS import Utility.FileMode #endif {- User-visible description of a git repo. -} repoDescribe :: Repo -> String repoDescribe Repo { remoteName = Just name } = name repoDescribe Repo { location = Url url } = show url repoDescribe Repo { location = Local { worktree = Just dir } } = dir repoDescribe Repo { location = Local { gitdir = dir } } = dir repoDescribe Repo { location = LocalUnknown dir } = dir repoDescribe Repo { location = Unknown } = "UNKNOWN" {- Location of the repo, either as a path or url. -} repoLocation :: Repo -> String repoLocation Repo { location = Url url } = show url repoLocation Repo { location = Local { worktree = Just dir } } = dir repoLocation Repo { location = Local { gitdir = dir } } = dir repoLocation Repo { location = LocalUnknown dir } = dir repoLocation Repo { location = Unknown } = undefined {- Path to a repository. For non-bare, this is the worktree, for bare, - it's the gitdir, and for URL repositories, is the path on the remote - host. -} repoPath :: Repo -> FilePath repoPath Repo { location = Url u } = unEscapeString $ uriPath u repoPath Repo { location = Local { worktree = Just d } } = d repoPath Repo { location = Local { gitdir = d } } = d repoPath Repo { location = LocalUnknown dir } = dir repoPath Repo { location = Unknown } = undefined {- Path to a local repository's .git directory. -} localGitDir :: Repo -> FilePath localGitDir Repo { location = Local { gitdir = d } } = d localGitDir _ = undefined {- Some code needs to vary between URL and normal repos, - or bare and non-bare, these functions help with that. -} repoIsUrl :: Repo -> Bool repoIsUrl Repo { location = Url _ } = True repoIsUrl _ = False repoIsSsh :: Repo -> Bool repoIsSsh Repo { location = Url url } | scheme == "ssh:" = True -- git treats these the same as ssh | scheme == "git+ssh:" = True | scheme == "ssh+git:" = True | otherwise = False where scheme = uriScheme url repoIsSsh _ = False repoIsHttp :: Repo -> Bool repoIsHttp Repo { location = Url url } | uriScheme url == "http:" = True | uriScheme url == "https:" = True | otherwise = False repoIsHttp _ = False repoIsLocal :: Repo -> Bool repoIsLocal Repo { location = Local { } } = True repoIsLocal _ = False repoIsLocalBare :: Repo -> Bool 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 [ "acting on non-local git repo" , repoDescribe repo , "not supported" ] | otherwise = action {- Path to a repository's gitattributes file. -} attributes :: Repo -> FilePath attributes repo | repoIsLocalBare repo = repoPath repo ++ "/info/.gitattributes" | otherwise = repoPath repo ++ "/.gitattributes" {- Path to a given hook script in a repository, only if the hook exists - and is executable. -} hookPath :: String -> Repo -> IO (Maybe FilePath) hookPath script repo = do let hook = localGitDir repo "hooks" script ifM (catchBoolIO $ isexecutable hook) ( return $ Just hook , return Nothing ) where #if mingw32_HOST_OS isexecutable f = doesFileExist f #else isexecutable f = isExecutable . fileMode <$> getFileStatus f #endif github-backup/Build/0000755000000000000000000000000012247423516011536 5ustar github-backup/Build/Version.hs0000644000000000000000000000403512235007306013511 0ustar {- Package version determination, for configure script. -} module Build.Version where import Data.Maybe import Control.Applicative import Data.List import System.Environment import System.Directory import Data.Char import System.Process import Build.TestConfig import Utility.Monad import Utility.Exception {- Set when making an official release. (Distribution vendors should set - this too.) -} isReleaseBuild :: IO Bool isReleaseBuild = isJust <$> catchMaybeIO (getEnv "RELEASE_BUILD") {- Version is usually based on the major version from the changelog, - plus the date of the last commit, plus the git rev of that commit. - This works for autobuilds, ad-hoc builds, etc. - - If git or a git repo is not available, or something goes wrong, - or this is a release build, just use the version from the changelog. -} getVersion :: Test getVersion = do changelogversion <- getChangelogVersion version <- ifM (isReleaseBuild) ( return changelogversion , catchDefaultIO changelogversion $ do let major = takeWhile (/= '.') changelogversion autoversion <- readProcess "sh" [ "-c" , "git log -n 1 --format=format:'%ci %h'| sed -e 's/-//g' -e 's/ .* /-g/'" ] "" if null autoversion then return changelogversion else return $ concat [ major, ".", autoversion ] ) return $ Config "packageversion" (StringConfig version) getChangelogVersion :: IO String getChangelogVersion = do changelog <- readFile "debian/changelog" let verline = takeWhile (/= '\n') changelog return $ middle (words verline !! 1) where middle = drop 1 . init {- Set up cabal file with version. -} cabalSetup :: FilePath -> IO () cabalSetup cabalfile = do version <- takeWhile (\c -> isDigit c || c == '.') <$> getChangelogVersion cabal <- readFile cabalfile writeFile tmpcabalfile $ unlines $ map (setfield "Version" version) $ lines cabal renameFile tmpcabalfile cabalfile where tmpcabalfile = cabalfile++".tmp" setfield field value s | fullfield `isPrefixOf` s = fullfield ++ value | otherwise = s where fullfield = field ++ ": " github-backup/Build/make-sdist.sh0000755000000000000000000000123312235007306014125 0ustar #!/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 github-backup/Build/Configure.hs0000644000000000000000000000125012235007306014001 0ustar {- Checks system configuration and generates SysConfig.hs. -} module Build.Configure where import System.Environment import Control.Applicative import Control.Monad.IfElse import Build.TestConfig import Build.Version import Git.Version tests :: [TestCase] tests = [ TestCase "version" getVersion , TestCase "git" $ requireCmd "git" "git --version >/dev/null" , TestCase "git version" getGitVersion ] getGitVersion :: Test getGitVersion = Config "gitversion" . StringConfig . show <$> Git.Version.installed run :: [TestCase] -> IO () run ts = do args <- getArgs config <- runTests ts writeSysConfig config whenM (isReleaseBuild) $ cabalSetup "github-backup.cabal" github-backup/Build/TestConfig.hs0000644000000000000000000001024412235007306014130 0ustar {- Tests the system and generates Build.SysConfig.hs. -} module Build.TestConfig where import Utility.Path import Utility.Monad import Utility.SafeCommand import System.IO import System.Cmd import System.Exit import System.FilePath import System.Directory type ConfigKey = String data ConfigValue = BoolConfig Bool | StringConfig String | MaybeStringConfig (Maybe String) | MaybeBoolConfig (Maybe Bool) data Config = Config ConfigKey ConfigValue type Test = IO Config type TestName = String data TestCase = TestCase TestName Test instance Show ConfigValue where show (BoolConfig b) = show b show (StringConfig s) = show s show (MaybeStringConfig s) = show s show (MaybeBoolConfig s) = show s instance Show Config where show (Config key value) = unlines [ key ++ " :: " ++ valuetype value , key ++ " = " ++ show value ] where valuetype (BoolConfig _) = "Bool" valuetype (StringConfig _) = "String" valuetype (MaybeStringConfig _) = "Maybe String" valuetype (MaybeBoolConfig _) = "Maybe Bool" writeSysConfig :: [Config] -> IO () writeSysConfig config = writeFile "Build/SysConfig.hs" body where body = unlines $ header ++ map show config ++ footer header = [ "{- Automatically generated. -}" , "module Build.SysConfig where" , "" ] footer = [] runTests :: [TestCase] -> IO [Config] runTests [] = return [] runTests (TestCase tname t : ts) = do testStart tname c <- t testEnd c rest <- runTests ts return $ c:rest {- Tests that a command is available, aborting if not. -} requireCmd :: ConfigKey -> String -> Test requireCmd k cmdline = do ret <- testCmd k cmdline handle ret where handle r@(Config _ (BoolConfig True)) = return r handle r = do testEnd r error $ "** the " ++ c ++ " command is required" c = head $ words cmdline {- Checks if a command is available by running a command line. -} testCmd :: ConfigKey -> String -> Test testCmd k cmdline = do ok <- boolSystem "sh" [ Param "-c", Param $ quiet cmdline ] return $ Config k (BoolConfig ok) {- Ensures that one of a set of commands is available by running each in - turn. The Config is set to the first one found. -} selectCmd :: ConfigKey -> [(String, String)] -> Test selectCmd k = searchCmd (return . Config k . StringConfig) (\cmds -> do testEnd $ Config k $ BoolConfig False error $ "* need one of these commands, but none are available: " ++ show cmds ) maybeSelectCmd :: ConfigKey -> [(String, String)] -> Test maybeSelectCmd k = searchCmd (return . Config k . MaybeStringConfig . Just) (\_ -> return $ Config k $ MaybeStringConfig Nothing) searchCmd :: (String -> Test) -> ([String] -> Test) -> [(String, String)] -> Test searchCmd success failure cmdsparams = search cmdsparams where search [] = failure $ fst $ unzip cmdsparams search ((c, params):cs) = do ok <- boolSystem "sh" [ Param "-c", Param $ quiet $ c ++ " " ++ params ] if ok then success c else search cs {- Finds a command, either in PATH or perhaps in a sbin directory not in - PATH. If it's in PATH the config is set to just the command name, - but if it's found outside PATH, the config is set to the full path to - the command. -} findCmdPath :: ConfigKey -> String -> Test findCmdPath k command = do ifM (inPath command) ( return $ Config k $ MaybeStringConfig $ Just command , do r <- getM find ["/usr/sbin", "/sbin", "/usr/local/sbin"] return $ Config k $ MaybeStringConfig r ) where find d = let f = d command in ifM (doesFileExist f) ( return (Just f), return Nothing ) quiet :: String -> String quiet s = s ++ " >/dev/null 2>&1" testStart :: TestName -> IO () testStart s = do putStr $ " checking " ++ s ++ "..." hFlush stdout testEnd :: Config -> IO () testEnd (Config _ (BoolConfig True)) = status "yes" testEnd (Config _ (BoolConfig False)) = status "no" testEnd (Config _ (StringConfig s)) = status s testEnd (Config _ (MaybeStringConfig (Just s))) = status s testEnd (Config _ (MaybeStringConfig Nothing)) = status "not available" testEnd (Config _ (MaybeBoolConfig (Just True))) = status "yes" testEnd (Config _ (MaybeBoolConfig (Just False))) = status "no" testEnd (Config _ (MaybeBoolConfig Nothing)) = status "unknown" status :: String -> IO () status s = putStrLn $ ' ':s github-backup/Setup.hs0000644000000000000000000000042312242443551012126 0ustar {- cabal setup file -} import Distribution.Simple import Distribution.Simple.Setup import qualified Build.Configure as Configure main = defaultMainWithHooks simpleUserHooks { preConf = configure } configure _ _ = do Configure.run Configure.tests return (Nothing, []) github-backup/README.md0000644000000000000000000000723612241055366011764 0ustar 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, watchers, and stars. ## Installation git clone git://github.com/joeyh/github-backup cd github-backup make (You will need ghc, hslogger, and MissingH installed first.) Or use cabal: cabal install github-backup --bindir=$HOME/bin (Cabal is bundled with the [Haskell Platform](http://www.haskell.org/platform/).) ## Use Run `github-backup` with no parameters, inside a git repository cloned from GitHub to back up that repository. 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 There are a couple of reasons to want to back this stuff up: * In case something happens to GitHub. More generally because keeping your data in the cloud *and* relying on the cloud to back it up is foolish. * 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 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. ## What to expect Each time you run github-backup, it will find any new forks on GitHub. It will add remotes to your repository for the forks, using names like `github_torvalds_subsurface`. It will fetch from every fork. It downloads metadata from each fork. This is stored into a branch named "github". Each fork gets a directory in there, like `torvalds_subsurface`. Inside the directory there will be some files, like `torvalds_subsurface/watchers`. There may be further directories, like for comments: `torvalds_subsurface/comments/1`. You can follow the commits to the github branch to see what information changed on GitHub over time. The format of the files in the github branch is currently Haskell serialized data types. This is plain text, and readable, if you squint. ## Limitations github-backup is repository-focused. It does not try to back up other information from GitHub. In particular, social network stuff, like users who are following you, is not backed up. github-backup does not log into GitHub, so it cannot backup private repositories. 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 enough for the extra work involved. Yell if you need them. github-backup re-downloads all issues, comments, and so on each time it's run. This may be slow if your repo has a lot of them, or even if it just has a lot of forks. Bear in mind that this uses the GitHub API; don't run it every 5 minutes. GitHub [rate limits](http://developer.github.com/v3/#rate-limiting) the API to some small number of requests per hour when used without authentication. To avoid this limit, you can set `GITHUB_USER` and `GITHUB_PASSWORD` in the environment and it will log in when making (most) API requests. Anyway, github-backup *does* do an incremental backup, picking up where it left off, so will complete the backup eventually even if it's rate limited. ## Author github-backup was written by Joey Hess It is made possible thanks to: * Mike Burns's [haskell github library](http://hackage.haskell.org/package/github) * GitHub, for providing an API exposing this data. github-backup/github-backup.cabal0000644000000000000000000000200112247423430014174 0ustar Name: github-backup Version: 1.20131203 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess Author: Joey Hess Stability: Stable Copyright: 2012 Joey Hess License-File: GPL Build-Type: Custom Homepage: https://github.com/joeyh/github-backup Category: Utility Synopsis: backs up everything github knows about a repository, to the repository Description: github-backup is a simple tool you run in a git repository you cloned from Github. It backs up everything Github knows about the repository, including other forks, issues, comments, milestones, pull requests, and watchers. 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.7.2 if (! os(windows)) Build-Depends: unix source-repository head type: git location: git://github.com/joeyh/github-backup.git github-backup/github-backup.hs0000644000000000000000000004650012241055366013563 0ustar {- github-backup - - Copyright 2012-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PackageImports #-} module Main where 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 System.Environment (getArgs) import Control.Exception (try, SomeException) import Text.Show.Pretty 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 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 import qualified Github.Issues.Milestones import Common import Utility.State import qualified Git import qualified Git.Construct import qualified Git.Config import qualified Git.Types import qualified Git.Command import qualified Git.Ref import qualified Git.Branch 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) 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" repoWikiUrl :: GithubUserRepo -> String repoWikiUrl (GithubUserRepo user remote) = "git://github.com/" ++ user ++ "/" ++ remote ++ ".wiki.git" -- A name for a github api call. type ApiName = String -- A request to make of github. It may have an extra parameter. data Request = RequestSimple ApiName GithubUserRepo | RequestNum ApiName GithubUserRepo Int deriving (Eq, Show, Read, Ord) requestRepo :: Request -> GithubUserRepo requestRepo (RequestSimple _ repo) = repo requestRepo (RequestNum _ repo _) = repo requestName :: Request -> String requestName (RequestSimple name _) = name requestName (RequestNum name _ _) = name 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. -} newtype Backup a = Backup { runBackup :: StateT BackupState IO a } deriving ( Monad, MonadState BackupState, MonadIO, Functor, Applicative ) inRepo :: (Git.Repo -> IO a) -> Backup a inRepo a = liftIO . a =<< getState gitRepo failedRequest :: Request -> Github.Error -> Backup () 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 runRequest :: Request -> Backup () runRequest req = do -- avoid re-running requests that were already retried retried <- getState retriedRequests unless (S.member req retried) $ (lookupApi req) req type Storer = Request -> Backup () data ApiListItem = ApiListItem ApiName Storer Bool apiList :: [ApiListItem] 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 -- Recursive things last. , ApiListItem "userrepo" userrepoStore True , ApiListItem "forks" forksStore True ] {- Map of Github api calls we can make to store their data. -} 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 data. -} toplevelApi :: [ApiName] toplevelApi = map (\(ApiListItem n _ _) -> n) $ filter (\(ApiListItem _ _ toplevel) -> toplevel) apiList lookupApi :: Request -> Storer lookupApi req = fromMaybe bad $ M.lookup name api where name = requestName req bad = error $ "internal error: bad api call: " ++ name watchersStore :: Storer watchersStore = simpleHelper "watchers" Github.watchersFor' $ storeSorted "watchers" stargazersStore :: Storer stargazersStore = simpleHelper "stargazers" Github.stargazersFor $ storeSorted "stargazers" pullrequestsStore :: Storer 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 "pullrequest" Github.pullRequest' $ \n -> store ("pullrequest" show n) milestonesStore :: Storer 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 "issue" (\a u r y -> Github.issuesForRepo' a u r (y <> [Github.Open]) >>= either (return . Left) (\xs -> Github.issuesForRepo' a 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 "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 "forks" Github.forksFor' $ \req fs -> do storeSorted "forks" req fs mapM_ addFork fs forValues :: (Request -> v -> Backup ()) -> Request -> [v] -> Backup () forValues handle req vs = forM_ vs (handle req) type ApiCall v = Maybe Github.GithubAuth -> String -> String -> IO (Either Github.Error v) type ApiWith v b = Maybe Github.GithubAuth -> String -> String -> b -> IO (Either Github.Error v) type ApiNum v = ApiWith v Int type Handler v = Request -> v -> Backup () type Helper = Request -> Backup () 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 :: 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 :: 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 <- () <$> 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) = user ++ "_" ++ repo filebase workDir :: Backup FilePath workDir = () <$> (Git.repoPath <$> getState gitRepo) <*> pure "github-backup.tmp" 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 = 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. - - The commit is made to the github branch without ever checking it out, - or otherwise disturbing the work tree. -} commitWorkDir :: Backup () commitWorkDir = do dir <- workDir whenM (liftIO $ doesDirectoryExist dir) $ do branchref <- getBranch withIndex $ do r <- getState gitRepo liftIO $ do -- Reset index to current content of github -- branch. Does not touch work tree. Git.Command.run [Param "reset", Param "-q", Param $ show branchref, File "." ] r -- Stage workDir files into the index. h <- hashObjectStart r Git.UpdateIndex.streamUpdateIndex r [genstream dir h] hashObjectStop h -- Commit void $ Git.Branch.commit "github-backup" fullname [branchref] r removeDirectoryRecursive dir where genstream dir h streamer = do fs <- filter (not . dirCruft) <$> dirContentsRecursive dir forM_ fs $ \f -> do sha <- hashFile h f let path = asTopFilePath (relPathDirToFile dir f) streamer $ Git.UpdateIndex.updateIndexLine sha Git.Types.FileBlob path {- Returns the ref of the github branch, creating it first if necessary. -} getBranch :: Backup Git.Ref getBranch = maybe (hasOrigin >>= create) return =<< branchsha where create True = do inRepo $ Git.Command.run [Param "branch", Param $ show branchname, Param $ show originname] fromMaybe (error $ "failed to create " ++ show branchname) <$> branchsha create False = withIndex $ inRepo $ Git.Branch.commit "branch created" fullname [] branchsha = inRepo $ Git.Ref.sha fullname {- Runs an action with a different index file, used for the github branch. -} withIndex :: Backup a -> Backup a withIndex a = do r <- getState gitRepo let f = Git.localGitDir r "github-backup.index" e <- liftIO getEnvironment let r' = r { Git.Types.gitEnv = Just $ ("GIT_INDEX_FILE", f):e } changeState $ \s -> s { gitRepo = r' } v <- a changeState $ \s -> s { gitRepo = (gitRepo s) { Git.Types.gitEnv = Git.Types.gitEnv r } } return v branchname :: Git.Ref branchname = Git.Ref "github" fullname :: Git.Ref fullname = Git.Ref $ "refs/heads/" ++ show branchname originname :: Git.Ref originname = Git.Ref $ "refs/remotes/origin/" ++ show branchname hasOrigin :: Backup Bool hasOrigin = inRepo $ Git.Ref.exists originname updateWiki :: GithubUserRepo -> Backup () updateWiki fork = ifM (any (\r -> Git.remoteName r == Just remote) <$> remotes) ( void fetchwiki , void $ -- github often does not really have a wiki, -- don't bloat config if there is none unlessM (addRemote remote $ repoWikiUrl fork) $ removeRemote remote ) where fetchwiki = inRepo $ Git.Command.runBool [Param "fetch", Param remote] remotes = Git.remotes <$> getState gitRepo remote = remoteFor fork remoteFor (GithubUserRepo user repo) = "github_" ++ user ++ "_" ++ repo ++ ".wiki" 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. -} addRemote :: String -> String -> Backup Bool addRemote remotename remoteurl = inRepo $ Git.Command.runBool [ Param "remote" , Param "add" , Param "-f" , Param remotename , Param remoteurl ] removeRemote :: String -> Backup () removeRemote remotename = void $ inRepo $ Git.Command.runBool [ Param "remote" , Param "rm" , Param remotename ] {- Fetches from the github remote. Done by github-backup, just because - it would be weird for a backup to not fetch all available data. - Even though its real focus is on metadata not stored in git. -} fetchRepo :: Git.Repo -> Backup Bool fetchRepo repo = inRepo $ Git.Command.runBool [Param "fetch", Param $ fromJust $ Git.Types.remoteName repo] gatherMetaData :: GithubUserRepo -> Backup () gatherMetaData repo = do liftIO $ putStrLn $ "Gathering metadata for " ++ repoUrl repo ++ " ..." mapM_ call toplevelApi where call name = runRequest $ RequestSimple name repo storeRetry :: [Request] -> Git.Repo -> IO () storeRetry [] r = void $ do try $ removeFile (retryFile r) :: IO (Either SomeException ()) storeRetry retryrequests r = writeFile (retryFile r) (show retryrequests) loadRetry :: Git.Repo -> IO [Request] loadRetry r = maybe [] (fromMaybe [] . readish) <$> catchMaybeIO (readFileStrict (retryFile r)) retryFile :: Git.Repo -> FilePath retryFile r = Git.localGitDir r "github-backup.todo" retry :: Backup () retry = do todo <- inRepo loadRetry unless (null todo) $ do liftIO $ putStrLn $ "Retrying " ++ show (length todo) ++ " requests that failed last time..." mapM_ runRequest todo changeState $ \s -> s { retriedFailed = failedRequests s , failedRequests = S.empty , retriedRequests = S.fromList todo } 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) {- 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 - 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 :: Backup [Request] save = do commitWorkDir failed <- getState failedRequests retriedfailed <- getState retriedFailed let toretry = S.toList failed ++ S.toList retriedfailed inRepo $ storeRetry toretry 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 <*> 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 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) = genBackupState repo >>= evalStateT (runBackup go) >>= showFailures where go = do 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' auth name Github.All , Github.reposWatchedBy' auth name , Github.reposStarredBy auth name , Github.organizationRepos' auth name ] 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 -- 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 url , Param dir ] unless ok $ error "clone failed" 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]" main :: IO () main = getArgs >>= go where go (('-':_):_) = error usage go [] = backupRepo =<< Git.Construct.fromCwd go (name:[]) = backupName name go _= error usage github-backup/github-backup.10000644000000000000000000000170012235012737013300 0ustar .\" -*- nroff -*- .TH github-backup 1 "Commands" .SH NAME github-backup \- backs up data from GitHub .SH SYNOPSIS .B github-backup [\fIusername\fP|\fIorganization\fP] .SH DESCRIPTION .I 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 branches, tags, forks, issues, comments, wikis, milestones, pull requests, and watchers. .PP Alternately, if you pass it the username of a GitHub user, it will check out, and back up, all that user's repositories, as well as all the repositories that user is watching. (Also works to pass the name of an organization using GitHub.) .PP By default it runs without logging in to GitHub. To log in, set GITHUB_USER and GITHUB_PASSWORD environment variables. However note that this only works around API rate limiting, it does not allow private repositories to be downloaded. .SH AUTHOR Joey Hess github-backup/Git/0000755000000000000000000000000012247423516011222 5ustar github-backup/Git/CatFile.hs0000644000000000000000000000616612241055366013074 0ustar {- 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 github-backup/Git/HashObject.hs0000644000000000000000000000224612235007306013564 0ustar {- git hash-object interface - - Copyright 2011-2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Git.HashObject where import Common import Git import Git.Sha import Git.Command import Git.Types import qualified Utility.CoProcess as CoProcess type HashObjectHandle = CoProcess.CoProcessHandle hashObjectStart :: Repo -> IO HashObjectHandle hashObjectStart = CoProcess.rawMode <=< gitCoProcessStart True [ Param "hash-object" , Param "-w" , Param "--stdin-paths" , Param "--no-filters" ] hashObjectStop :: HashObjectHandle -> IO () hashObjectStop = CoProcess.stop {- Injects a file into git, returning the Sha of the object. -} hashFile :: HashObjectHandle -> FilePath -> IO Sha hashFile h file = CoProcess.query h send receive where send to = hPutStrLn to file receive from = getSha "hash-object" $ hGetLine from {- Injects some content into git, returning its Sha. -} hashObject :: ObjectType -> String -> Repo -> IO Sha hashObject objtype content repo = getSha subcmd $ pipeWriteRead (map Param params) content repo where subcmd = "hash-object" params = [subcmd, "-t", show objtype, "-w", "--stdin", "--no-filters"] github-backup/Git/Version.hs0000644000000000000000000000221312235007306013171 0ustar {- git versions - - Copyright 2011, 2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Git.Version where import Common data GitVersion = GitVersion String Integer deriving (Eq) instance Ord GitVersion where compare (GitVersion _ x) (GitVersion _ y) = compare x y instance Show GitVersion where show (GitVersion s _) = s installed :: IO GitVersion installed = normalize . extract <$> readProcess "git" ["--version"] where 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-backup/Git/Queue.hs0000644000000000000000000001154112235007306012634 0ustar {- git repository command queue - - Copyright 2010,2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} module Git.Queue ( Queue, new, addCommand, addUpdateIndex, size, full, flush, ) where import qualified Data.Map as M import System.IO import System.Process 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 :: [CommandParam] } {- 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 ActionKey Action } {- A recommended maximum size for the queue, after which it should be - run. - - 10240 is semi-arbitrary. If we assume git filenames are between 10 and - 255 characters long, then the queue will build up between 100kb and - 2550kb long commands. The max command line length on linux is somewhere - above 20k, so this is a fairly good balance -- the queue will buffer - only a few megabytes of stuff and a minimal number of commands will be - run by xargs. -} defaultLimit :: Int defaultLimit = 10240 {- Constructor for empty queue. -} new :: Maybe Int -> Queue new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty {- 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 = map File 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 {- Runs a queue on a git repository. -} flush :: Queue -> Repo -> IO Queue flush (Queue _ lim m) repo = do forM_ (M.elems m) $ runAction repo return $ Queue 0 lim M.empty {- Runs an Action on a list of files in a git repository. - - Complicated by commandline length limits. - - 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 -> 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 $ intercalate "\0" $ toCommand $ 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 github-backup/Git/UpdateIndex.hs0000644000000000000000000000427512235007306013770 0ustar {- git-update-index library - - Copyright 2011-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE BangPatterns, CPP #-} module Git.UpdateIndex ( Streamer, pureStreamer, streamUpdateIndex, lsTree, updateIndexLine, unstageFile, stageSymlink ) where import Common import Git import Git.Types import Git.Command import Git.FilePath import Git.Sha {- Streamers are passed a callback and should feed it lines in the form - read by update-index, and generated by ls-tree. -} type Streamer = (String -> IO ()) -> IO () {- A streamer with a precalculated value. -} pureStreamer :: String -> Streamer pureStreamer !s = \streamer -> streamer s {- Streams content into update-index from a list of Streamers. -} streamUpdateIndex :: Repo -> [Streamer] -> IO () streamUpdateIndex repo as = pipeWrite params repo $ \h -> do fileEncoding h forM_ as (stream h) hClose h where params = map Param ["update-index", "-z", "--index-info"] stream h a = a (streamer h) streamer h s = do hPutStr h s hPutStr h "\0" {- A streamer that adds the current tree for a ref. Useful for eg, copying - and modifying branches. -} lsTree :: Ref -> Repo -> Streamer lsTree (Ref x) repo streamer = do (s, cleanup) <- pipeNullSplit params repo mapM_ streamer s void $ cleanup where params = map Param ["ls-tree", "-z", "-r", "--full-tree", x] {- Generates a line suitable to be fed into update-index, to add - a given file with a given sha. -} updateIndexLine :: Sha -> BlobType -> TopFilePath -> String updateIndexLine sha filetype file = show filetype ++ " blob " ++ show sha ++ "\t" ++ indexPath file {- A streamer that removes a file from the index. -} unstageFile :: FilePath -> Repo -> IO Streamer unstageFile file repo = do p <- toTopFilePath file repo return $ pureStreamer $ "0 " ++ show nullSha ++ "\t" ++ indexPath p {- A streamer that adds a symlink to the index. -} stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer stageSymlink file sha repo = do !line <- updateIndexLine <$> pure sha <*> pure SymlinkBlob <*> toTopFilePath file repo return $ pureStreamer line indexPath :: TopFilePath -> InternalGitPath indexPath = toInternalGitPath . getTopFilePath github-backup/Git/FilePath.hs0000644000000000000000000000312612235007306013244 0ustar {- git FilePath library - - Different git commands use different types of FilePaths to refer to - files in the repository. Some commands use paths relative to the - top of the repository even when run in a subdirectory. Adding some - types helps keep that straight. - - Copyright 2012-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE CPP #-} module Git.FilePath ( TopFilePath, getTopFilePath, toTopFilePath, asTopFilePath, InternalGitPath, toInternalGitPath, fromInternalGitPath ) where import Common import Git {- A FilePath, relative to the top of the git repository. -} newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } {- The input FilePath can be absolute, or relative to the CWD. -} toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) <$> absPath file {- The input FilePath must already be relative to the top of the git - repository -} asTopFilePath :: FilePath -> TopFilePath asTopFilePath file = TopFilePath file {- Git may use a different representation of a path when storing - it internally. For example, on Windows, git uses '/' to separate paths - stored in the repository, despite Windows using '\' -} type InternalGitPath = String toInternalGitPath :: FilePath -> InternalGitPath #ifndef mingw32_HOST_OS toInternalGitPath = id #else toInternalGitPath = replace "\\" "/" #endif fromInternalGitPath :: InternalGitPath -> FilePath #ifndef mingw32_HOST_OS fromInternalGitPath = id #else fromInternalGitPath = replace "/" "\\" #endif github-backup/Git/Construct.hs0000644000000000000000000001452112235007306013535 0ustar {- Construction of Git Repo objects - - Copyright 2010-2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE CPP #-} module Git.Construct ( fromCwd, fromAbsPath, fromPath, fromUrl, fromUnknown, localToUrl, remoteNamed, remoteNamedFromKey, fromRemotes, fromRemoteLocation, repoAbsPath, newFrom, checkForRepo, ) where #ifndef mingw32_HOST_OS import System.Posix.User #endif import qualified Data.Map as M hiding (map, split) import Network.URI import Common import Git.Types import Git import Git.Remote import qualified Git.Url as Url import Utility.UserInfo {- Finds the git repository used for the cwd, which may be in a parent - directory. -} fromCwd :: IO (Maybe Repo) fromCwd = getCurrentDirectory >>= seekUp where seekUp dir = do r <- checkForRepo dir case r of Nothing -> case parentDir dir of "" -> return Nothing d -> seekUp d Just loc -> Just <$> newFrom loc {- Local Repo constructor, accepts a relative or absolute path. -} fromPath :: FilePath -> IO Repo fromPath dir = fromAbsPath =<< absPath dir {- Local Repo constructor, requires an absolute path to the repo be - specified. -} fromAbsPath :: FilePath -> IO Repo fromAbsPath dir | isAbsolute dir = 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 | (pathSeparator:".git") `isSuffixOf` canondir = ifM (doesDirectoryExist $ dir ".git") ( ret dir , ret $ takeDirectory canondir ) | otherwise = ret dir {- Remote Repo constructor. Throws exception on invalid url. - - Git is somewhat forgiving about urls to repositories, allowing - eg spaces that are not normally allowed unescaped in urls. -} fromUrl :: String -> IO Repo fromUrl url | not (isURI url) = fromUrlStrict $ escapeURIString isUnescapedInURI url | otherwise = fromUrlStrict url fromUrlStrict :: String -> IO Repo fromUrlStrict url | startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u | otherwise = newFrom $ Url u where u = fromMaybe bad $ parseURI url bad = error $ "bad url " ++ url {- Creates a repo that has an unknown location. -} fromUnknown :: IO Repo fromUnknown = newFrom Unknown {- Converts a local Repo into a remote repo, using the reference repo - which is assumed to be on the same host. -} localToUrl :: Repo -> Repo -> Repo localToUrl reference r | not $ repoIsUrl reference = error "internal error; reference repo not url" | repoIsUrl r = r | otherwise = r { location = Url $ fromJust $ parseURI absurl } 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 {- Sets the name of a remote when constructing the Repo to represent it. -} remoteNamed :: String -> IO Repo -> IO Repo remoteNamed n constructor = do r <- constructor return $ r { remoteName = Just n } {- Sets the name of a remote based on the git config key, such as - "remote.foo.url". -} remoteNamedFromKey :: String -> IO Repo -> IO Repo remoteNamedFromKey k = remoteNamed basename where basename = intercalate "." $ 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 $ parseRemoteLocation s repo where gen (RemotePath p) = fromRemotePath p repo gen (RemoteUrl u) = fromUrl u {- Constructs a Repo from the path specified in the git remotes of - another Repo. -} fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do dir' <- expandTilde dir fromAbsPath $ repoPath repo dir' {- Git remotes can have a directory that is specified relative - to the user's home directory, or that contains tilde expansions. - This converts such a directory to an absolute path. - Note that it has to run on the system where the remote is. -} repoAbsPath :: FilePath -> IO FilePath repoAbsPath d = do d' <- expandTilde d h <- myHomeDir return $ h d' expandTilde :: FilePath -> IO FilePath #ifdef mingw32_HOST_OS expandTilde = return #else 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 #endif {- Checks if a git repository exists in a directory. Does not find - git repositories in parent directories. -} 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 ) 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 { location = l , config = M.empty , fullconfig = M.empty , remotes = [] , remoteName = Nothing , gitEnv = Nothing } github-backup/Git/Sha.hs0000644000000000000000000000170312235007306012262 0ustar {- git SHA stuff - - Copyright 2011 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Git.Sha where import Common import Git.Types {- Runs an action that causes a git subcommand to emit a Sha, and strips - 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 {- Extracts the Sha from a string. There can be a trailing newline after - it, but nothing else. -} extractSha :: String -> Maybe Sha extractSha s | 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 {- Size of a git sha. -} shaSize :: Int shaSize = 40 nullSha :: Ref nullSha = Ref $ replicate shaSize '0' github-backup/Git/Config.hs0000644000000000000000000001325312235007306012757 0ustar {- git repository configuration handling - - Copyright 2010-2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Git.Config where import qualified Data.Map as M import Data.Char import System.Process (cwd, env) import Control.Exception.Extensible 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 get key defaultValue repo = M.findWithDefault defaultValue key (config repo) {- Returns a list with each line of a multiline config setting. -} getList :: String -> Repo -> [String] getList key repo = M.findWithDefault [] key (fullconfig repo) {- Returns a single git config setting, if set. -} getMaybe :: String -> Repo -> Maybe String getMaybe key repo = M.lookup key (config repo) {- Runs git config and populates a repo with its config. - Avoids re-reading config when run repeatedly. -} read :: Repo -> IO Repo read repo@(Repo { config = c }) | c == M.empty = read' repo | otherwise = return repo {- Reads config even if it was read before. -} reRead :: Repo -> IO Repo 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 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 = 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 {- Stores a git config into a Repo, returning the new version of the Repo. - The git config may be multiple lines, or a single line. - Config settings can be updated incrementally. -} store :: String -> Repo -> IO Repo store s repo = do let c = parse s repo' <- updateLocation $ repo { config = (M.map Prelude.head c) `M.union` config repo , fullconfig = M.unionWith (++) c (fullconfig repo) } rs <- Git.Construct.fromRemotes repo' return $ repo' { remotes = rs } {- Updates the location of a repo, based on its configuration. - - Git.Construct makes LocalUknown repos, of which only a directory is - 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 -> IO Repo updateLocation r@(Repo { location = LocalUnknown d }) | 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] parse [] = M.empty parse s -- --list output will have an = in the first line | 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)) {- Checks if a string from git config is a true value. -} isTrue :: String -> Maybe Bool isTrue s | s' == "true" = Just True | s' == "false" = Just False | otherwise = Nothing 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 {- Runs a command to get the configuration of a repo, - and returns a repo populated with the configuration, as well as the raw - output of the command. -} fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String)) fromPipe r cmd params = try $ withHandle StdoutHandle createProcessSuccess p $ \h -> do fileEncoding h val <- hGetContentsStrict h r' <- store val r return (r', val) where p = proc cmd $ toCommand params {- Reads git config from a specified file and returns the repo populated - with the configuration. -} fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String)) fromFile r f = fromPipe r "git" [ Param "config" , Param "--file" , File f , Param "--list" ] {- Changes a git config setting in the specified config file. - (Creates the file if it does not already exist.) -} changeFile :: FilePath -> String -> String -> IO Bool changeFile f k v = boolSystem "git" [ Param "config" , Param "--file" , File f , Param k , Param v ] github-backup/Git/Branch.hs0000644000000000000000000000616412235007306012752 0ustar {- git branch stuff - - Copyright 2011 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} module Git.Branch where import Common import Git import Git.Sha import Git.Command import Git.Ref (headRef) {- 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 = 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 $ show headRef] 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 = 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. - - In order for that to be possible, one of the refs must contain - every commit present in all the other refs. -} fastForward :: Branch -> [Ref] -> Repo -> IO Bool fastForward _ [] _ = return True fastForward branch (first:rest) repo = -- First, check that the branch does not contain any -- new commits that are not in the first ref. If it does, -- cannot fast-forward. ifM (changed first branch repo) ( no_ff , maybe no_ff do_ff =<< findbest first rest ) where no_ff = return False do_ff to = do run [Param "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" $ pipeReadStrict [Param "write-tree"] repo sha <- getSha "commit-tree" $ pipeWriteRead (map Param $ ["commit-tree", show tree] ++ ps) message repo run [Param "update-ref", Param $ show branch, Param $ show sha] repo return sha where ps = concatMap (\r -> ["-p", show r]) parentrefs {- A leading + makes git-push force pushing a branch. -} forcePush :: String -> String forcePush b = "+" ++ b github-backup/Git/Url.hs0000644000000000000000000000327412235007306012316 0ustar {- git repository urls - - Copyright 2010, 2011 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Git.Url ( scheme, host, port, hostuser, authority, ) where import Network.URI hiding (scheme, authority) import Common import Git.Types import Git {- Scheme of an URL repo. -} scheme :: Repo -> String scheme Repo { location = Url u } = uriScheme u scheme repo = notUrl repo {- Work around a bug in the real uriRegName - -} 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 {- Hostname of an URL repo. -} host :: Repo -> String host = authpart uriRegName' {- Port of an URL repo, if it has a nonstandard one. -} port :: Repo -> Maybe Integer port r = case authpart uriPort r of ":" -> Nothing (':':p) -> readish p _ -> Nothing {- Hostname of an URL repo, including any username (ie, "user@host") -} hostuser :: Repo -> String hostuser r = authpart uriUserInfo r ++ authpart uriRegName' r {- 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 {- 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) authpart _ repo = notUrl repo notUrl :: Repo -> a notUrl repo = error $ "acting on local git repo " ++ repoDescribe repo ++ " not supported" github-backup/Git/Ref.hs0000644000000000000000000000626212235007306012270 0ustar {- git ref stuff - - Copyright 2011-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Git.Ref where import Common import Git import Git.Command import Data.Char (chr) headRef :: Ref headRef = Ref "HEAD" {- Converts a fully qualified git ref into a user-visible string. -} describe :: Ref -> String describe = show . base {- Often git refs are fully qualified (eg: refs/heads/master). - 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 {- 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, - such as refs/remotes/origin/master. -} under :: String -> Ref -> Ref under dir r = Ref $ dir show (base r) {- Checks if a ref exists. -} exists :: Ref -> Repo -> IO Bool exists ref = runBool [Param "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 = pipeReadStrict [Param "show-ref", Param "--hash", -- get the hash Param $ show branch] process [] = Nothing process s = Just $ Ref $ firstLine s {- List of (shas, branches) matching a given ref or refs. -} matching :: [Ref] -> Repo -> IO [(Sha, Branch)] matching refs repo = matching' (map show refs) repo {- Includes HEAD in the output, if asked for it. -} matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)] matchingWithHEAD refs repo = matching' ("--head" : map show refs) repo {- List of (shas, branches) matching a given ref or refs. -} matching' :: [String] -> Repo -> IO [(Sha, Branch)] matching' ps repo = map gen . lines <$> pipeReadStrict (Param "show-ref" : map Param ps) repo where gen l = let (r, b) = separate (== ' ') l in (Ref r, Ref b) {- List of (shas, branches) matching a given ref spec. - Duplicate shas are filtered out. -} matchingUniq :: [Ref] -> Repo -> IO [(Sha, Branch)] matchingUniq refs repo = nubBy uniqref <$> matching refs repo 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 pathbits = split "/" s illegalchars = " ~^:?*[\\" ++ controlchars controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)] github-backup/Git/BuildVersion.hs0000644000000000000000000000111612235007306014152 0ustar {- git build version - - Copyright 2011 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Git.BuildVersion where import Git.Version import qualified Build.SysConfig {- Using the version it was configured for avoids running git to check its - version, at the cost that upgrading git won't be noticed. - This is only acceptable because it's rare that git's version influences - code's behavior. -} buildVersion :: GitVersion buildVersion = normalize Build.SysConfig.gitversion older :: String -> Bool older n = buildVersion < normalize n github-backup/Git/Remote.hs0000644000000000000000000000625212235007306013006 0ustar {- git remote stuff - - Copyright 2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE CPP #-} module Git.Remote where import Common import Git import qualified Git.Command import qualified Git.BuildVersion import Data.Char import qualified Data.Map as M import Network.URI #ifdef mingw32_HOST_OS import Git.FilePath #endif type RemoteName = String {- Construct a legal git remote name out of an arbitrary input string. - - There seems to be no formal definition of this in the git source, - just some ad-hoc checks, and some other things that fail with certian - types of names (like ones starting with '-'). -} makeLegalName :: String -> RemoteName makeLegalName s = case filter legal $ replace "/" "_" s of -- it can't be empty [] -> "unnamed" -- it can't start with / or - or . '.':s' -> makeLegalName s' '/':s' -> makeLegalName s' '-':s' -> makeLegalName s' s' -> s' where {- Only alphanumerics, and a few common bits of punctuation common - in hostnames. -} legal '_' = True legal '.' = True legal c = isAlphaNum c remove :: RemoteName -> Repo -> IO () remove remotename = Git.Command.run [ Param "remote" -- name of this subcommand changed , Param $ if Git.BuildVersion.older "1.8.0" then "rm" else "remove" , Param remotename ] data RemoteLocation = RemoteUrl String | RemotePath FilePath remoteLocationIsUrl :: RemoteLocation -> Bool remoteLocationIsUrl (RemoteUrl _) = True remoteLocationIsUrl _ = False {- Determines if a given remote location is an url, or a local - path. Takes the repository's insteadOf configuration into account. -} parseRemoteLocation :: String -> Repo -> RemoteLocation parseRemoteLocation s repo = ret $ calcloc s where ret v #ifdef mingw32_HOST_OS | dosstyle v = RemotePath (dospath v) #endif | scpstyle v = RemoteUrl (scptourl v) | urlstyle v = RemoteUrl v | otherwise = RemotePath v -- 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 #ifdef mingw32_HOST_OS -- git on Windows will write a path to .git/config with "drive:", -- which is not to be confused with a "host:" dosstyle = hasDrive dospath = fromInternalGitPath #endif github-backup/Git/Types.hs0000644000000000000000000000430212235007306012651 0ustar {- git data types - - Copyright 2010-2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Git.Types where import Network.URI import qualified Data.Map as M {- Support repositories on local disk, and repositories accessed via an URL. - - Repos on local disk have a git directory, and unless bare, a worktree. - - A local repo may not have had its config read yet, in which case all - that's known about it is its path. - - Finally, an Unknown repository may be known to exist, but nothing - else known about it. -} data RepoLocation = Local { gitdir :: FilePath, worktree :: Maybe FilePath } | LocalUnknown FilePath | Url URI | Unknown deriving (Show, Eq) 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] -- remoteName holds the name used for this repo in remotes , 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 deriving (Eq, Ord) instance Show Ref where show (Ref v) = v {- Aliases for Ref. -} 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 github-backup/Git/Command.hs0000644000000000000000000001023012235007306013120 0ustar {- running git commands - - Copyright 2010-2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Git.Command where 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] gitCommandLine _ repo = assertLocal repo $ error "internal" {- Runs git in the specified repo. -} runBool :: [CommandParam] -> Repo -> IO Bool runBool params repo = assertLocal repo $ boolSystemEnv "git" (gitCommandLine params repo) (gitEnv repo) {- Runs git in the specified repo, throwing an error if it fails. -} run :: [CommandParam] -> Repo -> IO () run params repo = assertLocal repo $ unlessM (runBool params repo) $ error $ "git " ++ show params ++ " failed" {- Runs git and forces it to be quiet, throwing an error if it fails. -} runQuiet :: [CommandParam] -> Repo -> IO () runQuiet params repo = withQuietOutput createProcessSuccess $ (proc "git" $ toCommand $ gitCommandLine (params) repo) { env = gitEnv repo } {- Runs a git command and returns its output, lazily. - - 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. -} pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool) pipeReadLazy params repo = assertLocal repo $ do (_, Just h, _, pid) <- createProcess p { std_out = CreatePipe } fileEncoding h c <- hGetContents h return (c, checkSuccessProcess pid) where p = gitCreateProcess params repo {- Runs a git command, 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 command, 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 adjusthandle) where adjusthandle h = do fileEncoding h hSetNewlineMode h noNewlineTranslation {- Runs a git command, 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], IO Bool) pipeNullSplit params repo = do (s, cleanup) <- pipeReadLazy params repo return (filter (not . null) $ split sep s, cleanup) where sep = "\0" pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [String] pipeNullSplitStrict params repo = do s <- pipeReadStrict params repo return $ filter (not . null) $ split sep s where sep = "\0" 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 :: Bool -> [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle gitCoProcessStart restartable params repo = CoProcess.start restartable "git" (toCommand $ gitCommandLine params repo) (gitEnv repo) gitCreateProcess :: [CommandParam] -> Repo -> CreateProcess gitCreateProcess params repo = (proc "git" $ toCommand $ gitCommandLine params repo) { env = gitEnv repo } github-backup/.gitattributes0000644000000000000000000000005412235007306013361 0ustar debian/changelog merge=dpkg-mergechangelogs github-backup/Makefile0000644000000000000000000000175612242446671012152 0ustar PREFIX=/usr CABAL?=cabal # set to "./Setup" if you lack a cabal program build: Build/SysConfig.hs $(CABAL) build ln -sf dist/build/github-backup/github-backup github-backup @$(MAKE) tags >/dev/null 2>&1 & Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi $(CABAL) configure install: build install -d $(DESTDIR)$(PREFIX)/bin install github-backup $(DESTDIR)$(PREFIX)/bin install -d $(DESTDIR)$(PREFIX)/share/man/man1 install -m 0644 github-backup.1 $(DESTDIR)$(PREFIX)/share/man/man1 clean: rm -rf github-backup dist configure Build/SysConfig.hs Setup tags find -name \*.o -exec rm {} \; find -name \*.hi -exec rm {} \; # Upload to hackage. hackage: clean ./Build/make-sdist.sh @cabal upload dist/*.tar.gz # hothasktags chokes on some template haskell etc, so ignore errors tags: find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags > tags 2>/dev/null github-backup/Github/0000755000000000000000000000000012235007306011711 5ustar github-backup/Github/Data/0000755000000000000000000000000012247405215012566 5ustar github-backup/Github/Data/Readable.hs0000644000000000000000000000062712241055366014630 0ustar {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | This module re-exports the @Github.Data.Definitions@ module, adding -- instances of @Read@ to it. module Github.Data.Readable (module Github.Data.Definitions) where import Github.Data.Definitions deriving instance Read GithubDate deriving instance Read GithubOwner deriving instance Read Repo deriving instance Read RepoRef github-backup/Utility/0000755000000000000000000000000012247423516012142 5ustar github-backup/Utility/Path.hs0000644000000000000000000001733412235007306013372 0ustar {- path manipulation - - Copyright 2010-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE PackageImports, CPP #-} module Utility.Path where import Data.String.Utils import System.FilePath import System.Directory import Data.List import Data.Maybe import Data.Char import Control.Applicative #ifdef mingw32_HOST_OS import Data.Char import qualified System.FilePath.Posix as Posix #else import qualified "MissingH" System.Path as MissingH import System.Posix.Files #endif import Utility.Monad import Utility.UserInfo {- Makes a path absolute if it's not already. - The first parameter is a base directory (ie, the cwd) to use if the path - is not already absolute. - - On Unix, collapses and normalizes ".." etc in the path. May return Nothing - if the path cannot be normalized. - - MissingH's absNormPath does not work on Windows, so on Windows - no normalization is done. -} absNormPath :: FilePath -> FilePath -> Maybe FilePath #ifndef mingw32_HOST_OS absNormPath dir path = MissingH.absNormPath dir path #else absNormPath dir path = Just $ combine dir path #endif {- Returns the parent directory of a path. - - To allow this to be easily used in loops, which terminate upon reaching the - top, the parent of / is "" -} parentDir :: FilePath -> FilePath parentDir dir | null dirs = "" | otherwise = joinDrive drive (join s $ init dirs) where -- on Unix, the drive will be "/" when the dir is absolute, otherwise "" (drive, path) = splitDrive dir dirs = filter (not . null) $ split s path s = [pathSeparator] prop_parentDir_basics :: FilePath -> Bool prop_parentDir_basics dir | null dir = True | dir == "/" = parentDir dir == "" | otherwise = p /= 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 - are all equivilant. -} dirContains :: FilePath -> FilePath -> Bool dirContains a b = a == b || a' == b' || (a'++[pathSeparator]) `isPrefixOf` b' where norm p = fromMaybe "" $ absNormPath p "." a' = norm a b' = norm b {- Converts a filename into a normalized, absolute path. - - Unlike Directory.canonicalizePath, this does not require the path - already exists. -} absPath :: FilePath -> IO FilePath absPath file = do cwd <- getCurrentDirectory return $ absPathFrom cwd file {- Converts a filename into a normalized, absolute path - from the specified cwd. -} absPathFrom :: FilePath -> FilePath -> FilePath absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file where bad = error $ "unable to normalize " ++ file {- Constructs a relative path from the CWD to a file. - - For example, assuming CWD is /tmp/foo/bar: - relPathCwdToFile "/tmp/foo" == ".." - relPathCwdToFile "/tmp/foo/bar" == "" -} relPathCwdToFile :: FilePath -> IO FilePath relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f {- Constructs a relative path from a directory to a file. - - Both must be absolute, and normalized (eg with absNormpath). -} 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 prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool prop_relPathDirToFile_basics from to | from == to = null r | otherwise = not (null r) 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 (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"]) (joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]) == joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"] {- Given an original list of paths, and an expanded list derived from it, - generates a list of lists, where each sublist corresponds to one of the - original paths. When the original path is a directory, any items - in the expanded list that are contained in that directory will appear in - its segment. -} 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 {- 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. -} runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]] runSegmentPaths a paths = segmentPaths paths <$> a paths {- 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. - - The command may be fully-qualified, in which case, this succeeds as - long as it exists. -} inPath :: String -> IO Bool 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 = firstM doesFileExist #ifdef mingw32_HOST_OS [f, f ++ ".exe"] #else [f] #endif {- Checks if a filename is a unix dotfile. All files inside dotdirs - count as dotfiles. -} dotfile :: FilePath -> Bool dotfile file | f == "." = False | f == ".." = False | f == "" = False | otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file) where f = takeFileName file {- Converts a DOS style path to a Cygwin style path. Only on Windows. - Any trailing '\' is preserved as a trailing '/' -} toCygPath :: FilePath -> FilePath #ifndef mingw32_HOST_OS toCygPath = id #else toCygPath p | null drive = recombine parts | otherwise = recombine $ "/cygdrive" : driveletter drive : parts where (drive, p') = splitDrive p parts = splitDirectories p' driveletter = map toLower . takeWhile (/= ':') recombine = fixtrailing . Posix.joinPath fixtrailing s | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s | otherwise = s #endif {- Maximum size to use for a file in a specified directory. - - Many systems have a 255 byte limit to the name of a file, - so that's taken as the max if the system has a larger limit, or has no - limit. -} fileNameLengthLimit :: FilePath -> IO Int #ifdef mingw32_HOST_OS fileNameLengthLimit _ = return 255 #else fileNameLengthLimit dir = do l <- fromIntegral <$> getPathVar dir FileNameLimit if l <= 0 then return 255 else return $ minimum [l, 255] where #endif {- Given a string that we'd like to use as the basis for FilePath, but that - was provided by a third party and is not to be trusted, returns the closest - sane FilePath. - - All spaces and punctuation are replaced with '_', except for '.' - "../" will thus turn into ".._", which is safe. -} sanitizeFilePath :: String -> FilePath sanitizeFilePath = map sanitize where sanitize c | c == '.' = c | isSpace c || isPunctuation c || c == '/' = '_' | otherwise = c github-backup/Utility/State.hs0000644000000000000000000000127212235007306013550 0ustar {- state monad support - - Copyright 2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE PackageImports #-} module Utility.State where 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. - Why it's not the default, I don't know. - - Example: changeState $ \s -> s { foo = bar } -} changeState :: MonadState s m => (s -> s) -> m () changeState f = do x <- get put $! f x {- Gets a value from the internal state, selected by the passed value - constructor. -} getState :: MonadState s m => (s -> a) -> m a getState = gets github-backup/Utility/Monad.hs0000644000000000000000000000364012235007306013527 0ustar {- monadic stuff - - Copyright 2010-2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Utility.Monad where import Data.Maybe import Control.Monad {- Return the first value from a list, if any, satisfying the given - predicate -} firstM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) 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 anyM p = liftM isJust . firstM p allM :: Monad m => (a -> m Bool) -> [a] -> m Bool allM _ [] = return True allM p (x:xs) = p x <&&> allM p xs {- Runs an action on values from a list until it succeeds. -} untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool untilTrue = flip anyM {- if with a monadic conditional. -} ifM :: Monad m => m Bool -> (m a, m a) -> m a ifM cond (thenclause, elseclause) = do c <- cond if c then thenclause else elseclause {- short-circuiting monadic || -} (<||>) :: Monad m => m Bool -> m Bool -> m Bool ma <||> mb = ifM ma ( return True , mb ) {- 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 observe observer a = do r <- a _ <- observer r return r {- b `after` a runs first a, then b, and returns the value of a -} after :: Monad m => m b -> m a -> m a after = observe . const {- do nothing -} noop :: Monad m => m () noop = return () github-backup/Utility/SafeCommand.hs0000644000000000000000000000766512235007306014661 0ustar {- safely running shell commands - - Copyright 2010-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Utility.SafeCommand where import System.Exit import Utility.Process import System.Process (env) import Data.String.Utils import Control.Applicative import System.FilePath import Data.Char {- A type for parameters passed to a shell command. A command can - be passed either some Params (multiple parameters can be included, - whitespace-separated, or a single Param (for when parameters contain - whitespace), or a File. -} data CommandParam = Params String | Param String | File FilePath deriving (Eq, Show, Ord) {- Used to pass a list of CommandParams to a function that runs - a command and expects Strings. -} toCommand :: [CommandParam] -> [String] toCommand = concatMap unwrap where unwrap (Param s) = [s] unwrap (Params s) = filter (not . null) (split " " s) -- Files that start with a non-alphanumeric that is not a path -- separator are modified to avoid the command interpreting them as -- options or other special constructs. unwrap (File s@(h:_)) | isAlphaNum h || h `elem` pathseps = [s] | otherwise = ["./" ++ s] unwrap (File s) = [s] -- '/' is explicitly included because it's an alternative -- path separator on Windows. pathseps = pathSeparator:"./" {- Run a system command, and returns True or False - if it succeeded or failed. -} boolSystem :: FilePath -> [CommandParam] -> IO Bool boolSystem command params = boolSystemEnv command params Nothing boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool 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 safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode safeSystemEnv command params environ = do (_, _, _, pid) <- createProcess (proc command $ toCommand params) { env = environ } waitForProcess pid {- Wraps a shell command line inside sh -c, allowing it to be run in a - login shell that may not support POSIX shell, eg csh. -} shellWrap :: String -> String shellWrap cmdline = "sh -c " ++ shellEscape cmdline {- Escapes a filename or other parameter to be safely able to be exposed to - the shell. - - This method works for POSIX shells, as well as other shells like csh. -} shellEscape :: String -> String shellEscape f = "'" ++ escaped ++ "'" 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 {- For quickcheck. -} prop_idempotent_shellEscape :: String -> Bool prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s prop_idempotent_shellEscape_multiword :: [String] -> Bool prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s {- Segements a list of filenames into groups that are all below the manximum - command-line length limit. Does not preserve order. -} segmentXargs :: [FilePath] -> [[FilePath]] segmentXargs l = go l [] 0 [] where go [] c _ r = c:r go (f:fs) c accumlen r | len < maxlen && newlen > maxlen = go (f:fs) [] 0 (c:r) | otherwise = go fs (f:c) newlen r where len = length f newlen = accumlen + len {- 10k of filenames per command, well under Linux's 20k limit; - allows room for other parameters etc. -} maxlen = 10240 github-backup/Utility/CoProcess.hs0000644000000000000000000000467212235007306014377 0ustar {- Interface for running a shell command as a coprocess, - sending it queries and getting back results. - - Copyright 2012-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE CPP #-} module Utility.CoProcess ( CoProcessHandle, start, stop, query, rawMode ) where import Common import Control.Concurrent.MVar type CoProcessHandle = MVar CoProcessState data CoProcessState = CoProcessState { coProcessPid :: ProcessHandle , coProcessTo :: Handle , coProcessFrom :: Handle , coProcessSpec :: CoProcessSpec } data CoProcessSpec = CoProcessSpec { coProcessRestartable :: Bool , coProcessCmd :: FilePath , coProcessParams :: [String] , coProcessEnv :: Maybe [(String, String)] } start :: Bool -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle start restartable cmd params env = do s <- start' $ CoProcessSpec restartable cmd params env newMVar s start' :: CoProcessSpec -> IO CoProcessState start' s = do (pid, from, to) <- startInteractiveProcess (coProcessCmd s) (coProcessParams s) (coProcessEnv s) return $ CoProcessState pid to from s stop :: CoProcessHandle -> IO () stop ch = do s <- readMVar ch hClose $ coProcessTo s hClose $ coProcessFrom s let p = proc (coProcessCmd $ coProcessSpec s) (coProcessParams $ coProcessSpec s) forceSuccessProcess p (coProcessPid s) {- To handle a restartable process, any IO exception thrown by the send and - receive actions are assumed to mean communication with the process - failed, and the failed action is re-run with a new process. -} query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b query ch send receive = do s <- readMVar ch restartable s (send $ coProcessTo s) $ const $ restartable s (hFlush $ coProcessTo s) $ const $ restartable s (receive $ coProcessFrom s) $ return where restartable s a cont | coProcessRestartable (coProcessSpec s) = maybe restart cont =<< catchMaybeIO a | otherwise = cont =<< a restart = do s <- takeMVar ch void $ catchMaybeIO $ do hClose $ coProcessTo s hClose $ coProcessFrom s void $ waitForProcess $ coProcessPid s s' <- start' (coProcessSpec s) putMVar ch s' query ch send receive rawMode :: CoProcessHandle -> IO CoProcessHandle rawMode ch = do s <- readMVar ch raw $ coProcessFrom s raw $ coProcessTo s return ch where raw h = do fileEncoding h #ifdef mingw32_HOST_OS hSetNewlineMode h noNewlineTranslation #endif github-backup/Utility/Process.hs0000644000000000000000000002221012235007306014101 0ustar {- System.Process enhancements, including additional ways of running - processes, and logging. - - Copyright 2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE CPP, Rank2Types #-} module Utility.Process ( module X, CreateProcess, StdHandle(..), readProcess, readProcessEnv, writeReadProcessEnv, forceSuccessProcess, checkSuccessProcess, ignoreFailureProcess, createProcessSuccess, createProcessChecked, createBackgroundProcess, processTranscript, withHandle, withBothHandles, withQuietOutput, withNullHandle, createProcess, startInteractiveProcess, 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, readProcess) import System.Exit import System.IO import System.Log.Logger import Control.Concurrent import qualified Control.Exception as E import Control.Monad #ifndef mingw32_HOST_OS import System.Posix.IO import Data.Maybe #endif import Utility.Misc import Utility.Exception 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. - Note that using this with createProcessChecked will throw away - the Bool, and is only useful to ignore the exit code of a process, - while still waiting for it. -} checkSuccessProcess :: ProcessHandle -> IO Bool checkSuccessProcess pid = do code <- waitForProcess pid 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 - a checker action on its exit code, which must wait for the process. -} createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner createProcessChecked checker p a = do t@(_, _, _, pid) <- createProcess p r <- tryNonAsync $ a t _ <- checker pid either E.throw 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 process, optionally feeding it some input, and - returns a transcript combining its stdout and stderr, and - whether it succeeded or failed. -} processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) #ifndef mingw32_HOST_OS processTranscript cmd opts input = do (readf, writef) <- createPipe readh <- fdToHandle readf writeh <- fdToHandle writef p@(_, _, _, pid) <- createProcess $ (proc cmd opts) { std_in = if isJust input then CreatePipe else Inherit , std_out = UseHandle writeh , std_err = UseHandle writeh } hClose writeh -- fork off a thread to start consuming the output transcript <- hGetContents readh outMVar <- newEmptyMVar _ <- forkIO $ E.evaluate (length transcript) >> putMVar outMVar () -- now write and flush any input case input of Just s -> do let inh = stdinHandle p unless (null s) $ do hPutStr inh s hFlush inh hClose inh Nothing -> return () -- wait on the output takeMVar outMVar hClose readh ok <- checkSuccessProcess pid return (transcript, ok) #else processTranscript = error "processTranscript TODO" #endif {- 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 = withNullHandle $ \nullh -> do let p' = p { std_out = UseHandle nullh , std_err = UseHandle nullh } creator p' $ const $ return () withNullHandle :: (Handle -> IO a) -> IO a withNullHandle = withFile devnull WriteMode where #ifndef mingw32_HOST_OS devnull = "/dev/null" #else devnull = "NUL" #endif {- Extract a desired handle from createProcess's tuple. - These partial functions are safe as long as createProcess is run - with appropriate parameters to set up the desired handle. - Get it wrong and the runtime crash will always happen, so should be - easily noticed. -} 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 {- Starts an interactive process. Unlike runInteractiveProcess in - System.Process, stderr is inherited. -} startInteractiveProcess :: FilePath -> [String] -> Maybe [(String, String)] -> IO (ProcessHandle, Handle, Handle) startInteractiveProcess cmd args environ = do let p = (proc cmd args) { std_in = CreatePipe , std_out = CreatePipe , std_err = Inherit , env = environ } (Just from, Just to, _, pid) <- createProcess p return (pid, to, from) {- Wrapper around System.Process function that does debug logging. -} createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do debugProcess p System.Process.createProcess p github-backup/Utility/UserInfo.hs0000644000000000000000000000226112235007306014221 0ustar {- user info - - Copyright 2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE CPP #-} module Utility.UserInfo ( myHomeDir, myUserName, myUserGecos, ) where import Control.Applicative import System.PosixCompat import Utility.Env {- Current user's home directory. - - getpwent will fail on LDAP or NIS, so use HOME if set. -} myHomeDir :: IO FilePath myHomeDir = myVal env homeDirectory where #ifndef mingw32_HOST_OS env = ["HOME"] #else env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin #endif {- Current user's user name. -} myUserName :: IO String myUserName = myVal env userName where #ifndef mingw32_HOST_OS env = ["USER", "LOGNAME"] #else env = ["USERNAME", "USER", "LOGNAME"] #endif myUserGecos :: IO String #ifdef __ANDROID__ myUserGecos = return "" -- userGecos crashes on Android #else myUserGecos = myVal [] userGecos #endif 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 github-backup/Utility/PartialPrelude.hs0000644000000000000000000000320712235007306015405 0ustar {- Parts of the Prelude are partial functions, which are a common source of - bugs. - - This exports functions that conflict with the prelude, which avoids - them being accidentially used. -} module Utility.PartialPrelude where import qualified Data.Maybe {- read should be avoided, as it throws an error - Instead, use: readish -} read :: Read a => String -> a read = Prelude.read {- head is a partial function; head [] is an error - Instead, use: take 1 or headMaybe -} head :: [a] -> a head = Prelude.head {- tail is also partial - Instead, use: drop 1 -} tail :: [a] -> [a] tail = Prelude.tail {- init too - Instead, use: beginning -} init :: [a] -> [a] init = Prelude.init {- last too - Instead, use: end or lastMaybe -} last :: [a] -> a last = Prelude.last {- Attempts to read a value from a String. - - Ignores leading/trailing whitespace, and throws away any trailing - text after the part that can be read. - - readMaybe is available in Text.Read in new versions of GHC, - but that one requires the entire string to be consumed. -} readish :: Read a => String -> Maybe a readish s = case reads s of ((x,_):_) -> Just x _ -> Nothing {- Like head but Nothing on empty list. -} headMaybe :: [a] -> Maybe a headMaybe = Data.Maybe.listToMaybe {- Like last but Nothing on empty list. -} lastMaybe :: [a] -> Maybe a lastMaybe [] = Nothing lastMaybe v = Just $ Prelude.last v {- All but the last element of a list. - (Like init, but no error on an empty list.) -} beginning :: [a] -> [a] beginning [] = [] beginning l = Prelude.init l {- Like last, but no error on an empty list. -} end :: [a] -> [a] end [] = [] end l = [Prelude.last l] github-backup/Utility/Tmp.hs0000644000000000000000000000603012235007306013225 0ustar {- Temporary files and directories. - - Copyright 2010-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Utility.Tmp where import Control.Exception (bracket) import System.IO import System.Directory import Control.Monad.IfElse import Utility.Exception import System.FilePath import Utility.FileSystemEncoding type Template = String {- 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 = do let (dir, base) = splitFileName file createDirectoryIfMissing True dir (tmpfile, handle) <- openTempFile dir (base ++ ".tmp") hClose handle a tmpfile content renameFile 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. -} withTmpFile :: Template -> (FilePath -> Handle -> IO a) -> IO a withTmpFile template a = do tmpdir <- catchDefaultIO "." getTemporaryDirectory withTmpFileIn tmpdir template a {- Runs an action with a tmp file located in the specified directory, - then removes the file. -} withTmpFileIn :: FilePath -> Template -> (FilePath -> Handle -> IO a) -> IO a withTmpFileIn tmpdir template a = bracket create remove use where create = 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 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 template a = do tmpdir <- 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 where remove d = whenM (doesDirectoryExist d) $ removeDirectoryRecursive d create = do createDirectoryIfMissing True tmpdir makenewdir (tmpdir template) (0 :: Int) makenewdir t n = do let dir = t ++ "." ++ show n either (const $ makenewdir t $ n + 1) (const $ return dir) =<< tryIO (createDirectory dir) {- It's not safe to use a FilePath of an existing file as the template - for openTempFile, because if the FilePath is really long, the tmpfile - will be longer, and may exceed the maximum filename length. - - This generates a template that is never too long. - (Well, it allocates 20 characters for use in making a unique temp file, - anyway, which is enough for the current implementation and any - likely implementation.) -} relatedTemplate :: FilePath -> FilePath relatedTemplate f | len > 20 = truncateFilePath (len - 20) f | otherwise = f where len = length f github-backup/Utility/Data.hs0000644000000000000000000000065112235007306013341 0ustar {- utilities for simple data types - - Copyright 2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Utility.Data where {- First item in the list that is not Nothing. -} firstJust :: Eq a => [Maybe a] -> Maybe a firstJust ms = case dropWhile (== Nothing) ms of [] -> Nothing (md:_) -> md eitherToMaybe :: Either a b -> Maybe b eitherToMaybe = either (const Nothing) Just github-backup/Utility/FileMode.hs0000644000000000000000000000745112235007306014161 0ustar {- File mode utilities. - - Copyright 2010-2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE CPP #-} module Utility.FileMode where import Common import Control.Exception (bracket) import System.PosixCompat.Types #ifndef mingw32_HOST_OS import System.Posix.Files #endif 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 #ifdef mingw32_HOST_OS isSymLink _ = False #else isSymLink = checkMode symbolicLinkMode #endif {- 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 #ifndef mingw32_HOST_OS noUmask mode a | mode == stdFileMode = a | otherwise = bracket setup cleanup go where setup = setFileCreationMask nullFileMode cleanup = setFileCreationMask go _ = a #else noUmask _ a = a #endif combineModes :: [FileMode] -> FileMode combineModes [] = undefined combineModes [m] = m combineModes (m:ms) = foldl unionFileModes m ms isSticky :: FileMode -> Bool #ifdef mingw32_HOST_OS isSticky _ = False #else isSticky = checkMode stickyMode stickyMode :: FileMode stickyMode = 512 setSticky :: FilePath -> IO () setSticky f = modifyFileMode f $ addModes [stickyMode] #endif {- 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. - - On a filesystem that does not support file permissions, this is the same - as writeFile. -} writeFileProtected :: FilePath -> String -> IO () writeFileProtected file content = do h <- openFile file WriteMode void $ tryIO $ modifyFileMode file $ removeModes [groupReadMode, otherReadMode] hPutStr h content hClose h github-backup/Utility/Env.hs0000644000000000000000000000264712235007306013227 0ustar {- portable environment variables - - Copyright 2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE CPP #-} module Utility.Env where #ifdef mingw32_HOST_OS import Utility.Exception import Control.Applicative import Data.Maybe import qualified System.Environment as E #else import qualified System.Posix.Env as PE #endif getEnv :: String -> IO (Maybe String) #ifndef mingw32_HOST_OS getEnv = PE.getEnv #else getEnv = catchMaybeIO . E.getEnv #endif getEnvDefault :: String -> String -> IO String #ifndef mingw32_HOST_OS getEnvDefault = PE.getEnvDefault #else getEnvDefault var fallback = fromMaybe fallback <$> getEnv var #endif getEnvironment :: IO [(String, String)] #ifndef mingw32_HOST_OS getEnvironment = PE.getEnvironment #else getEnvironment = E.getEnvironment #endif {- Returns True if it could successfully set the environment variable. - - There is, apparently, no way to do this in Windows. Instead, - environment varuables must be provided when running a new process. -} setEnv :: String -> String -> Bool -> IO Bool #ifndef mingw32_HOST_OS setEnv var val overwrite = do PE.setEnv var val overwrite return True #else setEnv _ _ _ = return False #endif {- Returns True if it could successfully unset the environment variable. -} unsetEnv :: String -> IO Bool #ifndef mingw32_HOST_OS unsetEnv var = do PE.unsetEnv var return True #else unsetEnv _ = return False #endif github-backup/Utility/Directory.hs0000644000000000000000000000603512235007306014436 0ustar {- directory manipulation - - Copyright 2011 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE CPP #-} module Utility.Directory where import System.IO.Error import System.PosixCompat.Files import System.Directory import Control.Exception (throw) import Control.Monad import Control.Monad.IfElse import System.FilePath import Control.Applicative import System.IO.Unsafe (unsafeInterleaveIO) import Utility.SafeCommand import Utility.Tmp import Utility.Exception import Utility.Monad 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 (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 = dirContentsRecursiveSkipping (const False) topdir dirContentsRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath] dirContentsRecursiveSkipping skipdir topdir = go [topdir] where go [] = return [] go (dir:dirs) | skipdir dir = go dirs | otherwise = unsafeInterleaveIO $ do (files, dirs') <- collect [] [] =<< catchDefaultIO [] (dirContents dir) files' <- go (dirs' ++ dirs) return (files ++ files') 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 {- Removes a file, which may or may not exist, and does not have to - be a regular file. - - Note that an exception is thrown if the file exists but - cannot be removed. -} nukeFile :: FilePath -> IO () nukeFile file = void $ tryWhenExists go where #ifndef mingw32_HOST_OS go = removeLink file #else go = removeFile file #endif github-backup/Utility/Misc.hs0000644000000000000000000001001512235007306013356 0ustar {- misc utility functions - - Copyright 2010-2011 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE CPP #-} module Utility.Misc where import System.IO import Control.Monad import Foreign import Data.Char import Data.List import Control.Applicative #ifndef mingw32_HOST_OS import System.Posix.Process (getAnyProcessStatus) import Utility.Exception #endif {- A version of hgetContents that is not lazy. Ensures file is - all read before it gets closed. -} hGetContentsStrict :: Handle -> IO String hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s {- A version of readFile that is not lazy. -} readFileStrict :: FilePath -> IO String readFileStrict = readFile >=> \s -> length s `seq` return s {- Like break, but the character matching the condition is not included - in the second result list. - - separate (== ':') "foo:bar" = ("foo", "bar") - separate (== ':') "foobar" = ("foobar", "") -} 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) {- Breaks out the first line. -} 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 {- Replaces multiple values in a string. - - Takes care to skip over just-replaced values, so that they are not - mangled. For example, massReplace [("foo", "new foo")] does not - replace the "new foo" with "new new foo". -} massReplace :: [(String, String)] -> String -> String massReplace vs = go [] vs where go acc _ [] = concat $ reverse acc go acc [] (c:cs) = go ([c]:acc) vs cs go acc ((val, replacement):rest) s | val `isPrefixOf` s = go (replacement:acc) vs (drop (length val) s) | otherwise = go acc rest s {- 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 () #ifndef mingw32_HOST_OS reapZombies = do -- throws an exception when there are no child processes catchDefaultIO Nothing (getAnyProcessStatus False True) >>= maybe (return ()) (const reapZombies) #else reapZombies = return () #endif github-backup/Utility/FileSystemEncoding.hs0000644000000000000000000000624512235007306016230 0ustar {- GHC File system encoding handling. - - Copyright 2012-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Utility.FileSystemEncoding ( fileEncoding, withFilePath, md5FilePath, decodeW8, encodeW8, truncateFilePath, ) 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 {- Truncates a FilePath to the given number of bytes (or less), - as represented on disk. - - Avoids returning an invalid part of a unicode byte sequence, at the - cost of efficiency when running on a large FilePath. -} truncateFilePath :: Int -> FilePath -> FilePath truncateFilePath n = go . reverse where go f = let bytes = decodeW8 f in if length bytes <= n then reverse f else go (drop 1 f) github-backup/Utility/Applicative.hs0000644000000000000000000000056312235007306014733 0ustar {- applicative stuff - - Copyright 2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Utility.Applicative where {- Like <$> , but supports one level of currying. - - foo v = bar <$> action v == foo = bar <$$> action -} (<$$>) :: Functor f => (a -> b) -> (c -> f a) -> c -> f b f <$$> v = fmap f . v infixr 4 <$$> github-backup/Utility/Exception.hs0000644000000000000000000000344712235007306014434 0ustar {- Simple IO exception handling (and some more) - - Copyright 2011-2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE ScopedTypeVariables #-} module Utility.Exception where import Control.Exception import qualified Control.Exception as E import Control.Applicative import Control.Monad import System.IO.Error (isDoesNotExistError) import Utility.Data {- 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 = E.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) {- Catches only DoesNotExist exceptions, and lets all others through. -} tryWhenExists :: IO a -> IO (Maybe a) tryWhenExists a = eitherToMaybe <$> tryJust (guard . isDoesNotExistError) a github-backup/debian/0000755000000000000000000000000012247423516011721 5ustar github-backup/debian/copyright0000644000000000000000000000050712235011273013644 0ustar Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ Source: native package Files: * Copyright: © 2010-2013 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 Debian systems. github-backup/debian/changelog0000644000000000000000000000671212247405256013602 0ustar 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 name. Useful if you want to back up repositories that you have not forked; just watch them and run github-backup. * Can now log in to github, to avoid increasingly small API rate limits. Set GITHUB_USER and GITHUB_PASSWORD environment to enable. Note that a few api calls don't use authentication; see https://github.com/fpco/github/issues/40 * Build-Depend on git. Closes: #728481 * Don't include tmp directory in files stored in the github branch. -- Joey Hess Fri, 01 Nov 2013 18:00:16 -0400 github-backup (1.20131006) unstable; urgency=low * Ported to Windows. * Improve error message when it fails to query github for repositories belonging to a user. Closes: #705084 * Various updates to internal git and utility libraries shared with git-annex. * Makefile now uses cabal to build. -- Joey Hess Sun, 06 Oct 2013 18:04:56 -0400 github-backup (1.20130622) unstable; urgency=low * Add missing unix-compat build dependency. Closes: #713279 -- Joey Hess Sat, 22 Jun 2013 13:08:57 -0400 github-backup (1.20130618) unstable; urgency=low * Much better creation and committing to the github branch. -- Joey Hess Mon, 17 Jun 2013 17:40:02 -0400 github-backup (1.20130617) unstable; urgency=low * Build-Depend on libghc-extensible-exceptions-dev. Closes: #712549 * Various updates to internal git and utility libraries shared with git-annex, including some Windows portability. * Fixed to never touch the git work tree or index file, instead using its own to commit to the github branch. -- Joey Hess Mon, 17 Jun 2013 12:28:30 -0400 github-backup (1.20130614) unstable; urgency=low * Pass --ignore-removal to git-add, in preparation for a future change to its default behavior. Requires git 1.8.3. Closes: #711287 -- Joey Hess Fri, 14 Jun 2013 15:50:49 -0400 github-backup (1.20130414) experimental; urgency=low * Updated to use haskell-github 0.6.0, which supports pagination of queries Thanks to John Wiegley for making those changes. * Also backup closed issues. Thanks, John Wiegley. * cabal file no longer tries to list every source file, as that was error-prone, and I left some out. -- Joey Hess 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 Wed, 27 Jun 2012 22:21:01 -0400 github-backup (1.20120314) unstable; urgency=low * First release. -- Joey Hess Tue, 13 Mar 2012 20:22:43 -0400 github-backup/debian/rules0000755000000000000000000000046112235007306012772 0ustar #!/usr/bin/make -f # Avoid using cabal, as it writes to $HOME export CABAL=./Setup # Do use the changelog's version number, rather than making one up. export RELEASE_BUILD=1 %: dh $@ # Not intended for use by anyone except the author. announcedir: @echo ${HOME}/src/joeywiki/code/github-backup/news github-backup/debian/manpages0000644000000000000000000000002012235007306013417 0ustar github-backup.1 github-backup/debian/control0000644000000000000000000000147512247423366013336 0ustar Source: github-backup Section: utils Priority: optional Build-Depends: debhelper (>= 9), ghc, git, libghc-github-dev (>= 0.7.2), libghc-missingh-dev, libghc-hslogger-dev, libghc-pretty-show-dev, libghc-ifelse-dev, libghc-extensible-exceptions-dev, libghc-unix-compat-dev Maintainer: Joey Hess Standards-Version: 3.9.4 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}, git 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. github-backup/debian/compat0000644000000000000000000000000212235007306013107 0ustar 9 github-backup/GPL0000644000000000000000000010451312235007306011040 0ustar GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read .