packages feed

github-backup 1.20131203 → 1.20140707

raw patch · 40 files changed

+848/−266 lines, 40 filesdep +optparse-applicative

Dependencies added: optparse-applicative

Files

Build/make-sdist.sh view
@@ -13,7 +13,7 @@ | xargs cp --parents --target-directory dist/$sdist_dir  cd dist-tar -caf $sdist_dir.tar.gz $sdist_dir+tar --format=ustar -caf $sdist_dir.tar.gz $sdist_dir  # Check that tarball can be unpacked by cabal. # It's picky about tar longlinks etc.
Git.hs view
@@ -13,6 +13,7 @@ module Git ( 	Repo(..), 	Ref(..),+	fromRef, 	Branch, 	Sha, 	Tag,
Git/Branch.hs view
@@ -13,7 +13,7 @@ import Git import Git.Sha import Git.Command-import Git.Ref (headRef)+import qualified Git.Ref  {- The currently checked out branch.  -@@ -28,7 +28,7 @@ 	case v of 		Nothing -> return Nothing 		Just branch -> -			ifM (null <$> pipeReadStrict [Param "show-ref", Param $ show branch] r)+			ifM (null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r) 				( return Nothing 				, return v 				)@@ -36,7 +36,7 @@ {- 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+	<$> pipeReadStrict [Param "symbolic-ref", Param $ fromRef Git.Ref.headRef] r   where 	parse l 		| null l = Nothing@@ -51,10 +51,25 @@   where 	diffs = pipeReadStrict 		[ Param "log"-		, Param (show origbranch ++ ".." ++ show newbranch)-		, Params "--oneline -n1"+		, Param (fromRef origbranch ++ ".." ++ fromRef newbranch)+		, Param "-n1"+		, Param "--pretty=%H" 		] repo +{- Check if it's possible to fast-forward from the old+ - ref to the new ref.+ -+ - This requires there to be a path from the old to the new. -}+fastForwardable :: Ref -> Ref -> Repo -> IO Bool+fastForwardable old new repo = not . null <$>+	pipeReadStrict+		[ Param "log"+		, Param $ fromRef old ++ ".." ++ fromRef new+		, Param "-n1"+		, Param "--pretty=%H"+		, Param "--ancestry-path"+		] 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.  -@@ -74,7 +89,7 @@   where 	no_ff = return False 	do_ff to = do-		run [Param "update-ref", Param $ show branch, Param $ show to] repo+		update branch to repo 		return True 	findbest c [] = return $ Just c 	findbest c (r:rs)@@ -88,20 +103,90 @@ 			(False, True) -> findbest c rs -- worse 			(False, False) -> findbest c rs -- same +{- The user may have set commit.gpgsign, indending all their manual+ - commits to be signed. But signing automatic/background commits could+ - easily lead to unwanted gpg prompts or failures.+ -}+data CommitMode = ManualCommit | AutomaticCommit+	deriving (Eq)++{- Commit via the usual git command. -}+commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool+commitCommand = commitCommand' runBool++{- Commit will fail when the tree is clean. This suppresses that error. -}+commitQuiet :: CommitMode -> [CommandParam] -> Repo -> IO ()+commitQuiet commitmode ps = void . tryIO . commitCommand' runQuiet commitmode ps++commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> [CommandParam] -> Repo -> IO a+commitCommand' runner commitmode ps = runner (Param "commit" : ps')+  where+	ps'+		| commitmode == AutomaticCommit = Param "--no-gpg-sign" : ps+		| otherwise = ps+ {- 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+ - with the specified parent refs, and returns the committed sha.+ -+ - Without allowempy set, avoids making a commit if there is exactly+ - one parent, and it has the same tree that would be committed.+ -+ - Unlike git-commit, does not run any hooks, or examine the work tree+ - in any way.+ -}+commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)+commit commitmode allowempty 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+	ifM (cancommit tree)+		( do+			sha <- getSha "commit-tree" $ pipeWriteRead+				(map Param $ ["commit-tree", fromRef tree] ++ ps)+				(Just $ flip hPutStr message) repo+			update branch sha repo+			return $ Just sha+		, return Nothing+		)   where-	ps = concatMap (\r -> ["-p", show r]) parentrefs+	ps = +		(if commitmode == AutomaticCommit then ["--no-gpg-sign"] else [])+		++ concatMap (\r -> ["-p", fromRef r]) parentrefs+	cancommit tree+		| allowempty = return True+		| otherwise = case parentrefs of+			[p] -> maybe False (tree /=) <$> Git.Ref.tree p repo+			_ -> return True +commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha+commitAlways commitmode message branch parentrefs repo = fromJust+	<$> commit commitmode True message branch parentrefs repo+ {- A leading + makes git-push force pushing a branch. -} forcePush :: String -> String forcePush b = "+" ++ b++{- Updates a branch (or other ref) to a new Sha. -}+update :: Branch -> Sha -> Repo -> IO ()+update branch sha = run +	[ Param "update-ref"+	, Param $ fromRef branch+	, Param $ fromRef sha+	]++{- Checks out a branch, creating it if necessary. -}+checkout :: Branch -> Repo -> IO ()+checkout branch = run+	[ Param "checkout"+	, Param "-q"+	, Param "-B"+	, Param $ fromRef $ Git.Ref.base branch+	]++{- Removes a branch. -}+delete :: Branch -> Repo -> IO ()+delete branch = run+	[ Param "branch"+	, Param "-q"+	, Param "-D"+	, Param $ fromRef $ Git.Ref.base branch+	]
Git/CatFile.hs view
@@ -11,6 +11,7 @@ 	catFileStart', 	catFileStop, 	catFile,+	catFileDetails, 	catTree, 	catObject, 	catObjectDetails,@@ -50,8 +51,12 @@ {- 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+	fromRef branch ++ ":" ++ toInternalGitPath file +catFileDetails :: CatFileHandle -> Branch -> FilePath -> IO (Maybe (L.ByteString, Sha, ObjectType))+catFileDetails h branch file = catObjectDetails h $ Ref $+	fromRef 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@@ -60,7 +65,7 @@ catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType)) catObjectDetails (CatFileHandle hdl _) object = CoProcess.query hdl send receive   where-	query = show object+	query = fromRef object 	send to = hPutStrLn to query 	receive from = do 		header <- hGetLine from@@ -72,8 +77,8 @@ 						_ -> dne 				| otherwise -> dne 			_-				| header == show object ++ " missing" -> dne-				| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)+				| header == fromRef object ++ " missing" -> dne+				| otherwise -> error $ "unknown response from git cat-file " ++ show (header, query) 	readcontent objtype bytes from sha = do 		content <- S.hGet from bytes 		eatchar '\n' from@@ -103,6 +108,6 @@ 	dropsha = L.drop 21  	parsemodefile b = -		let (modestr, file) = separate (== ' ') (encodeW8 $ L.unpack b)+		let (modestr, file) = separate (== ' ') (decodeBS b) 		in (file, readmode modestr) 	readmode = fst . fromMaybe (0, undefined) . headMaybe . readOct
Git/Command.hs view
@@ -1,13 +1,13 @@ {- running git commands  -- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -} -module Git.Command where+{-# LANGUAGE CPP #-} -import System.Process (std_out, env)+module Git.Command where  import Common import Git@@ -16,7 +16,8 @@  {- Constructs a git command line operating on the specified repo. -} gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]-gitCommandLine params Repo { location = l@(Local _ _ ) } = setdir : settree ++ params+gitCommandLine params r@(Repo { location = l@(Local _ _ ) }) =+	setdir : settree ++ gitGlobalOpts r ++ params   where 	setdir = Param $ "--git-dir=" ++ gitdir l 	settree = case worktree l of@@ -27,9 +28,7 @@ {- Runs git in the specified repo. -} runBool :: [CommandParam] -> Repo -> IO Bool runBool params repo = assertLocal repo $-	boolSystemEnv "git"-		(gitCommandLine params repo)-		(gitEnv repo)+	boolSystemEnv "git" (gitCommandLine params repo) (gitEnv repo)  {- Runs git in the specified repo, throwing an error if it fails. -} run :: [CommandParam] -> Repo -> IO ()@@ -72,13 +71,13 @@   where 	p  = gitCreateProcess params repo -{- Runs a git command, feeding it input, and returning its output,+{- Runs a git command, feeding it an 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 $+pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO String+pipeWriteRead params writer repo = assertLocal repo $ 	writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) -		(gitEnv repo) s (Just adjusthandle)+		(gitEnv repo) writer (Just adjusthandle)   where   	adjusthandle h = do 		fileEncoding h@@ -114,9 +113,14 @@  {- Runs a git command as a coprocess. -} gitCoProcessStart :: Bool -> [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle-gitCoProcessStart restartable params repo = CoProcess.start restartable "git"+gitCoProcessStart restartable params repo = CoProcess.start numrestarts "git" 	(toCommand $ gitCommandLine params repo) 	(gitEnv repo)+  where+  	{- If a long-running git command like cat-file --batch+	 - crashes, it will likely start up again ok. If it keeps crashing+	 - 10 times, something is badly wrong. -}+	numrestarts = if restartable then 10 else 0  gitCreateProcess :: [CommandParam] -> Repo -> CreateProcess gitCreateProcess params repo =
Git/Config.hs view
@@ -9,7 +9,6 @@  import qualified Data.Map as M import Data.Char-import System.Process (cwd, env) import Control.Exception.Extensible  import Common@@ -110,8 +109,13 @@  -} 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)+	| isBare r = ifM (doesDirectoryExist dotgit)+			( updateLocation' r $ Local dotgit Nothing+			, updateLocation' r $ Local d Nothing+			)+	| otherwise = updateLocation' r $ Local dotgit (Just d)+  where+	dotgit = (d </> ".git") updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l updateLocation r = return r @@ -153,7 +157,10 @@ boolConfig False = "false"  isBare :: Repo -> Bool-isBare r = fromMaybe False $ isTrue =<< getMaybe "core.bare" r+isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r++coreBare :: String+coreBare = "core.bare"  {- Runs a command to get the configuration of a repo,  - and returns a repo populated with the configuration, as well as the raw
Git/Construct.hs view
@@ -33,6 +33,7 @@ import Git.Types import Git import Git.Remote+import Git.FilePath import qualified Git.Url as Url import Utility.UserInfo @@ -57,7 +58,7 @@  - specified. -} fromAbsPath :: FilePath -> IO Repo fromAbsPath dir-	| isAbsolute dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt )+	| absoluteGitPath dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt ) 	| otherwise = 		error $ "internal error, " ++ dir ++ " is not absolute"   where@@ -104,14 +105,16 @@ 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-		]+	| otherwise = case Url.authority reference of+		Nothing -> r+		Just auth -> +			let absurl = concat+				[ Url.scheme reference+				, "//"+				, auth+				, repoPath r+				]+			in r { location = Url $ fromJust $ parseURI absurl }  {- Calculates a list of a repo's configured remotes, by parsing its config. -} fromRemotes :: Repo -> IO [Repo]@@ -228,6 +231,7 @@ 	, remotes = [] 	, remoteName = Nothing 	, gitEnv = Nothing+	, gitGlobalOpts = [] 	}
Git/FilePath.hs view
@@ -14,20 +14,29 @@  module Git.FilePath ( 	TopFilePath,+	fromTopFilePath, 	getTopFilePath, 	toTopFilePath, 	asTopFilePath, 	InternalGitPath, 	toInternalGitPath,-	fromInternalGitPath+	fromInternalGitPath,+	absoluteGitPath ) where  import Common import Git +import qualified System.FilePath.Posix+ {- A FilePath, relative to the top of the git repository. -} newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }+	deriving (Show) +{- Returns an absolute FilePath. -}+fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath+fromTopFilePath p repo = absPathFrom (repoPath repo) (getTopFilePath p)+ {- The input FilePath can be absolute, or relative to the CWD. -} toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath toTopFilePath file repo = TopFilePath <$>@@ -39,8 +48,12 @@ 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 '\' -}+ - it internally. + -+ - On Windows, git uses '/' to separate paths stored in the repository,+ - despite Windows using '\'.+ -+ -} type InternalGitPath = String  toInternalGitPath :: FilePath -> InternalGitPath@@ -56,3 +69,10 @@ #else fromInternalGitPath = replace "/" "\\" #endif++{- isAbsolute on Windows does not think "/foo" or "\foo" is absolute,+ - so try posix paths.+ -}+absoluteGitPath :: FilePath -> Bool+absoluteGitPath p = isAbsolute p ||+	System.FilePath.Posix.isAbsolute (toInternalGitPath p)
Git/HashObject.hs view
@@ -1,6 +1,6 @@ {- git hash-object interface  -- - Copyright 2011-2012 Joey Hess <joey@kitenet.net>+ - Copyright 2011-2014 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -13,6 +13,7 @@ import Git.Command import Git.Types import qualified Utility.CoProcess as CoProcess+import Utility.Tmp  type HashObjectHandle = CoProcess.CoProcessHandle @@ -34,10 +35,24 @@ 	send to = hPutStrLn to file 	receive from = getSha "hash-object" $ hGetLine from -{- Injects some content into git, returning its Sha. -}+{- Injects a blob into git. Unfortunately, the current git-hash-object+ - interface does not allow batch hashing without using temp files. -}+hashBlob :: HashObjectHandle -> String -> IO Sha+hashBlob h s = withTmpFile "hash" $ \tmp tmph -> do+	hPutStr tmph s+	hClose tmph+	hashFile h tmp++{- Injects some content into git, returning its Sha.+ - + - Avoids using a tmp file, but runs a new hash-object command each+ - time called. -} hashObject :: ObjectType -> String -> Repo -> IO Sha-hashObject objtype content repo = getSha subcmd $-	pipeWriteRead (map Param params) content repo+hashObject objtype content = hashObject' objtype (flip hPutStr content)++hashObject' :: ObjectType -> (Handle -> IO ()) -> Repo -> IO Sha+hashObject' objtype writer repo = getSha subcmd $+	pipeWriteRead (map Param params) (Just writer) repo   where 	subcmd = "hash-object" 	params = [subcmd, "-t", show objtype, "-w", "--stdin", "--no-filters"]
Git/Queue.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP, BangPatterns #-}  module Git.Queue ( 	Queue,@@ -17,16 +17,14 @@ 	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-	++import qualified Data.Map as M+ {- Queable actions that can be performed in a git repository.  -} data Action@@ -84,16 +82,16 @@  -} addCommand :: String -> [CommandParam] -> [FilePath] -> Queue -> Repo -> IO Queue addCommand subcommand params files q repo =-	updateQueue action different (length newfiles) q repo+	updateQueue action different (length files) q repo   where 	key = actionKey action 	action = CommandAction 		{ getSubcommand = subcommand 		, getParams = params-		, getFiles = newfiles+		, getFiles = allfiles 		}-	newfiles = map File files ++ maybe [] getFiles (M.lookup key $ items q)-		+	allfiles = map File files ++ maybe [] getFiles (M.lookup key $ items q)+	 	different (CommandAction { getSubcommand = s }) = s /= subcommand 	different _ = True @@ -147,13 +145,21 @@ runAction repo (UpdateIndexAction streamers) = 	-- list is stored in reverse order 	Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers-runAction repo action@(CommandAction {}) =+runAction repo action@(CommandAction {}) = do+#ifndef mingw32_HOST_OS+	let p = (proc "xargs" $ "-0":"git":toCommand gitparams) { env = gitEnv repo } 	withHandle StdinHandle createProcessSuccess p $ \h -> do 		fileEncoding h 		hPutStr h $ intercalate "\0" $ toCommand $ getFiles action 		hClose h+#else+	-- Using xargs on Windows is problimatic, so just run the command+	-- once per file (not as efficient.)+	if null (getFiles action)+		then void $ boolSystemEnv "git" gitparams (gitEnv repo)+		else forM_ (getFiles action) $ \f ->+			void $ boolSystemEnv "git" (gitparams ++ [f]) (gitEnv repo)+#endif   where-	p = (proc "xargs" params) { env = gitEnv repo }-	params = "-0":"git":baseparams-	baseparams = toCommand $ gitCommandLine+	gitparams = gitCommandLine 		(Param (getSubcommand action):getParams action) repo
Git/Ref.hs view
@@ -10,6 +10,8 @@ import Common import Git import Git.Command+import Git.Sha+import Git.Types  import Data.Char (chr) @@ -18,28 +20,57 @@  {- Converts a fully qualified git ref into a user-visible string. -} describe :: Ref -> String-describe = show . base+describe = fromRef . 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+base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef   where 	remove prefix s 		| prefix `isPrefixOf` s = drop (length prefix) s 		| otherwise = s +{- Given a directory and any ref, takes the basename of the ref and puts+ - it under the directory. -}+under :: String -> Ref -> Ref+under dir r = Ref $ dir ++ "/" +++	(reverse $ takeWhile (/= '/') $ reverse $ fromRef r)+ {- 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)+underBase :: String -> Ref -> Ref+underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r) +{- A Ref that can be used to refer to a file in the repository, as staged+ - in the index.+ -+ - Prefixing the file with ./ makes this work even if in a subdirectory+ - of a repo.+ -}+fileRef :: FilePath -> Ref+fileRef f = Ref $ ":./" ++ f++{- Converts a Ref to refer to the content of the Ref on a given date. -}+dateRef :: Ref -> RefDate -> Ref+dateRef (Ref r) (RefDate d) = Ref $ r ++ "@" ++ d++{- A Ref that can be used to refer to a file in the repository as it+ - appears in a given Ref. -}+fileFromRef :: Ref -> FilePath -> Ref+fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)+ {- Checks if a ref exists. -} exists :: Ref -> Repo -> IO Bool exists ref = runBool-	[Param "show-ref", Param "--verify", Param "-q", Param $ show ref]+	[Param "show-ref", Param "--verify", Param "-q", Param $ fromRef ref] +{- The file used to record a ref. (Git also stores some refs in a+ - packed-refs file.) -}+file :: Ref -> Repo -> FilePath+file ref repo = localGitDir repo </> fromRef ref+ {- Checks if HEAD exists. It generally will, except for in a repository  - that was just created. -} headExists :: Repo -> IO Bool@@ -53,17 +84,17 @@   where 	showref = pipeReadStrict [Param "show-ref", 		Param "--hash", -- get the hash-		Param $ show branch]+		Param $ fromRef 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+matching refs repo =  matching' (map fromRef 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+matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo  {- List of (shas, branches) matching a given ref or refs. -} matching' :: [String] -> Repo -> IO [(Sha, Branch)]@@ -79,6 +110,11 @@ matchingUniq refs repo = nubBy uniqref <$> matching refs repo   where 	uniqref (a, _) (b, _) = a == b++{- Gets the sha of the tree a ref uses. -}+tree :: Ref -> Repo -> IO (Maybe Sha)+tree ref = extractSha <$$> pipeReadStrict+	[ Param "rev-parse", Param (fromRef ref ++ ":") ]  {- Checks if a String is a legal git ref name.  -
Git/Remote.hs view
@@ -11,6 +11,7 @@  import Common import Git+import Git.Types import qualified Git.Command import qualified Git.BuildVersion @@ -21,8 +22,6 @@ 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,@@ -61,6 +60,10 @@ remoteLocationIsUrl :: RemoteLocation -> Bool remoteLocationIsUrl (RemoteUrl _) = True remoteLocationIsUrl _ = False++remoteLocationIsSshUrl :: RemoteLocation -> Bool+remoteLocationIsSshUrl (RemoteUrl u) = "ssh://" `isPrefixOf` u+remoteLocationIsSshUrl _ = False  {- Determines if a given remote location is an url, or a local  - path. Takes the repository's insteadOf configuration into account. -}
Git/Sha.hs view
@@ -37,3 +37,7 @@  nullSha :: Ref		 nullSha = Ref $ replicate shaSize '0'++{- Git's magic empty tree. -}+emptyTree :: Ref+emptyTree = Ref "4b825dc642cb6eb9a060e54bf8d69288fbee4904"
Git/Types.hs view
@@ -9,6 +9,9 @@  import Network.URI import qualified Data.Map as M+import System.Posix.Types+import Utility.SafeCommand+import Utility.URI ()  {- Support repositories on local disk, and repositories accessed via an URL.  -@@ -25,7 +28,7 @@ 	| LocalUnknown FilePath 	| Url URI 	| Unknown-	deriving (Show, Eq)+	deriving (Show, Eq, Ord)  data Repo = Repo 	{ location :: RepoLocation@@ -34,23 +37,31 @@ 	, fullconfig :: M.Map String [String] 	, remotes :: [Repo] 	-- remoteName holds the name used for this repo in remotes-	, remoteName :: Maybe String+	, remoteName :: Maybe RemoteName 	-- alternate environment to use when running git commands 	, gitEnv :: Maybe [(String, String)]-	} deriving (Show, Eq)+	-- global options to pass to git when running git commands+	, gitGlobalOpts :: [CommandParam]+	} deriving (Show, Eq, Ord) +type RemoteName = String+ {- A git ref. Can be a sha1, or a branch or tag name. -} newtype Ref = Ref String-	deriving (Eq, Ord)+	deriving (Eq, Ord, Read, Show) -instance Show Ref where-	show (Ref v) = v+fromRef :: Ref -> String+fromRef (Ref s) = s  {- Aliases for Ref. -} type Branch = Ref type Sha = Ref type Tag = Ref +{- A date in the format described in gitrevisions. Includes the+ - braces, eg, "{yesterday}" -}+newtype RefDate = RefDate String+ {- Types of objects that can be stored in git. -} data ObjectType = BlobObject | CommitObject | TreeObject 	deriving (Eq)@@ -81,3 +92,9 @@ readBlobType "100755" = Just ExecutableBlob readBlobType "120000" = Just SymlinkBlob readBlobType _ = Nothing++toBlobType :: FileMode -> Maybe BlobType+toBlobType 0o100644 = Just FileBlob+toBlobType 0o100755 = Just ExecutableBlob+toBlobType 0o120000 = Just SymlinkBlob+toBlobType _ = Nothing
Git/UpdateIndex.hs view
@@ -11,8 +11,13 @@ 	Streamer, 	pureStreamer, 	streamUpdateIndex,+	streamUpdateIndex',+	startUpdateIndex,+	stopUpdateIndex, 	lsTree,+	lsSubTree, 	updateIndexLine,+	stageFile, 	unstageFile, 	stageSymlink ) where@@ -24,6 +29,8 @@ import Git.FilePath import Git.Sha +import Control.Exception (bracket)+ {- 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 ()@@ -34,17 +41,30 @@  {- Streams content into update-index from a list of Streamers. -} streamUpdateIndex :: Repo -> [Streamer] -> IO ()-streamUpdateIndex repo as = pipeWrite params repo $ \h -> do+streamUpdateIndex repo as = bracket (startUpdateIndex repo) stopUpdateIndex $+	(\h -> forM_ as $ streamUpdateIndex' h)++data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle++streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO ()+streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do+	hPutStr h s+	hPutStr h "\0"++startUpdateIndex :: Repo -> IO UpdateIndexHandle+startUpdateIndex repo = do+	(Just h, _, _, p) <- createProcess (gitCreateProcess params repo)+		{ std_in = CreatePipe } 	fileEncoding h-	forM_ as (stream h)-	hClose h+	return $ UpdateIndexHandle p 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" +stopUpdateIndex :: UpdateIndexHandle -> IO Bool+stopUpdateIndex (UpdateIndexHandle p h) = do+	hClose h+	checkSuccessProcess p+ {- A streamer that adds the current tree for a ref. Useful for eg, copying  - and modifying branches. -} lsTree :: Ref -> Repo -> Streamer@@ -54,18 +74,30 @@ 	void $ cleanup   where 	params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]+lsSubTree :: Ref -> FilePath -> Repo -> Streamer+lsSubTree (Ref x) p repo streamer = do+	(s, cleanup) <- pipeNullSplit params repo+	mapM_ streamer s+	void $ cleanup+  where+	params = map Param ["ls-tree", "-z", "-r", "--full-tree", x, p]  {- 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+	show filetype ++ " blob " ++ fromRef sha ++ "\t" ++ indexPath file +stageFile :: Sha -> BlobType -> FilePath -> Repo -> IO Streamer+stageFile sha filetype file repo = do+	p <- toTopFilePath file repo+	return $ pureStreamer $ updateIndexLine sha filetype p+ {- 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+	return $ pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p  {- A streamer that adds a symlink to the index. -} stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer
Git/Url.hs view
@@ -37,32 +37,33 @@ 	fixup x = x  {- Hostname of an URL repo. -}-host :: Repo -> String+host :: Repo -> Maybe 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+		Nothing -> Nothing+		Just ":" -> Nothing+		Just (':':p) -> readish p+		Just _ -> Nothing  {- Hostname of an URL repo, including any username (ie, "user@host") -}-hostuser :: Repo -> String-hostuser r = authpart uriUserInfo r ++ authpart uriRegName' r+hostuser :: Repo -> Maybe String+hostuser r = (++)+	<$> authpart uriUserInfo r+	<*> authpart uriRegName' r  {- The full authority portion an URL repo. (ie, "user@host:port") -}-authority :: Repo -> String+authority :: Repo -> Maybe 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 :: (URIAuth -> a) -> Repo -> Maybe a+authpart a Repo { location = Url u } = a <$> uriAuthority u authpart _ repo = notUrl repo  notUrl :: Repo -> a
README.md view
@@ -9,7 +9,7 @@     cd github-backup     make -(You will need ghc, hslogger, and MissingH installed first.)+(You will need ghc and several haskell libraries installed first.)  Or use cabal:
Utility/Applicative.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2012 Joey Hess <joey@kitenet.net>  -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause  -}  module Utility.Applicative where
Utility/CoProcess.hs view
@@ -3,7 +3,7 @@  -  - Copyright 2012-2013 Joey Hess <joey@kitenet.net>  -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause  -}  {-# LANGUAGE CPP #-}@@ -30,15 +30,15 @@ 	}  data CoProcessSpec = CoProcessSpec-	{ coProcessRestartable :: Bool+	{ coProcessNumRestarts :: Int 	, 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+start :: Int -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle+start numrestarts cmd params environ = do+	s <- start' $ CoProcessSpec numrestarts cmd params environ 	newMVar s  start' :: CoProcessSpec -> IO CoProcessState@@ -62,11 +62,11 @@ 	s <- readMVar ch 	restartable s (send $ coProcessTo s) $ const $ 		restartable s (hFlush $ coProcessTo s) $ const $-			restartable s (receive $ coProcessFrom s) $+			restartable s (receive $ coProcessFrom s) 				return   where   	restartable s a cont-		| coProcessRestartable (coProcessSpec s) =+		| coProcessNumRestarts (coProcessSpec s) > 0 = 			maybe restart cont =<< catchMaybeIO a 		| otherwise = cont =<< a 	restart = do@@ -75,7 +75,8 @@ 			hClose $ coProcessTo s 			hClose $ coProcessFrom s 		void $ waitForProcess $ coProcessPid s-		s' <- start' (coProcessSpec s)+		s' <- start' $ (coProcessSpec s)+			{ coProcessNumRestarts = coProcessNumRestarts (coProcessSpec s) - 1 } 		putMVar ch s' 		query ch send receive
Utility/Data.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2013 Joey Hess <joey@kitenet.net>  -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause  -}  module Utility.Data where
Utility/Directory.hs view
@@ -1,8 +1,8 @@ {- directory manipulation  -- - Copyright 2011 Joey Hess <joey@kitenet.net>+ - Copyright 2011-2014 Joey Hess <joey@kitenet.net>  -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause  -}  {-# LANGUAGE CPP #-}@@ -10,7 +10,6 @@ module Utility.Directory where  import System.IO.Error-import System.PosixCompat.Files import System.Directory import Control.Exception (throw) import Control.Monad@@ -19,10 +18,12 @@ import Control.Applicative import System.IO.Unsafe (unsafeInterleaveIO) +import Utility.PosixFiles import Utility.SafeCommand import Utility.Tmp import Utility.Exception import Utility.Monad+import Utility.Applicative  dirCruft :: FilePath -> Bool dirCruft "." = True@@ -35,17 +36,22 @@ 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,+ - and lazily.+ -+ - Does not follow symlinks to other subdirectories.+ -+ - When the directory does not exist, no exception is thrown,  - instead, [] is returned. -} dirContentsRecursive :: FilePath -> IO [FilePath]-dirContentsRecursive topdir = dirContentsRecursiveSkipping (const False) topdir+dirContentsRecursive = dirContentsRecursiveSkipping (const False) True -dirContentsRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]-dirContentsRecursiveSkipping skipdir topdir = go [topdir]+{- Skips directories whose basenames match the skipdir. -}+dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]+dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]   where   	go [] = return [] 	go (dir:dirs)-		| skipdir dir = go dirs+		| skipdir (takeFileName dir) = go dirs 		| otherwise = unsafeInterleaveIO $ do 			(files, dirs') <- collect [] [] 				=<< catchDefaultIO [] (dirContents dir)@@ -55,10 +61,33 @@ 	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-				)			+			let skip = collect (entry:files) dirs' entries+			let recurse = collect files (entry:dirs') entries+			ms <- catchMaybeIO $ getSymbolicLinkStatus entry+			case ms of+				(Just s) +					| isDirectory s -> recurse+					| isSymbolicLink s && followsubdirsymlinks ->+						ifM (doesDirectoryExist entry)+							( recurse+							, skip+							)+				_ -> skip++{- Gets the directory tree from a point, recursively and lazily,+ - with leaf directories **first**, skipping any whose basenames+ - match the skipdir. Does not follow symlinks. -}+dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]+dirTreeRecursiveSkipping skipdir topdir = go [] [topdir]+  where+  	go c [] = return c+	go c (dir:dirs)+		| skipdir (takeFileName dir) = go c dirs+		| otherwise = unsafeInterleaveIO $ do+			subdirs <- go c+				=<< filterM (isDirectory <$$> getSymbolicLinkStatus)+				=<< catchDefaultIO [] (dirContents dir)+			go (subdirs++[dir]) dirs  {- Moves one filename to another.  - First tries a rename, but falls back to moving across devices if needed. -}
Utility/Env.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2013 Joey Hess <joey@kitenet.net>  -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause  -}  {-# LANGUAGE CPP #-}@@ -61,3 +61,21 @@ #else unsetEnv _ = return False #endif++{- Adds the environment variable to the input environment. If already+ - present in the list, removes the old value.+ -+ - This does not really belong here, but Data.AssocList is for some reason+ - buried inside hxt.+ -}+addEntry :: Eq k => k -> v -> [(k, v)] -> [(k, v)]+addEntry k v l = ( (k,v) : ) $! delEntry k l++addEntries :: Eq k => [(k, v)] -> [(k, v)] -> [(k, v)]+addEntries = foldr (.) id . map (uncurry addEntry) . reverse++delEntry :: Eq k => k -> [(k, v)] -> [(k, v)]+delEntry _ []   = []+delEntry k (x@(k1,_) : rest)+	| k == k1 = rest+	| otherwise = ( x : ) $! delEntry k rest
Utility/Exception.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2011-2012 Joey Hess <joey@kitenet.net>  -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause  -}  {-# LANGUAGE ScopedTypeVariables #-}@@ -18,7 +18,7 @@  {- Catches IO errors and returns a Bool -} catchBoolIO :: IO Bool -> IO Bool-catchBoolIO a = catchDefaultIO False a+catchBoolIO = catchDefaultIO False  {- Catches IO errors and returns a Maybe -} catchMaybeIO :: IO a -> IO (Maybe a)
Utility/FileMode.hs view
@@ -2,22 +2,25 @@  -  - Copyright 2010-2012 Joey Hess <joey@kitenet.net>  -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause  -}  {-# LANGUAGE CPP #-}  module Utility.FileMode where -import Common-+import System.IO+import Control.Monad import Control.Exception (bracket) import System.PosixCompat.Types+import Utility.PosixFiles #ifndef mingw32_HOST_OS import System.Posix.Files #endif import Foreign (complement) +import Utility.Exception+ {- Applies a conversion function to a file's mode. -} modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO () modifyFileMode f convert = void $ modifyFileMode' f convert@@ -56,6 +59,12 @@ executeModes :: [FileMode] executeModes = [ownerExecuteMode, groupExecuteMode, otherExecuteMode] +otherGroupModes :: [FileMode]+otherGroupModes = +	[ groupReadMode, otherReadMode+	, groupWriteMode, otherWriteMode+	]+ {- Removes the write bits from a file. -} preventWrite :: FilePath -> IO () preventWrite f = modifyFileMode f $ removeModes writeModes@@ -64,13 +73,20 @@ allowWrite :: FilePath -> IO () allowWrite f = modifyFileMode f $ addModes [ownerWriteMode] +{- Turns a file's owner read bit back on. -}+allowRead :: FilePath -> IO ()+allowRead f = modifyFileMode f $ addModes [ownerReadMode]+ {- Allows owner and group to read and write to a file. -}-groupWriteRead :: FilePath -> IO ()-groupWriteRead f = modifyFileMode f $ addModes+groupSharedModes :: [FileMode]+groupSharedModes = 	[ ownerWriteMode, groupWriteMode 	, ownerReadMode, groupReadMode 	] +groupWriteRead :: FilePath -> IO ()+groupWriteRead f = modifyFileMode f $ addModes groupSharedModes+ checkMode :: FileMode -> FileMode -> Bool checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor @@ -92,13 +108,20 @@ #ifndef mingw32_HOST_OS noUmask mode a 	| mode == stdFileMode = a-	| otherwise = bracket setup cleanup go+	| otherwise = withUmask nullFileMode a+#else+noUmask _ a = a+#endif++withUmask :: FileMode -> IO a -> IO a+#ifndef mingw32_HOST_OS+withUmask umask a = bracket setup cleanup go   where-	setup = setFileCreationMask nullFileMode+	setup = setFileCreationMask umask 	cleanup = setFileCreationMask 	go _ = a #else-noUmask _ a = a+withUmask _ a = a #endif  combineModes :: [FileMode] -> FileMode@@ -120,16 +143,16 @@ #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.+ - or written by anyone other than the current user,+ - before any content is written.  -+ - When possible, this is done using the umask.+ -  - 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+writeFileProtected file content = withUmask 0o0077 $+	withFile file WriteMode $ \h -> do+		void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes+		hPutStr h content
Utility/FileSystemEncoding.hs view
@@ -1,14 +1,17 @@ {- GHC File system encoding handling.  -- - Copyright 2012-2013 Joey Hess <joey@kitenet.net>+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>  -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause  -} +{-# LANGUAGE CPP #-}+ module Utility.FileSystemEncoding ( 	fileEncoding, 	withFilePath, 	md5FilePath,+	decodeBS, 	decodeW8, 	encodeW8, 	truncateFilePath,@@ -22,13 +25,24 @@ import qualified Data.Hash.MD5 as MD5 import Data.Word import Data.Bits.Utils+import qualified Data.ByteString.Lazy as L+#ifdef mingw32_HOST_OS+import qualified Data.ByteString.Lazy.UTF8 as L8+#endif  {- 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". -}+ - allows "arbitrary undecodable bytes to be round-tripped through it".+ -} fileEncoding :: Handle -> IO ()+#ifndef mingw32_HOST_OS fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding+#else+{- The file system encoding does not work well on Windows,+ - and Windows only has utf FilePaths anyway. -}+fileEncoding h = hSetEncoding h Encoding.utf8+#endif  {- Marshal a Haskell FilePath into a NUL terminated C string using temporary  - storage. The FilePath is encoded using the filesystem encoding,@@ -60,6 +74,16 @@ md5FilePath :: FilePath -> MD5.Str md5FilePath = MD5.Str . _encodeFilePath +{- Decodes a ByteString into a FilePath, applying the filesystem encoding. -}+decodeBS :: L.ByteString -> FilePath+#ifndef mingw32_HOST_OS+decodeBS = encodeW8 . L.unpack+#else+{- On Windows, we assume that the ByteString is utf-8, since Windows+ - only uses unicode for filenames. -}+decodeBS = L8.toString+#endif+ {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.  -  - w82c produces a String, which may contain Chars that are invalid@@ -84,6 +108,7 @@  - cost of efficiency when running on a large FilePath.  -} truncateFilePath :: Int -> FilePath -> FilePath+#ifndef mingw32_HOST_OS truncateFilePath n = go . reverse   where   	go f =@@ -91,3 +116,17 @@ 		in if length bytes <= n 			then reverse f 			else go (drop 1 f)+#else+{- On Windows, count the number of bytes used by each utf8 character. -}+truncateFilePath n = reverse . go [] n . L8.fromString+  where+	go coll cnt bs+		| cnt <= 0 = coll+		| otherwise = case L8.decode bs of+			Just (c, x) | c /= L8.replacement_char ->+				let x' = fromIntegral x+				in if cnt - x' < 0+					then coll+					else go (c:coll) (cnt - x') (L8.drop 1 bs)+			_ -> coll+#endif
Utility/Misc.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2010-2011 Joey Hess <joey@kitenet.net>  -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause  -}  {-# LANGUAGE CPP #-}@@ -15,11 +15,15 @@ import Data.Char import Data.List import Control.Applicative+import System.Exit #ifndef mingw32_HOST_OS import System.Posix.Process (getAnyProcessStatus) import Utility.Exception #endif +import Utility.FileSystemEncoding+import Utility.Monad+ {- A version of hgetContents that is not lazy. Ensures file is   - all read before it gets closed. -} hGetContentsStrict :: Handle -> IO String@@ -29,7 +33,21 @@ readFileStrict :: FilePath -> IO String readFileStrict = readFile >=> \s -> length s `seq` return s -{- Like break, but the character matching the condition is not included+{-  Reads a file strictly, and using the FileSystemEncoding, so it will+ -  never crash on a badly encoded file. -}+readFileStrictAnyEncoding :: FilePath -> IO String+readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do+	fileEncoding h+	hClose h `after` hGetContentsStrict h++{- Writes a file, using the FileSystemEncoding so it will never crash+ - on a badly encoded content string. -}+writeFileAnyEncoding :: FilePath -> String -> IO ()+writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do+	fileEncoding h+	hPutStr h content++{- Like break, but the item matching the condition is not included  - in the second result list.  -  - separate (== ':') "foo:bar" = ("foo", "bar")@@ -91,18 +109,6 @@ 			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@@ -136,3 +142,7 @@ #else reapZombies = return () #endif++exitBool :: Bool -> IO a+exitBool False = exitFailure+exitBool True = exitSuccess
Utility/Monad.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2010-2012 Joey Hess <joey@kitenet.net>  -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause  -}  module Utility.Monad where
Utility/Path.hs view
@@ -1,8 +1,8 @@ {- path manipulation  -- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>  -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause  -}  {-# LANGUAGE PackageImports, CPP #-}@@ -18,31 +18,62 @@ 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 qualified "MissingH" System.Path as MissingH import Utility.Monad import Utility.UserInfo -{- Makes a path absolute if it's not already.+{- Simplifies a path, removing any ".." or ".", and removing the trailing+ - path separator.+ -+ - On Windows, preserves whichever style of path separator might be used in+ - the input FilePaths. This is done because some programs in Windows+ - demand a particular path separator -- and which one actually varies!+ -+ - This does not guarantee that two paths that refer to the same location,+ - and are both relative to the same location (or both absolute) will+ - yeild the same result. Run both through normalise from System.FilePath+ - to ensure that.+ -}+simplifyPath :: FilePath -> FilePath+simplifyPath path = dropTrailingPathSeparator $ +	joinDrive drive $ joinPath $ norm [] $ splitPath path'+  where+	(drive, path') = splitDrive path++	norm c [] = reverse c+	norm c (p:ps)+		| p' == ".." = norm (drop 1 c) ps+		| p' == "." = norm c ps+		| otherwise = norm (p:c) ps+	  where+		p' = dropTrailingPathSeparator p++{- Makes a path absolute.+ -  - 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.+ - Does not attempt to deal with edge cases or ensure security with+ - untrusted inputs.  -}-absNormPath :: FilePath -> FilePath -> Maybe FilePath+absPathFrom :: FilePath -> FilePath -> FilePath+absPathFrom dir path = simplifyPath (combine dir path)++{- On Windows, this converts the paths to unix-style, in order to run+ - MissingH's absNormPath on them. Resulting path will use / separators. -}+absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath #ifndef mingw32_HOST_OS-absNormPath dir path = MissingH.absNormPath dir path+absNormPathUnix dir path = MissingH.absNormPath dir path #else-absNormPath dir path = Just $ combine dir path+absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path)+  where+	fromdos = replace "\\" "/"+	todos = replace "/" "\\" #endif  {- Returns the parent directory of a path.@@ -72,13 +103,13 @@  - are all equivilant.  -} dirContains :: FilePath -> FilePath -> Bool-dirContains a b = a == b || a' == b' || (a'++[pathSeparator]) `isPrefixOf` b'+dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b'   where-	norm p = fromMaybe "" $ absNormPath p "." 	a' = norm a 	b' = norm b+	norm = normalise . simplifyPath -{- Converts a filename into a normalized, absolute path.+{- Converts a filename into an absolute path.  -  - Unlike Directory.canonicalizePath, this does not require the path  - already exists. -}@@ -87,13 +118,6 @@ 	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:@@ -105,7 +129,7 @@  {- Constructs a relative path from a directory to a file.  -- - Both must be absolute, and normalized (eg with absNormpath).+ - Both must be absolute, and cannot contain .. etc. (eg use absPath first).  -} relPathDirToFile :: FilePath -> FilePath -> FilePath relPathDirToFile from to = join s $ dotdots ++ uncommon@@ -242,13 +266,28 @@  - 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.+ - All spaces and punctuation and other wacky stuff 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 == '/' = '_'+		| isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_' 		| otherwise = c++{- Similar to splitExtensions, but knows that some things in FilePaths+ - after a dot are too long to be extensions. -}+splitShortExtensions :: FilePath -> (FilePath, [String])+splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg"+splitShortExtensions' :: Int -> FilePath -> (FilePath, [String])+splitShortExtensions' maxextension = go []+  where+	go c f+		| len > 0 && len <= maxextension && not (null base) = +			go (ext:c) base+		| otherwise = (f, c)+	  where+		(base, ext) = splitExtension f+		len = length ext
+ Utility/PosixFiles.hs view
@@ -0,0 +1,33 @@+{- POSIX files (and compatablity wrappers).+ -+ - This is like System.PosixCompat.Files, except with a fixed rename.+ -+ - Copyright 2014 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}++module Utility.PosixFiles (+	module X,+	rename+) where++import System.PosixCompat.Files as X hiding (rename)++#ifndef mingw32_HOST_OS+import System.Posix.Files (rename)+#else+import qualified System.Win32.File as Win32+#endif++{- System.PosixCompat.Files.rename on Windows calls renameFile,+ - so cannot rename directories. + -+ - Instead, use Win32 moveFile, which can. It needs to be told to overwrite+ - any existing file. -}+#ifdef mingw32_HOST_OS+rename :: FilePath -> FilePath -> IO ()+rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING+#endif
Utility/Process.hs view
@@ -3,14 +3,14 @@  -  - Copyright 2012 Joey Hess <joey@kitenet.net>  -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause  -}  {-# LANGUAGE CPP, Rank2Types #-}  module Utility.Process ( 	module X,-	CreateProcess,+	CreateProcess(..), 	StdHandle(..), 	readProcess, 	readProcessEnv,@@ -22,15 +22,17 @@ 	createProcessChecked, 	createBackgroundProcess, 	processTranscript,+	processTranscript', 	withHandle, 	withBothHandles, 	withQuietOutput,-	withNullHandle, 	createProcess, 	startInteractiveProcess, 	stdinHandle, 	stdoutHandle, 	stderrHandle,+	processHandle,+	devNull, ) where  import qualified System.Process@@ -44,8 +46,10 @@ import Control.Monad #ifndef mingw32_HOST_OS import System.Posix.IO-import Data.Maybe+#else+import Control.Applicative #endif+import Data.Maybe  import Utility.Misc import Utility.Exception@@ -72,17 +76,17 @@ 		, env = environ 		} -{- Writes a string to a process on its stdin, +{- Runs an action to write 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 ()))+	-> (Maybe (Handle -> IO ())) 	-> IO String-writeReadProcessEnv cmd args environ input adjusthandle = do+writeReadProcessEnv cmd args environ writestdin adjusthandle = do 	(Just inh, Just outh, _, pid) <- createProcess p  	maybe (return ()) (\a -> a inh) adjusthandle@@ -94,7 +98,7 @@ 	_ <- forkIO $ E.evaluate (length output) >> putMVar outMVar ()  	-- now write and flush any input-	when (not (null input)) $ do hPutStr inh input; hFlush inh+	maybe (return ()) (\a -> a inh >> hFlush inh) writestdin 	hClose inh -- done with stdin  	-- wait on the output@@ -160,8 +164,13 @@  - returns a transcript combining its stdout and stderr, and  - whether it succeeded or failed. -} processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)+processTranscript cmd opts input = processTranscript' cmd opts Nothing input++processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool)+processTranscript' cmd opts environ input = do #ifndef mingw32_HOST_OS-processTranscript cmd opts input = do+{- This implementation interleves stdout and stderr in exactly the order+ - the process writes them. -} 	(readf, writef) <- createPipe 	readh <- fdToHandle readf 	writeh <- fdToHandle writef@@ -170,34 +179,53 @@ 			{ std_in = if isJust input then CreatePipe else Inherit 			, std_out = UseHandle writeh 			, std_err = UseHandle writeh+			, env = environ 			} 	hClose writeh -	-- fork off a thread to start consuming the output-	transcript <- hGetContents readh-	outMVar <- newEmptyMVar-	_ <- forkIO $ E.evaluate (length transcript) >> putMVar outMVar ()+	get <- mkreader readh+	writeinput input p+	transcript <- get -	-- 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 ()+	ok <- checkSuccessProcess pid+	return (transcript, ok)+#else+{- This implementation for Windows puts stderr after stdout. -}+	p@(_, _, _, pid) <- createProcess $+		(proc cmd opts)+			{ std_in = if isJust input then CreatePipe else Inherit+			, std_out = CreatePipe+			, std_err = CreatePipe+			, env = environ+			} -	-- wait on the output-	takeMVar outMVar-	hClose readh+	getout <- mkreader (stdoutHandle p)+	geterr <- mkreader (stderrHandle p)+	writeinput input p+	transcript <- (++) <$> getout <*> geterr  	ok <- checkSuccessProcess pid 	return (transcript, ok)-#else-processTranscript = error "processTranscript TODO" #endif+  where+	mkreader h = do+		s <- hGetContents h+		v <- newEmptyMVar+		void $ forkIO $ do+			void $ E.evaluate (length s)+			putMVar v ()+		return $ do+			takeMVar v+			return s +	writeinput (Just s) p = do+		let inh = stdinHandle p+		unless (null s) $ do+			hPutStr inh s+			hFlush inh+		hClose inh+	writeinput Nothing _ = return ()+ {- 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. -}@@ -242,20 +270,18 @@ 	:: CreateProcessRunner 	-> CreateProcess 	-> IO ()-withQuietOutput creator p = withNullHandle $ \nullh -> do+withQuietOutput creator p = withFile devNull WriteMode $ \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+devNull :: FilePath #ifndef mingw32_HOST_OS-	devnull = "/dev/null"+devNull = "/dev/null" #else-	devnull = "NUL"+devNull = "NUL" #endif  {- Extract a desired handle from createProcess's tuple.@@ -276,6 +302,9 @@ bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) bothHandles (Just hin, Just hout, _, _) = (hin, hout) bothHandles _ = error "expected bothHandles"++processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle+processHandle (_, _, _, pid) = pid  {- Debugging trace for a CreateProcess. -} debugProcess :: CreateProcess -> IO ()
Utility/SafeCommand.hs view
@@ -2,14 +2,13 @@  -  - Copyright 2010-2013 Joey Hess <joey@kitenet.net>  -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause  -}  module Utility.SafeCommand where  import System.Exit import Utility.Process-import System.Process (env) import Data.String.Utils import Control.Applicative import System.FilePath
Utility/Tmp.hs view
@@ -2,19 +2,22 @@  -  - Copyright 2010-2013 Joey Hess <joey@kitenet.net>  -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause  -} +{-# LANGUAGE CPP #-}+ module Utility.Tmp where  import Control.Exception (bracket) import System.IO import System.Directory import Control.Monad.IfElse+import System.FilePath  import Utility.Exception-import System.FilePath import Utility.FileSystemEncoding+import Utility.PosixFiles  type Template = String @@ -22,13 +25,20 @@  - 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+viaTmp a file content = bracket setup cleanup use+  where+	(dir, base) = splitFileName file+	template = base ++ ".tmp"+	setup = do+		createDirectoryIfMissing True dir+		openTempFile dir template+	cleanup (tmpfile, handle) = do+		_ <- tryIO $ hClose handle+		tryIO $ removeFile tmpfile+	use (tmpfile, handle) = do+		hClose handle+		a tmpfile content+		rename tmpfile file  {- Runs an action with a tmp file located in the system's tmp directory  - (or in "." if there is none) then removes the file. -}@@ -61,8 +71,17 @@ withTmpDirIn :: FilePath -> Template -> (FilePath -> IO a) -> IO a withTmpDirIn tmpdir template = bracket create remove   where-	remove d = whenM (doesDirectoryExist d) $+	remove d = whenM (doesDirectoryExist d) $ do+#if mingw32_HOST_OS+		-- Windows will often refuse to delete a file+		-- after a process has just written to it and exited.+		-- Because it's crap, presumably. So, ignore failure+		-- to delete the temp directory.+		_ <- tryIO $ removeDirectoryRecursive d+		return ()+#else 		removeDirectoryRecursive d+#endif 	create = do 		createDirectoryIfMissing True tmpdir 		makenewdir (tmpdir </> template) (0 :: Int)
+ Utility/URI.hs view
@@ -0,0 +1,18 @@+{- Network.URI+ -+ - Copyright 2014 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}++module Utility.URI where++-- Old versions of network lacked an Ord for URI+#if ! MIN_VERSION_network(2,4,0)+import Network.URI++instance Ord URI where+	a `compare` b = show a `compare` show b+#endif
Utility/UserInfo.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2012 Joey Hess <joey@kitenet.net>  -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause  -}  {-# LANGUAGE CPP #-}
debian/changelog view
@@ -1,3 +1,22 @@+github-backup (1.20140707) unstable; urgency=medium++  * Add --exclude to skip backing up a specific repository+    when backing up a user or organization's repositories.+    Closes: #754072+  * Converted to using optparse-applicative.+  * Multiple usernames can now be specified to back up at once.++ -- Joey Hess <joeyh@debian.org>  Mon, 07 Jul 2014 23:01:03 -0400++github-backup (1.20140704) unstable; urgency=medium++  * Avoid making signed commits when committing to the github-backup branch+    and the user has commit.gpgsign=true.+    Closes: #753720+  * Various updates to internal git and utility libraries shared with git-annex.++ -- Joey Hess <joeyh@debian.org>  Fri, 04 Jul 2014 12:01:11 -0400+ github-backup (1.20131203) unstable; urgency=low    * Now also backs up the repos a user has starred, when run with a user's
debian/control view
@@ -11,9 +11,10 @@ 	libghc-pretty-show-dev, 	libghc-ifelse-dev, 	libghc-extensible-exceptions-dev,-	libghc-unix-compat-dev+	libghc-unix-compat-dev,+	libghc-optparse-applicative-dev Maintainer: Joey Hess <joeyh@debian.org>-Standards-Version: 3.9.4+Standards-Version: 3.9.5 Vcs-Git: git://github.com/joeyh/github-backup.git Homepage: http://github.com/joeyh/github-backup
debian/copyright view
@@ -7,3 +7,29 @@  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.++Files: Utility/*+Copyright: 2012-2014 Joey Hess <joey@kitenet.net>+License: BSD-2-clause++License: BSD-2-clause+ Redistribution and use in source and binary forms, with or without+ modification, are permitted provided that the following conditions+ are met:+ 1. Redistributions of source code must retain the above copyright+    notice, this list of conditions and the following disclaimer.+ 2. Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in the+    documentation and/or other materials provided with the distribution.+ .+ THIS SOFTWARE IS PROVIDED BY AUTHORS AND CONTRIBUTORS ``AS IS'' AND+ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+ SUCH DAMAGE.
github-backup.1 view
@@ -3,7 +3,7 @@ .SH NAME github-backup \- backs up data from GitHub .SH SYNOPSIS-.B github-backup [\fIusername\fP|\fIorganization\fP]+.B github-backup [\fIusername\fP|\fIorganization\fP ...] [--exclude=username/repository ...] .SH DESCRIPTION .I github-backup is a simple tool you run in a git repository you cloned from@@ -18,7 +18,7 @@ .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+this only works around API rate limiting; it does not allow private repositories to be downloaded. .SH AUTHOR  Joey Hess <joey@kitenet.net>
github-backup.cabal view
@@ -1,5 +1,5 @@ Name: github-backup-Version: 1.20131203+Version: 1.20140707 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess <joey@kitenet.net>@@ -21,7 +21,9 @@   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+   IfElse, pretty-show, text, process, optparse-applicative,+   github >= 0.7.2,+   base >= 4.5, base < 5    if (! os(windows))     Build-Depends: unix
github-backup.hs view
@@ -16,11 +16,10 @@ import Data.Text.Encoding (encodeUtf8) import Data.Either import Data.Monoid-import System.Environment (getArgs)+import Options.Applicative 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@@ -353,7 +352,7 @@ 					[genstream dir h] 				hashObjectStop h 				-- Commit-				void $ Git.Branch.commit "github-backup" fullname [branchref] r+				void $ Git.Branch.commit Git.Branch.AutomaticCommit False "github-backup" fullname [branchref] r 				removeDirectoryRecursive dir   where   	genstream dir h streamer = do@@ -374,7 +373,7 @@ 		fromMaybe (error $ "failed to create " ++ show branchname) 			<$> branchsha 	create False = withIndex $-		inRepo $ Git.Branch.commit "branch created" fullname []+		inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit "branch created" fullname [] 	branchsha = inRepo $ Git.Ref.sha fullname  {- Runs an action with a different index file, used for the github branch. -}@@ -580,8 +579,8 @@ 		-- more actions to be deferred; run them too. 		runDeferred -backupName :: String -> IO ()-backupName name = do+backupOwner :: [GithubUserRepo] -> Owner -> IO ()+backupOwner exclude (Owner name) = do 	auth <- getAuth 	l <- sequence 	 	[ Github.userRepos' auth name Github.All@@ -596,16 +595,7 @@ 			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+	states <- catMaybes <$> forM nameurls prepare 	-- First pass only retries things that failed before, so the 	-- retried actions will run in each repo before too much API is 	-- used up.@@ -613,15 +603,62 @@ 	states'' <- forM states' (execStateT . runBackup $ mainBackup) 	forM states'' (evalStateT . runBackup $ runDeferred >> save) 		>>= showFailures . concat+  where+	excludeurls = map repoUrl exclude+	prepare (dir, url)+		| url `elem` excludeurls = return Nothing+		| otherwise = do+			print url+			unlessM (doesDirectoryExist dir) $ do+				putStrLn $ "New repository: " ++ dir+				ok <- boolSystem "git"+					[ Param "clone"+					, Param url+					, Param dir+					]+				unless ok $ error "clone failed"+			Just <$> (genBackupState =<< Git.Construct.fromPath dir) -usage :: String-usage = "usage: github-backup [username|organization]"+data Options = Options+	{ includeOwner :: [Owner]+	, excludeRepo :: [GithubUserRepo]+	}+	deriving (Show) -main :: IO ()-main = getArgs >>= go+data Owner = Owner String+	deriving (Show)++options :: Parser Options+options = Options <$> many owneropt <*> many excludeopt   where-	go (('-':_):_) = error usage-	go [] = backupRepo =<< Git.Construct.fromCwd-	go (name:[]) = backupName name-	go _= error usage+	owneropt = (argument (Just . Owner))+		( metavar "USERNAME|ORGANIZATION"+		<> help "Back up repositories owned by this entity."+		)+	excludeopt = parseUserRepo <$> (strOption+		( long "exclude"+		<> metavar "USERNAME/REPOSITORY"+		<> help "Skip backing up a repository."+		)) +parseUserRepo :: String -> GithubUserRepo+parseUserRepo s =+	let (user, repo) = separate (== '/') s+	in GithubUserRepo user repo++main :: IO ()+main = execParser opts >>= go+  where+	opts = info (helper <*> options)+		( fullDesc+		<> progDesc desc+		<> header "github-backup - backs up data from GitHub"+		)+	desc = unlines+		[ "Backs up all forks, issues, etc of a GitHub repository."+		, "Run without any parameters inside a clone of a repository to back it up."+		, "Or, specify whose repositories to back up."+		]+	go (Options owner exclude)+		| null owner = backupRepo =<< Git.Construct.fromCwd+		| otherwise = mapM_ (backupOwner exclude) owner