diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,13 @@ +github-backup (1.20170221) unstable; urgency=medium + + * Updated to use github-0.15. + * Due to a regression in github-0.15, the pull request list is retrieved + without authentication. + * Various updates to internal git and utility libraries shared + with git-annex. + + -- Joey Hess Tue, 21 Feb 2017 15:33:56 -0400 + github-backup (1.20161118) unstable; urgency=medium * Fix build with recent versions of cabal. diff --git a/Common.hs b/Common.hs --- a/Common.hs +++ b/Common.hs @@ -29,6 +29,5 @@ 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 diff --git a/Git/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -37,6 +37,7 @@ import Git.Types import Git.FilePath import qualified Utility.CoProcess as CoProcess +import Utility.FileSystemEncoding data CatFileHandle = CatFileHandle { catFileProcess :: CoProcess.CoProcessHandle diff --git a/Git/Command.hs b/Git/Command.hs --- a/Git/Command.hs +++ b/Git/Command.hs @@ -53,7 +53,6 @@ pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool) pipeReadLazy params repo = assertLocal repo $ do (_, Just h, _, pid) <- createProcess p { std_out = CreatePipe } - fileEncoding h c <- hGetContents h return (c, checkSuccessProcess pid) where @@ -66,7 +65,6 @@ pipeReadStrict :: [CommandParam] -> Repo -> IO String pipeReadStrict params repo = assertLocal repo $ withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do - fileEncoding h output <- hGetContentsStrict h hClose h return output @@ -81,9 +79,7 @@ writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) (gitEnv repo) writer (Just adjusthandle) where - adjusthandle h = do - fileEncoding h - hSetNewlineMode h noNewlineTranslation + adjusthandle h = hSetNewlineMode h noNewlineTranslation {- Runs a git command, feeding it input on a handle with an action. -} pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO () diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -79,10 +79,6 @@ {- Reads git config from a handle and populates a repo with it. -} hRead :: Repo -> Handle -> IO Repo hRead repo h = do - -- We use the FileSystemEncoding when reading from git-config, - -- because it can contain arbitrary filepaths (and other strings) - -- in any encoding. - fileEncoding h val <- hGetContentsStrict h store val repo @@ -167,7 +163,6 @@ 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) diff --git a/Git/HashObject.hs b/Git/HashObject.hs --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -41,7 +41,6 @@ - interface does not allow batch hashing without using temp files. -} hashBlob :: HashObjectHandle -> String -> IO Sha hashBlob h s = withTmpFile "hash" $ \tmp tmph -> do - fileEncoding tmph #ifdef mingw32_HOST_OS hSetNewlineMode tmph noNewlineTranslation #endif diff --git a/Git/Queue.hs b/Git/Queue.hs --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -159,7 +159,6 @@ #ifndef mingw32_HOST_OS let p = (proc "xargs" $ "-0":"git":toCommand gitparams) { env = gitEnv repo } withHandle StdinHandle createProcessSuccess p $ \h -> do - fileEncoding h hPutStr h $ intercalate "\0" $ toCommand $ getFiles action hClose h #else diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -55,7 +55,6 @@ startUpdateIndex repo = do (Just h, _, _, p) <- createProcess (gitCreateProcess params repo) { std_in = CreatePipe } - fileEncoding h return $ UpdateIndexHandle p h where params = map Param ["update-index", "-z", "--index-info"] diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -10,9 +10,9 @@ sudo apt-get install haskell-stack -Then to build and install github-backup: +Then to build and install github-backup, clone it, cd inside, and run: - stack install github-backup + stack install There is also a Makefile, which uses cabal to build, and installs a man page, bash completion file, etc. This is recommended for use when diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -47,10 +47,10 @@ rawMode to return $ CoProcessState pid to from s where - rawMode h = do - fileEncoding h #ifdef mingw32_HOST_OS - hSetNewlineMode h noNewlineTranslation + rawMode h = hSetNewlineMode h noNewlineTranslation +#else + rawMode _ = return () #endif stop :: CoProcessHandle -> IO () diff --git a/Utility/Exception.hs b/Utility/Exception.hs --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -1,6 +1,6 @@ {- Simple IO exception handling (and some more) - - - Copyright 2011-2015 Joey Hess + - Copyright 2011-2016 Joey Hess - - License: BSD-2-clause -} @@ -10,6 +10,7 @@ module Utility.Exception ( module X, + giveup, catchBoolIO, catchMaybeIO, catchDefaultIO, @@ -39,6 +40,21 @@ import GHC.IO.Exception (IOErrorType(..)) import Utility.Data + +{- Like error, this throws an exception. Unlike error, if this exception + - is not caught, it won't generate a backtrace. So use this for situations + - where there's a problem that the user is excpected to see in some + - circumstances. -} +giveup :: [Char] -> a +#ifdef MIN_VERSION_base +#if MIN_VERSION_base(4,9,0) +giveup = errorWithoutStackTrace +#else +giveup = error +#endif +#else +giveup = error +#endif {- Catches IO errors and returns a Bool -} catchBoolIO :: MonadCatch m => m Bool -> m Bool diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -1,6 +1,6 @@ {- GHC File system encoding handling. - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2016 Joey Hess - - License: BSD-2-clause -} @@ -9,7 +9,7 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.FileSystemEncoding ( - fileEncoding, + useFileSystemEncoding, withFilePath, md5FilePath, decodeBS, @@ -19,7 +19,6 @@ encodeW8NUL, decodeW8NUL, truncateFilePath, - setConsoleEncoding, ) where import qualified GHC.Foreign as GHC @@ -39,19 +38,30 @@ import Utility.Exception -{- Sets a Handle to use the filesystem encoding. This causes data - - written or read from it to be encoded/decoded the same - - as ghc 7.4 does to filenames etc. This special encoding - - allows "arbitrary undecodable bytes to be round-tripped through it". +{- Makes all subsequent Handles that are opened, as well as stdio Handles, + - use the filesystem encoding, instead of the encoding of the current + - locale. + - + - The filesystem encoding allows "arbitrary undecodable bytes to be + - round-tripped through it". This avoids encoded failures when data is not + - encoded matching the current locale. + - + - Note that code can still use hSetEncoding to change the encoding of a + - Handle. This only affects the default encoding. -} -fileEncoding :: Handle -> IO () +useFileSystemEncoding :: IO () +useFileSystemEncoding = do #ifndef mingw32_HOST_OS -fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding + e <- Encoding.getFileSystemEncoding #else -{- The file system encoding does not work well on Windows, - - and Windows only has utf FilePaths anyway. -} -fileEncoding h = hSetEncoding h Encoding.utf8 + {- The file system encoding does not work well on Windows, + - and Windows only has utf FilePaths anyway. -} + let e = Encoding.utf8 #endif + hSetEncoding stdin e + hSetEncoding stdout e + hSetEncoding stderr e + Encoding.setLocaleEncoding e {- Marshal a Haskell FilePath into a NUL terminated C string using temporary - storage. The FilePath is encoded using the filesystem encoding, @@ -165,10 +175,3 @@ else go (c:coll) (cnt - x') (L8.drop 1 bs) _ -> coll #endif - -{- This avoids ghc's output layer crashing on invalid encoded characters in - - filenames when printing them out. -} -setConsoleEncoding :: IO () -setConsoleEncoding = do - fileEncoding stdout - fileEncoding stderr diff --git a/Utility/Misc.hs b/Utility/Misc.hs --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -10,9 +10,6 @@ module Utility.Misc where -import Utility.FileSystemEncoding -import Utility.Monad - import System.IO import Control.Monad import Foreign @@ -34,20 +31,6 @@ {- A version of readFile that is not lazy. -} readFileStrict :: FilePath -> IO String readFileStrict = readFile >=> \s -> length s `seq` return s - -{- Reads a file strictly, and using the FileSystemEncoding, so it will - - never crash on a badly encoded file. -} -readFileStrictAnyEncoding :: FilePath -> IO String -readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do - fileEncoding h - hClose h `after` hGetContentsStrict h - -{- Writes a file, using the FileSystemEncoding so it will never crash - - on a badly encoded content string. -} -writeFileAnyEncoding :: FilePath -> String -> IO () -writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do - fileEncoding h - hPutStr h content {- Like break, but the item matching the condition is not included - in the second result list. diff --git a/Utility/SystemDirectory.hs b/Utility/SystemDirectory.hs --- a/Utility/SystemDirectory.hs +++ b/Utility/SystemDirectory.hs @@ -13,4 +13,4 @@ module System.Directory ) where -import System.Directory hiding (isSymbolicLink) +import System.Directory hiding (isSymbolicLink, getFileSize) diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -16,6 +16,7 @@ import Utility.Env import Utility.Data +import Utility.Exception import System.PosixCompat import Control.Applicative @@ -25,7 +26,7 @@ - - getpwent will fail on LDAP or NIS, so use HOME if set. -} myHomeDir :: IO FilePath -myHomeDir = either error return =<< myVal env homeDirectory +myHomeDir = either giveup return =<< myVal env homeDirectory where #ifndef mingw32_HOST_OS env = ["HOME"] diff --git a/github-backup.cabal b/github-backup.cabal --- a/github-backup.cabal +++ b/github-backup.cabal @@ -1,5 +1,5 @@ Name: github-backup -Version: 1.20161118 +Version: 1.20170221 Cabal-Version: >= 1.8 Maintainer: Joey Hess Author: Joey Hess @@ -37,11 +37,12 @@ Executable github-backup Main-Is: github-backup.hs GHC-Options: -Wall -fno-warn-tabs - Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl, - network, exceptions, transformers, unix-compat, bytestring, vector, - IfElse, pretty-show, text, process, optparse-applicative, utf8-string, - github >= 0.14.0 && < 0.15.0, - base >= 4.8, base < 5 + Build-Depends: + base (>= 4.8 && < 5), + github (>= 0.15.0 && < 0.16.0), + MissingH, hslogger, directory, filepath, containers, mtl, + network, exceptions, transformers, unix-compat, bytestring, vector, + IfElse, pretty-show, text, process, optparse-applicative, utf8-string if (! os(windows)) Build-Depends: unix @@ -104,9 +105,12 @@ Executable gitriddance Main-Is: gitriddance.hs GHC-Options: -Wall -fno-warn-tabs - Build-Depends: github >= 0.14.0 && < 0.15.0, base >= 4.8, base < 5, text, filepath, - MissingH, exceptions, transformers, bytestring, vector, hslogger, process, - containers, unix-compat, IfElse, directory, mtl, utf8-string + Build-Depends: + base (>= 4.8 && < 5), + github (>= 0.15.0 && < 0.16.0), + text, filepath, MissingH, exceptions, transformers, bytestring, vector, + hslogger, process, containers, unix-compat, IfElse, directory, mtl, + utf8-string if (! os(windows)) Build-Depends: unix diff --git a/github-backup.hs b/github-backup.hs --- a/github-backup.hs +++ b/github-backup.hs @@ -52,6 +52,7 @@ import Git.CatFile import Git.Index import Utility.Env +import Utility.FileSystemEncoding repoUrl :: GithubUserRepo -> String repoUrl (GithubUserRepo user remote) = @@ -156,7 +157,9 @@ storeSorted "stargazers" pullrequestsStore :: Storer -pullrequestsStore = simpleHelper "pullrequest" Github.pullRequestsFor' $ +pullrequestsStore = simpleHelper "pullrequest" + -- No way to send auth to pullRequestsFor currently. + (\_auth -> Github.pullRequestsFor) $ forValues $ \req r -> do let repo = requestRepo req let n = Github.simplePullRequestNumber r @@ -178,14 +181,9 @@ store ("milestone" show n) req m issuesStore :: Storer -issuesStore = withHelper "issue" (\a u r y -> - Github.issuesForRepo' a (fromString u) (fromString r) (y <> [Github.Open]) - >>= either (return . Left) - (\xs -> Github.issuesForRepo' a (fromString u) (fromString r) - (y <> [Github.OnlyClosed]) - >>= either (return . Left) - (\ys -> return (Right (xs <> ys))))) - [Github.PerPage 100] go +issuesStore = withHelper "issue" + (\a u r -> Github.issuesForRepo' a (fromString u) (fromString r)) + Github.stateAll go where go = forValues $ \req i -> do let repo = requestRepo req @@ -567,9 +565,10 @@ where excludeurls = map repoUrl exclude + makenameurl :: Github.Repo -> Maybe (String, String) makenameurl repo = case Github.repoGitUrl repo of - Just url -> Just (T.unpack $ Github.untagName $ Github.repoName repo, T.unpack url) + Just url -> Just (T.unpack $ Github.untagName $ Github.repoName repo, T.unpack $ Github.getUrl url) Nothing -> Nothing prepare (dir, url) @@ -618,7 +617,9 @@ in GithubUserRepo user repo main :: IO () -main = execParser opts >>= go +main = do + useFileSystemEncoding + execParser opts >>= go where opts = info (helper <*> options) ( fullDesc diff --git a/gitriddance.hs b/gitriddance.hs --- a/gitriddance.hs +++ b/gitriddance.hs @@ -48,7 +48,7 @@ closeall :: Github.Auth -> GithubUserRepo -> String -> IO () closeall auth (GithubUserRepo user repo) msg = either (oops "getting issue list") (mapM_ close) - =<< Github.issuesForRepo' (Just auth) (fromString user) (fromString repo) [Github.Open] + =<< Github.issuesForRepo' (Just auth) (fromString user) (fromString repo) Github.stateOpen where oops action err = error $ "failed " ++ action ++ ": " ++ show err close issue = do @@ -58,4 +58,4 @@ =<< Github.createComment auth (fromString user) (fromString repo) (Github.mkId (Github.Id 0) i) (T.pack msg) either (oops "closing issue/pull") (const $ return ()) =<< Github.editIssue auth (fromString user) (fromString repo) (Github.mkId (Github.Id 0) i) - (Github.editOfIssue { Github.editIssueState = Just (T.pack "closed") } ) + (Github.editOfIssue { Github.editIssueState = Just Github.StateClosed } ) diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ packages: - '.' -resolver: lts-6.12 +resolver: lts-8.2 extra-deps: []