diff --git a/Build/TestConfig.hs b/Build/TestConfig.hs --- a/Build/TestConfig.hs +++ b/Build/TestConfig.hs @@ -1,5 +1,7 @@ {- Tests the system and generates Build.SysConfig.hs. -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Build.TestConfig where import Utility.Path diff --git a/Build/Version.hs b/Build/Version.hs --- a/Build/Version.hs +++ b/Build/Version.hs @@ -1,5 +1,7 @@ {- Package version determination, for configure script. -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Build.Version where import Data.Maybe @@ -10,14 +12,15 @@ import Data.Char import System.Process -import Build.TestConfig import Utility.Monad import Utility.Exception +type Version = String + {- Set when making an official release. (Distribution vendors should set - this too.) -} isReleaseBuild :: IO Bool -isReleaseBuild = isJust <$> catchMaybeIO (getEnv "RELEASE_BUILD") +isReleaseBuild = (== Just "1") <$> 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. @@ -25,14 +28,14 @@ - - 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 :: IO Version getVersion = do changelogversion <- getChangelogVersion - version <- ifM (isReleaseBuild) + ifM (isReleaseBuild) ( return changelogversion , catchDefaultIO changelogversion $ do let major = takeWhile (/= '.') changelogversion - autoversion <- readProcess "sh" + autoversion <- takeWhile (\c -> isAlphaNum c || c == '-') <$> readProcess "sh" [ "-c" , "git log -n 1 --format=format:'%ci %h'| sed -e 's/-//g' -e 's/ .* /-g/'" ] "" @@ -40,9 +43,8 @@ then return changelogversion else return $ concat [ major, ".", autoversion ] ) - return $ Config "packageversion" (StringConfig version) -getChangelogVersion :: IO String +getChangelogVersion :: IO Version getChangelogVersion = do changelog <- readFile "debian/changelog" let verline = takeWhile (/= '\n') changelog diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,189 @@ +github-backup (1.20150617) unstable; urgency=medium + + * Add missing build deps for windows to cabal file. + Thanks, Jeff Segal. + * Various updates to internal git and utility libraries shared + with git-annex. + + -- Joey Hess Wed, 17 Jun 2015 14:44:14 -0400 + +github-backup (1.20150106) unstable; urgency=medium + + * Fix build with process 1.2.1.0. + * Various updates to internal git and utility libraries shared + with git-annex. + + -- Joey Hess Tue, 06 Jan 2015 19:08:08 -0400 + +github-backup (1.20141222) unstable; urgency=medium + + * Added gitriddance(1), a utility to close all issues and pull requests, + for repos that don't want to be bothered with GitHub's proprietary + issue tracker. + * gitriddance depends on github 0.13.1, which has bug fixes + for posting comments. + * Various updates to internal git and utility libraries shared + with git-annex. + + -- Joey Hess Mon, 22 Dec 2014 15:30:08 -0400 + +github-backup (1.20141204) unstable; urgency=high + + * Fix broken argument parser for the username|organization parameter. + Closes: #772043 + + -- Joey Hess Thu, 04 Dec 2014 12:29:06 -0400 + +github-backup (1.20141110) unstable; urgency=medium + + * Orphaned the Debian package. + (I continue to maintain github-backup upstream.) + + -- Joey Hess Mon, 10 Nov 2014 12:19:59 -0400 + +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 + + -- Joey Hess Mon, 21 Jul 2014 13:10:49 -0400 + +github-backup (1.20140720) unstable; urgency=medium + + * Deal with trailing slashes on github repo urls. Closes: #755261 + * Fix bug introduced by change to embedded git libraries + in last release. Closes: #755262 + + -- Joey Hess Sun, 20 Jul 2014 17:20:26 -0400 + +github-backup (1.20140707) unstable; urgency=medium + + * Add --exclude to skip backing up a specific repository + when backing up a user or organization's repositories. + Closes: #754072 + * Converted to using optparse-applicative. + * Multiple usernames can now be specified to back up at once. + + -- Joey Hess Mon, 07 Jul 2014 23:01:03 -0400 + +github-backup (1.20140704) unstable; urgency=medium + + * Avoid making signed commits when committing to the github-backup branch + and the user has commit.gpgsign=true. + Closes: #753720 + * Various updates to internal git and utility libraries shared with git-annex. + + -- Joey Hess Fri, 04 Jul 2014 12:01:11 -0400 + +github-backup (1.20131203) unstable; urgency=low + + * Now also backs up the repos a user has starred, when run with a user's + name. + * Now finds and backs up the parent repository that a repository got forked + from. + * Uses authentication for all API calls. + * Fairer ordering of requests when backing up many repositories at once. + * Avoid making requests for data that has already been backed up until + after new data has been backed up. Handles API rate limiting much better. + Closes: #723859 + + -- Joey Hess Tue, 03 Dec 2013 12:45:18 -0400 + +github-backup (1.20131101) unstable; urgency=low + + * Now also backs up the repos a user is watching, when run with a user's + name. Useful if you want to back up repositories that you have not forked; + just watch them and run github-backup. + * Can now log in to github, to avoid increasingly small API rate limits. + Set GITHUB_USER and GITHUB_PASSWORD environment to enable. + Note that a few api calls don't use authentication; see + https://github.com/fpco/github/issues/40 + * Build-Depend on git. Closes: #728481 + * Don't include tmp directory in files stored in the github branch. + + -- Joey Hess Fri, 01 Nov 2013 18:00:16 -0400 + +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 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 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 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 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 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 + Thanks to John Wiegley for making those changes. + * Also backup closed issues. Thanks, John Wiegley. + * cabal file no longer tries to list every source file, as that was + error-prone, and I left some out. + + -- Joey Hess Fri, 12 Apr 2013 18:33:11 -0400 + +github-backup (1.20120627) unstable; urgency=low + + * Rebuilt with new haskell-github, that works with the new version + of http-conduit in Debian. Closes: #678787 + * Various updates to internal git and utility libraries shared with git-annex. + + -- Joey Hess Wed, 27 Jun 2012 22:21:01 -0400 + +github-backup (1.20120314) unstable; urgency=low + + * First release. + + -- Joey Hess Tue, 13 Mar 2012 20:22:43 -0400 diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,35 @@ +Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ +Source: native package + +Files: * +Copyright: © 2010-2014 Joey Hess +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 systems. + +Files: Utility/* +Copyright: 2012-2014 Joey Hess +License: BSD-2-clause + +License: BSD-2-clause + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + . + THIS SOFTWARE IS PROVIDED BY AUTHORS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. diff --git a/Git.hs b/Git.hs --- a/Git.hs +++ b/Git.hs @@ -3,7 +3,7 @@ - This is written to be completely independant of git-annex and should be - suitable for other uses. - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -30,6 +30,8 @@ attributes, hookPath, assertLocal, + adjustPath, + relPath, ) where import Network.URI (uriPath, uriScheme, unEscapeString) @@ -58,7 +60,7 @@ repoLocation Repo { location = Local { worktree = Just dir } } = dir repoLocation Repo { location = Local { gitdir = dir } } = dir repoLocation Repo { location = LocalUnknown dir } = dir -repoLocation Repo { location = Unknown } = undefined +repoLocation Repo { location = Unknown } = error "unknown repoLocation" {- Path to a repository. For non-bare, this is the worktree, for bare, - it's the gitdir, and for URL repositories, is the path on the remote @@ -68,12 +70,12 @@ repoPath Repo { location = Local { worktree = Just d } } = d repoPath Repo { location = Local { gitdir = d } } = d repoPath Repo { location = LocalUnknown dir } = dir -repoPath Repo { location = Unknown } = undefined +repoPath Repo { location = Unknown } = error "unknown repoPath" {- Path to a local repository's .git directory. -} localGitDir :: Repo -> FilePath localGitDir Repo { location = Local { gitdir = d } } = d -localGitDir _ = undefined +localGitDir _ = error "unknown localGitDir" {- Some code needs to vary between URL and normal repos, - or bare and non-bare, these functions help with that. -} @@ -139,3 +141,29 @@ #else isexecutable f = isExecutable . fileMode <$> getFileStatus f #endif + +{- Makes the path to a local Repo be relative to the cwd. -} +relPath :: Repo -> IO Repo +relPath = adjustPath torel + where + torel p = do + p' <- relPathCwdToFile p + if null p' + then return "." + else return p' + +{- Adusts the path to a local Repo using the provided function. -} +adjustPath :: (FilePath -> IO FilePath) -> Repo -> IO Repo +adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do + d' <- f d + w' <- maybe (pure Nothing) (Just <$$> f) w + return $ r + { location = l + { gitdir = d' + , worktree = w' + } + } +adjustPath f r@(Repo { location = LocalUnknown d }) = do + d' <- f d + return $ r { location = LocalUnknown d' } +adjustPath _ r = pure r diff --git a/Git/Branch.hs b/Git/Branch.hs --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -1,6 +1,6 @@ {- git branch stuff - - - Copyright 2011 Joey Hess + - Copyright 2011 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -37,14 +37,11 @@ {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Git.Ref) currentUnsafe r = parse . firstLine - <$> pipeReadStrict [Param "symbolic-ref", Param $ fromRef Git.Ref.headRef] r + <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r where parse l | null l = Nothing | otherwise = Just $ Git.Ref l - -currentSha :: Repo -> IO (Maybe Git.Sha) -currentSha r = maybe (pure Nothing) (`Git.Ref.sha` r) =<< current r {- Checks if the second branch has any commits not present on the first - branch. -} diff --git a/Git/BuildVersion.hs b/Git/BuildVersion.hs --- a/Git/BuildVersion.hs +++ b/Git/BuildVersion.hs @@ -1,6 +1,6 @@ {- git build version - - - Copyright 2011 Joey Hess + - Copyright 2011 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Git/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -1,6 +1,6 @@ {- git cat-file interface - - - Copyright 2011, 2013 Joey Hess + - Copyright 2011, 2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -110,4 +110,4 @@ parsemodefile b = let (modestr, file) = separate (== ' ') (decodeBS b) in (file, readmode modestr) - readmode = fst . fromMaybe (0, undefined) . headMaybe . readOct + readmode = fromMaybe 0 . fmap fst . headMaybe . readOct diff --git a/Git/Command.hs b/Git/Command.hs --- a/Git/Command.hs +++ b/Git/Command.hs @@ -1,6 +1,6 @@ {- running git commands - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -16,7 +16,7 @@ {- Constructs a git command line operating on the specified repo. -} gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] -gitCommandLine params r@(Repo { location = l@(Local _ _ ) }) = +gitCommandLine params r@(Repo { location = l@(Local { } ) }) = setdir : settree ++ gitGlobalOpts r ++ params where setdir = Param $ "--git-dir=" ++ gitdir l diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -1,6 +1,6 @@ {- git repository configuration handling - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -14,6 +14,7 @@ import Git import Git.Types import qualified Git.Construct +import qualified Git.Command import Utility.UserInfo {- Returns a single git config setting, or a default value if not set. -} @@ -66,10 +67,9 @@ home <- myHomeDir ifM (doesFileExist $ home ".gitconfig") ( do - repo <- Git.Construct.fromUnknown - repo' <- withHandle StdoutHandle createProcessSuccess p $ - hRead repo - return $ Just repo' + repo <- withHandle StdoutHandle createProcessSuccess p $ + hRead (Git.Construct.fromUnknown) + return $ Just repo , return Nothing ) where @@ -194,3 +194,17 @@ , Param k , Param v ] + +{- Unsets a git config setting, in both the git repo, + - and the cached config in the Repo. + - + - If unsetting the config fails, including in a read-only repo, or + - when the config is not set, returns Nothing. + -} +unset :: String -> Repo -> IO (Maybe Repo) +unset k r = ifM (Git.Command.runBool ps r) + ( return $ Just $ r { config = M.delete k (config r) } + , return Nothing + ) + where + ps = [Param "config", Param "--unset-all", Param k] diff --git a/Git/Construct.hs b/Git/Construct.hs --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -1,6 +1,6 @@ {- Construction of Git Repo objects - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -19,8 +19,8 @@ fromRemotes, fromRemoteLocation, repoAbsPath, - newFrom, checkForRepo, + newFrom, ) where #ifndef mingw32_HOST_OS @@ -45,10 +45,10 @@ seekUp dir = do r <- checkForRepo dir case r of - Nothing -> case parentDir dir of + Nothing -> case upFrom dir of Nothing -> return Nothing Just d -> seekUp d - Just loc -> Just <$> newFrom loc + Just loc -> pure $ Just $ newFrom loc {- Local Repo constructor, accepts a relative or absolute path. -} fromPath :: FilePath -> IO Repo @@ -62,7 +62,7 @@ | otherwise = error $ "internal error, " ++ dir ++ " is not absolute" where - ret = newFrom . LocalUnknown + ret = pure . newFrom . LocalUnknown {- Git always looks for "dir.git" in preference to - to "dir", even if dir ends in a "/". -} canondir = dropTrailingPathSeparator dir @@ -90,13 +90,13 @@ fromUrlStrict :: String -> IO Repo fromUrlStrict url | startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u - | otherwise = newFrom $ Url u + | otherwise = pure $ newFrom $ Url u where u = fromMaybe bad $ parseURI url bad = error $ "bad url " ++ url {- Creates a repo that has an unknown location. -} -fromUnknown :: IO Repo +fromUnknown :: Repo fromUnknown = newFrom Unknown {- Converts a local Repo into a remote repo, using the reference repo @@ -153,7 +153,7 @@ fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do dir' <- expandTilde dir - fromAbsPath $ repoPath repo dir' + fromPath $ repoPath repo dir' {- Git remotes can have a directory that is specified relative - to the user's home directory, or that contains tilde expansions. @@ -223,8 +223,8 @@ gitdirprefix = "gitdir: " gitSignature file = doesFileExist $ dir file -newFrom :: RepoLocation -> IO Repo -newFrom l = return Repo +newFrom :: RepoLocation -> Repo +newFrom l = Repo { location = l , config = M.empty , fullconfig = M.empty @@ -233,5 +233,4 @@ , gitEnv = Nothing , gitGlobalOpts = [] } - diff --git a/Git/DiffTreeItem.hs b/Git/DiffTreeItem.hs --- a/Git/DiffTreeItem.hs +++ b/Git/DiffTreeItem.hs @@ -1,6 +1,6 @@ {- git diff-tree item - - - Copyright 2012 Joey Hess + - Copyright 2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Git/FilePath.hs b/Git/FilePath.hs --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -5,7 +5,7 @@ - top of the repository even when run in a subdirectory. Adding some - types helps keep that straight. - - - Copyright 2012-2013 Joey Hess + - Copyright 2012-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -39,8 +39,7 @@ {- 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 +toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file {- The input FilePath must already be relative to the top of the git - repository -} diff --git a/Git/HashObject.hs b/Git/HashObject.hs --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -1,6 +1,6 @@ {- git hash-object interface - - - Copyright 2011-2014 Joey Hess + - Copyright 2011-2014 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -32,7 +32,7 @@ hashFile :: HashObjectHandle -> FilePath -> IO Sha hashFile h file = CoProcess.query h send receive where - send to = hPutStrLn to file + send to = hPutStrLn to =<< absPath file receive from = getSha "hash-object" $ hGetLine from {- Injects a blob into git. Unfortunately, the current git-hash-object diff --git a/Git/Queue.hs b/Git/Queue.hs --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -1,6 +1,6 @@ {- git repository command queue - - - Copyright 2010,2012 Joey Hess + - Copyright 2010,2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Git/Ref.hs b/Git/Ref.hs --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -1,6 +1,6 @@ {- git ref stuff - - - Copyright 2011-2013 Joey Hess + - Copyright 2011-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -87,6 +87,9 @@ Param $ fromRef branch] process [] = Nothing process s = Just $ Ref $ firstLine s + +headSha :: Repo -> IO (Maybe Sha) +headSha = sha headRef {- List of (shas, branches) matching a given ref or refs. -} matching :: [Ref] -> Repo -> IO [(Sha, Branch)] diff --git a/Git/Remote.hs b/Git/Remote.hs --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -1,6 +1,6 @@ {- git remote stuff - - - Copyright 2012 Joey Hess + - Copyright 2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Git/Sha.hs b/Git/Sha.hs --- a/Git/Sha.hs +++ b/Git/Sha.hs @@ -1,6 +1,6 @@ {- git SHA stuff - - - Copyright 2011 Joey Hess + - Copyright 2011 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Git/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -1,6 +1,6 @@ {- git data types - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -1,6 +1,6 @@ {- git-update-index library - - - Copyright 2011-2013 Joey Hess + - Copyright 2011-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Git/Url.hs b/Git/Url.hs --- a/Git/Url.hs +++ b/Git/Url.hs @@ -1,6 +1,6 @@ {- git repository urls - - - Copyright 2010, 2011 Joey Hess + - Copyright 2010, 2011 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Git/Version.hs b/Git/Version.hs --- a/Git/Version.hs +++ b/Git/Version.hs @@ -1,9 +1,11 @@ {- git versions - - - Copyright 2011, 2013 Joey Hess + - Copyright 2011, 2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} module Git.Version ( installed, diff --git a/Utility/Applicative.hs b/Utility/Applicative.hs --- a/Utility/Applicative.hs +++ b/Utility/Applicative.hs @@ -1,6 +1,6 @@ {- applicative stuff - - - Copyright 2012 Joey Hess + - Copyright 2012 Joey Hess - - License: BSD-2-clause -} diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -1,7 +1,7 @@ {- Interface for running a shell command as a coprocess, - sending it queries and getting back results. - - - Copyright 2012-2013 Joey Hess + - Copyright 2012-2013 Joey Hess - - License: BSD-2-clause -} diff --git a/Utility/Data.hs b/Utility/Data.hs --- a/Utility/Data.hs +++ b/Utility/Data.hs @@ -1,9 +1,11 @@ {- utilities for simple data types - - - Copyright 2013 Joey Hess + - Copyright 2013 Joey Hess - - License: BSD-2-clause -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Data where diff --git a/Utility/Directory.hs b/Utility/Directory.hs --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -1,11 +1,12 @@ {- directory traversal and manipulation - - - Copyright 2011-2014 Joey Hess + - Copyright 2011-2014 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Directory where @@ -18,6 +19,7 @@ import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO) import Data.Maybe +import Prelude #ifdef mingw32_HOST_OS import qualified System.Win32 as Win32 @@ -111,7 +113,7 @@ -- But, mv will move into a directory if -- dest is one, which is not desired. whenM (isdir dest) rethrow - viaTmp mv dest undefined + viaTmp mv dest "" where rethrow = throwM e mv tmp _ = do diff --git a/Utility/DottedVersion.hs b/Utility/DottedVersion.hs --- a/Utility/DottedVersion.hs +++ b/Utility/DottedVersion.hs @@ -1,9 +1,11 @@ {- dotted versions, such as 1.0.1 - - - Copyright 2011-2014 Joey Hess + - Copyright 2011-2014 Joey Hess - - License: BSD-2-clause -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.DottedVersion where diff --git a/Utility/Env.hs b/Utility/Env.hs --- a/Utility/Env.hs +++ b/Utility/Env.hs @@ -1,11 +1,12 @@ {- portable environment variables - - - Copyright 2013 Joey Hess + - Copyright 2013 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Env where @@ -13,6 +14,7 @@ import Utility.Exception import Control.Applicative import Data.Maybe +import Prelude import qualified System.Environment as E import qualified System.SetEnv #else diff --git a/Utility/Exception.hs b/Utility/Exception.hs --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -1,11 +1,12 @@ {- Simple IO exception handling (and some more) - - - Copyright 2011-2014 Joey Hess + - Copyright 2011-2015 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Exception ( module X, @@ -19,6 +20,7 @@ catchNonAsync, tryNonAsync, tryWhenExists, + catchHardwareFault, ) where import Control.Monad.Catch as X hiding (Handler) @@ -26,7 +28,9 @@ import Control.Exception (IOException, AsyncException) import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) -import System.IO.Error (isDoesNotExistError) +import System.IO.Error (isDoesNotExistError, ioeGetErrorType) +import GHC.IO.Exception (IOErrorType(..)) + import Utility.Data {- Catches IO errors and returns a Bool -} @@ -86,3 +90,12 @@ tryWhenExists a = do v <- tryJust (guard . isDoesNotExistError) a return (eitherToMaybe v) + +{- Catches only exceptions caused by hardware faults. + - Ie, disk IO error. -} +catchHardwareFault :: MonadCatch m => m a -> (IOException -> m a) -> m a +catchHardwareFault a onhardwareerr = catchIO a onlyhw + where + onlyhw e + | ioeGetErrorType e == HardwareFault = onhardwareerr e + | otherwise = throwM e diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -1,6 +1,6 @@ {- File mode utilities. - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2012 Joey Hess - - License: BSD-2-clause -} @@ -22,15 +22,12 @@ {- Applies a conversion function to a file's mode. -} modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO () -modifyFileMode f convert = void $ modifyFileMode' f convert -modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode -modifyFileMode' f convert = do +modifyFileMode f convert = do s <- getFileStatus f let old = fileMode s let new = convert old when (new /= old) $ setFileMode f new - return old {- Adds the specified FileModes to the input mode, leaving the rest - unchanged. -} @@ -41,14 +38,6 @@ removeModes :: [FileMode] -> FileMode -> FileMode removeModes ms m = m `intersectFileModes` complement (combineModes ms) -{- Runs an action after changing a file's mode, then restores the old mode. -} -withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a -withModifiedFileMode file convert a = bracket setup cleanup go - where - setup = modifyFileMode' file convert - cleanup oldmode = modifyFileMode file (const oldmode) - go _ = a - writeModes :: [FileMode] writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode] @@ -124,7 +113,7 @@ #endif combineModes :: [FileMode] -> FileMode -combineModes [] = undefined +combineModes [] = 0 combineModes [m] = m combineModes (m:ms) = foldl unionFileModes m ms @@ -151,7 +140,11 @@ - as writeFile. -} writeFileProtected :: FilePath -> String -> IO () -writeFileProtected file content = withUmask 0o0077 $ +writeFileProtected file content = writeFileProtected' file + (\h -> hPutStr h content) + +writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO () +writeFileProtected' file writer = withUmask 0o0077 $ withFile file WriteMode $ \h -> do void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes - hPutStr h content + writer h diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -1,11 +1,12 @@ {- GHC File system encoding handling. - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2014 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.FileSystemEncoding ( fileEncoding, @@ -14,6 +15,8 @@ decodeBS, decodeW8, encodeW8, + encodeW8NUL, + decodeW8NUL, truncateFilePath, ) where @@ -25,6 +28,7 @@ import qualified Data.Hash.MD5 as MD5 import Data.Word import Data.Bits.Utils +import Data.List.Utils import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS import qualified Data.ByteString.Lazy.UTF8 as L8 @@ -89,6 +93,9 @@ - w82c produces a String, which may contain Chars that are invalid - unicode. From there, this is really a simple matter of applying the - file system encoding, only complicated by GHC's interface to doing so. + - + - Note that the encoding stops at any NUL in the input. FilePaths + - do not normally contain embedded NUL, but Haskell Strings may. -} {-# NOINLINE encodeW8 #-} encodeW8 :: [Word8] -> FilePath @@ -100,6 +107,17 @@ - represent the FilePath on disk. -} decodeW8 :: FilePath -> [Word8] decodeW8 = s2w8 . _encodeFilePath + +{- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -} +encodeW8NUL :: [Word8] -> FilePath +encodeW8NUL = join nul . map encodeW8 . split (s2w8 nul) + where + nul = ['\NUL'] + +decodeW8NUL :: FilePath -> [Word8] +decodeW8NUL = join (s2w8 nul) . map decodeW8 . split nul + where + nul = ['\NUL'] {- Truncates a FilePath to the given number of bytes (or less), - as represented on disk. diff --git a/Utility/Misc.hs b/Utility/Misc.hs --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -1,28 +1,30 @@ {- misc utility functions - - - Copyright 2010-2011 Joey Hess + - Copyright 2010-2011 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Misc where +import Utility.FileSystemEncoding +import Utility.Monad + import System.IO import Control.Monad import Foreign import Data.Char import Data.List -import Control.Applicative import System.Exit #ifndef mingw32_HOST_OS import System.Posix.Process (getAnyProcessStatus) import Utility.Exception #endif - -import Utility.FileSystemEncoding -import Utility.Monad +import Control.Applicative +import Prelude {- A version of hgetContents that is not lazy. Ensures file is - all read before it gets closed. -} diff --git a/Utility/Monad.hs b/Utility/Monad.hs --- a/Utility/Monad.hs +++ b/Utility/Monad.hs @@ -1,9 +1,11 @@ {- monadic stuff - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2012 Joey Hess - - License: BSD-2-clause -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Monad where diff --git a/Utility/PartialPrelude.hs b/Utility/PartialPrelude.hs --- a/Utility/PartialPrelude.hs +++ b/Utility/PartialPrelude.hs @@ -5,6 +5,8 @@ - them being accidentially used. -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Utility.PartialPrelude where import qualified Data.Maybe diff --git a/Utility/Path.hs b/Utility/Path.hs --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -1,11 +1,12 @@ {- path manipulation - - - Copyright 2010-2014 Joey Hess + - Copyright 2010-2014 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE PackageImports, CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Path where @@ -16,6 +17,7 @@ import Data.Maybe import Data.Char import Control.Applicative +import Prelude #ifdef mingw32_HOST_OS import qualified System.FilePath.Posix as Posix @@ -66,7 +68,7 @@ absPathFrom dir path = simplifyPath (combine dir path) {- On Windows, this converts the paths to unix-style, in order to run - - MissingH's absNormPath on them. Resulting path will use / separators. -} + - MissingH's absNormPath on them. -} absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath #ifndef mingw32_HOST_OS absNormPathUnix dir path = MissingH.absNormPath dir path @@ -77,11 +79,15 @@ todos = replace "/" "\\" #endif +{- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -} +parentDir :: FilePath -> FilePath +parentDir = takeDirectory . dropTrailingPathSeparator + {- Just the parent directory of a path, or Nothing if the path has no - - parent (ie for "/") -} -parentDir :: FilePath -> Maybe FilePath -parentDir dir - | null dirs = Nothing +- parent (ie for "/" or ".") -} +upFrom :: FilePath -> Maybe FilePath +upFrom dir + | length dirs < 2 = Nothing | otherwise = Just $ joinDrive drive (join s $ init dirs) where -- on Unix, the drive will be "/" when the dir is absolute, otherwise "" @@ -89,13 +95,13 @@ dirs = filter (not . null) $ split s path s = [pathSeparator] -prop_parentDir_basics :: FilePath -> Bool -prop_parentDir_basics dir +prop_upFrom_basics :: FilePath -> Bool +prop_upFrom_basics dir | null dir = True - | dir == "/" = parentDir dir == Nothing + | dir == "/" = p == Nothing | otherwise = p /= Just dir where - p = parentDir dir + p = upFrom dir {- Checks if the first FilePath is, or could be said to contain the second. - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc @@ -124,14 +130,25 @@ - relPathCwdToFile "/tmp/foo/bar" == "" -} relPathCwdToFile :: FilePath -> IO FilePath -relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f +relPathCwdToFile f = do + c <- getCurrentDirectory + relPathDirToFile c f -{- Constructs a relative path from a directory to a file. +{- Constructs a relative path from a directory to a file. -} +relPathDirToFile :: FilePath -> FilePath -> IO FilePath +relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to + +{- This requires the first path to be absolute, and the + - second path cannot contain ../ or ./ - - - Both must be absolute, and cannot contain .. etc. (eg use absPath first). + - On Windows, if the paths are on different drives, + - a relative path is not possible and the path is simply + - returned as-is. -} -relPathDirToFile :: FilePath -> FilePath -> FilePath -relPathDirToFile from to = join s $ dotdots ++ uncommon +relPathDirToFileAbs :: FilePath -> FilePath -> FilePath +relPathDirToFileAbs from to + | takeDrive from /= takeDrive to = to + | otherwise = join s $ dotdots ++ uncommon where s = [pathSeparator] pfrom = split s from @@ -144,10 +161,11 @@ prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool prop_relPathDirToFile_basics from to + | null from || null to = True | from == to = null r | otherwise = not (null r) where - r = relPathDirToFile from to + r = relPathDirToFileAbs from to prop_relPathDirToFile_regressionTest :: Bool prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference @@ -156,22 +174,31 @@ - location, but it's not really the same directory. - Code used to get this wrong. -} same_dir_shortcurcuits_at_difference = - relPathDirToFile (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"]) + relPathDirToFileAbs (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 directory, any items - - in the expanded list that are contained in that directory will appear in - - its segment. + - which may be arbitrarily reordered, generates a list of lists, where + - each sublist corresponds to one of the 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. + - + - The order of the original list of paths is attempted to be preserved in + - the order of the returned segments. However, doing so has a O^NM + - growth factor. So, if the original list has more than 100 paths on it, + - we stop preserving ordering at that point. Presumably a user passing + - that many paths in doesn't care too much about order of the later ones. -} segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]] segmentPaths [] new = [new] segmentPaths [_] new = [new] -- optimisation -segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest +segmentPaths (l:ls) new = found : segmentPaths ls rest where - (found, rest)=partition (l `dirContains`) new + (found, rest) = if length ls < 100 + then partition (l `dirContains`) new + else break (\p -> not (l `dirContains` p)) new {- This assumes that it's cheaper to call segmentPaths on the result, - than it would be to run the action separately with each path. In @@ -185,7 +212,7 @@ relHome path = do home <- myHomeDir return $ if dirContains home path - then "~/" ++ relPathDirToFile home path + then "~/" ++ relPathDirToFileAbs home path else path {- Checks if a command is available in PATH. diff --git a/Utility/PosixFiles.hs b/Utility/PosixFiles.hs --- a/Utility/PosixFiles.hs +++ b/Utility/PosixFiles.hs @@ -2,12 +2,13 @@ - - This is like System.PosixCompat.Files, except with a fixed rename. - - - Copyright 2014 Joey Hess + - Copyright 2014 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.PosixFiles ( module X, diff --git a/Utility/Process.hs b/Utility/Process.hs --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -1,12 +1,13 @@ {- System.Process enhancements, including additional ways of running - processes, and logging. - - - Copyright 2012 Joey Hess + - Copyright 2012-2015 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP, Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Process ( module X, @@ -25,14 +26,16 @@ processTranscript, processTranscript', withHandle, - withBothHandles, + withIOHandles, + withOEHandles, withQuietOutput, + feedWithQuietOutput, createProcess, startInteractiveProcess, stdinHandle, stdoutHandle, stderrHandle, - bothHandles, + ioHandles, processHandle, devNull, ) where @@ -52,6 +55,7 @@ import Control.Applicative #endif import Data.Maybe +import Prelude import Utility.Misc import Utility.Exception @@ -61,8 +65,8 @@ data StdHandle = StdinHandle | StdoutHandle | StderrHandle deriving (Eq) -{- Normally, when reading from a process, it does not need to be fed any - - standard input. -} +-- | Normally, when reading from a process, it does not need to be fed any +-- standard input. readProcess :: FilePath -> [String] -> IO String readProcess cmd args = readProcessEnv cmd args Nothing @@ -80,9 +84,8 @@ hClose h return output -{- Runs an action to write to a process on its stdin, - - returns its output, and also allows specifying the environment. - -} +-- | Runs an action to write to a process on its stdin, +-- returns its output, and also allows specifying the environment. writeReadProcessEnv :: FilePath -> [String] @@ -122,8 +125,8 @@ , env = environ } -{- Waits for a ProcessHandle, and throws an IOError if the process - - did not exit successfully. -} +-- | Waits for a ProcessHandle, and throws an IOError if the process +-- did not exit successfully. forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO () forceSuccessProcess p pid = do code <- waitForProcess pid @@ -131,10 +134,10 @@ ExitSuccess -> return () ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n -{- 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. -} +-- | 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 @@ -145,13 +148,13 @@ void $ waitForProcess pid return True -{- Runs createProcess, then an action on its handles, and then - - forceSuccessProcess. -} +-- | Runs createProcess, then an action on its handles, and then +-- forceSuccessProcess. createProcessSuccess :: CreateProcessRunner createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a -{- Runs createProcess, then an action on its handles, and then - - a checker action on its exit code, which must wait for the process. -} +-- | Runs createProcess, then an action on its handles, and then +-- 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 @@ -159,14 +162,14 @@ _ <- checker pid either E.throw return r -{- Leaves the process running, suitable for lazy streaming. - - Note: Zombies will result, and must be waited on. -} +-- | 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. -} +-- | 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) processTranscript cmd opts input = processTranscript' cmd opts Nothing input @@ -230,9 +233,9 @@ hClose inh writeinput Nothing _ = return () -{- Runs a CreateProcessRunner, on a CreateProcess structure, that - - is adjusted to pipe only from/to a single StdHandle, and passes - - the resulting Handle to an action. -} +-- | 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. withHandle :: StdHandle -> CreateProcessRunner @@ -254,13 +257,13 @@ | h == StderrHandle = (stderrHandle, base { std_err = CreatePipe }) -{- Like withHandle, but passes (stdin, stdout) handles to the action. -} -withBothHandles +-- | Like withHandle, but passes (stdin, stdout) handles to the action. +withIOHandles :: CreateProcessRunner -> CreateProcess -> ((Handle, Handle) -> IO a) -> IO a -withBothHandles creator p a = creator p' $ a . bothHandles +withIOHandles creator p a = creator p' $ a . ioHandles where p' = p { std_in = CreatePipe @@ -268,8 +271,22 @@ , std_err = Inherit } -{- Forces the CreateProcessRunner to run quietly; - - both stdout and stderr are discarded. -} +-- | Like withHandle, but passes (stdout, stderr) handles to the action. +withOEHandles + :: CreateProcessRunner + -> CreateProcess + -> ((Handle, Handle) -> IO a) + -> IO a +withOEHandles creator p a = creator p' $ a . oeHandles + where + p' = p + { std_in = Inherit + , std_out = CreatePipe + , std_err = CreatePipe + } + +-- | Forces the CreateProcessRunner to run quietly; +-- both stdout and stderr are discarded. withQuietOutput :: CreateProcessRunner -> CreateProcess @@ -281,6 +298,21 @@ } creator p' $ const $ return () +-- | Stdout and stderr are discarded, while the process is fed stdin +-- from the handle. +feedWithQuietOutput + :: CreateProcessRunner + -> CreateProcess + -> (Handle -> IO a) + -> IO a +feedWithQuietOutput creator p a = withFile devNull WriteMode $ \nullh -> do + let p' = p + { std_in = CreatePipe + , std_out = UseHandle nullh + , std_err = UseHandle nullh + } + creator p' $ a . stdinHandle + devNull :: FilePath #ifndef mingw32_HOST_OS devNull = "/dev/null" @@ -288,11 +320,11 @@ 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. - - Get it wrong and the runtime crash will always happen, so should be - - easily noticed. -} +-- | 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. +-- Get it wrong and the runtime crash will always happen, so should be +-- easily noticed. type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle stdinHandle :: HandleExtractor stdinHandle (Just h, _, _, _) = h @@ -303,14 +335,17 @@ stderrHandle :: HandleExtractor stderrHandle (_, _, Just h, _) = h stderrHandle _ = error "expected stderrHandle" -bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) -bothHandles (Just hin, Just hout, _, _) = (hin, hout) -bothHandles _ = error "expected bothHandles" +ioHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) +ioHandles (Just hin, Just hout, _, _) = (hin, hout) +ioHandles _ = error "expected ioHandles" +oeHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) +oeHandles (_, Just hout, Just herr, _) = (hout, herr) +oeHandles _ = error "expected oeHandles" processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle processHandle (_, _, _, pid) = pid -{- Debugging trace for a CreateProcess. -} +-- | Debugging trace for a CreateProcess. debugProcess :: CreateProcess -> IO () debugProcess p = do debugM "Utility.Process" $ unwords @@ -326,15 +361,15 @@ piped Inherit = False piped _ = True -{- Shows the command that a CreateProcess will run. -} +-- | Shows the command that a CreateProcess will run. showCmd :: CreateProcess -> String showCmd = go . cmdspec where go (ShellCommand s) = s go (RawCommand c ps) = c ++ " " ++ show ps -{- Starts an interactive process. Unlike runInteractiveProcess in - - System.Process, stderr is inherited. -} +-- | Starts an interactive process. Unlike runInteractiveProcess in +-- System.Process, stderr is inherited. startInteractiveProcess :: FilePath -> [String] @@ -350,7 +385,8 @@ (Just from, Just to, _, pid) <- createProcess p return (pid, to, from) -{- Wrapper around System.Process function that does debug logging. -} +-- | Wrapper around 'System.Process.createProcess' from System.Process, +-- that does debug logging. createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do debugProcess p diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -1,84 +1,93 @@ {- safely running shell commands - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2015 Joey Hess - - License: BSD-2-clause -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Utility.SafeCommand where import System.Exit import Utility.Process import Data.String.Utils -import Control.Applicative import System.FilePath import Data.Char +import Control.Applicative +import Prelude -{- A type for parameters passed to a shell command. A command can - - be passed either some Params (multiple parameters can be included, - - whitespace-separated, or a single Param (for when parameters contain - - whitespace), or a File. - -} -data CommandParam = Params String | Param String | File FilePath +-- | Parameters that can be passed to a shell command. +data CommandParam + = Param String -- ^ A parameter + | File FilePath -- ^ The name of a file deriving (Eq, Show, Ord) -{- Used to pass a list of CommandParams to a function that runs - - a command and expects Strings. -} +-- | Used to pass a list of CommandParams to a function that runs +-- a command and expects Strings. -} toCommand :: [CommandParam] -> [String] -toCommand = concatMap unwrap +toCommand = map unwrap where - unwrap (Param s) = [s] - unwrap (Params s) = filter (not . null) (split " " s) + unwrap (Param 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] + | 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. - -} +-- | Run a system command, and returns True or False if it succeeded or failed. +-- +-- This and other command running functions in this module log the commands +-- run at debug level, using System.Log.Logger. boolSystem :: FilePath -> [CommandParam] -> IO Bool -boolSystem command params = boolSystemEnv command params Nothing +boolSystem command params = boolSystem' command params id -boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool -boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ +boolSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO Bool +boolSystem' command params mkprocess = dispatch <$> safeSystem' command params mkprocess where dispatch ExitSuccess = True dispatch _ = False -{- Runs a system command, returning the exit status. -} +boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool +boolSystemEnv command params environ = boolSystem' command params $ + \p -> p { env = environ } + +-- | Runs a system command, returning the exit status. safeSystem :: FilePath -> [CommandParam] -> IO ExitCode -safeSystem command params = safeSystemEnv command params Nothing +safeSystem command params = safeSystem' command params id -safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode -safeSystemEnv command params environ = do - (_, _, _, pid) <- createProcess (proc command $ toCommand params) - { env = environ } +safeSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO ExitCode +safeSystem' command params mkprocess = do + (_, _, _, pid) <- createProcess p waitForProcess pid + where + p = mkprocess $ proc command (toCommand params) -{- 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. -} +safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode +safeSystemEnv command params environ = safeSystem' command params $ + \p -> p { env = environ } + +-- | 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. - - - - This method works for POSIX shells, as well as other shells like csh. - -} +-- | Escapes a filename or other parameter to be safely able to be exposed to +-- the shell. +-- +-- This method works for POSIX shells, as well as other shells like csh. shellEscape :: String -> String shellEscape f = "'" ++ escaped ++ "'" where -- replace ' with '"'"' escaped = join "'\"'\"'" $ split "'" f -{- Unescapes a set of shellEscaped words or filenames. -} +-- | Unescapes a set of shellEscaped words or filenames. shellUnEscape :: String -> [String] shellUnEscape [] = [] shellUnEscape s = word : shellUnEscape rest @@ -95,25 +104,32 @@ | c == q = findword w cs | otherwise = inquote q (w++[c]) cs -{- For quickcheck. -} +-- | For quickcheck. prop_idempotent_shellEscape :: String -> Bool 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 [] +-- | Segments a list of filenames into groups that are all below the maximum +-- command-line length limit. +segmentXargsOrdered :: [FilePath] -> [[FilePath]] +segmentXargsOrdered = reverse . map reverse . segmentXargsUnordered + +-- | Not preserving order is a little faster, and streams better when +-- there are a great many filenames. +segmentXargsUnordered :: [FilePath] -> [[FilePath]] +segmentXargsUnordered l = go l [] 0 [] where - go [] c _ r = c:r + go [] c _ r = (c:r) go (f:fs) c accumlen r - | len < maxlen && newlen > maxlen = go (f:fs) [] 0 (c:r) + | newlen > maxlen && len < 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. -} + {- 10k of filenames per command, well under 100k limit + - of Linux (and OSX has a similar limit); + - allows room for other parameters etc. Also allows for + - eg, multibyte characters. -} maxlen = 10240 diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -1,11 +1,12 @@ {- Temporary files and directories. - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2013 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Tmp where diff --git a/Utility/URI.hs b/Utility/URI.hs --- a/Utility/URI.hs +++ b/Utility/URI.hs @@ -1,6 +1,6 @@ {- Network.URI - - - Copyright 2014 Joey Hess + - Copyright 2014 Joey Hess - - License: BSD-2-clause -} diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -1,11 +1,12 @@ {- user info - - - Copyright 2012 Joey Hess + - Copyright 2012 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.UserInfo ( myHomeDir, @@ -13,12 +14,13 @@ myUserGecos, ) where +import Utility.Env + import System.PosixCompat #ifndef mingw32_HOST_OS import Control.Applicative #endif - -import Utility.Env +import Prelude {- Current user's home directory. - diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,12 @@ +github-backup (1.20150617) unstable; urgency=medium + + * Add missing build deps for windows to cabal file. + Thanks, Jeff Segal. + * Various updates to internal git and utility libraries shared + with git-annex. + + -- Joey Hess Wed, 17 Jun 2015 14:44:14 -0400 + github-backup (1.20150106) unstable; urgency=medium * Fix build with process 1.2.1.0. diff --git a/debian/rules b/debian/rules --- a/debian/rules +++ b/debian/rules @@ -8,7 +8,3 @@ %: dh $@ - -# Not intended for use by anyone except the author. -announcedir: - @echo ${HOME}/src/joeywiki/code/github-backup/news diff --git a/github-backup.cabal b/github-backup.cabal --- a/github-backup.cabal +++ b/github-backup.cabal @@ -1,13 +1,14 @@ Name: github-backup -Version: 1.20150106 +Version: 1.20150617 Cabal-Version: >= 1.8 -License: GPL Maintainer: Joey Hess Author: Joey Hess Stability: Stable Copyright: 2012 Joey Hess -License-File: GPL +License: GPL-3 +License-File: COPYRIGHT Build-Type: Custom +Extra-Source-Files: CHANGELOG Homepage: https://github.com/joeyh/github-backup Category: Utility Synopsis: backs up everything github knows about a repository, to the repository @@ -25,7 +26,7 @@ Executable github-backup Main-Is: github-backup.hs - GHC-Options: -Wall + GHC-Options: -Wall -fno-warn-tabs Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl, network, exceptions, transformers, unix-compat, bytestring, IfElse, pretty-show, text, process, optparse-applicative, @@ -34,6 +35,8 @@ if (! os(windows)) Build-Depends: unix + else + Build-Depends: Win32, setenv, utf8-string if flag(network-uri) Build-Depends: network-uri (>= 2.6), network (>= 2.6) @@ -49,6 +52,8 @@ if (! os(windows)) Build-Depends: unix + else + Build-Depends: Win32, setenv, utf8-string if flag(network-uri) Build-Depends: network-uri (>= 2.6), network (>= 2.6) diff --git a/github-backup.hs b/github-backup.hs --- a/github-backup.hs +++ b/github-backup.hs @@ -310,7 +310,7 @@ fs <- filter (not . dirCruft) <$> dirContentsRecursive dir forM_ fs $ \f -> do sha <- hashFile h f - let path = asTopFilePath (relPathDirToFile dir f) + path <- asTopFilePath <$> relPathDirToFile dir f streamer $ Git.UpdateIndex.updateIndexLine sha Git.Types.FileBlob path