diff --git a/.exrc b/.exrc deleted file mode 100644 --- a/.exrc +++ /dev/null @@ -1,51 +0,0 @@ -if &cp | set nocp | endif -let s:cpo_save=&cpo -set cpo&vim -imap :cprev -imap :cnext -imap :pop a -imap a -inoremap HaskellKeyword() -imap :w :SyntasticCheck a -noremap  :make -nmap gx NetrwBrowseX -nnoremap NetrwBrowseX :call netrw#NetrwBrowseX(expand(""),0) -noremap :cprev -noremap :cnext -noremap :pop -noremap  -noremap :w :SyntasticCheck -inoremap  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= -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 : diff --git a/Common.hs b/Common.hs --- a/Common.hs +++ b/Common.hs @@ -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) diff --git a/Git/Branch.hs b/Git/Branch.hs --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -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 diff --git a/Git/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -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) diff --git a/Git/Command.hs b/Git/Command.hs --- a/Git/Command.hs +++ b/Git/Command.hs @@ -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 diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -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) diff --git a/Git/Remote.hs b/Git/Remote.hs --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -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 diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -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 () diff --git a/Git/Version.hs b/Git/Version.hs --- a/Git/Version.hs +++ b/Git/Version.hs @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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/).) diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -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 diff --git a/Utility/Directory.hs b/Utility/Directory.hs --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -1,4 +1,4 @@ -{- directory manipulation +{- directory traversal and manipulation - - Copyright 2011-2014 Joey Hess - @@ -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 diff --git a/Utility/Env.hs b/Utility/Env.hs --- a/Utility/Env.hs +++ b/Utility/Env.hs @@ -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 diff --git a/Utility/Exception.hs b/Utility/Exception.hs --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -1,59 +1,88 @@ {- Simple IO exception handling (and some more) - - - Copyright 2011-2012 Joey Hess + - Copyright 2011-2014 Joey Hess - - 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) diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -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 diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -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 diff --git a/Utility/Path.hs b/Utility/Path.hs --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -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 diff --git a/Utility/Process.hs b/Utility/Process.hs --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -31,6 +31,7 @@ stdinHandle, stdoutHandle, stderrHandle, + bothHandles, processHandle, devNull, ) where diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -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 diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -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 Fri, 31 Oct 2014 11:17:49 -0400 + +github-backup (1.20140831) unstable; urgency=medium + + * Fix build with github 0.10. + + -- Joey Hess 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 Thu, 07 Aug 2014 22:17:22 -0400 + github-backup (1.20140721) unstable; urgency=medium * Fix typo in fix for url parsing. Closes: #755261 diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -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 diff --git a/github-backup.cabal b/github-backup.cabal --- a/github-backup.cabal +++ b/github-backup.cabal @@ -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 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 diff --git a/github-backup.hs b/github-backup.hs --- a/github-backup.hs +++ b/github-backup.hs @@ -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"