github-backup 1.20130414 → 1.20131006

raw patch · 45 files changed

+1553/−327 lines, 45 filesdep +unix-compatbuild-type:Customsetup-changed

Dependencies added: unix-compat

Files

.gitignore +0/−4
Build/Configure.hs +30/−0
Build/TestConfig.hs +143/−0
Build/Version.hs +69/−0
Common.hs +8/−7
Git.hs +10/−0
Git/Branch.hs +8/−4
Git/BuildVersion.hs +21/−0
Git/Command.hs +32/−14
Git/Config.hs +35/−0
Git/Construct.hs +28/−48
Git/FilePath.hs +58/−0
Git/HashObject.hs +43/−0
Git/Queue.hs +3/−4
Git/Ref.hs +22/−11
Git/Remote.hs +112/−0
Git/Types.hs +1/−1
Git/UpdateIndex.hs +80/−0
Git/Version.hs +43/−0
Makefile +13/−29
README.md +2/−0
Setup.hs +15/−1
Utility/Applicative.hs +16/−0
Utility/CoProcess.hs +73/−15
Utility/Data.hs +17/−0
Utility/Directory.hs +24/−11
Utility/Env.hs +63/−0
Utility/Exception.hs +10/−2
Utility/FileMode.hs +29/−6
Utility/FileSystemEncoding.hs +18/−2
Utility/Misc.hs +27/−1
Utility/Monad.hs +5/−1
Utility/Path.hs +101/−11
Utility/Process.hs +88/−29
Utility/SafeCommand.hs +39/−6
Utility/TempFile.hs +0/−58
Utility/Tmp.hs +88/−0
Utility/UserInfo.hs +23/−4
configure.hs +6/−0
debian/changelog +39/−0
debian/control +4/−2
debian/copyright +1/−1
debian/rules +7/−0
github-backup.cabal +7/−4
github-backup.hs +92/−51

− .gitignore

@@ -1,4 +0,0 @@-tmp-*.hi-*.o-github-backup

+ Build/Configure.hs view

@@ -0,0 +1,30 @@+{- Checks system configuration and generates SysConfig.hs. -}++module Build.Configure where++import System.Environment+import Control.Applicative+import Control.Monad.IfElse++import Build.TestConfig+import Build.Version+import Git.Version++tests :: [TestCase]+tests =+	[ TestCase "version" getVersion+	, TestCase "git" $ requireCmd "git" "git --version >/dev/null"+	, TestCase "git version" getGitVersion+	]++getGitVersion :: Test+getGitVersion = Config "gitversion" . StringConfig . show+	<$> Git.Version.installed++run :: [TestCase] -> IO ()+run ts = do+	args <- getArgs+	config <- runTests ts+	writeSysConfig config+	whenM (isReleaseBuild) $+		cabalSetup "github-backup.cabal"

+ Build/TestConfig.hs view

@@ -0,0 +1,143 @@+{- Tests the system and generates Build.SysConfig.hs. -}++module Build.TestConfig where++import Utility.Path+import Utility.Monad+import Utility.SafeCommand++import System.IO+import System.Cmd+import System.Exit+import System.FilePath+import System.Directory++type ConfigKey = String+data ConfigValue =+	BoolConfig Bool |+	StringConfig String |+	MaybeStringConfig (Maybe String) |+	MaybeBoolConfig (Maybe Bool)+data Config = Config ConfigKey ConfigValue++type Test = IO Config+type TestName = String+data TestCase = TestCase TestName Test++instance Show ConfigValue where+	show (BoolConfig b) = show b+	show (StringConfig s) = show s+	show (MaybeStringConfig s) = show s+	show (MaybeBoolConfig s) = show s++instance Show Config where+	show (Config key value) = unlines+		[ key ++ " :: " ++ valuetype value+		, key ++ " = " ++ show value+		]+	  where+		valuetype (BoolConfig _) = "Bool"+		valuetype (StringConfig _) = "String"+		valuetype (MaybeStringConfig _) = "Maybe String"+		valuetype (MaybeBoolConfig _) = "Maybe Bool"++writeSysConfig :: [Config] -> IO ()+writeSysConfig config = writeFile "Build/SysConfig.hs" body+  where+	body = unlines $ header ++ map show config ++ footer+	header = [+		  "{- Automatically generated. -}"+		, "module Build.SysConfig where"+		, ""+		]+	footer = []++runTests :: [TestCase] -> IO [Config]+runTests [] = return []+runTests (TestCase tname t : ts) = do+	testStart tname+	c <- t+	testEnd c+	rest <- runTests ts+	return $ c:rest++{- Tests that a command is available, aborting if not. -}+requireCmd :: ConfigKey -> String -> Test+requireCmd k cmdline = do+	ret <- testCmd k cmdline+	handle ret+  where+	handle r@(Config _ (BoolConfig True)) = return r+	handle r = do+		testEnd r+		error $ "** the " ++ c ++ " command is required"+	c = head $ words cmdline++{- Checks if a command is available by running a command line. -}+testCmd :: ConfigKey -> String -> Test+testCmd k cmdline = do+	ok <- boolSystem "sh" [ Param "-c", Param $ quiet cmdline ]+	return $ Config k (BoolConfig ok)++{- Ensures that one of a set of commands is available by running each in+ - turn. The Config is set to the first one found. -}+selectCmd :: ConfigKey -> [(String, String)] -> Test+selectCmd k = searchCmd+		(return . Config k . StringConfig)+		(\cmds -> do+			testEnd $ Config k $ BoolConfig False+			error $ "* need one of these commands, but none are available: " ++ show cmds+		)++maybeSelectCmd :: ConfigKey -> [(String, String)] -> Test+maybeSelectCmd k = searchCmd+		(return . Config k . MaybeStringConfig . Just)+		(\_ -> return $ Config k $ MaybeStringConfig Nothing)++searchCmd :: (String -> Test) -> ([String] -> Test) -> [(String, String)] -> Test+searchCmd success failure cmdsparams = search cmdsparams+  where+	search [] = failure $ fst $ unzip cmdsparams+	search ((c, params):cs) = do+		ok <- boolSystem "sh" [ Param "-c", Param $ quiet $ c ++ " " ++ params ]+		if ok+			then success c+			else search cs++{- Finds a command, either in PATH or perhaps in a sbin directory not in+ - PATH. If it's in PATH the config is set to just the command name,+ - but if it's found outside PATH, the config is set to the full path to+ - the command. -}+findCmdPath :: ConfigKey -> String -> Test+findCmdPath k command = do+	ifM (inPath command)+		( return $ Config k $ MaybeStringConfig $ Just command+		, do+			r <- getM find ["/usr/sbin", "/sbin", "/usr/local/sbin"]+			return $ Config k $ MaybeStringConfig r+		)+  where+	find d =+		let f = d </> command+		in ifM (doesFileExist f) ( return (Just f), return Nothing )++quiet :: String -> String+quiet s = s ++ " >/dev/null 2>&1"++testStart :: TestName -> IO ()+testStart s = do+	putStr $ "  checking " ++ s ++ "..."+	hFlush stdout++testEnd :: Config -> IO ()+testEnd (Config _ (BoolConfig True)) = status "yes"+testEnd (Config _ (BoolConfig False)) = status "no"+testEnd (Config _ (StringConfig s)) = status s+testEnd (Config _ (MaybeStringConfig (Just s))) = status s+testEnd (Config _ (MaybeStringConfig Nothing)) = status "not available"+testEnd (Config _ (MaybeBoolConfig (Just True))) = status "yes"+testEnd (Config _ (MaybeBoolConfig (Just False))) = status "no"+testEnd (Config _ (MaybeBoolConfig Nothing)) = status "unknown"++status :: String -> IO ()+status s = putStrLn $ ' ':s

+ Build/Version.hs view

@@ -0,0 +1,69 @@+{- Package version determination, for configure script. -}++module Build.Version where++import Data.Maybe+import Control.Applicative+import Data.List+import System.Environment+import System.Directory+import Data.Char+import System.Process++import Build.TestConfig+import Utility.Monad+import Utility.Exception++{- Set when making an official release. (Distribution vendors should set+ - this too.) -}+isReleaseBuild :: IO Bool+isReleaseBuild = isJust <$> catchMaybeIO (getEnv "RELEASE_BUILD")++{- Version is usually based on the major version from the changelog, + - plus the date of the last commit, plus the git rev of that commit.+ - This works for autobuilds, ad-hoc builds, etc.+ -+ - If git or a git repo is not available, or something goes wrong,+ - or this is a release build, just use the version from the changelog. -}+getVersion :: Test+getVersion = do+	changelogversion <- getChangelogVersion+	version <- ifM (isReleaseBuild)+		( return changelogversion+		, catchDefaultIO changelogversion $ do+			let major = takeWhile (/= '.') changelogversion+			autoversion <- readProcess "sh"+				[ "-c"+				, "git log -n 1 --format=format:'%ci %h'| sed -e 's/-//g' -e 's/ .* /-g/'"+				] ""+			if null autoversion+				then return changelogversion+				else return $ concat [ major, ".", autoversion ]+		)+	return $ Config "packageversion" (StringConfig version)+	+getChangelogVersion :: IO String+getChangelogVersion = do+	changelog <- readFile "debian/changelog"+	let verline = takeWhile (/= '\n') changelog+	return $ middle (words verline !! 1)+  where+	middle = drop 1 . init++{- Set up cabal file with version. -}+cabalSetup :: FilePath -> IO ()+cabalSetup cabalfile = do+	version <- takeWhile (\c -> isDigit c || c == '.')+		<$> getChangelogVersion+	cabal <- readFile cabalfile+	writeFile tmpcabalfile $ unlines $ +		map (setfield "Version" version) $+		lines cabal+	renameFile tmpcabalfile cabalfile+  where+	tmpcabalfile = cabalfile++".tmp"+	setfield field value s+		| fullfield `isPrefixOf` s = fullfield ++ value+		| otherwise = s+	  where+		fullfield = field ++ ": "

Common.hs view

