github-backup 1.20120314 → 1.20120627
raw patch · 20 files changed
+360/−276 lines, 20 filesdep ~basesetup-changed
Dependency ranges changed: base
Files
- Common.hs +3/−1
- Git.hs +51/−42
- Git/Branch.hs +11/−14
- Git/Command.hs +28/−26
- Git/Config.hs +64/−19
- Git/Construct.hs +32/−64
- Git/Queue.hs +21/−17
- Git/Ref.hs +31/−4
- Git/Types.hs +16/−4
- Makefile +8/−4
- README.md +2/−2
- Setup.hs +1/−1
- Utility/Directory.hs +31/−5
- Utility/Misc.hs +0/−21
- Utility/Monad.hs +20/−6
- Utility/Path.hs +10/−10
- Utility/TempFile.hs +1/−1
- github-backup.1 +2/−2
- github-backup.cabal +2/−2
- github-backup.hs +26/−31
Common.hs view
@@ -3,7 +3,7 @@ import Control.Monad as X hiding (join) import Control.Monad.IfElse as X import Control.Applicative as X-import Control.Monad.State as X (liftIO)+import Control.Monad.State.Strict as X (liftIO) import Control.Exception.Extensible as X (IOException) import Data.Maybe as X@@ -21,9 +21,11 @@ import System.Exit as X import Utility.Misc as X+import Utility.Exception as X import Utility.SafeCommand as X import Utility.Path as X import Utility.Directory as X import Utility.Monad as X+import Utility.FileSystemEncoding as X import Utility.PartialPrelude as X
Git.hs view
@@ -3,7 +3,7 @@ - This is written to be completely independant of git-annex and should be - suitable for other uses. -- - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -}@@ -17,36 +17,56 @@ repoIsUrl, repoIsSsh, repoIsHttp,+ repoIsLocal, repoIsLocalBare, repoDescribe, repoLocation,- workTree,- gitDir,- configTrue,+ repoPath,+ localGitDir, attributes,+ hookPath, assertLocal, ) where -import qualified Data.Map as M-import Data.Char import Network.URI (uriPath, uriScheme, unEscapeString)+import System.Posix.Files import Common import Git.Types+import Utility.FileMode {- 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 = Dir dir } = dir+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 = Dir dir } = dir+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@@ -71,46 +91,35 @@ | otherwise = False repoIsHttp _ = False -configAvail ::Repo -> Bool-configAvail Repo { config = c } = c /= M.empty+repoIsLocal :: Repo -> Bool+repoIsLocal Repo { location = Local { } } = True+repoIsLocal _ = False repoIsLocalBare :: Repo -> Bool-repoIsLocalBare r@(Repo { location = Dir _ }) = configAvail r && configBare r+repoIsLocalBare Repo { location = Local { worktree = Nothing } } = True repoIsLocalBare _ = False assertLocal :: Repo -> a -> a-assertLocal repo action = - if not $ repoIsUrl repo- then action- else error $ "acting on non-local git repo " ++ repoDescribe repo ++ - " not supported"-configBare :: Repo -> Bool-configBare repo = maybe unknown configTrue $ M.lookup "core.bare" $ config repo- where- unknown = error $ "it is not known if git repo " ++- repoDescribe repo ++- " is a bare repository; config not read"+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 -> String+attributes :: Repo -> FilePath attributes repo- | configBare repo = workTree repo ++ "/info/.gitattributes"- | otherwise = workTree repo ++ "/.gitattributes"--{- Path to a repository's .git directory. -}-gitDir :: Repo -> String-gitDir repo- | configBare repo = workTree repo- | otherwise = workTree repo </> ".git"--{- Path to a repository's --work-tree, that is, its top.- -- - Note that for URL repositories, this is the path on the remote host. -}-workTree :: Repo -> FilePath-workTree Repo { location = Url u } = unEscapeString $ uriPath u-workTree Repo { location = Dir d } = d-workTree Repo { location = Unknown } = undefined+ | repoIsLocalBare repo = repoPath repo ++ "/info/.gitattributes"+ | otherwise = repoPath repo ++ "/.gitattributes" -{- Checks if a string from git config is a true value. -}-configTrue :: String -> Bool-configTrue s = map toLower s == "true"+{- 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+ isexecutable f = isExecutable . fileMode <$> getFileStatus f
Git/Branch.hs view
@@ -7,8 +7,6 @@ module Git.Branch where -import qualified Data.ByteString.Lazy.Char8 as L- import Common import Git import Git.Sha@@ -19,15 +17,15 @@ current r = parse <$> pipeRead [Param "symbolic-ref", Param "HEAD"] r where parse v- | L.null v = Nothing- | otherwise = Just $ Git.Ref $ firstLine $ L.unpack v+ | null v = Nothing+ | otherwise = Just $ Git.Ref $ firstLine v {- 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 . L.null <$> diffs+ | otherwise = not . null <$> diffs where diffs = pipeRead [ Param "log"@@ -43,14 +41,14 @@ -} fastForward :: Branch -> [Ref] -> Repo -> IO Bool fastForward _ [] _ = return True-fastForward branch (first:rest) repo = do+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.- diverged <- changed first branch repo- if diverged- then no_ff- else maybe no_ff do_ff =<< findbest first rest+ ifM (changed first branch repo)+ ( no_ff+ , maybe no_ff do_ff =<< findbest first rest+ ) where no_ff = return False do_ff to = do@@ -73,15 +71,14 @@ - 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" $ asString $+ tree <- getSha "write-tree" $ pipeRead [Param "write-tree"] repo- sha <- getSha "commit-tree" $ asString $+ sha <- getSha "commit-tree" $ ignorehandle $ pipeWriteRead (map Param $ ["commit-tree", show tree] ++ ps)- (L.pack message) repo+ message repo run "update-ref" [Param $ show branch, Param $ show sha] repo return sha where ignorehandle a = snd <$> a- asString a = L.unpack <$> a ps = concatMap (\r -> ["-p", show r]) parentrefs
Git/Command.hs view
@@ -1,13 +1,16 @@ {- running git commands -- - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} module Git.Command where -import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.IO as L+import Control.Concurrent+import Control.Exception (finally) import Common import Git@@ -15,11 +18,12 @@ {- Constructs a git command line operating on the specified repo. -} gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]-gitCommandLine params repo@(Repo { location = Dir _ } ) =- -- force use of specified repo via --git-dir and --work-tree- [ Param ("--git-dir=" ++ gitDir repo)- , Param ("--work-tree=" ++ workTree repo)- ] ++ params+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. -}@@ -31,52 +35,50 @@ run :: String -> [CommandParam] -> Repo -> IO () run subcommand params repo = assertLocal repo $ unlessM (runBool subcommand params repo) $- error $ "git " ++ show params ++ " failed"+ error $ "git " ++ subcommand ++ " " ++ show params ++ " failed" {- Runs a git subcommand and returns its output, lazily. - - Note that this leaves the git process running, and so zombies will - result unless reap is called. -}-pipeRead :: [CommandParam] -> Repo -> IO L.ByteString+pipeRead :: [CommandParam] -> Repo -> IO String pipeRead params repo = assertLocal repo $ do (_, h) <- hPipeFrom "git" $ toCommand $ gitCommandLine params repo- hSetBinaryMode h True- L.hGetContents h+ fileEncoding h+ hGetContents h {- Runs a git subcommand, feeding it input. - You should call either getProcessStatus or forceSuccess on the PipeHandle. -}-pipeWrite :: [CommandParam] -> L.ByteString -> Repo -> IO PipeHandle+pipeWrite :: [CommandParam] -> L.Text -> Repo -> IO PipeHandle pipeWrite params s repo = assertLocal repo $ do (p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo)- L.hPut h s+ L.hPutStr h s hClose h return p {- Runs a git subcommand, feeding it input, and returning its output. - You should call either getProcessStatus or forceSuccess on the PipeHandle. -}-pipeWriteRead :: [CommandParam] -> L.ByteString -> Repo -> IO (PipeHandle, L.ByteString)+pipeWriteRead :: [CommandParam] -> String -> Repo -> IO (PipeHandle, String) pipeWriteRead params s repo = assertLocal repo $ do (p, from, to) <- hPipeBoth "git" (toCommand $ gitCommandLine params repo)- hSetBinaryMode from True- L.hPut to s- hClose to- c <- L.hGetContents from+ fileEncoding to+ fileEncoding from+ _ <- forkIO $ finally (hPutStr to s) (hClose to)+ c <- hGetContents from return (p, c) {- Reads null terminated output of a git command (as enabled by the -z - parameter), and splits it. -} pipeNullSplit :: [CommandParam] -> Repo -> IO [String]-pipeNullSplit params repo = map L.unpack <$> pipeNullSplitB params repo--{- For when Strings are not needed. -}-pipeNullSplitB ::[CommandParam] -> Repo -> IO [L.ByteString]-pipeNullSplitB params repo = filter (not . L.null) . L.split '\0' <$>- pipeRead params repo+pipeNullSplit params repo =+ filter (not . null) . split sep <$> pipeRead params repo+ where+ sep = "\0" {- Reaps any zombie git processes. -} reap :: IO () reap = do -- throws an exception when there are no child processes- r <- catchDefaultIO (getAnyProcessStatus False True) Nothing- maybe (return ()) (const reap) r+ catchDefaultIO (getAnyProcessStatus False True) Nothing+ >>= maybe noop (const reap)
Git/Config.hs view
@@ -1,15 +1,14 @@ {- git repository configuration handling -- - Copyright 2010,2011 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} module Git.Config where -import System.Posix.Directory-import Control.Exception (bracket_) import qualified Data.Map as M+import Data.Char import Common import Git@@ -20,24 +19,37 @@ 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. -}+{- Runs git config and populates a repo with its config.+ - Avoids re-reading config when run repeatedly. -} read :: Repo -> IO Repo-read repo@(Repo { location = Dir d }) = do- {- Cannot use pipeRead because it relies on the config having- been already read. Instead, chdir to the repo. -}- cwd <- getCurrentDirectory- if dirContains d cwd- then go- else bracket_ (changeWorkingDirectory d) (changeWorkingDirectory cwd) go+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 = read'++{- Cannot use pipeRead because it relies on the config having been already+ - read. Instead, chdir to the repo.+ -}+read' :: Repo -> IO Repo+read' repo = go repo where- go = pOpen ReadFromPipe "git" ["config", "--null", "--list"] $- hRead repo-read r = assertLocal r $- error $ "internal error; trying to read config of " ++ show r+ go Repo { location = Local { gitdir = d } } = git_config d+ go Repo { location = LocalUnknown d } = git_config d+ go _ = assertLocal repo $ error "internal"+ git_config d = bracketCd d $+ pOpen ReadFromPipe "git" ["config", "--null", "--list"] $+ hRead repo {- Reads git config from a handle and populates a repo with it. -} hRead :: Repo -> Handle -> IO Repo@@ -45,19 +57,37 @@ 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 inrementally. -}+{- 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- let repo' = repo+ let 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 -> Repo+updateLocation r@(Repo { location = LocalUnknown d })+ | isBare r = newloc $ Local d Nothing+ | otherwise = newloc $ Local (d </> ".git") (Just d)+ where+ newloc l = r { location = getworktree l }+ getworktree l = case workTree r of+ Nothing -> l+ wt -> l { worktree = wt }+updateLocation r = r+ {- Parses git config --list or git config --null --list output into a - config map. -} parse :: String -> M.Map String [String]@@ -71,3 +101,18 @@ 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++isBare :: Repo -> Bool+isBare r = fromMaybe False $ isTrue =<< getMaybe "core.bare" r++workTree :: Repo -> Maybe FilePath+workTree = getMaybe "core.worktree"
Git/Construct.hs view
@@ -1,12 +1,11 @@ {- Construction of Git Repo objects -- - Copyright 2010,2011 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} module Git.Construct (- fromCurrent, fromCwd, fromAbsPath, fromPath,@@ -21,8 +20,6 @@ ) where import System.Posix.User-import System.Posix.Env (getEnv, unsetEnv)-import System.Posix.Directory (changeWorkingDirectory) import qualified Data.Map as M hiding (map, split) import Network.URI @@ -31,34 +28,12 @@ import Git import qualified Git.Url as Url -{- Finds the current git repository.- -- - GIT_DIR can override the location of the .git directory.- -- - When GIT_WORK_TREE is set, chdir to it, so that anything using- - this repository runs in the right location. However, this chdir is- - done after determining GIT_DIR; git does not let GIT_WORK_TREE- - influence the git directory.- -- - Both environment variables are unset, to avoid confusing other git- - commands that also look at them. This would particularly be a problem- - when GIT_DIR is relative and we chdir for GIT_WORK_TREE. Instead,- - the Git module passes --work-tree and --git-dir to git commands it runs.- -}-fromCurrent :: IO Repo-fromCurrent = do- r <- maybe fromCwd fromPath =<< getEnv "GIT_DIR"- maybe (return ()) changeWorkingDirectory =<< getEnv "GIT_WORK_TREE"- unsetEnv "GIT_DIR"- unsetEnv "GIT_WORK_TREE"- return r- {- Finds the git repository used for the Cwd, which may be in a parent - directory. -} fromCwd :: IO Repo fromCwd = getCurrentDirectory >>= seekUp isRepoTop >>= maybe norepo makerepo where- makerepo = newFrom . Dir+ makerepo = newFrom . LocalUnknown norepo = error "Not in a git repository." {- Local Repo constructor, accepts a relative or absolute path. -}@@ -69,27 +44,25 @@ - specified. -} fromAbsPath :: FilePath -> IO Repo fromAbsPath dir- | "/" `isPrefixOf` dir = do- -- Git always looks for "dir.git" in preference to- -- to "dir", even if dir ends in a "/".- let canondir = dropTrailingPathSeparator dir- let dir' = canondir ++ ".git"- e <- doesDirectoryExist dir'- if e- then ret dir'- else if "/.git" `isSuffixOf` canondir- then do- -- When dir == "foo/.git", git looks- -- for "foo/.git/.git", and failing- -- that, uses "foo" as the repository.- e' <- doesDirectoryExist $ dir </> ".git"- if e'- then ret dir- else ret $ takeDirectory canondir- else ret dir- | otherwise = error $ "internal error, " ++ dir ++ " is not absolute"+ | "/" `isPrefixOf` dir =+ ifM (doesDirectoryExist dir') ( ret dir' , hunt )+ | otherwise =+ error $ "internal error, " ++ dir ++ " is not absolute" where- ret = newFrom . Dir+ ret = newFrom . LocalUnknown+ {- Git always looks for "dir.git" in preference to+ - to "dir", even if dir ends in a "/". -}+ canondir = dropTrailingPathSeparator dir+ dir' = canondir ++ ".git"+ {- When dir == "foo/.git", git looks for "foo/.git/.git",+ - and failing that, uses "foo" as the repository. -}+ hunt+ | "/.git" `isSuffixOf` canondir =+ ifM (doesDirectoryExist $ dir </> ".git")+ ( ret dir+ , ret $ takeDirectory canondir+ )+ | otherwise = ret dir {- Remote Repo constructor. Throws exception on invalid url. -@@ -124,7 +97,7 @@ absurl = Url.scheme reference ++ "//" ++ Url.authority reference ++- workTree r+ repoPath r {- Calculates a list of a repo's configured remotes, by parsing its config. -} fromRemotes :: Repo -> IO [Repo]@@ -193,7 +166,7 @@ fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do dir' <- expandTilde dir- fromAbsPath $ workTree repo </> 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.@@ -229,27 +202,20 @@ | otherwise = findname (n++[c]) cs seekUp :: (FilePath -> IO Bool) -> FilePath -> IO (Maybe FilePath)-seekUp want dir = do- ok <- want dir- if ok- then return $ Just dir- else case parentDir dir of+seekUp want dir =+ ifM (want dir)+ ( return $ Just dir+ , case parentDir dir of "" -> return Nothing d -> seekUp want d+ ) isRepoTop :: FilePath -> IO Bool-isRepoTop dir = do- r <- isRepo- if r- then return r- else isBareRepo+isRepoTop dir = ifM isRepo ( return True , isBareRepo ) where isRepo = gitSignature (".git" </> "config")- isBareRepo = do- e <- doesDirectoryExist (dir </> "objects")- if not e- then return e- else gitSignature "config"+ isBareRepo = ifM (doesDirectoryExist $ dir </> "objects")+ ( gitSignature "config" , return False ) gitSignature file = doesFileExist (dir </> file) newFrom :: RepoLocation -> IO Repo@@ -260,3 +226,5 @@ , remotes = [] , remoteName = Nothing }++
Git/Queue.hs view
@@ -5,21 +5,23 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE BangPatterns #-}+ module Git.Queue ( Queue, new, add, size, full,- flush+ flush, ) where import qualified Data.Map as M import System.IO import System.Cmd.Utils import Data.String.Utils-import Utility.SafeCommand +import Utility.SafeCommand import Common import Git import Git.Command@@ -34,7 +36,11 @@ {- 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 Int (M.Map Action [FilePath])+data Queue = Queue+ { size :: Int+ , _limit :: Int+ , _items :: M.Map Action [FilePath]+ } deriving (Show, Eq) {- A recommended maximum size for the queue, after which it should be@@ -46,37 +52,33 @@ - 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. -}-maxSize :: Int-maxSize = 10240+defaultLimit :: Int+defaultLimit = 10240 {- Constructor for empty queue. -}-new :: Queue-new = Queue 0 M.empty+new :: Maybe Int -> Queue+new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty {- Adds an action to a queue. -} add :: Queue -> String -> [CommandParam] -> [FilePath] -> Queue-add (Queue n m) subcommand params files = Queue (n + 1) m'+add (Queue cur lim m) subcommand params files = Queue (cur + 1) lim m' where action = Action subcommand params -- There are probably few items in the map, but there -- can be a lot of files per item. So, optimise adding -- files. m' = M.insertWith' const action fs m- fs = files ++ M.findWithDefault [] action m--{- Number of items in a queue. -}-size :: Queue -> Int-size (Queue n _) = n+ !fs = files ++ M.findWithDefault [] action m {- Is a queue large enough that it should be flushed? -} full :: Queue -> Bool-full (Queue n _) = n > maxSize+full (Queue cur lim _) = cur > lim {- Runs a queue on a git repository. -} flush :: Queue -> Repo -> IO Queue-flush (Queue _ m) repo = do+flush (Queue _ lim m) repo = do forM_ (M.toList m) $ uncurry $ runAction repo- return new+ return $ Queue 0 lim M.empty {- Runs an Action on a list of files in a git repository. -@@ -90,4 +92,6 @@ where params = toCommand $ gitCommandLine (Param (getSubcommand action):getParams action) repo- feedxargs h = hPutStr h $ join "\0" files+ feedxargs h = do+ fileEncoding h+ hPutStr h $ join "\0" files
Git/Ref.hs view
@@ -7,12 +7,12 @@ module Git.Ref where -import qualified Data.ByteString.Lazy.Char8 as L- import Common import Git import Git.Command +import Data.Char (chr)+ {- Converts a fully qualified git ref into a user-visible string. -} describe :: Ref -> String describe = show . base@@ -40,7 +40,7 @@ {- Get the sha of a fully qualified git ref, if it exists. -} sha :: Branch -> Repo -> IO (Maybe Sha)-sha branch repo = process . L.unpack <$> showref repo+sha branch repo = process <$> showref repo where showref = pipeRead [Param "show-ref", Param "--hash", -- get the hash@@ -52,7 +52,7 @@ matching :: Ref -> Repo -> IO [(Ref, Branch)] matching ref repo = do r <- pipeRead [Param "show-ref", Param $ show ref] repo- return $ map (gen . L.unpack) (L.lines r)+ return $ map gen (lines r) where gen l = let (r, b) = separate (== ' ') l in (Ref r, Ref b)@@ -63,3 +63,30 @@ matchingUniq ref repo = nubBy uniqref <$> matching ref 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)]
Git/Types.hs view
@@ -1,6 +1,6 @@ {- git data types -- - Copyright 2010,2011 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -}@@ -10,9 +10,21 @@ import Network.URI import qualified Data.Map as M -{- There are two types of repositories; those on local disk and those- - accessed via an URL. -}-data RepoLocation = Dir FilePath | Url URI | Unknown+{- 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 {
Makefile view
@@ -1,12 +1,12 @@ PREFIX=/usr-BASEFLAGS=-Wall+BASEFLAGS=-Wall -outputdir tmp GHCFLAGS=-O2 $(BASEFLAGS) bins=github-backup mans=github-backup.1 all=$(bins) ifdef PROFILE-GHCFLAGS=-prof -auto-all -rtsopts -caf-all -fforce-recomp+GHCFLAGS=-prof -auto-all -rtsopts -caf-all -fforce-recomp $(BASEFLAGS) endif GHCMAKE=ghc $(GHCFLAGS) --make@@ -32,7 +32,11 @@ install -m 0644 $(mans) $(DESTDIR)$(PREFIX)/share/man/man1 clean:- rm -f $(bins)- find . \( -name \*.o -or -name \*.hi \) -exec rm {} \;+ rm -rf $(bins) tmp++# Upload to hackage.+hackage: clean+ @cabal sdist+ @cabal upload dist/*.tar.gz .PHONY: $(bins)
README.md view
@@ -1,7 +1,7 @@ github-backup is a simple tool you run in a git repository you cloned from GitHub. It backs up everything GitHub publishes about the repository,-including other forks, issues, comments, wikis, milestones, pull requests,-and watchers.+including branches, tags, other forks, issues, comments, wikis, milestones,+pull requests, and watchers. ## Installation
Setup.hs view
@@ -1,2 +1,2 @@ import Distribution.Simple-main = defaultMainWithHooks simpleUserHooks+main = defaultMain
Utility/Directory.hs view
@@ -13,16 +13,32 @@ import Control.Exception (throw) import Control.Monad import Control.Monad.IfElse+import System.FilePath+import Control.Applicative+import Control.Exception (bracket_)+import System.Posix.Directory import Utility.SafeCommand import Utility.TempFile+import Utility.Exception+import Utility.Monad+import Utility.Path +{- Lists the contents of a directory.+ - Unlike getDirectoryContents, paths are not relative to the directory. -}+dirContents :: FilePath -> IO [FilePath]+dirContents d = map (d </>) . filter notcruft <$> getDirectoryContents d+ where+ notcruft "." = False+ notcruft ".." = False+ notcruft _ = True+ {- 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 = try (rename src dest) >>= onrename+moveFile src dest = tryIO (rename src dest) >>= onrename where- onrename (Right _) = return ()+ onrename (Right _) = noop onrename (Left e) | isPermissionError e = rethrow | isDoesNotExistError e = rethrow@@ -40,11 +56,21 @@ Param src, Param tmp] unless ok $ do -- delete any partial- _ <- try $- removeFile tmp+ _ <- tryIO $ removeFile tmp rethrow isdir f = do- r <- try (getFileStatus f)+ r <- tryIO $ getFileStatus f case r of (Left _) -> return False (Right s) -> return $ isDirectory s++{- Runs an action in another directory. -}+bracketCd :: FilePath -> IO a -> IO a+bracketCd dir a = go =<< getCurrentDirectory+ where+ go cwd+ | dirContains dir cwd = a+ | otherwise = bracket_+ (changeWorkingDirectory dir)+ (changeWorkingDirectory cwd)+ a
Utility/Misc.hs view
@@ -8,9 +8,7 @@ module Utility.Misc where import System.IO-import System.IO.Error (try) import Control.Monad-import Control.Applicative {- A version of hgetContents that is not lazy. Ensures file is - all read before it gets closed. -}@@ -37,22 +35,3 @@ {- Breaks out the first line. -} firstLine :: String-> String firstLine = takeWhile (/= '\n')--{- Catches IO errors and returns a Bool -}-catchBoolIO :: IO Bool -> IO Bool-catchBoolIO a = catchDefaultIO a False--{- Catches IO errors and returns a Maybe -}-catchMaybeIO :: IO a -> IO (Maybe a)-catchMaybeIO a = catchDefaultIO (Just <$> a) Nothing--{- Catches IO errors and returns a default value. -}-catchDefaultIO :: IO a -> a -> IO a-catchDefaultIO a def = catch a (const $ return def)--{- Catches IO errors and returns the error message. -}-catchMsgIO :: IO a -> IO (Either String a)-catchMsgIO a = dispatch <$> try a- where- dispatch (Left e) = Left $ show e- dispatch (Right v) = Right v
Utility/Monad.hs view
@@ -1,6 +1,6 @@ {- monadic stuff -- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -}@@ -14,11 +14,7 @@ - predicate -} firstM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) firstM _ [] = return Nothing-firstM p (x:xs) = do- q <- p x- if q- then return (Just x)- else firstM p xs+firstM p (x:xs) = ifM (p x) (return $ Just x , firstM p xs) {- Returns true if any value in the list satisfies the predicate, - stopping once one is found. -}@@ -29,6 +25,20 @@ 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 )+ {- 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@@ -39,3 +49,7 @@ {- 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 ()
Utility/Path.hs view
@@ -82,7 +82,7 @@ s = [pathSeparator] pfrom = split s from pto = split s to- common = map fst $ filter same $ zip pfrom pto+ common = map fst $ takeWhile same $ zip pfrom pto same (c,d) = c == d uncommon = drop numcommon pto dotdots = replicate (length pfrom - numcommon) ".."@@ -95,6 +95,15 @@ where r = relPathDirToFile from to +prop_relPathDirToFile_regressionTest :: Bool+prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference+ where+ {- Two paths have the same directory component at the same+ - location, but it's not really the same directory.+ - Code used to get this wrong. -}+ same_dir_shortcurcuits_at_difference =+ relPathDirToFile "/tmp/r/lll/xxx/yyy/18" "/tmp/r/.git/annex/objects/18/gk/SHA256-foo/SHA256-foo" == "../../../../.git/annex/objects/18/gk/SHA256-foo/SHA256-foo"+ {- Given an original list of files, and an expanded list derived from it, - ensures that the original list's ordering is preserved. -@@ -118,15 +127,6 @@ -} runPreserveOrder :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath] runPreserveOrder a files = preserveOrder files <$> a files--{- Lists the contents of a directory.- - Unlike getDirectoryContents, paths are not relative to the directory. -}-dirContents :: FilePath -> IO [FilePath]-dirContents d = map (d </>) . filter notcruft <$> getDirectoryContents d- where- notcruft "." = False- notcruft ".." = False- notcruft _ = True {- Current user's home directory. -} myHomeDir :: IO FilePath
Utility/TempFile.hs view
@@ -12,7 +12,7 @@ import System.Posix.Process hiding (executeFile) import System.Directory -import Utility.Misc+import Utility.Exception import Utility.Path {- Runs an action like writeFile, writing to a temp file first and
github-backup.1 view
@@ -8,8 +8,8 @@ .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 forks, issues, comments, wikis, milestones, pull requests,-and watchers.+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. (Also works to pass
github-backup.cabal view
@@ -1,5 +1,5 @@ Name: github-backup-Version: 1.20120314+Version: 1.20120627 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess <joey@kitenet.net>@@ -25,7 +25,7 @@ Executable github-backup Main-Is: github-backup.hs Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl,- network, extensible-exceptions, unix, bytestring, base < 5,+ network, extensible-exceptions, unix, bytestring, base >= 4.5, base < 5, IfElse, pretty-show, github >= 0.2.1 source-repository head
github-backup.hs view
@@ -220,7 +220,7 @@ workDir :: Backup FilePath workDir = (</>)- <$> (Git.gitDir <$> getState gitRepo)+ <$> (Git.repoPath <$> getState gitRepo) <*> pure "github-backup.tmp" storeSorted :: Ord a => Show a => FilePath -> Request -> [a] -> Backup ()@@ -270,14 +270,14 @@ when (oldbranch == Just branchref) $ error $ "it's not currently safe to run github-backup while the " ++ branchname ++ " branch is checked out!"- exists <- Git.Ref.matching branchref r- if null exists- then checkout [Param "--orphan", Param branchname]- else checkout [Param branchname]+ ifM (null <$> Git.Ref.matching branchref r)+ ( checkout [Param "--orphan", Param branchname]+ , checkout [Param branchname]+ ) return oldbranch- cleanup Nothing = return ()+ cleanup Nothing = noop cleanup (Just oldbranch)- | name == branchname = return ()+ | name == branchname = noop | otherwise = checkout [Param "--force", Param name] where name = show $ Git.Ref.base oldbranch@@ -292,7 +292,7 @@ r <- getState gitRepo let git_false_worktree ps = boolSystem "git" $ [ Param ("--work-tree=" ++ dir)- , Param ("--git-dir=" ++ Git.gitDir r)+ , Param ("--git-dir=" ++ Git.localGitDir r) ] ++ ps liftIO $ whenM (doesDirectoryExist dir) $ onGithubBranch r $ do _ <- git_false_worktree [ Param "add", Param "." ]@@ -301,33 +301,31 @@ removeDirectoryRecursive dir updateWiki :: GithubUserRepo -> Backup ()-updateWiki fork = do- remotes <- Git.remotes <$> getState gitRepo- if any (\r -> Git.remoteName r == Just remote) remotes- then do- _ <- fetchwiki- return ()- else do+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- return ()+ ) where fetchwiki = inRepo $ Git.Command.runBool "fetch" [Param remote]+ remotes = Git.remotes <$> getState gitRepo remote = remoteFor fork remoteFor (GithubUserRepo user repo) = "github_" ++ user ++ "_" ++ repo ++ ".wiki" addFork :: GithubUserRepo -> Backup Bool-addFork fork = do- remotes <- gitHubRemotes- if fork `elem` remotes- then return False- else do+addFork fork =+ ifM (elem fork <$> gitHubRemotes)+ ( return False+ , do liftIO $ putStrLn $ "New fork: " ++ repoUrl fork _ <- addRemote (remoteFor fork) (repoUrl fork) return True+ ) where remoteFor (GithubUserRepo user repo) = "github_" ++ user ++ "_" ++ repo@@ -343,12 +341,10 @@ ] removeRemote :: String -> Backup ()-removeRemote remotename = do- _ <- inRepo $ Git.Command.runBool "remote"- [ Param "rm"- , Param remotename- ]- return ()+removeRemote remotename = void $ inRepo $ Git.Command.runBool "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.@@ -368,9 +364,8 @@ call name = runRequest $ RequestSimple name repo storeRetry :: [Request] -> Git.Repo -> IO ()-storeRetry [] r = do- _ <- try $ removeFile (retryFile r) :: IO (Either SomeException ()) - return ()+storeRetry [] r = void $ do+ try $ removeFile (retryFile r) :: IO (Either SomeException ()) storeRetry retryrequests r = writeFile (retryFile r) (show retryrequests) loadRetry :: Git.Repo -> IO [Request]@@ -378,7 +373,7 @@ <$> catchMaybeIO (readFileStrict (retryFile r)) retryFile :: Git.Repo -> FilePath-retryFile r = Git.gitDir r </> "github-backup.todo"+retryFile r = Git.localGitDir r </> "github-backup.todo" retry :: Backup (S.Set Request) retry = do