packages feed

github-backup 1.20140721 → 1.20141031

raw patch · 23 files changed

+278/−173 lines, 23 filesdep +exceptionsdep +network-uridep +transformersdep −extensible-exceptionsdep ~network

Dependencies added: exceptions, network-uri, transformers

Dependencies removed: extensible-exceptions

Dependency ranges changed: network

Files

− .exrc 
@@ -1,51 +0,0 @@-if &cp | set nocp | endif-let s:cpo_save=&cpo-set cpo&vim-imap <S-Left> :cprev
-imap <S-Right> :cnext
-imap <C-Left> :pop
a-imap <C-Right> a-inoremap <expr> <C-Up> HaskellKeyword()-imap <C-Down> :w
:SyntasticCheck
a-noremap  :make
-nmap gx <Plug>NetrwBrowseX-nnoremap <silent> <Plug>NetrwBrowseX :call netrw#NetrwBrowseX(expand("<cfile>"),0)
-noremap <S-Left> :cprev
-noremap <S-Right> :cnext
-noremap <C-Left> :pop
-noremap <C-Right> -noremap <C-Down> :w
:SyntasticCheck
-inoremap <expr>  HaskellKeyword()-iabbr jjjj --[[Joey]]-let &cpo=s:cpo_save-unlet s:cpo_save-set autoindent-set autowrite-set backspace=indent,eol,start-set backup-set backupdir=~/tmp-set fileencodings=utf-8-set guicursor=n:blinkon0-set helplang=en-set history=50-set ignorecase-set incsearch-set iskeyword=a-z,A-Z,_,.,39-set nojoinspaces-set laststatus=2-set lazyredraw-set pastetoggle=<C-P>-set printoptions=paper:letter-set ruler-set runtimepath=~/.vim,~/.vim/bundle/syntastic,~/.vim/bundle/vim-fugitive,~/.vim/bundle/vim-hdevtools,/var/lib/vim/addons,/usr/share/vim/vimfiles,/usr/share/vim/vim74,/usr/share/vim/vimfiles/after,/var/lib/vim/addons/after,~/.vim/after-set shortmess=filnxtToOI-set showcmd-set showmatch-set smartcase-set suffixes=.bak,~,.swp,.o,.info,.aux,.log,.dvi,.bbl,.blg,.brf,.cb,.ind,.idx,.ilg,.inx,.out,.toc-set tags=.tags,tags-set textwidth=75-set viminfo='20,\"1000-set visualbell-set wildmenu-" vim: set ft=vim :
Common.hs view
@@ -6,7 +6,6 @@ import Control.Monad.IfElse as X import Control.Applicative as X import "mtl" Control.Monad.State.Strict as X (liftIO)-import Control.Exception.Extensible as X (IOException)  import Data.Maybe as X import Data.List as X hiding (head, tail, init, last)
Git/Branch.hs view
@@ -14,6 +14,7 @@ import Git.Sha import Git.Command import qualified Git.Ref+import qualified Git.BuildVersion  {- The currently checked out branch.  -@@ -110,6 +111,12 @@ data CommitMode = ManualCommit | AutomaticCommit 	deriving (Eq) +applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam]+applyCommitMode commitmode ps+	| commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") =+		Param "--no-gpg-sign" : ps+	| otherwise = ps+ {- Commit via the usual git command. -} commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool commitCommand = commitCommand' runBool@@ -119,11 +126,8 @@ 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+commitCommand' runner commitmode ps = runner $+	Param "commit" : applyCommitMode commitmode ps  {- Commits the index into the specified branch (or other ref),   - with the specified parent refs, and returns the committed sha.@@ -140,22 +144,21 @@ 		pipeReadStrict [Param "write-tree"] repo 	ifM (cancommit tree) 		( do-			sha <- getSha "commit-tree" $ pipeWriteRead-				(map Param $ ["commit-tree", fromRef tree] ++ ps)-				(Just $ flip hPutStr message) repo+			sha <- getSha "commit-tree" $+				pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) sendmsg repo 			update branch sha repo 			return $ Just sha 		, return Nothing 		)   where-	ps = -		(if commitmode == AutomaticCommit then ["--no-gpg-sign"] else [])-		++ concatMap (\r -> ["-p", fromRef r]) parentrefs+	ps = applyCommitMode commitmode $+		map Param $ 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+	sendmsg = Just $ flip hPutStr message  commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha commitAlways commitmode message branch parentrefs repo = fromJust
Git/CatFile.hs view
@@ -94,7 +94,7 @@ catTree h treeref = go <$> catObjectDetails h treeref   where 	go (Just (b, _, TreeObject)) = parsetree [] b-  	go _ = []+	go _ = []  	parsetree c b = case L.break (== 0) b of 		(modefile, rest)
Git/Command.hs view
@@ -79,7 +79,7 @@ 	writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo)  		(gitEnv repo) writer (Just adjusthandle)   where-  	adjusthandle h = do+	adjusthandle h = do 		fileEncoding h 		hSetNewlineMode h noNewlineTranslation @@ -117,7 +117,7 @@ 	(toCommand $ gitCommandLine params repo) 	(gitEnv repo)   where-  	{- If a long-running git command like cat-file --batch+	{- 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
Git/Config.hs view
@@ -9,7 +9,6 @@  import qualified Data.Map as M import Data.Char-import Control.Exception.Extensible  import Common import Git@@ -168,7 +167,7 @@ fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String)) fromPipe r cmd params = try $ 	withHandle StdoutHandle createProcessSuccess p $ \h -> do- 		fileEncoding h+		fileEncoding h 		val <- hGetContentsStrict h 		r' <- store val r 		return (r', val)
Git/Remote.hs view
@@ -12,8 +12,6 @@ import Common import Git import Git.Types-import qualified Git.Command-import qualified Git.BuildVersion  import Data.Char import qualified Data.Map as M@@ -44,17 +42,6 @@ 	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@@ -70,7 +57,7 @@ parseRemoteLocation :: String -> Repo -> RemoteLocation parseRemoteLocation s repo = ret $ calcloc s   where-  	ret v+	ret v #ifdef mingw32_HOST_OS 		| dosstyle v = RemotePath (dospath v) #endif@@ -102,7 +89,13 @@ 		&& not ("::" `isInfixOf` v) 	scptourl v = "ssh://" ++ host ++ slash dir 	  where-		(host, dir) = separate (== ':') v+		(host, dir)+			-- handle ipv6 address inside []+			| "[" `isPrefixOf` v = case break (== ']') v of+				(h, ']':':':d) -> (h ++ "]", d)+				(h, ']':d) -> (h ++ "]", d)+				(h, d) -> (h, d)+			| otherwise = separate (== ':') v 		slash d	| d == "" = "/~/" ++ d 			| "/" `isPrefixOf` d = d 			| "~" `isPrefixOf` d = '/':d
Git/UpdateIndex.hs view
@@ -29,8 +29,6 @@ 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 ()
Git/Version.hs view
@@ -21,7 +21,7 @@ installed :: IO GitVersion installed = normalize . extract <$> readProcess "git" ["--version"]   where-  	extract s = case lines s of+	extract s = case lines s of 		[] -> "" 		(l:_) -> unwords $ drop 2 $ words l
README.md view
@@ -5,14 +5,6 @@  ## Installation -    git clone git://github.com/joeyh/github-backup-    cd github-backup-    make--(You will need ghc and several haskell libraries installed first.)--Or use cabal:-     cabal install github-backup --bindir=$HOME/bin  (Cabal is bundled with the [Haskell Platform](http://www.haskell.org/platform/).)
Utility/CoProcess.hs view
@@ -65,7 +65,7 @@ 			restartable s (receive $ coProcessFrom s) 				return   where-  	restartable s a cont+	restartable s a cont 		| coProcessNumRestarts (coProcessSpec s) > 0 = 			maybe restart cont =<< catchMaybeIO a 		| otherwise = cont =<< a@@ -87,7 +87,7 @@ 	raw $ coProcessTo s 	return ch   where-  	raw h = do+	raw h = do 		fileEncoding h #ifdef mingw32_HOST_OS 		hSetNewlineMode h noNewlineTranslation
Utility/Directory.hs view
@@ -1,4 +1,4 @@-{- directory manipulation+{- directory traversal and manipulation  -  - Copyright 2011-2014 Joey Hess <joey@kitenet.net>  -@@ -11,13 +11,20 @@  import System.IO.Error import System.Directory-import Control.Exception (throw) import Control.Monad import Control.Monad.IfElse import System.FilePath import Control.Applicative+import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO)+import Data.Maybe +#ifdef mingw32_HOST_OS+import qualified System.Win32 as Win32+#else+import qualified System.Posix as Posix+#endif+ import Utility.PosixFiles import Utility.SafeCommand import Utility.Tmp@@ -49,7 +56,7 @@ dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath] dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]   where-  	go [] = return []+	go [] = return [] 	go (dir:dirs) 		| skipdir (takeFileName dir) = go dirs 		| otherwise = unsafeInterleaveIO $ do@@ -80,7 +87,7 @@ dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath] dirTreeRecursiveSkipping skipdir topdir = go [] [topdir]   where-  	go c [] = return c+	go c [] = return c 	go c (dir:dirs) 		| skipdir (takeFileName dir) = go c dirs 		| otherwise = unsafeInterleaveIO $ do@@ -106,7 +113,7 @@ 			whenM (isdir dest) rethrow 			viaTmp mv dest undefined 	  where-		rethrow = throw e+		rethrow = throwM e 		mv tmp _ = do 			ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] 			unless ok $ do@@ -133,3 +140,90 @@ #else 	go = removeFile file #endif++#ifndef mingw32_HOST_OS+data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream+#else+data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar ())+#endif++type IsOpen = MVar () -- full when the handle is open++openDirectory :: FilePath -> IO DirectoryHandle+openDirectory path = do+#ifndef mingw32_HOST_OS+	dirp <- Posix.openDirStream path+	isopen <- newMVar ()+	return (DirectoryHandle isopen dirp)+#else+	(h, fdat) <- Win32.findFirstFile (path </> "*")+	-- Indicate that the fdat contains a filename that readDirectory+	-- has not yet returned, by making the MVar be full.+	-- (There's always at least a "." entry.)+	alreadyhave <- newMVar ()+	isopen <- newMVar ()+	return (DirectoryHandle isopen h fdat alreadyhave)+#endif++closeDirectory :: DirectoryHandle -> IO ()+#ifndef mingw32_HOST_OS+closeDirectory (DirectoryHandle isopen dirp) =+	whenOpen isopen $+		Posix.closeDirStream dirp+#else+closeDirectory (DirectoryHandle isopen h _ alreadyhave) =+	whenOpen isopen $ do+		_ <- tryTakeMVar alreadyhave+		Win32.findClose h+#endif+  where+	whenOpen :: IsOpen -> IO () -> IO ()+	whenOpen mv f = do+		v <- tryTakeMVar mv+		when (isJust v) f++{- |Reads the next entry from the handle. Once the end of the directory+is reached, returns Nothing and automatically closes the handle.+-}+readDirectory :: DirectoryHandle -> IO (Maybe FilePath)+#ifndef mingw32_HOST_OS+readDirectory hdl@(DirectoryHandle _ dirp) = do+	e <- Posix.readDirStream dirp+	if null e+		then do+			closeDirectory hdl+			return Nothing+		else return (Just e)+#else+readDirectory hdl@(DirectoryHandle _ h fdat mv) = do+	-- If the MVar is full, then the filename in fdat has+	-- not yet been returned. Otherwise, need to find the next+	-- file.+	r <- tryTakeMVar mv+	case r of+		Just () -> getfn+		Nothing -> do+			more <- Win32.findNextFile h fdat+			if more+				then getfn+				else do+					closeDirectory hdl+					return Nothing+  where+	getfn = do+		filename <- Win32.getFindDataFileName fdat+		return (Just filename)+#endif++-- True only when directory exists and contains nothing.+-- Throws exception if directory does not exist.+isDirectoryEmpty :: FilePath -> IO Bool+isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check+  where+	check h = do+		v <- readDirectory h+		case v of+			Nothing -> return True+			Just f+				| not (dirCruft f) -> return False+				| otherwise -> check h
Utility/Env.hs view
@@ -14,6 +14,7 @@ import Control.Applicative import Data.Maybe import qualified System.Environment as E+import qualified System.SetEnv #else import qualified System.Posix.Env as PE #endif@@ -39,27 +40,27 @@ getEnvironment = E.getEnvironment #endif -{- Returns True if it could successfully set the environment variable.+{- Sets an environment variable. To overwrite an existing variable,+ - overwrite must be True.  -- - 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+ - On Windows, setting a variable to "" unsets it. -}+setEnv :: String -> String -> Bool -> IO () #ifndef mingw32_HOST_OS-setEnv var val overwrite = do-	PE.setEnv var val overwrite-	return True+setEnv var val overwrite = PE.setEnv var val overwrite #else-setEnv _ _ _ = return False+setEnv var val True = System.SetEnv.setEnv var val+setEnv var val False = do+	r <- getEnv var+	case r of+		Nothing -> setEnv var val True+		Just _ -> return () #endif -{- Returns True if it could successfully unset the environment variable. -}-unsetEnv :: String -> IO Bool+unsetEnv :: String -> IO () #ifndef mingw32_HOST_OS-unsetEnv var = do-	PE.unsetEnv var-	return True+unsetEnv = PE.unsetEnv #else-unsetEnv _ = return False+unsetEnv = System.SetEnv.unsetEnv #endif  {- Adds the environment variable to the input environment. If already
Utility/Exception.hs view
@@ -1,59 +1,88 @@ {- Simple IO exception handling (and some more)  -- - Copyright 2011-2012 Joey Hess <joey@kitenet.net>+ - Copyright 2011-2014 Joey Hess <joey@kitenet.net>  -  - License: BSD-2-clause  -}  {-# LANGUAGE ScopedTypeVariables #-} -module Utility.Exception where+module Utility.Exception (+	module X,+	catchBoolIO,+	catchMaybeIO,+	catchDefaultIO,+	catchMsgIO,+	catchIO,+	tryIO,+	bracketIO,+	catchNonAsync,+	tryNonAsync,+	tryWhenExists,+) where -import Control.Exception-import qualified Control.Exception as E-import Control.Applicative+import Control.Monad.Catch as X hiding (Handler)+import qualified Control.Monad.Catch as M+import Control.Exception (IOException, AsyncException) import Control.Monad+import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError) import Utility.Data  {- Catches IO errors and returns a Bool -}-catchBoolIO :: IO Bool -> IO Bool+catchBoolIO :: MonadCatch m => m Bool -> m Bool catchBoolIO = catchDefaultIO False  {- Catches IO errors and returns a Maybe -}-catchMaybeIO :: IO a -> IO (Maybe a)-catchMaybeIO a = catchDefaultIO Nothing $ Just <$> a+catchMaybeIO :: MonadCatch m => m a -> m (Maybe a)+catchMaybeIO a = do+	catchDefaultIO Nothing $ do+		v <- a+		return (Just v)  {- Catches IO errors and returns a default value. -}-catchDefaultIO :: a -> IO a -> IO a+catchDefaultIO :: MonadCatch m => a -> m a -> m a catchDefaultIO def a = catchIO a (const $ return def)  {- Catches IO errors and returns the error message. -}-catchMsgIO :: IO a -> IO (Either String a)-catchMsgIO a = either (Left . show) Right <$> tryIO a+catchMsgIO :: MonadCatch m => m a -> m (Either String a)+catchMsgIO a = do+	v <- tryIO a+	return $ either (Left . show) Right v  {- catch specialized for IO errors only -}-catchIO :: IO a -> (IOException -> IO a) -> IO a-catchIO = E.catch+catchIO :: MonadCatch m => m a -> (IOException -> m a) -> m a+catchIO = M.catch  {- try specialized for IO errors only -}-tryIO :: IO a -> IO (Either IOException a)-tryIO = try+tryIO :: MonadCatch m => m a -> m (Either IOException a)+tryIO = M.try +{- bracket with setup and cleanup actions lifted to IO.+ -+ - Note that unlike catchIO and tryIO, this catches all exceptions. -}+bracketIO :: (MonadMask m, MonadIO m) => IO v -> (v -> IO b) -> (v -> m a) -> m a+bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup)+ {- Catches all exceptions except for async exceptions.  - This is often better to use than catching them all, so that  - ThreadKilled and UserInterrupt get through.  -}-catchNonAsync :: IO a -> (SomeException -> IO a) -> IO a+catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchNonAsync a onerr = a `catches`-	[ Handler (\ (e :: AsyncException) -> throw e)-	, Handler (\ (e :: SomeException) -> onerr e)+	[ M.Handler (\ (e :: AsyncException) -> throwM e)+	, M.Handler (\ (e :: SomeException) -> onerr e) 	] -tryNonAsync :: IO a -> IO (Either SomeException a)-tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left)+tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a)+tryNonAsync a = go `catchNonAsync` (return . Left)+  where+	go = do+		v <- a+		return (Right v)  {- Catches only DoesNotExist exceptions, and lets all others through. -}-tryWhenExists :: IO a -> IO (Maybe a)-tryWhenExists a = eitherToMaybe <$>-	tryJust (guard . isDoesNotExistError) a+tryWhenExists :: MonadCatch m => m a -> m (Maybe a)+tryWhenExists a = do+	v <- tryJust (guard . isDoesNotExistError) a+	return (eitherToMaybe v)
Utility/FileMode.hs view
@@ -11,7 +11,6 @@  import System.IO import Control.Monad-import Control.Exception (bracket) import System.PosixCompat.Types import Utility.PosixFiles #ifndef mingw32_HOST_OS
Utility/FileSystemEncoding.hs view
@@ -111,7 +111,7 @@ #ifndef mingw32_HOST_OS truncateFilePath n = go . reverse   where-  	go f =+	go f = 		let bytes = decodeW8 f 		in if length bytes <= n 			then reverse f
Utility/Path.hs view
@@ -235,11 +235,11 @@ 	| null drive = recombine parts 	| otherwise = recombine $ "/cygdrive" : driveletter drive : parts   where-  	(drive, p') = splitDrive p+	(drive, p') = splitDrive p 	parts = splitDirectories p'-  	driveletter = map toLower . takeWhile (/= ':')+	driveletter = map toLower . takeWhile (/= ':') 	recombine = fixtrailing . Posix.joinPath-  	fixtrailing s+	fixtrailing s 		| hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s 		| otherwise = s #endif@@ -272,7 +272,7 @@ sanitizeFilePath :: String -> FilePath sanitizeFilePath = map sanitize   where-  	sanitize c+	sanitize c 		| c == '.' = c 		| isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_' 		| otherwise = c
Utility/Process.hs view
@@ -31,6 +31,7 @@ 	stdinHandle, 	stdoutHandle, 	stderrHandle,+	bothHandles, 	processHandle, 	devNull, ) where
Utility/Tmp.hs view
@@ -9,11 +9,11 @@  module Utility.Tmp where -import Control.Exception (bracket) import System.IO import System.Directory import Control.Monad.IfElse import System.FilePath+import Control.Monad.IO.Class  import Utility.Exception import Utility.FileSystemEncoding@@ -32,31 +32,31 @@ 	setup = do 		createDirectoryIfMissing True dir 		openTempFile dir template-	cleanup (tmpfile, handle) = do-		_ <- tryIO $ hClose handle+	cleanup (tmpfile, h) = do+		_ <- tryIO $ hClose h 		tryIO $ removeFile tmpfile-	use (tmpfile, handle) = do-		hClose handle+	use (tmpfile, h) = do+		hClose h 		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. -}-withTmpFile :: Template -> (FilePath -> Handle -> IO a) -> IO a+withTmpFile :: (MonadIO m, MonadMask m) => Template -> (FilePath -> Handle -> m a) -> m a withTmpFile template a = do-	tmpdir <- catchDefaultIO "." getTemporaryDirectory+	tmpdir <- liftIO $ 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 :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a withTmpFileIn tmpdir template a = bracket create remove use   where-	create = openTempFile tmpdir template-	remove (name, handle) = do-		hClose handle+	create = liftIO $ openTempFile tmpdir template+	remove (name, h) = liftIO $ do+		hClose h 		catchBoolIO (removeFile name >> return True)-	use (name, handle) = a name handle+	use (name, h) = a name h  {- Runs an action with a tmp directory located within the system's tmp  - directory (or within "." if there is none), then removes the tmp
debian/changelog view
@@ -1,3 +1,26 @@+github-backup (1.20141031) unstable; urgency=medium++  * Adjust cabal file for network-uri split.+  * Avoid using optparse-applicate's argument combinator, so it will build+    with 0.11 and older too.+  * Various updates to internal git and utility libraries shared with+    git-annex.++ -- Joey Hess <joeyh@debian.org>  Fri, 31 Oct 2014 11:17:49 -0400++github-backup (1.20140831) unstable; urgency=medium++  * Fix build with github 0.10.++ -- Joey Hess <joeyh@debian.org>  Sun, 31 Aug 2014 15:31:26 -0700++github-backup (1.20140807) unstable; urgency=medium++  * Fix build with github 0.9.+  * Fix creation of github branch.++ -- Joey Hess <joeyh@debian.org>  Thu, 07 Aug 2014 22:17:22 -0400+ github-backup (1.20140721) unstable; urgency=medium    * Fix typo in fix for url parsing. Closes: #755261
debian/control view
@@ -10,7 +10,8 @@ 	libghc-hslogger-dev, 	libghc-pretty-show-dev, 	libghc-ifelse-dev,-	libghc-extensible-exceptions-dev,+	libghc-exceptions-dev,+	libghc-transformers-dev, 	libghc-unix-compat-dev, 	libghc-optparse-applicative-dev Maintainer: Joey Hess <joeyh@debian.org>
github-backup.cabal view
@@ -1,6 +1,6 @@ Name: github-backup-Version: 1.20140721-Cabal-Version: >= 1.6+Version: 1.20141031+Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess <joey@kitenet.net> Author: Joey Hess@@ -16,17 +16,26 @@  Github. It backs up everything Github knows about the repository, including  other forks, issues, comments, milestones, pull requests, and watchers. +Flag network-uri+  Description: Get Network.URI from the network-uri package+  Default: True+ Executable github-backup   Main-Is: github-backup.hs   GHC-Options: -Wall   Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl,-   network, extensible-exceptions, unix-compat, bytestring,+   network, exceptions, transformers, unix-compat, bytestring,    IfElse, pretty-show, text, process, optparse-applicative,    github >= 0.7.2,    base >= 4.5, base < 5    if (! os(windows))     Build-Depends: unix+  +  if flag(network-uri)+    Build-Depends: network-uri (>= 2.6), network (>= 2.6)+  else+    Build-Depends: network (< 2.6), network (>= 2.0)  source-repository head   type: git
github-backup.hs view
@@ -5,6 +5,7 @@  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PackageImports #-} @@ -17,10 +18,12 @@ import Data.Either import Data.Monoid import Options.Applicative-import Control.Exception (try, SomeException) import Text.Show.Pretty import "mtl" Control.Monad.State.Strict import qualified Github.Repos as Github+#if MIN_VERSION_github(0,9,0)+import qualified Github.Auth as Github+#endif import qualified Github.Repos.Forks as Github import qualified Github.PullRequests as Github import qualified Github.Repos.Watching as Github@@ -215,7 +218,7 @@ 	mapM_ addFork fs  forValues :: (Request -> v -> Backup ()) -> Request -> [v] -> Backup ()-forValues handle req vs = forM_ vs (handle req)+forValues a req vs = forM_ vs (a req)  type ApiCall v = Maybe Github.GithubAuth -> String -> String -> IO (Either Github.Error v) type ApiWith v b = Maybe Github.GithubAuth -> String -> String -> b -> IO (Either Github.Error v)@@ -224,24 +227,24 @@ type Helper = Request -> Backup ()  simpleHelper :: FilePath -> ApiCall v -> Handler v -> Helper-simpleHelper dest call handle req@(RequestSimple _ (GithubUserRepo user repo)) =+simpleHelper dest call handler req@(RequestSimple _ (GithubUserRepo user repo)) = 	deferOn dest req $ do 		auth <- getState gitHubAuth-		either (failedRequest req) (handle req) =<< liftIO (call auth user repo)+		either (failedRequest req) (handler req) =<< liftIO (call auth user repo) simpleHelper _ _ _ r = badRequest r  withHelper :: FilePath -> ApiWith v b -> b -> Handler v -> Helper-withHelper dest call b handle req@(RequestSimple _ (GithubUserRepo user repo)) =+withHelper dest call b handler req@(RequestSimple _ (GithubUserRepo user repo)) = 	deferOn dest req $ do 		auth <- getState gitHubAuth-		either (failedRequest req) (handle req) =<< liftIO (call auth user repo b)+		either (failedRequest req) (handler req) =<< liftIO (call auth user repo b) withHelper _ _ _ _ r = badRequest r  numHelper :: FilePath -> ApiNum v -> (Int -> Handler v) -> Helper-numHelper dest call handle req@(RequestNum _ (GithubUserRepo user repo) num) =+numHelper dest call handler req@(RequestNum _ (GithubUserRepo user repo) num) = 	deferOn dest req $ do 		auth <- getState gitHubAuth-		either (failedRequest req) (handle num req) =<< liftIO (call auth user repo num)+		either (failedRequest req) (handler num req) =<< liftIO (call auth user repo num) numHelper _ _ _ r = badRequest r  badRequest :: Request -> a@@ -392,7 +395,7 @@ branchname = Git.Ref "github"  fullname :: Git.Ref-fullname = Git.Ref $ "refs/heads/github" ++ Git.Types.fromRef branchname+fullname = Git.Ref $ "refs/heads/" ++ Git.Types.fromRef branchname  originname :: Git.Ref originname = Git.Ref $ "refs/remotes/origin/" ++ Git.Types.fromRef branchname@@ -588,7 +591,7 @@ 		, Github.reposStarredBy auth name 		, Github.organizationRepos' auth name 		]-	let nameurls = nub $ map (\repo -> (Github.repoName repo, Github.repoGitUrl repo)) $ concat $ rights l+	let nameurls = nub $ mapMaybe makenameurl $ concat $ rights l 	when (null nameurls) $ 		if (null $ rights l) 			then error $ unlines $ "Failed to query github for repos:" : map show (lefts l)@@ -605,6 +608,16 @@ 		>>= showFailures . concat   where 	excludeurls = map repoUrl exclude+	+	makenameurl repo = +#if MIN_VERSION_github(0,10,0)+		case Github.repoGitUrl repo of+			Just url -> Just (Github.repoName repo, url)+			Nothing -> Nothing+#else+		Just (Github.repoName repo, Github.repoGitUrl repo)+#endif+ 	prepare (dir, url) 		| url `elem` excludeurls = return Nothing 		| otherwise = do@@ -629,12 +642,14 @@ 	deriving (Show)  options :: Parser Options-options = Options <$> many owneropt <*> many excludeopt+options = Options+	<$> many owneropt+	<*> many excludeopt   where-	owneropt = (argument (Just . Owner))+	owneropt = Owner <$> (strOption 		( metavar "USERNAME|ORGANIZATION" 		<> help "Back up repositories owned by this entity."-		)+		)) 	excludeopt = parseUserRepo <$> (strOption 		( long "exclude" 		<> metavar "USERNAME/REPOSITORY"