@@ -1,8 +1,8 @@-{-# LANGUAGE PackageImports #-}+{-# LANGUAGE PackageImports, CPP #-}  module Common (module X) where -import Control.Monad as X hiding (join)+import Control.Monad as X import Control.Monad.IfElse as X import Control.Applicative as X import "mtl" Control.Monad.State.Strict as X (liftIO)@@ -10,16 +10,15 @@  import Data.Maybe as X import Data.List as X hiding (head, tail, init, last)-import Data.String.Utils as X+import Data.String.Utils as X hiding (join) -import System.Path as X import System.FilePath as X import System.Directory as X-import System.Cmd.Utils as X hiding (safeSystem) import System.IO as X hiding (FilePath)-import System.Posix.Files as X+import System.PosixCompat.Files as X+#ifndef mingw32_HOST_OS import System.Posix.IO as X-import System.Posix.Process as X hiding (executeFile)+#endif import System.Exit as X  import Utility.Misc as X@@ -29,6 +28,8 @@ import Utility.Path as X import Utility.Directory as X import Utility.Monad as X+import Utility.Data as X+import Utility.Applicative as X import Utility.FileSystemEncoding as X  import Utility.PartialPrelude as X

Git.hs view

@@ -8,6 +8,8 @@  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE CPP #-}+ module Git ( 	Repo(..), 	Ref(..),@@ -30,11 +32,15 @@ ) where  import Network.URI (uriPath, uriScheme, unEscapeString)+#ifndef mingw32_HOST_OS import System.Posix.Files+#endif  import Common import Git.Types+#ifndef mingw32_HOST_OS import Utility.FileMode+#endif  {- User-visible description of a git repo. -} repoDescribe :: Repo -> String@@ -127,4 +133,8 @@ 	ifM (catchBoolIO $ isexecutable hook) 		( return $ Just hook , return Nothing )   where+#if mingw32_HOST_OS+	isexecutable f = doesFileExist f+#else 	isexecutable f = isExecutable . fileMode <$> getFileStatus f+#endif

Git/Branch.hs view

@@ -13,6 +13,7 @@ import Git import Git.Sha import Git.Command+import Git.Ref (headRef)  {- The currently checked out branch.  -@@ -35,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 "HEAD"] r+	<$> pipeReadStrict [Param "symbolic-ref", Param $ show headRef] r   where 	parse l 		| null l = Nothing@@ -73,8 +74,7 @@   where 	no_ff = return False 	do_ff to = do-		run "update-ref"-			[Param $ show branch, Param $ show to] repo+		run [Param "update-ref", Param $ show branch, Param $ show to] repo 		return True 	findbest c [] = return $ Just c 	findbest c (r:rs)@@ -97,7 +97,11 @@ 	sha <- getSha "commit-tree" $ pipeWriteRead 		(map Param $ ["commit-tree", show tree] ++ ps) 		message repo-	run "update-ref" [Param $ show branch, Param $ show sha] repo+	run [Param "update-ref", Param $ show branch, Param $ show sha] repo 	return sha   where 	ps = concatMap (\r -> ["-p", show r]) parentrefs++{- A leading + makes git-push force pushing a branch. -}+forcePush :: String -> String+forcePush b = "+" ++ b

+ Git/BuildVersion.hs view

@@ -0,0 +1,21 @@+{- git build version+ -+ - Copyright 2011 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.BuildVersion where++import Git.Version+import qualified Build.SysConfig++{- Using the version it was configured for avoids running git to check its+ - version, at the cost that upgrading git won't be noticed.+ - This is only acceptable because it's rare that git's version influences+ - code's behavior. -}+buildVersion :: GitVersion+buildVersion = normalize Build.SysConfig.gitversion++older :: String -> Bool+older n = buildVersion < normalize n

Git/Command.hs view

@@ -25,19 +25,25 @@ gitCommandLine _ repo = assertLocal repo $ error "internal"  {- Runs git in the specified repo. -}-runBool :: String -> [CommandParam] -> Repo -> IO Bool-runBool subcommand params repo = assertLocal repo $+runBool :: [CommandParam] -> Repo -> IO Bool+runBool params repo = assertLocal repo $ 	boolSystemEnv "git"-		(gitCommandLine (Param subcommand : params) repo)+		(gitCommandLine params repo) 		(gitEnv repo)  {- Runs git in the specified repo, throwing an error if it fails. -}-run :: String -> [CommandParam] -> Repo -> IO ()-run subcommand params repo = assertLocal repo $-	unlessM (runBool subcommand params repo) $-		error $ "git " ++ subcommand ++ " " ++ show params ++ " failed"+run :: [CommandParam] -> Repo -> IO ()+run params repo = assertLocal repo $+	unlessM (runBool params repo) $+		error $ "git " ++ show params ++ " failed" -{- Runs a git subcommand and returns its output, lazily.+{- Runs git and forces it to be quiet, throwing an error if it fails. -}+runQuiet :: [CommandParam] -> Repo -> IO ()+runQuiet params repo = withQuietOutput createProcessSuccess $+	(proc "git" $ toCommand $ gitCommandLine (params) repo)+		{ env = gitEnv repo }++{- Runs a git command and returns its output, lazily.  -  - Also returns an action that should be used when the output is all  - read (or no more is needed), that will wait on the command, and@@ -52,7 +58,7 @@   where 	p  = gitCreateProcess params repo -{- Runs a git subcommand, and returns its output, strictly.+{- Runs a git command, and returns its output, strictly.  -  - Nonzero exit status is ignored.  -}@@ -66,15 +72,19 @@   where 	p  = gitCreateProcess params repo -{- Runs a git subcommand, feeding it input, and returning its output,+{- Runs a git command, feeding it input, and returning its output,  - which is expected to be fairly small, since it's all read into memory  - strictly. -} pipeWriteRead :: [CommandParam] -> String -> Repo -> IO String pipeWriteRead params s repo = assertLocal repo $ 	writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) -		(gitEnv repo) s (Just fileEncoding)+		(gitEnv repo) s (Just adjusthandle)+  where+  	adjusthandle h = do+		fileEncoding h+		hSetNewlineMode h noNewlineTranslation -{- Runs a git subcommand, feeding it input on a handle with an action. -}+{- Runs a git command, feeding it input on a handle with an action. -} pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO () pipeWrite params repo = withHandle StdinHandle createProcessSuccess $ 	gitCreateProcess params repo@@ -88,6 +98,12 @@   where 	sep = "\0" +pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [String]+pipeNullSplitStrict params repo = do+	s <- pipeReadStrict params repo+	return $ filter (not . null) $ split sep s+  where+	sep = "\0"  pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String] pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo@@ -97,8 +113,10 @@ leaveZombie = fst  {- Runs a git command as a coprocess. -}-gitCoProcessStart :: [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle-gitCoProcessStart params repo = CoProcess.start "git" (toCommand $ gitCommandLine params repo) (gitEnv repo)+gitCoProcessStart :: Bool -> [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle+gitCoProcessStart restartable params repo = CoProcess.start restartable "git"+	(toCommand $ gitCommandLine params repo)+	(gitEnv repo)  gitCreateProcess :: [CommandParam] -> Repo -> CreateProcess gitCreateProcess params repo =

Git/Config.hs view

@@ -10,6 +10,7 @@ import qualified Data.Map as M import Data.Char import System.Process (cwd, env)+import Control.Exception.Extensible  import Common import Git@@ -153,3 +154,37 @@  isBare :: Repo -> Bool isBare r = fromMaybe False $ isTrue =<< getMaybe "core.bare" r++{- Runs a command to get the configuration of a repo,+ - and returns a repo populated with the configuration, as well as the raw+ - output of the command. -}+fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String))+fromPipe r cmd params = try $+	withHandle StdoutHandle createProcessSuccess p $ \h -> do+ 		fileEncoding h+		val <- hGetContentsStrict h+		r' <- store val r+		return (r', val)+  where+	p = proc cmd $ toCommand params++{- Reads git config from a specified file and returns the repo populated+ - with the configuration. -}+fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String))+fromFile r f = fromPipe r "git"+	[ Param "config"+	, Param "--file"+	, File f+	, Param "--list"+	]++{- Changes a git config setting in the specified config file.+ - (Creates the file if it does not already exist.) -}+changeFile :: FilePath -> String -> String -> IO Bool+changeFile f k v = boolSystem "git"+	[ Param "config"+	, Param "--file"+	, File f+	, Param k+	, Param v+	]

Git/Construct.hs view

@@ -5,6 +5,8 @@  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE CPP #-}+ module Git.Construct ( 	fromCwd, 	fromAbsPath,@@ -17,31 +19,35 @@ 	fromRemotes, 	fromRemoteLocation, 	repoAbsPath,+	newFrom,+	checkForRepo, ) where +#ifndef mingw32_HOST_OS import System.Posix.User+#endif import qualified Data.Map as M hiding (map, split) import Network.URI  import Common import Git.Types import Git+import Git.Remote import qualified Git.Url as Url import Utility.UserInfo  {- Finds the git repository used for the cwd, which may be in a parent  - directory. -}-fromCwd :: IO Repo-fromCwd = getCurrentDirectory >>= seekUp checkForRepo+fromCwd :: IO (Maybe Repo)+fromCwd = getCurrentDirectory >>= seekUp   where-	norepo = error "Not in a git repository."-	seekUp check dir = do-		r <- check dir+	seekUp dir = do+		r <- checkForRepo dir 		case r of 			Nothing -> case parentDir dir of-				"" -> norepo-				d -> seekUp check d-			Just loc -> newFrom loc+				"" -> return Nothing+				d -> seekUp d+			Just loc -> Just <$> newFrom loc  {- Local Repo constructor, accepts a relative or absolute path. -} fromPath :: FilePath -> IO Repo@@ -51,8 +57,7 @@  - specified. -} fromAbsPath :: FilePath -> IO Repo fromAbsPath dir-	| "/" `isPrefixOf` dir =-		ifM (doesDirectoryExist dir') ( ret dir' , hunt )+	| isAbsolute dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt ) 	| otherwise = 		error $ "internal error, " ++ dir ++ " is not absolute"   where@@ -64,7 +69,7 @@ 	{- When dir == "foo/.git", git looks for "foo/.git/.git", 	 - and failing that, uses "foo" as the repository. -} 	hunt-		| "/.git" `isSuffixOf` canondir =+		| (pathSeparator:".git") `isSuffixOf` canondir = 			ifM (doesDirectoryExist $ dir </> ".git") 				( ret dir 				, ret $ takeDirectory canondir@@ -83,7 +88,7 @@  fromUrlStrict :: String -> IO Repo fromUrlStrict url-	| startswith "file://" url = fromAbsPath $ uriPath u+	| startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u 	| otherwise = newFrom $ Url u   where 	u = fromMaybe bad $ parseURI url@@ -129,47 +134,16 @@ remoteNamedFromKey :: String -> IO Repo -> IO Repo remoteNamedFromKey k = remoteNamed basename   where-	basename = join "." $ reverse $ drop 1 $ reverse $ drop 1 $ split "." k+	basename = intercalate "." $ +		reverse $ drop 1 $ reverse $ drop 1 $ split "." k  {- Constructs a new Repo for one of a Repo's remotes using a given  - location (ie, an url). -} fromRemoteLocation :: String -> Repo -> IO Repo-fromRemoteLocation s repo = gen $ calcloc s+fromRemoteLocation s repo = gen $ parseRemoteLocation s repo   where-	gen v	-		| scpstyle v = fromUrl $ scptourl v-		| urlstyle v = fromUrl v-		| otherwise = fromRemotePath v repo-	-- insteadof config can rewrite remote location-	calcloc l-		| null insteadofs = l-		| otherwise = replacement ++ drop (length bestvalue) l-	  where-		replacement = drop (length prefix) $-			take (length bestkey - length suffix) bestkey-		(bestkey, bestvalue) = maximumBy longestvalue insteadofs-		longestvalue (_, a) (_, b) = compare b a-		insteadofs = filterconfig $ \(k, v) -> -			startswith prefix k &&-			endswith suffix k &&-			startswith v l-		filterconfig f = filter f $-			concatMap splitconfigs $ M.toList $ fullconfig repo-		splitconfigs (k, vs) = map (\v -> (k, v)) vs-		(prefix, suffix) = ("url." , ".insteadof")-	urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v-	-- git remotes can be written scp style -- [user@]host:dir-	-- but foo::bar is a git-remote-helper location instead-	scpstyle v = ":" `isInfixOf` v -		&& not ("//" `isInfixOf` v)-		&& not ("::" `isInfixOf` v)-	scptourl v = "ssh://" ++ host ++ slash dir-	  where-		(host, dir) = separate (== ':') v-		slash d	| d == "" = "/~/" ++ d-			| "/" `isPrefixOf` d = d-			| "~" `isPrefixOf` d = '/':d-			| otherwise = "/~/" ++ d+	gen (RemotePath p) = fromRemotePath p repo+	gen (RemoteUrl u) = fromUrl u  {- Constructs a Repo from the path specified in the git remotes of  - another Repo. -}@@ -190,6 +164,9 @@ 	return $ h </> d'  expandTilde :: FilePath -> IO FilePath+#ifdef mingw32_HOST_OS+expandTilde = return+#else expandTilde = expandt True   where 	expandt _ [] = return ""@@ -210,7 +187,10 @@ 	findname n (c:cs) 		| c == '/' = (n, cs) 		| otherwise = findname (n++[c]) cs+#endif +{- Checks if a git repository exists in a directory. Does not find+ - git repositories in parent directories. -} checkForRepo :: FilePath -> IO (Maybe RepoLocation) checkForRepo dir =  	check isRepo $

+ Git/FilePath.hs view

@@ -0,0 +1,58 @@+{- git FilePath library+ -+ - Different git commands use different types of FilePaths to refer to+ - files in the repository. Some commands use paths relative to the+ - top of the repository even when run in a subdirectory. Adding some+ - types helps keep that straight.+ -+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Git.FilePath (+	TopFilePath,+	getTopFilePath,+	toTopFilePath,+	asTopFilePath,+	InternalGitPath,+	toInternalGitPath,+	fromInternalGitPath+) where++import Common+import Git++{- A FilePath, relative to the top of the git repository. -}+newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }++{- The input FilePath can be absolute, or relative to the CWD. -}+toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath+toTopFilePath file repo = TopFilePath <$>+	relPathDirToFile (repoPath repo) <$> absPath file++{- The input FilePath must already be relative to the top of the git+ - repository -}+asTopFilePath :: FilePath -> TopFilePath+asTopFilePath file = TopFilePath file++{- Git may use a different representation of a path when storing+ - it internally. For example, on Windows, git uses '/' to separate paths+ - stored in the repository, despite Windows using '\' -}+type InternalGitPath = String++toInternalGitPath :: FilePath -> InternalGitPath+#ifndef mingw32_HOST_OS+toInternalGitPath = id+#else+toInternalGitPath = replace "\\" "/"+#endif++fromInternalGitPath :: InternalGitPath -> FilePath+#ifndef mingw32_HOST_OS+fromInternalGitPath = id+#else+fromInternalGitPath = replace "/" "\\"+#endif

+ Git/HashObject.hs view

@@ -0,0 +1,43 @@+{- git hash-object interface+ -+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.HashObject where++import Common+import Git+import Git.Sha+import Git.Command+import Git.Types+import qualified Utility.CoProcess as CoProcess++type HashObjectHandle = CoProcess.CoProcessHandle++hashObjectStart :: Repo -> IO HashObjectHandle+hashObjectStart = CoProcess.rawMode <=< gitCoProcessStart True+	[ Param "hash-object"+	, Param "-w"+	, Param "--stdin-paths"+	, Param "--no-filters"+	]++hashObjectStop :: HashObjectHandle -> IO ()+hashObjectStop = CoProcess.stop++{- Injects a file into git, returning the Sha of the object. -}+hashFile :: HashObjectHandle -> FilePath -> IO Sha+hashFile h file = CoProcess.query h send receive+  where+	send to = hPutStrLn to file+	receive from = getSha "hash-object" $ hGetLine from++{- Injects some content into git, returning its Sha. -}+hashObject :: ObjectType -> String -> Repo -> IO Sha+hashObject objtype content repo = getSha subcmd $+	pipeWriteRead (map Param params) content repo+  where+	subcmd = "hash-object"+	params = [subcmd, "-t", show objtype, "-w", "--stdin", "--no-filters"]

Git/Queue.hs view

@@ -20,7 +20,6 @@ import qualified Data.Map as M import System.IO import System.Process-import Data.String.Utils  import Utility.SafeCommand import Common@@ -41,7 +40,7 @@ 	| CommandAction  		{ getSubcommand :: String 		, getParams :: [CommandParam]-		, getFiles :: [FilePath]+		, getFiles :: [CommandParam] 		}   {- A key that can uniquely represent an action in a Map. -}@@ -93,7 +92,7 @@ 		, getParams = params 		, getFiles = newfiles 		}-	newfiles = files ++ maybe [] getFiles (M.lookup key $ items q)+	newfiles = map File files ++ maybe [] getFiles (M.lookup key $ items q) 		 	different (CommandAction { getSubcommand = s }) = s /= subcommand 	different _ = True@@ -151,7 +150,7 @@ runAction repo action@(CommandAction {}) = 	withHandle StdinHandle createProcessSuccess p $ \h -> do 		fileEncoding h-		hPutStr h $ join "\0" $ getFiles action+		hPutStr h $ intercalate "\0" $ toCommand $ getFiles action 		hClose h   where 	p = (proc "xargs" params) { env = gitEnv repo }

Git/Ref.hs view

@@ -1,6 +1,6 @@ {- git ref stuff  -- - Copyright 2011 Joey Hess <joey@kitenet.net>+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -13,6 +13,9 @@  import Data.Char (chr) +headRef :: Ref+headRef = Ref "HEAD"+ {- Converts a fully qualified git ref into a user-visible string. -} describe :: Ref -> String describe = show . base@@ -34,8 +37,8 @@  {- Checks if a ref exists. -} exists :: Ref -> Repo -> IO Bool-exists ref = runBool "show-ref" -	[Param "--verify", Param "-q", Param $ show ref]+exists ref = runBool+	[Param "show-ref", Param "--verify", Param "-q", Param $ show ref]  {- Checks if HEAD exists. It generally will, except for in a repository  - that was just created. -}@@ -54,18 +57,26 @@ 	process [] = Nothing 	process s = Just $ Ref $ firstLine s -{- List of (refs, branches) matching a given ref spec. -}-matching :: Ref -> Repo -> IO [(Ref, Branch)]-matching ref repo = map gen . lines <$> -	pipeReadStrict [Param "show-ref", Param $ show ref] repo+{- List of (shas, branches) matching a given ref or refs. -}+matching :: [Ref] -> Repo -> IO [(Sha, Branch)]+matching refs repo =  matching' (map show refs) repo++{- Includes HEAD in the output, if asked for it. -}+matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)]+matchingWithHEAD refs repo = matching' ("--head" : map show refs) repo++{- List of (shas, branches) matching a given ref or refs. -}+matching' :: [String] -> Repo -> IO [(Sha, Branch)]+matching' ps repo = map gen . lines <$> +	pipeReadStrict (Param "show-ref" : map Param ps) repo   where 	gen l = let (r, b) = separate (== ' ') l 		in (Ref r, Ref b) -{- List of (refs, branches) matching a given ref spec.- - Duplicate refs are filtered out. -}-matchingUniq :: Ref -> Repo -> IO [(Ref, Branch)]-matchingUniq ref repo = nubBy uniqref <$> matching ref repo+{- List of (shas, branches) matching a given ref spec.+ - Duplicate shas are filtered out. -}+matchingUniq :: [Ref] -> Repo -> IO [(Sha, Branch)]+matchingUniq refs repo = nubBy uniqref <$> matching refs repo   where 	uniqref (a, _) (b, _) = a == b

+ Git/Remote.hs view

@@ -0,0 +1,112 @@+{- git remote stuff+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Git.Remote where++import Common+import Git+import qualified Git.Command+import qualified Git.BuildVersion++import Data.Char+import qualified Data.Map as M+import Network.URI+#ifdef mingw32_HOST_OS+import Git.FilePath+#endif++type RemoteName = String++{- Construct a legal git remote name out of an arbitrary input string.+ -+ - There seems to be no formal definition of this in the git source,+ - just some ad-hoc checks, and some other things that fail with certian+ - types of names (like ones starting with '-').+ -}+makeLegalName :: String -> RemoteName+makeLegalName s = case filter legal $ replace "/" "_" s of+	-- it can't be empty+	[] -> "unnamed"+	-- it can't start with / or - or .+	'.':s' -> makeLegalName s'+	'/':s' -> makeLegalName s'+	'-':s' -> makeLegalName s'+	s' -> s'+  where+	{- Only alphanumerics, and a few common bits of punctuation common+	 - in hostnames. -}+	legal '_' = True+	legal '.' = True+	legal c = isAlphaNum c+	+remove :: RemoteName -> Repo -> IO ()+remove remotename = Git.Command.run+	[ Param "remote"+	-- name of this subcommand changed+	, Param $+		if Git.BuildVersion.older "1.8.0"+			then "rm"+			else "remove"+	, Param remotename+	]++data RemoteLocation = RemoteUrl String | RemotePath FilePath++remoteLocationIsUrl :: RemoteLocation -> Bool+remoteLocationIsUrl (RemoteUrl _) = True+remoteLocationIsUrl _ = False++{- Determines if a given remote location is an url, or a local+ - path. Takes the repository's insteadOf configuration into account. -}+parseRemoteLocation :: String -> Repo -> RemoteLocation+parseRemoteLocation s repo = ret $ calcloc s+  where+  	ret v+#ifdef mingw32_HOST_OS+		| dosstyle v = RemotePath (dospath v)+#endif+		| scpstyle v = RemoteUrl (scptourl v)+		| urlstyle v = RemoteUrl v+		| otherwise = RemotePath v+	-- insteadof config can rewrite remote location+	calcloc l+		| null insteadofs = l+		| otherwise = replacement ++ drop (length bestvalue) l+	  where+		replacement = drop (length prefix) $+			take (length bestkey - length suffix) bestkey+		(bestkey, bestvalue) = maximumBy longestvalue insteadofs+		longestvalue (_, a) (_, b) = compare b a+		insteadofs = filterconfig $ \(k, v) -> +			startswith prefix k &&+			endswith suffix k &&+			startswith v l+		filterconfig f = filter f $+			concatMap splitconfigs $ M.toList $ fullconfig repo+		splitconfigs (k, vs) = map (\v -> (k, v)) vs+		(prefix, suffix) = ("url." , ".insteadof")+	urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v+	-- git remotes can be written scp style -- [user@]host:dir+	-- but foo::bar is a git-remote-helper location instead+	scpstyle v = ":" `isInfixOf` v +		&& not ("//" `isInfixOf` v)+		&& not ("::" `isInfixOf` v)+	scptourl v = "ssh://" ++ host ++ slash dir+	  where+		(host, dir) = separate (== ':') v+		slash d	| d == "" = "/~/" ++ d+			| "/" `isPrefixOf` d = d+			| "~" `isPrefixOf` d = '/':d+			| otherwise = "/~/" ++ d+#ifdef mingw32_HOST_OS+	-- git on Windows will write a path to .git/config with "drive:",+	-- which is not to be confused with a "host:"+	dosstyle = hasDrive+	dospath = fromInternalGitPath+#endif

Git/Types.hs view

@@ -41,7 +41,7 @@  {- A git ref. Can be a sha1, or a branch or tag name. -} newtype Ref = Ref String-	deriving (Eq)+	deriving (Eq, Ord)  instance Show Ref where 	show (Ref v) = v

+ Git/UpdateIndex.hs view

@@ -0,0 +1,80 @@+{- git-update-index library+ -+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE BangPatterns, CPP #-}++module Git.UpdateIndex (+	Streamer,+	pureStreamer,+	streamUpdateIndex,+	lsTree,+	updateIndexLine,+	unstageFile,+	stageSymlink+) where++import Common+import Git+import Git.Types+import Git.Command+import Git.FilePath+import Git.Sha++{- Streamers are passed a callback and should feed it lines in the form+ - read by update-index, and generated by ls-tree. -}+type Streamer = (String -> IO ()) -> IO ()++{- A streamer with a precalculated value. -}+pureStreamer :: String -> Streamer+pureStreamer !s = \streamer -> streamer s++{- Streams content into update-index from a list of Streamers. -}+streamUpdateIndex :: Repo -> [Streamer] -> IO ()+streamUpdateIndex repo as = pipeWrite params repo $ \h -> do+	fileEncoding h+	forM_ as (stream h)+	hClose h+  where+	params = map Param ["update-index", "-z", "--index-info"]+	stream h a = a (streamer h)+	streamer h s = do+		hPutStr h s+		hPutStr h "\0"++{- A streamer that adds the current tree for a ref. Useful for eg, copying+ - and modifying branches. -}+lsTree :: Ref -> Repo -> Streamer+lsTree (Ref x) repo streamer = do+	(s, cleanup) <- pipeNullSplit params repo+	mapM_ streamer s+	void $ cleanup+  where+	params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]++{- Generates a line suitable to be fed into update-index, to add+ - a given file with a given sha. -}+updateIndexLine :: Sha -> BlobType -> TopFilePath -> String+updateIndexLine sha filetype file =+	show filetype ++ " blob " ++ show sha ++ "\t" ++ indexPath file++{- A streamer that removes a file from the index. -}+unstageFile :: FilePath -> Repo -> IO Streamer+unstageFile file repo = do+	p <- toTopFilePath file repo+	return $ pureStreamer $ "0 " ++ show nullSha ++ "\t" ++ indexPath p++{- A streamer that adds a symlink to the index. -}+stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer+stageSymlink file sha repo = do+	!line <- updateIndexLine+		<$> pure sha+		<*> pure SymlinkBlob+		<*> toTopFilePath file repo+	return $ pureStreamer line++indexPath :: TopFilePath -> InternalGitPath+indexPath = toInternalGitPath . getTopFilePath

+ Git/Version.hs view

@@ -0,0 +1,43 @@+{- git versions+ -+ - Copyright 2011, 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.Version where++import Common++data GitVersion = GitVersion String Integer+	deriving (Eq)++instance Ord GitVersion where+	compare (GitVersion _ x) (GitVersion _ y) = compare x y++instance Show GitVersion where+	show (GitVersion s _) = s++installed :: IO GitVersion+installed = normalize . extract <$> readProcess "git" ["--version"]+  where+  	extract s = case lines s of+		[] -> ""+		(l:_) -> unwords $ drop 2 $ words l++{- To compare dotted versions like 1.7.7 and 1.8, they are normalized to+ - a somewhat arbitrary integer representation. -}+normalize :: String -> GitVersion+normalize v = GitVersion v $ +	sum $ mult 1 $ reverse $ extend precision $ take precision $+		map readi $ split "." v+  where+	extend n l = l ++ replicate (n - length l) 0+	mult _ [] = []+	mult n (x:xs) = (n*x) : mult (n*10^width) xs+	readi :: String -> Integer+	readi s = case reads s of+		((x,_):_) -> x+		_ -> 0+	precision = 10 -- number of segments of the version to compare+	width = length "yyyymmddhhmmss" -- maximum width of a segment

Makefile view

@@ -1,42 +1,26 @@ PREFIX=/usr-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 $(BASEFLAGS)-endif--GHCMAKE=ghc $(GHCFLAGS) --make--# Am I typing :make in vim? Do a fast build.-ifdef VIM-all=fast-endif--all: $(all)+CABAL?=cabal # set to "./Setup" if you lack a cabal program -# Disables optimisation. Not for production use.-fast: GHCFLAGS=$(BASEFLAGS)-fast: $(bins)+build: Build/SysConfig.hs+	$(CABAL) build+	ln -sf dist/build/github-backup/github-backup github-backup -$(bins):-	$(GHCMAKE) $@+Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs+	if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi+	$(CABAL) configure -install: all+install: build 	install -d $(DESTDIR)$(PREFIX)/bin-	install $(bins) $(DESTDIR)$(PREFIX)/bin+	install github-backup $(DESTDIR)$(PREFIX)/bin 	install -d $(DESTDIR)$(PREFIX)/share/man/man1-	install -m 0644 $(mans) $(DESTDIR)$(PREFIX)/share/man/man1+	install -m 0644 github-backup.1 $(DESTDIR)$(PREFIX)/share/man/man1  clean:-	rm -rf $(bins) tmp dist+	rm -rf github-backup dist configure Build/SysConfig.hs Setup+	find -name \*.o -exec rm {} \;+	find -name \*.hi -exec rm {} \;  # Upload to hackage. hackage: clean 	./make-sdist.sh 	@cabal upload dist/*.tar.gz--.PHONY: $(bins)

README.md view

@@ -15,6 +15,8 @@      cabal install github-backup --bindir=$HOME/bin +(Cabal is bundled with the [Haskell Platform](http://www.haskell.org/platform/).)+ ## Use    Run `github-backup` with no parameters, inside a git repository cloned

Setup.hs view

@@ -1,2 +1,16 @@+{-# LANGUAGE NamedFieldPuns #-}++{- cabal setup file -}+ import Distribution.Simple-main = defaultMain+import Distribution.Simple.Setup++import qualified Build.Configure as Configure++main = defaultMainWithHooks simpleUserHooks+	{ preConf = configure+	}++configure _ _ = do+	Configure.run Configure.tests+	return (Nothing, [])

+ Utility/Applicative.hs view

@@ -0,0 +1,16 @@+{- applicative stuff+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.Applicative where++{- Like <$> , but supports one level of currying.+ - + - foo v = bar <$> action v  ==  foo = bar <$$> action+ -}+(<$$>) :: Functor f => (a -> b) -> (c -> f a) -> c -> f b+f <$$> v = fmap f . v+infixr 4 <$$>

Utility/CoProcess.hs view

@@ -1,35 +1,93 @@ {- Interface for running a shell command as a coprocess,  - sending it queries and getting back results.  -- - Copyright 2012 Joey Hess <joey@kitenet.net>+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE CPP #-}+ module Utility.CoProcess ( 	CoProcessHandle, 	start, 	stop,-	query+	query,+	rawMode ) where  import Common -type CoProcessHandle = (ProcessHandle, Handle, Handle, CreateProcess)+import Control.Concurrent.MVar -start :: FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle-start command params env = do-	(from, to, _err, pid) <- runInteractiveProcess command params Nothing env-	return (pid, to, from, proc command params)+type CoProcessHandle = MVar CoProcessState +data CoProcessState = CoProcessState+	{ coProcessPid :: ProcessHandle+	, coProcessTo :: Handle+	, coProcessFrom :: Handle+	, coProcessSpec :: CoProcessSpec+	}++data CoProcessSpec = CoProcessSpec+	{ coProcessRestartable :: Bool+	, coProcessCmd :: FilePath+	, coProcessParams :: [String]+	, coProcessEnv :: Maybe [(String, String)]+	}++start :: Bool -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle+start restartable cmd params env = do+	s <- start' $ CoProcessSpec restartable cmd params env+	newMVar s++start' :: CoProcessSpec -> IO CoProcessState+start' s = do+	(pid, from, to) <- startInteractiveProcess (coProcessCmd s) (coProcessParams s) (coProcessEnv s)+	return $ CoProcessState pid to from s+ stop :: CoProcessHandle -> IO ()-stop (pid, from, to, p) = do-	hClose to-	hClose from-	forceSuccessProcess p pid+stop ch = do+	s <- readMVar ch+	hClose $ coProcessTo s+	hClose $ coProcessFrom s+	let p = proc (coProcessCmd $ coProcessSpec s) (coProcessParams $ coProcessSpec s)+	forceSuccessProcess p (coProcessPid s) +{- To handle a restartable process, any IO exception thrown by the send and+ - receive actions are assumed to mean communication with the process+ - failed, and the failed action is re-run with a new process. -} query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b-query (_, from, to, _) send receive = do-	_ <- send to-	hFlush to-	receive from+query ch send receive = do+	s <- readMVar ch+	restartable s (send $ coProcessTo s) $ const $+		restartable s (hFlush $ coProcessTo s) $ const $+			restartable s (receive $ coProcessFrom s) $+				return+  where+  	restartable s a cont+		| coProcessRestartable (coProcessSpec s) =+			maybe restart cont =<< catchMaybeIO a+		| otherwise = cont =<< a+	restart = do+		s <- takeMVar ch+		void $ catchMaybeIO $ do+			hClose $ coProcessTo s+			hClose $ coProcessFrom s+		void $ waitForProcess $ coProcessPid s+		s' <- start' (coProcessSpec s)+		putMVar ch s'+		query ch send receive++rawMode :: CoProcessHandle -> IO CoProcessHandle+rawMode ch = do+	s <- readMVar ch+	raw $ coProcessFrom s+	raw $ coProcessTo s+	return ch+  where+  	raw h = do+		fileEncoding h+#ifdef mingw32_HOST_OS+		hSetNewlineMode h noNewlineTranslation+#endif

+ Utility/Data.hs view

@@ -0,0 +1,17 @@+{- utilities for simple data types+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.Data where++{- First item in the list that is not Nothing. -}+firstJust :: Eq a => [Maybe a] -> Maybe a+firstJust ms = case dropWhile (== Nothing) ms of+	[] -> Nothing+	(md:_) -> md++eitherToMaybe :: Either a b -> Maybe b+eitherToMaybe = either (const Nothing) Just

Utility/Directory.hs view

@@ -5,10 +5,12 @@  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE CPP #-}+ module Utility.Directory where  import System.IO.Error-import System.Posix.Files+import System.PosixCompat.Files import System.Directory import Control.Exception (throw) import Control.Monad@@ -18,7 +20,7 @@ import System.IO.Unsafe (unsafeInterleaveIO)  import Utility.SafeCommand-import Utility.TempFile+import Utility.Tmp import Utility.Exception import Utility.Monad @@ -36,15 +38,19 @@  - and lazily. If the directory does not exist, no exception is thrown,  - instead, [] is returned. -} dirContentsRecursive :: FilePath -> IO [FilePath]-dirContentsRecursive topdir = dirContentsRecursive' [topdir]+dirContentsRecursive topdir = dirContentsRecursiveSkipping (const False) topdir -dirContentsRecursive' :: [FilePath] -> IO [FilePath]-dirContentsRecursive' [] = return []-dirContentsRecursive' (dir:dirs) = unsafeInterleaveIO $ do-	(files, dirs') <- collect [] [] =<< catchDefaultIO [] (dirContents dir)-	files' <- dirContentsRecursive' (dirs' ++ dirs)-	return (files ++ files')+dirContentsRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]+dirContentsRecursiveSkipping skipdir topdir = go [topdir]   where+  	go [] = return []+	go (dir:dirs)+		| skipdir dir = go dirs+		| otherwise = unsafeInterleaveIO $ do+			(files, dirs') <- collect [] []+				=<< catchDefaultIO [] (dirContents dir)+			files' <- go (dirs' ++ dirs)+			return (files ++ files') 	collect files dirs' [] = return (reverse files, reverse dirs') 	collect files dirs' (entry:entries) 		| dirCruft entry = collect files dirs' entries@@ -85,9 +91,16 @@ 			(Left _) -> return False 			(Right s) -> return $ isDirectory s -{- Removes a file, which may or may not exist.+{- Removes a file, which may or may not exist, and does not have to+ - be a regular file.  -  - Note that an exception is thrown if the file exists but  - cannot be removed. -} nukeFile :: FilePath -> IO ()-nukeFile file = whenM (doesFileExist file) $ removeFile file+nukeFile file = void $ tryWhenExists go+  where+#ifndef mingw32_HOST_OS+	go = removeLink file+#else+	go = removeFile file+#endif

+ Utility/Env.hs view

@@ -0,0 +1,63 @@+{- portable environment variables+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.Env where++#ifdef mingw32_HOST_OS+import Utility.Exception+import Control.Applicative+import Data.Maybe+import qualified System.Environment as E+#else+import qualified System.Posix.Env as PE+#endif++getEnv :: String -> IO (Maybe String)+#ifndef mingw32_HOST_OS+getEnv = PE.getEnv+#else+getEnv = catchMaybeIO . E.getEnv+#endif++getEnvDefault :: String -> String -> IO String+#ifndef mingw32_HOST_OS+getEnvDefault = PE.getEnvDefault+#else+getEnvDefault var fallback = fromMaybe fallback <$> getEnv var+#endif++getEnvironment :: IO [(String, String)]+#ifndef mingw32_HOST_OS+getEnvironment = PE.getEnvironment+#else+getEnvironment = E.getEnvironment+#endif++{- Returns True if it could successfully set the environment variable.+ -+ - There is, apparently, no way to do this in Windows. Instead,+ - environment varuables must be provided when running a new process. -}+setEnv :: String -> String -> Bool -> IO Bool+#ifndef mingw32_HOST_OS+setEnv var val overwrite = do+	PE.setEnv var val overwrite+	return True+#else+setEnv _ _ _ = return False+#endif++{- Returns True if it could successfully unset the environment variable. -}+unsetEnv :: String -> IO Bool+#ifndef mingw32_HOST_OS+unsetEnv var = do+	PE.unsetEnv var+	return True+#else+unsetEnv _ = return False+#endif

Utility/Exception.hs view

@@ -9,9 +9,12 @@  module Utility.Exception where -import Prelude hiding (catch) import Control.Exception+import qualified Control.Exception as E import Control.Applicative+import Control.Monad+import System.IO.Error (isDoesNotExistError)+import Utility.Data  {- Catches IO errors and returns a Bool -} catchBoolIO :: IO Bool -> IO Bool@@ -31,7 +34,7 @@  {- catch specialized for IO errors only -} catchIO :: IO a -> (IOException -> IO a) -> IO a-catchIO = catch+catchIO = E.catch  {- try specialized for IO errors only -} tryIO :: IO a -> IO (Either IOException a)@@ -49,3 +52,8 @@  tryNonAsync :: IO a -> IO (Either SomeException a) tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left)++{- Catches only DoesNotExist exceptions, and lets all others through. -}+tryWhenExists :: IO a -> IO (Maybe a)+tryWhenExists a = eitherToMaybe <$>+	tryJust (guard . isDoesNotExistError) a

Utility/FileMode.hs view

@@ -5,12 +5,17 @@  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE CPP #-}+ module Utility.FileMode where  import Common  import Control.Exception (bracket)-import System.Posix.Types+import System.PosixCompat.Types+#ifndef mingw32_HOST_OS+import System.Posix.Files+#endif import Foreign (complement)  {- Applies a conversion function to a file's mode. -}@@ -71,7 +76,11 @@  {- Checks if a file mode indicates it's a symlink. -} isSymLink :: FileMode -> Bool+#ifdef mingw32_HOST_OS+isSymLink _ = False+#else isSymLink = checkMode symbolicLinkMode+#endif  {- Checks if a file has any executable bits set. -} isExecutable :: FileMode -> Bool@@ -80,6 +89,7 @@ {- Runs an action without that pesky umask influencing it, unless the  - passed FileMode is the standard one. -} noUmask :: FileMode -> IO a -> IO a+#ifndef mingw32_HOST_OS noUmask mode a 	| mode == stdFileMode = a 	| otherwise = bracket setup cleanup go@@ -87,26 +97,39 @@ 	setup = setFileCreationMask nullFileMode 	cleanup = setFileCreationMask 	go _ = a+#else+noUmask _ a = a+#endif  combineModes :: [FileMode] -> FileMode combineModes [] = undefined combineModes [m] = m combineModes (m:ms) = foldl unionFileModes m ms -stickyMode :: FileMode-stickyMode = 512- isSticky :: FileMode -> Bool+#ifdef mingw32_HOST_OS+isSticky _ = False+#else isSticky = checkMode stickyMode +stickyMode :: FileMode+stickyMode = 512+ setSticky :: FilePath -> IO () setSticky f = modifyFileMode f $ addModes [stickyMode]+#endif  {- Writes a file, ensuring that its modes do not allow it to be read- - by anyone other than the current user, before any content is written. -}+ - by anyone other than the current user, before any content is written.+ -+ - On a filesystem that does not support file permissions, this is the same+ - as writeFile.+ -} writeFileProtected :: FilePath -> String -> IO () writeFileProtected file content = do 	h <- openFile file WriteMode-	modifyFileMode file $ removeModes [groupReadMode, otherReadMode]+	void $ tryIO $+		modifyFileMode file $+			removeModes [groupReadMode, otherReadMode] 	hPutStr h content 	hClose h

Utility/FileSystemEncoding.hs view

@@ -1,6 +1,6 @@ {- GHC File system encoding handling.  -- - Copyright 2012 Joey Hess <joey@kitenet.net>+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -10,7 +10,8 @@ 	withFilePath, 	md5FilePath, 	decodeW8,-	encodeW8	+	encodeW8,+	truncateFilePath, ) where  import qualified GHC.Foreign as GHC@@ -75,3 +76,18 @@  - represent the FilePath on disk. -} decodeW8 :: FilePath -> [Word8] decodeW8 = s2w8 . _encodeFilePath++{- Truncates a FilePath to the given number of bytes (or less),+ - as represented on disk.+ -+ - Avoids returning an invalid part of a unicode byte sequence, at the+ - cost of efficiency when running on a large FilePath.+ -}+truncateFilePath :: Int -> FilePath -> FilePath+truncateFilePath n = go . reverse+  where+  	go f =+		let bytes = decodeW8 f+		in if length bytes <= n+			then reverse f+			else go (drop 1 f)

Utility/Misc.hs view

@@ -5,16 +5,20 @@  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE CPP #-}+ module Utility.Misc where  import System.IO import Control.Monad import Foreign import Data.Char+import Data.List import Control.Applicative+#ifndef mingw32_HOST_OS import System.Posix.Process (getAnyProcessStatus)- import Utility.Exception+#endif  {- A version of hgetContents that is not lazy. Ensures file is   - all read before it gets closed. -}@@ -70,6 +74,23 @@ 		| p i = go [] ([i]:c:r) is 		| otherwise = go (i:c) r is +{- Replaces multiple values in a string.+ -+ - Takes care to skip over just-replaced values, so that they are not+ - mangled. For example, massReplace [("foo", "new foo")] does not+ - replace the "new foo" with "new new foo".+ -}+massReplace :: [(String, String)] -> String -> String+massReplace vs = go [] vs+  where++	go acc _ [] = concat $ reverse acc+	go acc [] (c:cs) = go ([c]:acc) vs cs+	go acc ((val, replacement):rest) s+		| val `isPrefixOf` s =+			go (replacement:acc) vs (drop (length val) s)+		| otherwise = go acc rest s+ {- Given two orderings, returns the second if the first is EQ and returns  - the first otherwise.  -@@ -106,7 +127,12 @@  - on a process and get back an exit status is going to be confused  - if this reap gets there first. -} reapZombies :: IO ()+#ifndef mingw32_HOST_OS reapZombies = do 	-- throws an exception when there are no child processes 	catchDefaultIO Nothing (getAnyProcessStatus False True) 		>>= maybe (return ()) (const reapZombies)++#else+reapZombies = return ()+#endif

Utility/Monad.hs view

@@ -8,7 +8,7 @@ module Utility.Monad where  import Data.Maybe-import Control.Monad (liftM)+import Control.Monad  {- Return the first value from a list, if any, satisfying the given  - predicate -}@@ -26,6 +26,10 @@  - stopping once one is found. -} anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool anyM p = liftM isJust . firstM p++allM :: Monad m => (a -> m Bool) -> [a] -> m Bool+allM _ [] = return True+allM p (x:xs) = p x <&&> allM p xs  {- Runs an action on values from a list until it succeeds. -} untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool

Utility/Path.hs view

@@ -1,31 +1,62 @@ {- path manipulation  -- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE PackageImports, CPP #-}+ module Utility.Path where  import Data.String.Utils-import System.Path import System.FilePath import System.Directory import Data.List import Data.Maybe+import Data.Char import Control.Applicative +#ifdef mingw32_HOST_OS+import Data.Char+import qualified System.FilePath.Posix as Posix+#else+import qualified "MissingH" System.Path as MissingH+import System.Posix.Files+#endif+ import Utility.Monad import Utility.UserInfo -{- Returns the parent directory of a path. Parent of / is "" -}+{- Makes a path absolute if it's not already.+ - The first parameter is a base directory (ie, the cwd) to use if the path+ - is not already absolute.+ -+ - On Unix, collapses and normalizes ".." etc in the path. May return Nothing+ - if the path cannot be normalized.+ -+ - MissingH's absNormPath does not work on Windows, so on Windows+ - no normalization is done.+ -}+absNormPath :: FilePath -> FilePath -> Maybe FilePath+#ifndef mingw32_HOST_OS+absNormPath dir path = MissingH.absNormPath dir path+#else+absNormPath dir path = Just $ combine dir path+#endif++{- Returns the parent directory of a path.+ -+ - To allow this to be easily used in loops, which terminate upon reaching the+ - top, the parent of / is "" -} parentDir :: FilePath -> FilePath parentDir dir-	| not $ null dirs = slash ++ join s (init dirs)-	| otherwise = ""+	| null dirs = ""+	| otherwise = joinDrive drive (join s $ init dirs)   where-	dirs = filter (not . null) $ split s dir-	slash = if isAbsolute dir then s else ""+	-- on Unix, the drive will be "/" when the dir is absolute, otherwise ""+	(drive, path) = splitDrive dir+	dirs = filter (not . null) $ split s path 	s = [pathSeparator]  prop_parentDir_basics :: FilePath -> Bool@@ -41,7 +72,7 @@  - are all equivilant.  -} dirContains :: FilePath -> FilePath -> Bool-dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b'+dirContains a b = a == b || a' == b' || (a'++[pathSeparator]) `isPrefixOf` b'   where 	norm p = fromMaybe "" $ absNormPath p "." 	a' = norm a@@ -102,11 +133,13 @@ 	 - 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"+		relPathDirToFile (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])+			(joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])+				== joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]  {- Given an original list of paths, and an expanded list derived from it,  - generates a list of lists, where each sublist corresponds to one of the- - original paths. When the original path is a direcotry, any items+ - original paths. When the original path is a directory, any items  - in the expanded list that are contained in that directory will appear in  - its segment.  -}@@ -150,7 +183,12 @@ 	| otherwise = getSearchPath >>= getM indir   where 	indir d = check $ d </> command-	check f = ifM (doesFileExist f) ( return (Just f), return Nothing )+	check f = firstM doesFileExist+#ifdef mingw32_HOST_OS+		[f, f ++ ".exe"]+#else+		[f]+#endif  {- Checks if a filename is a unix dotfile. All files inside dotdirs  - count as dotfiles. -}@@ -162,3 +200,55 @@ 	| otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)   where 	f = takeFileName file++{- Converts a DOS style path to a Cygwin style path. Only on Windows.+ - Any trailing '\' is preserved as a trailing '/' -}+toCygPath :: FilePath -> FilePath+#ifndef mingw32_HOST_OS+toCygPath = id+#else+toCygPath p+	| null drive = recombine parts+	| otherwise = recombine $ "/cygdrive" : driveletter drive : parts+  where+  	(drive, p') = splitDrive p+	parts = splitDirectories p'+  	driveletter = map toLower . takeWhile (/= ':')+	recombine = fixtrailing . Posix.joinPath+  	fixtrailing s+		| hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s+		| otherwise = s+#endif++{- Maximum size to use for a file in a specified directory.+ -+ - Many systems have a 255 byte limit to the name of a file, + - so that's taken as the max if the system has a larger limit, or has no+ - limit.+ -}+fileNameLengthLimit :: FilePath -> IO Int+#ifdef mingw32_HOST_OS+fileNameLengthLimit _ = return 255+#else+fileNameLengthLimit dir = do+	l <- fromIntegral <$> getPathVar dir FileNameLimit+	if l <= 0+		then return 255+		else return $ minimum [l, 255]+  where+#endif++{- Given a string that we'd like to use as the basis for FilePath, but that+ - was provided by a third party and is not to be trusted, returns the closest+ - sane FilePath.+ -+ - All spaces and punctuation are replaced with '_', except for '.'+ - "../" will thus turn into ".._", which is safe.+ -}+sanitizeFilePath :: String -> FilePath+sanitizeFilePath = map sanitize+  where+  	sanitize c+		| c == '.' = c+		| isSpace c || isPunctuation c || c == '/' = '_'+		| otherwise = c

Utility/Process.hs view

@@ -6,7 +6,7 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE CPP, Rank2Types #-}  module Utility.Process ( 	module X,@@ -21,11 +21,13 @@ 	createProcessSuccess, 	createProcessChecked, 	createBackgroundProcess,+	processTranscript, 	withHandle, 	withBothHandles, 	withQuietOutput,+	withNullHandle, 	createProcess,-	runInteractiveProcess,+	startInteractiveProcess, 	stdinHandle, 	stdoutHandle, 	stderrHandle,@@ -33,15 +35,20 @@  import qualified System.Process import System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)-import System.Process hiding (createProcess, runInteractiveProcess, readProcess)+import System.Process hiding (createProcess, readProcess) import System.Exit import System.IO import System.Log.Logger import Control.Concurrent import qualified Control.Exception as E import Control.Monad+#ifndef mingw32_HOST_OS+import System.Posix.IO+import Data.Maybe+#endif  import Utility.Misc+import Utility.Exception  type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a @@ -116,7 +123,10 @@ 		ExitSuccess -> return () 		ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n -{- Waits for a ProcessHandle and returns True if it exited successfully. -}+{- Waits for a ProcessHandle and returns True if it exited successfully.+ - Note that using this with createProcessChecked will throw away+ - the Bool, and is only useful to ignore the exit code of a process,+ - while still waiting for it. -} checkSuccessProcess :: ProcessHandle -> IO Bool checkSuccessProcess pid = do 	code <- waitForProcess pid@@ -133,19 +143,61 @@ createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a  {- Runs createProcess, then an action on its handles, and then- - an action on its exit code. -}+ - a checker action on its exit code, which must wait for the process. -} createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner createProcessChecked checker p a = do 	t@(_, _, _, pid) <- createProcess p-	r <- a t+	r <- tryNonAsync $ a t 	_ <- checker pid-	return r+	either E.throw return r  {- Leaves the process running, suitable for lazy streaming.  - Note: Zombies will result, and must be waited on. -} createBackgroundProcess :: CreateProcessRunner createBackgroundProcess p a = a =<< createProcess p +{- Runs a process, optionally feeding it some input, and+ - returns a transcript combining its stdout and stderr, and+ - whether it succeeded or failed. -}+processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)+#ifndef mingw32_HOST_OS+processTranscript cmd opts input = do+	(readf, writef) <- createPipe+	readh <- fdToHandle readf+	writeh <- fdToHandle writef+	p@(_, _, _, pid) <- createProcess $+		(proc cmd opts)+			{ std_in = if isJust input then CreatePipe else Inherit+			, std_out = UseHandle writeh+			, std_err = UseHandle writeh+			}+	hClose writeh++	-- fork off a thread to start consuming the output+	transcript <- hGetContents readh+	outMVar <- newEmptyMVar+	_ <- forkIO $ E.evaluate (length transcript) >> putMVar outMVar ()++	-- now write and flush any input+	case input of+		Just s -> do+			let inh = stdinHandle p+			unless (null s) $ do+				hPutStr inh s+				hFlush inh+			hClose inh+		Nothing -> return ()++	-- wait on the output+	takeMVar outMVar+	hClose readh++	ok <- checkSuccessProcess pid+	return (transcript, ok)+#else+processTranscript = error "processTranscript TODO"+#endif+ {- Runs a CreateProcessRunner, on a CreateProcess structure, that  - is adjusted to pipe only from/to a single StdHandle, and passes  - the resulting Handle to an action. -}@@ -190,13 +242,22 @@ 	:: CreateProcessRunner 	-> CreateProcess 	-> IO ()-withQuietOutput creator p = withFile "/dev/null" WriteMode $ \devnull -> do+withQuietOutput creator p = withNullHandle $ \nullh -> do 	let p' = p-		{ std_out = UseHandle devnull-		, std_err = UseHandle devnull+		{ std_out = UseHandle nullh+		, std_err = UseHandle nullh 		} 	creator p' $ const $ return () +withNullHandle :: (Handle -> IO a) -> IO a+withNullHandle = withFile devnull WriteMode+  where+#ifndef mingw32_HOST_OS+	devnull = "/dev/null"+#else+	devnull = "NUL"+#endif+ {- Extract a desired handle from createProcess's tuple.  - These partial functions are safe as long as createProcess is run  - with appropriate parameters to set up the desired handle.@@ -239,27 +300,25 @@ 	go (ShellCommand s) = s 	go (RawCommand c ps) = c ++ " " ++ show ps -{- Wrappers for System.Process functions that do debug logging.- - - - More could be added, but these are the only ones I usually need.- -}+{- Starts an interactive process. Unlike runInteractiveProcess in+ - System.Process, stderr is inherited. -}+startInteractiveProcess+	:: FilePath+	-> [String]+	-> Maybe [(String, String)]+	-> IO (ProcessHandle, Handle, Handle)+startInteractiveProcess cmd args environ = do+	let p = (proc cmd args)+		{ std_in = CreatePipe+		, std_out = CreatePipe+		, std_err = Inherit+		, env = environ+		}+	(Just from, Just to, _, pid) <- createProcess p+	return (pid, to, from) +{- Wrapper around System.Process function that does debug logging. -} createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do 	debugProcess p 	System.Process.createProcess p--runInteractiveProcess-	:: FilePath	-	-> [String]	-	-> Maybe FilePath	-	-> Maybe [(String, String)]	-	-> IO (Handle, Handle, Handle, ProcessHandle)-runInteractiveProcess f args c e = do-	debugProcess $ (proc f args)-			{ std_in = CreatePipe-			, std_out = CreatePipe-			, std_err = CreatePipe-			, env = e-			}-	System.Process.runInteractiveProcess f args c e

Utility/SafeCommand.hs view

@@ -1,6 +1,6 @@ {- safely running shell 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.  -}@@ -12,6 +12,8 @@ import System.Process (env) import Data.String.Utils import Control.Applicative+import System.FilePath+import Data.Char  {- A type for parameters passed to a shell command. A command can  - be passed either some Params (multiple parameters can be included,@@ -24,14 +26,20 @@ {- Used to pass a list of CommandParams to a function that runs  - a command and expects Strings. -} toCommand :: [CommandParam] -> [String]-toCommand = (>>= unwrap)+toCommand = concatMap unwrap   where 	unwrap (Param s) = [s] 	unwrap (Params s) = filter (not . null) (split " " s)-	-- Files that start with a dash are modified to avoid-	-- the command interpreting them as options.-	unwrap (File s@('-':_)) = ["./" ++ s]+	-- Files that start with a non-alphanumeric that is not a path+	-- separator are modified to avoid the command interpreting them as+	-- options or other special constructs.+	unwrap (File s@(h:_))+		| isAlphaNum h || h `elem` pathseps = [s]+		| otherwise = ["./" ++ s] 	unwrap (File s) = [s]+	-- '/' is explicitly included because it's an alternative+	-- path separator on Windows.+	pathseps = pathSeparator:"./"  {- Run a system command, and returns True or False  - if it succeeded or failed.@@ -55,8 +63,16 @@ 		{ env = environ } 	waitForProcess pid +{- Wraps a shell command line inside sh -c, allowing it to be run in a+ - login shell that may not support POSIX shell, eg csh. -}+shellWrap :: String -> String+shellWrap cmdline = "sh -c " ++ shellEscape cmdline+ {- Escapes a filename or other parameter to be safely able to be exposed to- - the shell. -}+ - the shell.+ -+ - This method works for POSIX shells, as well as other shells like csh.+ -} shellEscape :: String -> String shellEscape f = "'" ++ escaped ++ "'"   where@@ -85,3 +101,20 @@ prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s prop_idempotent_shellEscape_multiword :: [String] -> Bool prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s++{- Segements a list of filenames into groups that are all below the manximum+ - command-line length limit. Does not preserve order. -}+segmentXargs :: [FilePath] -> [[FilePath]]+segmentXargs l = go l [] 0 []+  where+	go [] c _ r = c:r+	go (f:fs) c accumlen r+		| len < maxlen && newlen > maxlen = go (f:fs) [] 0 (c:r)+		| otherwise = go fs (f:c) newlen r+	  where+		len = length f+		newlen = accumlen + len++	{- 10k of filenames per command, well under Linux's 20k limit;+	 - allows room for other parameters etc. -}+	maxlen = 10240

− Utility/TempFile.hs

@@ -1,58 +0,0 @@-{- temp file functions- -- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>- -- - Licensed under the GNU GPL version 3 or higher.- -}--module Utility.TempFile where--import Control.Exception (bracket)-import System.IO-import System.Posix.Process-import System.Directory--import Utility.Exception-import Utility.Path-import System.FilePath--{- Runs an action like writeFile, writing to a temp file first and- - then moving it into place. The temp file is stored in the same- - directory as the final file to avoid cross-device renames. -}-viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO ()-viaTmp a file content = do-	pid <- getProcessID-	let tmpfile = file ++ ".tmp" ++ show pid-	createDirectoryIfMissing True (parentDir file)-	a tmpfile content-	renameFile tmpfile file--type Template = String--{- Runs an action with a temp file, then removes the file. -}-withTempFile :: Template -> (FilePath -> Handle -> IO a) -> IO a-withTempFile template a = bracket create remove use-  where-	create = do-		tmpdir <- catchDefaultIO "." getTemporaryDirectory-		openTempFile tmpdir template-	remove (name, handle) = do-		hClose handle-		catchBoolIO (removeFile name >> return True)-	use (name, handle) = a name handle--{- Runs an action with a temp directory, then removes the directory and- - all its contents. -}-withTempDir :: Template -> (FilePath -> IO a) -> IO a-withTempDir template = bracket create remove-  where-	remove = removeDirectoryRecursive-	create = do-		tmpdir <- catchDefaultIO "." getTemporaryDirectory-		createDirectoryIfMissing True tmpdir-		pid <- getProcessID-		makedir tmpdir (template ++ show pid) (0 :: Int)-	makedir tmpdir t n = do-		let dir = tmpdir </> t ++ "." ++ show n-		r <- tryIO $ createDirectory dir-		either (const $ makedir tmpdir t $ n + 1) (const $ return dir) r

+ Utility/Tmp.hs view

@@ -0,0 +1,88 @@+{- Temporary files and directories.+ -+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.Tmp where++import Control.Exception (bracket)+import System.IO+import System.Directory+import Control.Monad.IfElse++import Utility.Exception+import System.FilePath+import Utility.FileSystemEncoding++type Template = String++{- Runs an action like writeFile, writing to a temp file first and+ - then moving it into place. The temp file is stored in the same+ - directory as the final file to avoid cross-device renames. -}+viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO ()+viaTmp a file content = do+	let (dir, base) = splitFileName file+	createDirectoryIfMissing True dir+	(tmpfile, handle) <- openTempFile dir (base ++ ".tmp")+	hClose handle+	a tmpfile content+	renameFile tmpfile file++{- Runs an action with a tmp file located in the system's tmp directory+ - (or in "." if there is none) then removes the file. -}+withTmpFile :: Template -> (FilePath -> Handle -> IO a) -> IO a+withTmpFile template a = do+	tmpdir <- catchDefaultIO "." getTemporaryDirectory+	withTmpFileIn tmpdir template a++{- Runs an action with a tmp file located in the specified directory,+ - then removes the file. -}+withTmpFileIn :: FilePath -> Template -> (FilePath -> Handle -> IO a) -> IO a+withTmpFileIn tmpdir template a = bracket create remove use+  where+	create = openTempFile tmpdir template+	remove (name, handle) = do+		hClose handle+		catchBoolIO (removeFile name >> return True)+	use (name, handle) = a name handle++{- Runs an action with a tmp directory located within the system's tmp+ - directory (or within "." if there is none), then removes the tmp+ - directory and all its contents. -}+withTmpDir :: Template -> (FilePath -> IO a) -> IO a+withTmpDir template a = do+	tmpdir <- catchDefaultIO "." getTemporaryDirectory+	withTmpDirIn tmpdir template a++{- Runs an action with a tmp directory located within a specified directory,+ - then removes the tmp directory and all its contents. -}+withTmpDirIn :: FilePath -> Template -> (FilePath -> IO a) -> IO a+withTmpDirIn tmpdir template = bracket create remove+  where+	remove d = whenM (doesDirectoryExist d) $+		removeDirectoryRecursive d+	create = do+		createDirectoryIfMissing True tmpdir+		makenewdir (tmpdir </> template) (0 :: Int)+	makenewdir t n = do+		let dir = t ++ "." ++ show n+		either (const $ makenewdir t $ n + 1) (const $ return dir)+			=<< tryIO (createDirectory dir)++{- It's not safe to use a FilePath of an existing file as the template+ - for openTempFile, because if the FilePath is really long, the tmpfile+ - will be longer, and may exceed the maximum filename length.+ -+ - This generates a template that is never too long.+ - (Well, it allocates 20 characters for use in making a unique temp file,+ - anyway, which is enough for the current implementation and any+ - likely implementation.)+ -}+relatedTemplate :: FilePath -> FilePath+relatedTemplate f+	| len > 20 = truncateFilePath (len - 20) f+	| otherwise = f+  where+	len = length f

Utility/UserInfo.hs view

@@ -5,6 +5,8 @@  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE CPP #-}+ module Utility.UserInfo ( 	myHomeDir, 	myUserName,@@ -12,21 +14,38 @@ ) where  import Control.Applicative-import System.Posix.User-import System.Posix.Env+import System.PosixCompat +import Utility.Env+ {- Current user's home directory.  -  - getpwent will fail on LDAP or NIS, so use HOME if set. -} myHomeDir :: IO FilePath-myHomeDir = myVal ["HOME"] homeDirectory+myHomeDir = myVal env homeDirectory+  where+#ifndef mingw32_HOST_OS+	env = ["HOME"]+#else+	env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin+#endif  {- Current user's user name. -} myUserName :: IO String-myUserName = myVal ["USER", "LOGNAME"] userName+myUserName = myVal env userName+  where+#ifndef mingw32_HOST_OS+	env = ["USER", "LOGNAME"]+#else+	env = ["USERNAME", "USER", "LOGNAME"]+#endif  myUserGecos :: IO String+#ifdef __ANDROID__+myUserGecos = return "" -- userGecos crashes on Android+#else myUserGecos = myVal [] userGecos+#endif  myVal :: [String] -> (UserEntry -> String) -> IO String myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars

+ configure.hs view

@@ -0,0 +1,6 @@+{- configure program -}++import Build.Configure++main :: IO ()+main = run tests

debian/changelog view

@@ -1,3 +1,42 @@+github-backup (1.20131006) unstable; urgency=low++  * Ported to Windows.+  * Improve error message when it fails to query github for repositories+    belonging to a user. Closes: #705084+  * Various updates to internal git and utility libraries shared with git-annex.+  * Makefile now uses cabal to build.++ -- Joey Hess <joeyh@debian.org>  Sun, 06 Oct 2013 18:04:56 -0400++github-backup (1.20130622) unstable; urgency=low++  * Add missing unix-compat build dependency. Closes: #713279++ -- Joey Hess <joeyh@debian.org>  Sat, 22 Jun 2013 13:08:57 -0400++github-backup (1.20130618) unstable; urgency=low++  * Much better creation and committing to the github branch. ++ -- Joey Hess <joeyh@debian.org>  Mon, 17 Jun 2013 17:40:02 -0400++github-backup (1.20130617) unstable; urgency=low++  * Build-Depend on libghc-extensible-exceptions-dev. Closes: #712549+  * Various updates to internal git and utility libraries shared with+    git-annex, including some Windows portability.+  * Fixed to never touch the git work tree or index file, instead using+    its own to commit to the github branch.++ -- Joey Hess <joeyh@debian.org>  Mon, 17 Jun 2013 12:28:30 -0400++github-backup (1.20130614) unstable; urgency=low++  * Pass --ignore-removal to git-add, in preparation for a future change+    to its default behavior. Requires git 1.8.3. Closes: #711287++ -- Joey Hess <joeyh@debian.org>  Fri, 14 Jun 2013 15:50:49 -0400+ github-backup (1.20130414) experimental; urgency=low    * Updated to use haskell-github 0.6.0, which supports pagination of queries

debian/control view

@@ -9,15 +9,17 @@ 	libghc-hslogger-dev, 	libghc-pretty-show-dev, 	libghc-ifelse-dev,+	libghc-extensible-exceptions-dev,+	libghc-unix-compat-dev Maintainer: Joey Hess <joeyh@debian.org>-Standards-Version: 3.9.3+Standards-Version: 3.9.4 Vcs-Git: git://github.com/joeyh/github-backup.git Homepage: http://github.com/joeyh/github-backup  Package: github-backup Architecture: any Section: utils-Depends: ${misc:Depends}, ${shlibs:Depends}+Depends: ${misc:Depends}, ${shlibs:Depends}, git Description: backs up data from GitHub  github-backup is a simple tool you run in a git repository you cloned from  GitHub. It backs up everything GitHub publishes about the repository,

debian/copyright view

@@ -2,7 +2,7 @@ Source: native package  Files: *-Copyright: © 2010-2012 Joey Hess <joey@kitenet.net>+Copyright: © 2010-2013 Joey Hess <joey@kitenet.net> License: GPL-3+  The full text of version 3 of the GPL is distributed as doc/GPL in  this package's source, or in /usr/share/common-licenses/GPL-3 on

debian/rules view

@@ -1,4 +1,11 @@ #!/usr/bin/make -f++# Avoid using cabal, as it writes to $HOME+export CABAL=./Setup++# Do use the changelog's version number, rather than making one up.+export RELEASE_BUILD=1+ %: 	dh $@

github-backup.cabal view

@@ -1,5 +1,5 @@ Name: github-backup-Version: 1.20130414+Version: 1.20131006 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess <joey@kitenet.net>@@ -7,7 +7,7 @@ Stability: Stable Copyright: 2012 Joey Hess License-File: GPL-Build-Type: Simple+Build-Type: Custom Homepage: https://github.com/joeyh/github-backup Category: Utility Synopsis: backs up everything github knows about a repository, to the repository@@ -19,8 +19,11 @@ Executable github-backup   Main-Is: github-backup.hs   Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl,-   network, extensible-exceptions, unix, bytestring, base >= 4.5, base < 5,-   IfElse, pretty-show, text, process, github >= 0.6.0+   network, extensible-exceptions, unix-compat, bytestring,+   base >= 4.5, base < 5, IfElse, pretty-show, text, process, github >= 0.6.0++  if (! os(windows))+    Build-Depends: unix  source-repository head   type: git

github-backup.hs view

@@ -15,7 +15,7 @@ import Data.Either import Data.Monoid import System.Environment-import Control.Exception (bracket, try, SomeException)+import Control.Exception (try, SomeException) import Text.Show.Pretty import "mtl" Control.Monad.State.Strict import qualified Github.Data.Readable as Github@@ -37,6 +37,9 @@ import qualified Git.Command import qualified Git.Ref import qualified Git.Branch+import qualified Git.UpdateIndex+import Git.HashObject+import Git.FilePath  -- A github user and repo. data GithubUserRepo = GithubUserRepo String String@@ -272,44 +275,78 @@ 	, "ssh://git@github.com/~/" 	] -onGithubBranch :: Git.Repo -> IO () -> IO ()-onGithubBranch r a = bracket prep cleanup (const a)-  where-	prep = do-		oldbranch <- Git.Branch.current r-		when (oldbranch == Just branchref) $-			error $ "it's not currently safe to run github-backup while the " ++-				branchname ++ " branch is checked out!"-		ifM (null <$> Git.Ref.matching branchref r)-			( checkout [Param "--orphan", Param branchname]-			, checkout [Param branchname]-			)-		return oldbranch-	cleanup Nothing = noop-	cleanup (Just oldbranch)-		| name == branchname = noop-		| otherwise = checkout [Param "--force", Param name]-	  where-		name = show $ Git.Ref.base oldbranch-	checkout params = Git.Command.run "checkout" (Param "-q" : params) r-	branchname = "github"-	branchref = Git.Ref $ "refs/heads/" ++ branchname--{- Commits all files in the workDir into git, and deletes it. -}+{- Commits all files in the workDir into the github branch, and deletes the+ - workDir.+ -+ - The commit is made to the github branch without ever checking it out,+ - or otherwise disturbing the work tree.+ -} commitWorkDir :: Backup () commitWorkDir = do 	dir <- workDir+	whenM (liftIO $ doesDirectoryExist dir) $ do+		branchref <- getBranch+		withIndex $ do+			r <- getState gitRepo+			liftIO $ do+				-- Reset index to current content of github+				-- branch. Does not touch work tree.+				Git.Command.run+					[Param "reset", Param "-q", Param $ show branchref, File "." ] r+				-- Stage workDir files into the index.+				h <- hashObjectStart r+				Git.UpdateIndex.streamUpdateIndex r+					[genstream r dir h]+				hashObjectStop h+				-- Commit+				void $ Git.Branch.commit "github-backup" fullname [branchref] r+				removeDirectoryRecursive dir+  where+  	genstream r dir h streamer = do+		fs <- filter (not . dirCruft) <$> dirContentsRecursive dir+		forM_ fs $ \f -> do+			sha <- hashFile h f+			path <- toTopFilePath f r+			streamer $ Git.UpdateIndex.updateIndexLine+				sha Git.Types.FileBlob path++{- Returns the ref of the github branch, creating it first if necessary. -}+getBranch :: Backup Git.Ref+getBranch = maybe (hasOrigin >>= create) return =<< branchsha+  where+  	create True = do+		inRepo $ Git.Command.run+			[Param "branch", Param $ show branchname, Param $ show originname]+		fromMaybe (error $ "failed to create " ++ show branchname)+			<$> branchsha+	create False = withIndex $+		inRepo $ Git.Branch.commit "branch created" fullname []+	branchsha = inRepo $ Git.Ref.sha fullname++{- Runs an action with a different index file, used for the github branch. -}+withIndex :: Backup a -> Backup a+withIndex a = do 	r <- getState gitRepo-	let git_false_worktree ps = boolSystem "git" $-		[ Param ("--work-tree=" ++ dir)-		, Param ("--git-dir=" ++ Git.localGitDir r)-		] ++ ps-	liftIO $ whenM (doesDirectoryExist dir) $ onGithubBranch r $ do-		_ <- git_false_worktree [ Param "add", Param "." ]-		_ <- git_false_worktree [ Param "commit",-			 Param "-a", Param "-m", Param "github-backup"]-		removeDirectoryRecursive dir+	let f = Git.localGitDir r </> "github-backup.index"+	e <- liftIO getEnvironment+	let r' = r { Git.Types.gitEnv = Just $ ("GIT_INDEX_FILE", f):e }+	changeState $ \s -> s { gitRepo = r' }+	v <- a+	changeState $ \s -> s { gitRepo = (gitRepo s) { Git.Types.gitEnv = Git.Types.gitEnv r } }+	return v +branchname :: Git.Ref+branchname = Git.Ref "github"++fullname :: Git.Ref+fullname = Git.Ref $ "refs/heads/" ++ show branchname++originname :: Git.Ref+originname = Git.Ref $ "refs/remotes/origin/" ++ show branchname++hasOrigin :: Backup Bool+hasOrigin = inRepo $ Git.Ref.exists originname+ updateWiki :: GithubUserRepo -> Backup () updateWiki fork = 	ifM (any (\r -> Git.remoteName r == Just remote) <$> remotes)@@ -321,7 +358,7 @@ 				removeRemote remote 		)   where-	fetchwiki = inRepo $ Git.Command.runBool "fetch" [Param remote]+	fetchwiki = inRepo $ Git.Command.runBool [Param "fetch", Param remote] 	remotes = Git.remotes <$> getState gitRepo 	remote = remoteFor fork 	remoteFor (GithubUserRepo user repo) =@@ -342,16 +379,18 @@ {- Adds a remote, also fetching from it. -} addRemote :: String -> String -> Backup Bool addRemote remotename remoteurl =-	inRepo $ Git.Command.runBool "remote"-		[ Param "add"+	inRepo $ Git.Command.runBool+		[ Param "remote"+		, Param "add" 		, Param "-f" 		, Param remotename 		, Param remoteurl 		]  removeRemote :: String -> Backup ()-removeRemote remotename = void $ inRepo $ Git.Command.runBool "remote"-	[ Param "rm"+removeRemote remotename = void $ inRepo $ Git.Command.runBool+	[ Param "remote"+	, Param "rm" 	, Param remotename 	] @@ -359,9 +398,8 @@  - it would be weird for a backup to not fetch all available data.  - Even though its real focus is on metadata not stored in git. -} fetchRepo :: Git.Repo -> Backup Bool-fetchRepo repo = inRepo $-	Git.Command.runBool "fetch"-		[Param $ fromJust $ Git.Types.remoteName repo]+fetchRepo repo = inRepo $ Git.Command.runBool+	[Param "fetch", Param $ fromJust $ Git.Types.remoteName repo]  {- Gathers metadata for the repo. Retuns a list of files written  - and a list that may contain requests that need to be retried later. -}@@ -429,8 +467,9 @@ newState :: Git.Repo -> BackupState newState = BackupState S.empty S.empty -backupRepo :: Git.Repo -> IO ()-backupRepo repo = evalStateT (runBackup go) . newState =<< Git.Config.read repo+backupRepo :: (Maybe Git.Repo) -> IO ()+backupRepo Nothing = error "not in a git repository, and nothing specified to back up"+backupRepo (Just repo) = evalStateT (runBackup go) . newState =<< Git.Config.read repo   where 	go = do 		retriedfailed <- retry@@ -444,13 +483,15 @@  backupName :: String -> IO () backupName name = do-	userrepos <- either (const []) id <$>-		Github.userRepos name Github.All-	orgrepos <- either (const []) id <$>-		Github.organizationRepos name-	let repos = userrepos ++ orgrepos+	l <- sequence+	 	[ Github.userRepos name Github.All+		, Github.organizationRepos name+		]+	let repos = concat $ rights l 	when (null repos) $-		error $ "No GitHub repositories found for " ++ name+		if (null $ rights l)+			then error $ unlines $ "Failed to query github for repos:" : map show (lefts l)+			else error $ "No GitHub repositories found for " ++ name 	status <- forM repos $ \repo -> do 		let dir = Github.repoName repo 		unlessM (doesDirectoryExist dir) $ do@@ -461,7 +502,7 @@ 				, Param dir 				] 			unless ok $ error "clone failed"-		try (backupRepo =<< Git.Construct.fromPath dir)+		try (backupRepo . Just =<< Git.Construct.fromPath dir) 			:: IO (Either SomeException ()) 	unless (null $ lefts status) $ 		error "Failed to successfully back everything up. Run again later."