From 007ff882d69eda1527c74899290889251b304bc8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 15 Dec 2015 20:52:43 -0400 Subject: add news item for git-repair 1.20151215 --- doc/news/version_1.20151215.mdwn | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 doc/news/version_1.20151215.mdwn diff --git a/doc/news/version_1.20151215.mdwn b/doc/news/version_1.20151215.mdwn new file mode 100644 index 0000000..79b16f1 --- /dev/null +++ b/doc/news/version_1.20151215.mdwn @@ -0,0 +1,5 @@ +git-repair 1.20151215 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * Fix insecure temporary permissions and potential denial of + service attack when creating temp dirs. Closes: #[807341](http://bugs.debian.org/807341) + * Merge from git-annex."""]] \ No newline at end of file -- cgit v1.2.3 From c61b677e7a67a286df34c0629c52aeae9be9299a Mon Sep 17 00:00:00 2001 From: Richard Hartmann Date: Wed, 16 Dec 2015 07:21:46 +0100 Subject: debian/control: New Depends and Standards-Version --- debian/control | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/debian/control b/debian/control index cdbef1c..23dab3d 100644 --- a/debian/control +++ b/debian/control @@ -16,9 +16,9 @@ Build-Depends: libghc-quickcheck2-dev, libghc-utf8-string-dev, libghc-async-dev, - libghc-optparse-applicative-dev (>= 0.10.0) + libghc-network-uri-dev Maintainer: Richard Hartmann -Standards-Version: 3.9.5 +Standards-Version: 3.9.6 Vcs-Git: git://git-repair.branchable.com/ Homepage: http://git-repair.branchable.com/ -- cgit v1.2.3 From 98a07ed5de97e80c389271b9cb9fa3ffa91c1bee Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 4 May 2016 12:16:44 -0400 Subject: git-repair.cabal: Add Setup-Depends. --- debian/changelog | 6 ++++++ git-repair.cabal | 3 +++ 2 files changed, 9 insertions(+) diff --git a/debian/changelog b/debian/changelog index efbd0a8..395b4dc 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +git-repair (1.20151216) UNRELEASED; urgency=medium + + * git-repair.cabal: Add Setup-Depends. + + -- Joey Hess Wed, 04 May 2016 12:16:33 -0400 + git-repair (1.20151215) unstable; urgency=medium * Fix insecure temporary permissions and potential denial of diff --git a/git-repair.cabal b/git-repair.cabal index d4583ea..25f0f2e 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -44,6 +44,9 @@ Executable git-repair else Build-Depends: unix +custom-setup + Setup-Depends: base (>= 4.5), hslogger, MissingH + source-repository head type: git location: git://git-repair.branchable.com/ -- cgit v1.2.3 From 1f0dd5752920cda9b247ff11fa3a80fcc7188bfb Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 24 May 2016 01:22:37 -0400 Subject: merge from git-annex --- Build/Configure.hs | 2 ++ Build/TestConfig.hs | 4 +++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/Build/Configure.hs b/Build/Configure.hs index e488ee1..d48d580 100644 --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -1,5 +1,7 @@ {- Checks system configuration and generates SysConfig.hs. -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Build.Configure where import System.Environment diff --git a/Build/TestConfig.hs b/Build/TestConfig.hs index e55641f..79979c5 100644 --- a/Build/TestConfig.hs +++ b/Build/TestConfig.hs @@ -1,14 +1,16 @@ {- Tests the system and generates Build.SysConfig.hs. -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Build.TestConfig where import Utility.Path import Utility.Monad import Utility.SafeCommand +import Utility.Directory import System.IO import System.FilePath -import System.Directory type ConfigKey = String data ConfigValue = -- cgit v1.2.3 From c86fb48e2fe685434558c0ccfc27d093ce741835 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 24 May 2016 01:30:21 -0400 Subject: merge from git-annex --- Utility/Directory.hs | 9 +++++++-- Utility/SystemDirectory.hs | 16 ++++++++++++++++ 2 files changed, 23 insertions(+), 2 deletions(-) create mode 100644 Utility/SystemDirectory.hs diff --git a/Utility/Directory.hs b/Utility/Directory.hs index fae33b5..693e771 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -8,10 +8,12 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Directory where +module Utility.Directory ( + module Utility.Directory, + module Utility.SystemDirectory +) where import System.IO.Error -import System.Directory import Control.Monad import System.FilePath import Control.Applicative @@ -28,6 +30,7 @@ import Utility.SafeCommand import Control.Monad.IfElse #endif +import Utility.SystemDirectory import Utility.PosixFiles import Utility.Tmp import Utility.Exception @@ -134,11 +137,13 @@ moveFile src dest = tryIO (rename src dest) >>= onrename _ <- tryIO $ removeFile tmp throwM e' +#ifndef mingw32_HOST_OS isdir f = do r <- tryIO $ getFileStatus f case r of (Left _) -> return False (Right s) -> return $ isDirectory s +#endif {- Removes a file, which may or may not exist, and does not have to - be a regular file. diff --git a/Utility/SystemDirectory.hs b/Utility/SystemDirectory.hs new file mode 100644 index 0000000..3dd44d1 --- /dev/null +++ b/Utility/SystemDirectory.hs @@ -0,0 +1,16 @@ +{- System.Directory without its conflicting isSymbolicLink + - + - Copyright 2016 Joey Hess + - + - License: BSD-2-clause + -} + +-- Disable warnings because only some versions of System.Directory export +-- isSymbolicLink. +{-# OPTIONS_GHC -fno-warn-tabs -w #-} + +module Utility.SystemDirectory ( + module System.Directory +) where + +import System.Directory hiding (isSymbolicLink) -- cgit v1.2.3 From c80dce468b0660387e71e66743920b284c04f720 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 24 May 2016 01:34:17 -0400 Subject: Updated cabal file explictly lists source files. The tarball on hackage will include only the files needed for cabal install; it is NOT the full git-repair source tree. debian/changelog: Converted to symlinks to CHANGELOG. --- Build/Version.hs | 12 +++--- Build/make-sdist.sh | 21 ---------- CHANGELOG | 116 +++++++++++++++++++++++++++++++++++++++++++++++++++- Makefile | 2 +- Setup.hs | 2 + configure.hs | 6 --- debian/changelog | 112 +------------------------------------------------- git-repair.cabal | 79 +++++++++++++++++++++++++++++++---- 8 files changed, 198 insertions(+), 152 deletions(-) delete mode 100755 Build/make-sdist.sh mode change 120000 => 100644 CHANGELOG delete mode 100644 configure.hs mode change 100644 => 120000 debian/changelog diff --git a/Build/Version.hs b/Build/Version.hs index da9d1bb..d39a0fe 100644 --- a/Build/Version.hs +++ b/Build/Version.hs @@ -1,24 +1,26 @@ {- Package version determination, for configure script. -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Build.Version where -import Data.Maybe -import Control.Applicative import Data.List import System.Environment -import System.Directory import Data.Char import System.Process +import Control.Applicative +import Prelude import Utility.Monad import Utility.Exception +import Utility.Directory 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. @@ -44,7 +46,7 @@ getVersion = do getChangelogVersion :: IO Version getChangelogVersion = do - changelog <- readFile "debian/changelog" + changelog <- readFile "CHANGELOG" let verline = takeWhile (/= '\n') changelog return $ middle (words verline !! 1) where diff --git a/Build/make-sdist.sh b/Build/make-sdist.sh deleted file mode 100755 index d4dbdb9..0000000 --- a/Build/make-sdist.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/bin/sh -# -# Workaround for `cabal sdist` requiring all included files to be listed -# in .cabal. - -# Create target directory -sdist_dir=git-repair-$(grep '^Version:' git-repair.cabal | sed -re 's/Version: *//') -mkdir --parents dist/$sdist_dir - -find . \( -name .git -or -name dist -or -name cabal-dev \) -prune \ - -or -not -name \\*.orig -not -type d -print \ -| perl -ne "print unless length >= 100 - length q{$sdist_dir}" \ -| xargs cp --parents --target-directory dist/$sdist_dir - -cd dist -tar --format=ustar -caf $sdist_dir.tar.gz $sdist_dir - -# Check that tarball can be unpacked by cabal. -# It's picky about tar longlinks etc. -rm -rf $sdist_dir -cabal unpack $sdist_dir.tar.gz diff --git a/CHANGELOG b/CHANGELOG deleted file mode 120000 index d526672..0000000 --- a/CHANGELOG +++ /dev/null @@ -1 +0,0 @@ -debian/changelog \ No newline at end of file diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 index 0000000..94f0743 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,115 @@ +git-repair (1.20151216) UNRELEASED; urgency=medium + + * git-repair.cabal: Add Setup-Depends. + * Updated cabal file explictly lists source files. The tarball + on hackage will include only the files needed for cabal install; + it is NOT the full git-repair source tree. + * debian/changelog: Converted to symlinks to CHANGELOG. + + -- Joey Hess Wed, 04 May 2016 12:16:33 -0400 + +git-repair (1.20151215) unstable; urgency=medium + + * Fix insecure temporary permissions and potential denial of + service attack when creating temp dirs. Closes: #807341 + * Merge from git-annex. + + -- Joey Hess Tue, 15 Dec 2015 20:47:59 -0400 + +git-repair (1.20150106) unstable; urgency=medium + + * Debian package is now maintained by Richard Hartmann. + * Fix build with process 1.2.1.0. + * Merge from git-annex. + + -- Joey Hess Tue, 06 Jan 2015 19:09:23 -0400 + +git-repair (1.20141027) unstable; urgency=medium + + * Adjust cabal file to support network-uri split. + * Merge Build/ from git-annex, including removing a use of deprecated + System.Cmd. + + -- Joey Hess Mon, 27 Oct 2014 11:09:56 -0400 + +git-repair (1.20141026) unstable; urgency=medium + + * Prevent auto gc from happening when fetching from a remote. + * Merge from git-annex. + + -- Joey Hess Sun, 26 Oct 2014 13:37:30 -0400 + +git-repair (1.20140914) unstable; urgency=medium + + * Update to build with optparse-applicative 0.10. Closes: #761552 + + -- Joey Hess Sun, 14 Sep 2014 12:48:27 -0400 + +git-repair (1.20140815) unstable; urgency=medium + + * Removing bad objects could leave fsck finding no more unreachable objects, + but some branches no longer accessible. Fix this, including support for + fixing up repositories that were incompletely repaired before. + * Merge from git-annex. + + -- Joey Hess Fri, 15 Aug 2014 13:49:09 -0400 + +git-repair (1.20140423) unstable; urgency=medium + + * Improve memory usage when git fsck finds a great many broken objects. + * Merge from git-annex. + + -- Joey Hess Wed, 23 Apr 2014 14:01:30 -0400 + +git-repair (1.20140227) unstable; urgency=medium + + * Optimise unpacking of pack files, and avoid repeated error + messages about corrupt pack files. + * Add swapping 2 files test case. + + -- Joey Hess Thu, 27 Feb 2014 11:56:27 -0400 + +git-repair (1.20140115) unstable; urgency=medium + + * Support old git versions from before git fsck --no-dangling was + implemented. + * Fix bug in packed refs file exploding code that caused a .gitrefs + directory to be created instead of .git/refs + * Check git version at run time. + + -- Joey Hess Wed, 15 Jan 2014 16:53:30 -0400 + +git-repair (1.20131213) unstable; urgency=low + + * Improve repair of index files in some situations. + + -- Joey Hess Fri, 13 Dec 2013 14:51:51 -0400 + +git-repair (1.20131203) unstable; urgency=low + + * Fix build deps. Closes: #731179 + + -- Joey Hess Tue, 03 Dec 2013 15:02:21 -0400 + +git-repair (1.20131122) unstable; urgency=low + + * Added test mode, which can be used to randomly corrupt test + repositories, in reproducible ways, which allows easy + corruption-driven-development. + * Improve repair code in the case where the index file is corrupt, + and this hides other problems. + * Write a dummy .git/HEAD if the file is missing or corrupt, as + git otherwise will not treat the repository as a git repo. + * Improve fsck code to find badly corrupted objects that crash git fsck + before it can complain about them. + * Fixed crashes on bad file encodings. + * Can now run 10000 tests (git-repair --test -n 10000 --force) + with 0 failures. + + -- Joey Hess Fri, 22 Nov 2013 11:16:03 -0400 + +git-repair (1.20131118) unstable; urgency=low + + * First release + + -- Joey Hess Mon, 18 Nov 2013 13:38:12 -0400 diff --git a/Makefile b/Makefile index dcdcbbb..19312be 100644 --- a/Makefile +++ b/Makefile @@ -24,7 +24,7 @@ clean: # Upload to hackage. hackage: clean - ./Build/make-sdist.sh + @cabal sdist @cabal upload dist/*.tar.gz # hothasktags chokes on some template haskell etc, so ignore errors diff --git a/Setup.hs b/Setup.hs index 03c23a3..b5603f8 100644 --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-tabs #-} + {- cabal setup file -} import Distribution.Simple diff --git a/configure.hs b/configure.hs deleted file mode 100644 index 15833e6..0000000 --- a/configure.hs +++ /dev/null @@ -1,6 +0,0 @@ -{- configure program -} - -import Build.Configure - -main :: IO () -main = run tests diff --git a/debian/changelog b/debian/changelog deleted file mode 100644 index 395b4dc..0000000 --- a/debian/changelog +++ /dev/null @@ -1,111 +0,0 @@ -git-repair (1.20151216) UNRELEASED; urgency=medium - - * git-repair.cabal: Add Setup-Depends. - - -- Joey Hess Wed, 04 May 2016 12:16:33 -0400 - -git-repair (1.20151215) unstable; urgency=medium - - * Fix insecure temporary permissions and potential denial of - service attack when creating temp dirs. Closes: #807341 - * Merge from git-annex. - - -- Joey Hess Tue, 15 Dec 2015 20:47:59 -0400 - -git-repair (1.20150106) unstable; urgency=medium - - * Debian package is now maintained by Richard Hartmann. - * Fix build with process 1.2.1.0. - * Merge from git-annex. - - -- Joey Hess Tue, 06 Jan 2015 19:09:23 -0400 - -git-repair (1.20141027) unstable; urgency=medium - - * Adjust cabal file to support network-uri split. - * Merge Build/ from git-annex, including removing a use of deprecated - System.Cmd. - - -- Joey Hess Mon, 27 Oct 2014 11:09:56 -0400 - -git-repair (1.20141026) unstable; urgency=medium - - * Prevent auto gc from happening when fetching from a remote. - * Merge from git-annex. - - -- Joey Hess Sun, 26 Oct 2014 13:37:30 -0400 - -git-repair (1.20140914) unstable; urgency=medium - - * Update to build with optparse-applicative 0.10. Closes: #761552 - - -- Joey Hess Sun, 14 Sep 2014 12:48:27 -0400 - -git-repair (1.20140815) unstable; urgency=medium - - * Removing bad objects could leave fsck finding no more unreachable objects, - but some branches no longer accessible. Fix this, including support for - fixing up repositories that were incompletely repaired before. - * Merge from git-annex. - - -- Joey Hess Fri, 15 Aug 2014 13:49:09 -0400 - -git-repair (1.20140423) unstable; urgency=medium - - * Improve memory usage when git fsck finds a great many broken objects. - * Merge from git-annex. - - -- Joey Hess Wed, 23 Apr 2014 14:01:30 -0400 - -git-repair (1.20140227) unstable; urgency=medium - - * Optimise unpacking of pack files, and avoid repeated error - messages about corrupt pack files. - * Add swapping 2 files test case. - - -- Joey Hess Thu, 27 Feb 2014 11:56:27 -0400 - -git-repair (1.20140115) unstable; urgency=medium - - * Support old git versions from before git fsck --no-dangling was - implemented. - * Fix bug in packed refs file exploding code that caused a .gitrefs - directory to be created instead of .git/refs - * Check git version at run time. - - -- Joey Hess Wed, 15 Jan 2014 16:53:30 -0400 - -git-repair (1.20131213) unstable; urgency=low - - * Improve repair of index files in some situations. - - -- Joey Hess Fri, 13 Dec 2013 14:51:51 -0400 - -git-repair (1.20131203) unstable; urgency=low - - * Fix build deps. Closes: #731179 - - -- Joey Hess Tue, 03 Dec 2013 15:02:21 -0400 - -git-repair (1.20131122) unstable; urgency=low - - * Added test mode, which can be used to randomly corrupt test - repositories, in reproducible ways, which allows easy - corruption-driven-development. - * Improve repair code in the case where the index file is corrupt, - and this hides other problems. - * Write a dummy .git/HEAD if the file is missing or corrupt, as - git otherwise will not treat the repository as a git repo. - * Improve fsck code to find badly corrupted objects that crash git fsck - before it can complain about them. - * Fixed crashes on bad file encodings. - * Can now run 10000 tests (git-repair --test -n 10000 --force) - with 0 failures. - - -- Joey Hess Fri, 22 Nov 2013 11:16:03 -0400 - -git-repair (1.20131118) unstable; urgency=low - - * First release - - -- Joey Hess Mon, 18 Nov 2013 13:38:12 -0400 diff --git a/debian/changelog b/debian/changelog new file mode 120000 index 0000000..a535994 --- /dev/null +++ b/debian/changelog @@ -0,0 +1 @@ +../CHANGELOG \ No newline at end of file diff --git a/git-repair.cabal b/git-repair.cabal index 25f0f2e..5076fbd 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -7,7 +7,6 @@ Author: Joey Hess Stability: Stable Copyright: 2013 Joey Hess License-File: GPL -Extra-Source-Files: CHANGELOG Build-Type: Custom Homepage: http://git-repair.branchable.com/ Category: Utility @@ -21,11 +20,24 @@ Description: As well as avoiding the need to rm -rf a damaged repository and re-clone, using git-repair can help rescue commits you've made to the damaged repository and not yet pushed out. +Extra-Source-Files: + CHANGELOG + TODO + git-repair.1 Flag network-uri Description: Get Network.URI from the network-uri package Default: True +custom-setup + Setup-Depends: base (>= 4.5), hslogger, MissingH, unix-compat, process, + unix, filepath, exceptions, bytestring, directory, IfElse, data-default, + Cabal + +source-repository head + type: git + location: git://git-repair.branchable.com/ + Executable git-repair Main-Is: git-repair.hs GHC-Options: -threaded -Wall -fno-warn-tabs @@ -44,9 +56,62 @@ Executable git-repair else Build-Depends: unix -custom-setup - Setup-Depends: base (>= 4.5), hslogger, MissingH - -source-repository head - type: git - location: git://git-repair.branchable.com/ + Other-Modules: + Build.Configure + Build.TestConfig + Build.Version + Common + Git + Git.Branch + Git.BuildVersion + Git.CatFile + Git.Command + Git.Config + Git.Construct + Git.CurrentRepo + Git.Destroyer + Git.DiffTreeItem + Git.FilePath + Git.Filename + Git.Fsck + Git.Index + Git.LsFiles + Git.LsTree + Git.Objects + Git.Ref + Git.RefLog + Git.Remote + Git.Repair + Git.Sha + Git.Types + Git.UpdateIndex + Git.Url + Git.Version + Utility.Applicative + Utility.Batch + Utility.CoProcess + Utility.Data + Utility.Directory + Utility.DottedVersion + Utility.Env + Utility.Exception + Utility.FileMode + Utility.FileSize + Utility.FileSystemEncoding + Utility.Format + Utility.Metered + Utility.Misc + Utility.Monad + Utility.PartialPrelude + Utility.Path + Utility.PosixFiles + Utility.Process + Utility.Process.Shim + Utility.QuickCheck + Utility.Rsync + Utility.SafeCommand + Utility.SystemDirectory + Utility.ThreadScheduler + Utility.Tmp + Utility.URI + Utility.UserInfo -- cgit v1.2.3 From 7d7f93302c72cbe1a16598b0c90a49c10aaf3669 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 31 Aug 2016 18:46:18 -0400 Subject: removed hackage target, not used now --- Makefile | 5 ----- 1 file changed, 5 deletions(-) diff --git a/Makefile b/Makefile index 19312be..f4acea5 100644 --- a/Makefile +++ b/Makefile @@ -22,11 +22,6 @@ clean: find . -name \*.o -exec rm {} \; find . -name \*.hi -exec rm {} \; -# Upload to hackage. -hackage: clean - @cabal sdist - @cabal upload dist/*.tar.gz - # hothasktags chokes on some template haskell etc, so ignore errors tags: (for f in $$(find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$'); do hothasktags -c --cpp -c -traditional -c --include=dist/build/autogen/cabal_macros.h $$f; done) 2>/dev/null | sort > tags -- cgit v1.2.3 From 962e279e17c1f3cf3be49ffdfb5e7310711a220c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 11 Nov 2016 15:01:13 -0400 Subject: merge from git-annex --- CHANGELOG | 5 +- Git.hs | 13 ++++- Git/Branch.hs | 82 ++++++++++++++++++-------- Git/CatFile.hs | 130 +++++++++++++++++++++++++++++++++--------- Git/Command.hs | 6 +- Git/Construct.hs | 1 + Git/FilePath.hs | 17 ++++-- Git/Fsck.hs | 67 ++++++++++++++++------ Git/Index.hs | 21 ++++++- Git/LsTree.hs | 33 +++++++---- Git/Ref.hs | 18 +++--- Git/Repair.hs | 4 +- Git/Types.hs | 23 +++++++- Utility/CoProcess.hs | 22 +++---- Utility/Exception.hs | 18 +++++- Utility/FileMode.hs | 3 +- Utility/FileSize.hs | 6 +- Utility/FileSystemEncoding.hs | 8 +++ Utility/Format.hs | 8 +-- Utility/Metered.hs | 25 +++++++- Utility/Path.hs | 22 ++++--- Utility/PosixFiles.hs | 10 +++- Utility/Process.hs | 12 ++-- Utility/QuickCheck.hs | 10 +++- Utility/Rsync.hs | 6 +- Utility/Tmp.hs | 2 +- Utility/UserInfo.hs | 17 +++--- 27 files changed, 431 insertions(+), 158 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 94f0743..c57824c 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,12 +1,13 @@ -git-repair (1.20151216) UNRELEASED; urgency=medium +git-repair (1.20161111) unstable; urgency=medium * git-repair.cabal: Add Setup-Depends. * Updated cabal file explictly lists source files. The tarball on hackage will include only the files needed for cabal install; it is NOT the full git-repair source tree. * debian/changelog: Converted to symlinks to CHANGELOG. + * Merge from git-annex. - -- Joey Hess Wed, 04 May 2016 12:16:33 -0400 + -- Joey Hess Fri, 11 Nov 2016 14:56:14 -0400 git-repair (1.20151215) unstable; urgency=medium diff --git a/Git.hs b/Git.hs index 1bc789f..b350515 100644 --- a/Git.hs +++ b/Git.hs @@ -26,8 +26,10 @@ module Git ( repoDescribe, repoLocation, repoPath, + repoWorkTree, localGitDir, attributes, + attributesLocal, hookPath, assertLocal, adjustPath, @@ -72,6 +74,10 @@ repoPath Repo { location = Local { gitdir = d } } = d repoPath Repo { location = LocalUnknown dir } = dir repoPath Repo { location = Unknown } = error "unknown repoPath" +repoWorkTree :: Repo -> Maybe FilePath +repoWorkTree Repo { location = Local { worktree = Just d } } = Just d +repoWorkTree _ = Nothing + {- Path to a local repository's .git directory. -} localGitDir :: Repo -> FilePath localGitDir Repo { location = Local { gitdir = d } } = d @@ -125,8 +131,11 @@ assertLocal repo action {- Path to a repository's gitattributes file. -} attributes :: Repo -> FilePath attributes repo - | repoIsLocalBare repo = repoPath repo ++ "/info/.gitattributes" - | otherwise = repoPath repo ++ "/.gitattributes" + | repoIsLocalBare repo = attributesLocal repo + | otherwise = repoPath repo ".gitattributes" + +attributesLocal :: Repo -> FilePath +attributesLocal repo = localGitDir repo "info" "attributes" {- Path to a given hook script in a repository, only if the hook exists - and is executable. -} diff --git a/Git/Branch.hs b/Git/Branch.hs index a2225dc..875f20f 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -13,6 +13,7 @@ import Common import Git import Git.Sha import Git.Command +import qualified Git.Config import qualified Git.Ref import qualified Git.BuildVersion @@ -23,7 +24,7 @@ import qualified Git.BuildVersion - branch is not created yet. So, this also looks at show-ref HEAD - to double-check. -} -current :: Repo -> IO (Maybe Git.Ref) +current :: Repo -> IO (Maybe Branch) current r = do v <- currentUnsafe r case v of @@ -35,7 +36,7 @@ current r = do ) {- The current branch, which may not really exist yet. -} -currentUnsafe :: Repo -> IO (Maybe Git.Ref) +currentUnsafe :: Repo -> IO (Maybe Branch) currentUnsafe r = parse . firstLine <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r where @@ -48,15 +49,25 @@ currentUnsafe r = parse . firstLine changed :: Branch -> Branch -> Repo -> IO Bool changed origbranch newbranch repo | origbranch == newbranch = return False - | otherwise = not . null <$> diffs + | otherwise = not . null + <$> changed' origbranch newbranch [Param "-n1"] repo where - diffs = pipeReadStrict + +changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String +changed' origbranch newbranch extraps repo = pipeReadStrict ps repo + where + ps = [ Param "log" , Param (fromRef origbranch ++ ".." ++ fromRef newbranch) - , Param "-n1" , Param "--pretty=%H" - ] repo - + ] ++ extraps + +{- Lists commits that are in the second branch and not in the first branch. -} +changedCommits :: Branch -> Branch -> [CommandParam] -> Repo -> IO [Sha] +changedCommits origbranch newbranch extraps repo = + catMaybes . map extractSha . lines + <$> changed' origbranch newbranch extraps repo + {- Check if it's possible to fast-forward from the old - ref to the new ref. - @@ -90,7 +101,7 @@ fastForward branch (first:rest) repo = where no_ff = return False do_ff to = do - update branch to repo + update' branch to repo return True findbest c [] = return $ Just c findbest c (r:rs) @@ -104,27 +115,37 @@ fastForward branch (first:rest) repo = (False, True) -> findbest c rs -- worse (False, False) -> findbest c rs -- same -{- The user may have set commit.gpgsign, indending all their manual +{- The user may have set commit.gpgsign, intending all their manual - commits to be signed. But signing automatic/background commits could - easily lead to unwanted gpg prompts or failures. -} data CommitMode = ManualCommit | AutomaticCommit deriving (Eq) +{- Prevent signing automatic commits. -} applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam] applyCommitMode commitmode ps | commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") = Param "--no-gpg-sign" : ps | otherwise = ps +{- Some versions of git commit-tree honor commit.gpgsign themselves, + - but others need -S to be passed to enable gpg signing of manual commits. -} +applyCommitModeForCommitTree :: CommitMode -> [CommandParam] -> Repo -> [CommandParam] +applyCommitModeForCommitTree commitmode ps r + | commitmode == ManualCommit = + case (Git.Config.getMaybe "commit.gpgsign" r) of + Just s | Git.Config.isTrue s == Just True -> + Param "-S":ps + _ -> ps' + | otherwise = ps' + where + ps' = applyCommitMode commitmode ps + {- Commit via the usual git command. -} commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool commitCommand = commitCommand' runBool -{- Commit will fail when the tree is clean. This suppresses that error. -} -commitQuiet :: CommitMode -> [CommandParam] -> Repo -> IO () -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" : applyCommitMode commitmode ps @@ -144,36 +165,51 @@ commit commitmode allowempty message branch parentrefs repo = do pipeReadStrict [Param "write-tree"] repo ifM (cancommit tree) ( do - sha <- getSha "commit-tree" $ - pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) sendmsg repo - update branch sha repo + sha <- commitTree commitmode message parentrefs tree repo + update' branch sha repo return $ Just sha , return Nothing ) where - 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 <$> commit commitmode True message branch parentrefs repo +commitTree :: CommitMode -> String -> [Ref] -> Ref -> Repo -> IO Sha +commitTree commitmode message parentrefs tree repo = + getSha "commit-tree" $ + pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) + sendmsg repo + where + sendmsg = Just $ flip hPutStr message + ps = applyCommitModeForCommitTree commitmode parentparams repo + parentparams = map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs + {- A leading + makes git-push force pushing a branch. -} forcePush :: String -> String forcePush b = "+" ++ b -{- Updates a branch (or other ref) to a new Sha. -} -update :: Branch -> Sha -> Repo -> IO () -update branch sha = run +{- Updates a branch (or other ref) to a new Sha or branch Ref. -} +update :: String -> Branch -> Ref -> Repo -> IO () +update message branch r = run + [ Param "update-ref" + , Param "-m" + , Param message + , Param $ fromRef branch + , Param $ fromRef r + ] + +update' :: Branch -> Ref -> Repo -> IO () +update' branch r = run [ Param "update-ref" , Param $ fromRef branch - , Param $ fromRef sha + , Param $ fromRef r ] {- Checks out a branch, creating it if necessary. -} diff --git a/Git/CatFile.hs b/Git/CatFile.hs index c63a064..061349f 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -1,6 +1,6 @@ {- git cat-file interface - - - Copyright 2011, 2013 Joey Hess + - Copyright 2011-2016 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -13,13 +13,19 @@ module Git.CatFile ( catFile, catFileDetails, catTree, + catCommit, catObject, catObjectDetails, + catObjectMetaData, ) where import System.IO import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.Map as M +import Data.String +import Data.Char import Data.Tuple.Utils import Numeric import System.Posix.Types @@ -32,21 +38,28 @@ import Git.Types import Git.FilePath import qualified Utility.CoProcess as CoProcess -data CatFileHandle = CatFileHandle CoProcess.CoProcessHandle Repo +data CatFileHandle = CatFileHandle + { catFileProcess :: CoProcess.CoProcessHandle + , checkFileProcess :: CoProcess.CoProcessHandle + } catFileStart :: Repo -> IO CatFileHandle catFileStart = catFileStart' True catFileStart' :: Bool -> Repo -> IO CatFileHandle -catFileStart' restartable repo = do - coprocess <- CoProcess.rawMode =<< gitCoProcessStart restartable +catFileStart' restartable repo = CatFileHandle + <$> startp "--batch" + <*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)" + where + startp p = gitCoProcessStart restartable [ Param "cat-file" - , Param "--batch" + , Param p ] repo - return $ CatFileHandle coprocess repo catFileStop :: CatFileHandle -> IO () -catFileStop (CatFileHandle p _) = CoProcess.stop p +catFileStop h = do + CoProcess.stop (catFileProcess h) + CoProcess.stop (checkFileProcess h) {- Reads a file from a specified branch. -} catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString @@ -63,32 +76,52 @@ catObject :: CatFileHandle -> Ref -> IO L.ByteString catObject h object = maybe L.empty fst3 <$> catObjectDetails h object catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType)) -catObjectDetails (CatFileHandle hdl _) object = CoProcess.query hdl send receive +catObjectDetails h object = query (catFileProcess h) object $ \from -> do + header <- hGetLine from + case parseResp object header of + Just (ParsedResp sha size objtype) -> do + content <- S.hGet from (fromIntegral size) + eatchar '\n' from + return $ Just (L.fromChunks [content], sha, objtype) + Just DNE -> return Nothing + Nothing -> error $ "unknown response from git cat-file " ++ show (header, object) where - query = fromRef object - send to = hPutStrLn to query - receive from = do - header <- hGetLine from - case words header of - [sha, objtype, size] - | length sha == shaSize -> - case (readObjectType objtype, reads size) of - (Just t, [(bytes, "")]) -> readcontent t bytes from sha - _ -> dne - | otherwise -> dne - _ - | header == fromRef object ++ " missing" -> dne - | otherwise -> error $ "unknown response from git cat-file " ++ show (header, query) - readcontent objtype bytes from sha = do - content <- S.hGet from bytes - eatchar '\n' from - return $ Just (L.fromChunks [content], Ref sha, objtype) - dne = return Nothing eatchar expected from = do c <- hGetChar from when (c /= expected) $ error $ "missing " ++ (show expected) ++ " from git cat-file" +{- Gets the size and type of an object, without reading its content. -} +catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Integer, ObjectType)) +catObjectMetaData h object = query (checkFileProcess h) object $ \from -> do + resp <- hGetLine from + case parseResp object resp of + Just (ParsedResp _ size objtype) -> + return $ Just (size, objtype) + Just DNE -> return Nothing + Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object) + +data ParsedResp = ParsedResp Sha Integer ObjectType | DNE + +query :: CoProcess.CoProcessHandle -> Ref -> (Handle -> IO a) -> IO a +query hdl object receive = CoProcess.query hdl send receive + where + send to = hPutStrLn to (fromRef object) + +parseResp :: Ref -> String -> Maybe ParsedResp +parseResp object l + | " missing" `isSuffixOf` l -- less expensive than full check + && l == fromRef object ++ " missing" = Just DNE + | otherwise = case words l of + [sha, objtype, size] + | length sha == shaSize -> + case (readObjectType objtype, reads size) of + (Just t, [(bytes, "")]) -> + Just $ ParsedResp (Ref sha) bytes t + _ -> Nothing + | otherwise -> Nothing + _ -> Nothing + {- Gets a list of files and directories in a tree. (Not recursive.) -} catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)] catTree h treeref = go <$> catObjectDetails h treeref @@ -104,10 +137,51 @@ catTree h treeref = go <$> catObjectDetails h treeref (dropsha rest) -- these 20 bytes after the NUL hold the file's sha - -- TODO: convert from raw form to regular sha dropsha = L.drop 21 parsemodefile b = let (modestr, file) = separate (== ' ') (decodeBS b) in (file, readmode modestr) readmode = fromMaybe 0 . fmap fst . headMaybe . readOct + +catCommit :: CatFileHandle -> Ref -> IO (Maybe Commit) +catCommit h commitref = go <$> catObjectDetails h commitref + where + go (Just (b, _, CommitObject)) = parseCommit b + go _ = Nothing + +parseCommit :: L.ByteString -> Maybe Commit +parseCommit b = Commit + <$> (extractSha . L8.unpack =<< field "tree") + <*> Just (maybe [] (mapMaybe (extractSha . L8.unpack)) (fields "parent")) + <*> (parsemetadata <$> field "author") + <*> (parsemetadata <$> field "committer") + <*> Just (L8.unpack $ L.intercalate (L.singleton nl) message) + where + field n = headMaybe =<< fields n + fields n = M.lookup (fromString n) fieldmap + fieldmap = M.fromListWith (++) ((map breakfield) header) + breakfield l = + let (k, sp_v) = L.break (== sp) l + in (k, [L.drop 1 sp_v]) + (header, message) = separate L.null ls + ls = L.split nl b + + -- author and committer lines have the form: "name date" + -- The email is always present, even if empty "<>" + parsemetadata l = CommitMetaData + { commitName = whenset $ L.init name_sp + , commitEmail = whenset email + , commitDate = whenset $ L.drop 2 gt_sp_date + } + where + (name_sp, rest) = L.break (== lt) l + (email, gt_sp_date) = L.break (== gt) (L.drop 1 rest) + whenset v + | L.null v = Nothing + | otherwise = Just (L8.unpack v) + + nl = fromIntegral (ord '\n') + sp = fromIntegral (ord ' ') + lt = fromIntegral (ord '<') + gt = fromIntegral (ord '>') diff --git a/Git/Command.hs b/Git/Command.hs index 02e3e5a..2060563 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -17,9 +17,11 @@ import qualified Utility.CoProcess as CoProcess {- Constructs a git command line operating on the specified repo. -} gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] gitCommandLine params r@(Repo { location = l@(Local { } ) }) = - setdir : settree ++ gitGlobalOpts r ++ params + setdir ++ settree ++ gitGlobalOpts r ++ params where - setdir = Param $ "--git-dir=" ++ gitdir l + setdir + | gitEnvOverridesGitDir r = [] + | otherwise = [Param $ "--git-dir=" ++ gitdir l] settree = case worktree l of Nothing -> [] Just t -> [Param $ "--work-tree=" ++ t] diff --git a/Git/Construct.hs b/Git/Construct.hs index 03dd29f..7655622 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -236,6 +236,7 @@ newFrom l = Repo , remotes = [] , remoteName = Nothing , gitEnv = Nothing + , gitEnvOverridesGitDir = False , gitGlobalOpts = [] } diff --git a/Git/FilePath.hs b/Git/FilePath.hs index edc3c0f..ffa3331 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -14,8 +14,10 @@ module Git.FilePath ( TopFilePath, - fromTopFilePath, + BranchFilePath(..), + descBranchFilePath, getTopFilePath, + fromTopFilePath, toTopFilePath, asTopFilePath, InternalGitPath, @@ -31,11 +33,18 @@ import qualified System.FilePath.Posix {- A FilePath, relative to the top of the git repository. -} newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } - deriving (Show) + deriving (Show, Eq, Ord) + +{- A file in a branch or other treeish. -} +data BranchFilePath = BranchFilePath Ref TopFilePath + +{- Git uses the branch:file form to refer to a BranchFilePath -} +descBranchFilePath :: BranchFilePath -> String +descBranchFilePath (BranchFilePath b f) = fromRef b ++ ':' : getTopFilePath f -{- Returns an absolute FilePath. -} +{- Path to a TopFilePath, within the provided git repo. -} fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath -fromTopFilePath p repo = absPathFrom (repoPath repo) (getTopFilePath p) +fromTopFilePath p repo = combine (repoPath repo) (getTopFilePath p) {- The input FilePath can be absolute, or relative to the CWD. -} toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath diff --git a/Git/Fsck.hs b/Git/Fsck.hs index f3e6db9..a716b56 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE BangPatterns #-} + module Git.Fsck ( FsckResults(..), MissingObjects, @@ -25,8 +27,6 @@ import qualified Git.Version import qualified Data.Set as S import Control.Concurrent.Async -type MissingObjects = S.Set Sha - data FsckResults = FsckFoundMissing { missingObjects :: MissingObjects @@ -35,6 +35,25 @@ data FsckResults | FsckFailed deriving (Show) +data FsckOutput + = FsckOutput MissingObjects Truncated + | NoFsckOutput + | AllDuplicateEntriesWarning + +type MissingObjects = S.Set Sha + +type Truncated = Bool + +instance Monoid FsckOutput where + mempty = NoFsckOutput + mappend (FsckOutput s1 t1) (FsckOutput s2 t2) = FsckOutput (S.union s1 s2) (t1 || t2) + mappend (FsckOutput s t) _ = FsckOutput s t + mappend _ (FsckOutput s t) = FsckOutput s t + mappend NoFsckOutput NoFsckOutput = NoFsckOutput + mappend AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning + mappend AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning + mappend NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning + {- Runs fsck to find some of the broken objects in the repository. - May not find all broken objects, if fsck fails on bad data in some of - the broken objects it does find. @@ -58,18 +77,24 @@ findBroken batchmode r = do { std_out = CreatePipe , std_err = CreatePipe } - (bad1, bad2) <- concurrently - (readMissingObjs maxobjs r supportsNoDangling (stdoutHandle p)) - (readMissingObjs maxobjs r supportsNoDangling (stderrHandle p)) + (o1, o2) <- concurrently + (parseFsckOutput maxobjs r supportsNoDangling (stdoutHandle p)) + (parseFsckOutput maxobjs r supportsNoDangling (stderrHandle p)) fsckok <- checkSuccessProcess pid - let truncated = S.size bad1 == maxobjs || S.size bad1 == maxobjs - let badobjs = S.union bad1 bad2 - - if S.null badobjs && not fsckok - then return FsckFailed - else return $ FsckFoundMissing badobjs truncated + case mappend o1 o2 of + FsckOutput badobjs truncated + | S.null badobjs && not fsckok -> return FsckFailed + | otherwise -> return $ FsckFoundMissing badobjs truncated + NoFsckOutput + | not fsckok -> return FsckFailed + | otherwise -> return noproblem + -- If all fsck output was duplicateEntries warnings, + -- the repository is not broken, it just has some unusual + -- tree objects in it. So ignore nonzero exit status. + AllDuplicateEntriesWarning -> return noproblem where maxobjs = 10000 + noproblem = FsckFoundMissing S.empty False foundBroken :: FsckResults -> Bool foundBroken FsckFailed = True @@ -87,10 +112,18 @@ knownMissing (FsckFoundMissing s _) = s findMissing :: [Sha] -> Repo -> IO MissingObjects findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs -readMissingObjs :: Int -> Repo -> Bool -> Handle -> IO MissingObjects -readMissingObjs maxobjs r supportsNoDangling h = do - objs <- take maxobjs . findShas supportsNoDangling <$> hGetContents h - findMissing objs r +parseFsckOutput :: Int -> Repo -> Bool -> Handle -> IO FsckOutput +parseFsckOutput maxobjs r supportsNoDangling h = do + ls <- lines <$> hGetContents h + if null ls + then return NoFsckOutput + else if all ("duplicateEntries" `isInfixOf`) ls + then return AllDuplicateEntriesWarning + else do + let shas = findShas supportsNoDangling ls + let !truncated = length shas > maxobjs + missingobjs <- findMissing (take maxobjs shas) r + return $ FsckOutput missingobjs truncated isMissing :: Sha -> Repo -> IO Bool isMissing s r = either (const True) (const False) <$> tryIO dump @@ -100,8 +133,8 @@ isMissing s r = either (const True) (const False) <$> tryIO dump , Param (fromRef s) ] r -findShas :: Bool -> String -> [Sha] -findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted . lines +findShas :: Bool -> [String] -> [Sha] +findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted where wanted l | supportsNoDangling = True diff --git a/Git/Index.hs b/Git/Index.hs index 551fd98..85ea480 100644 --- a/Git/Index.hs +++ b/Git/Index.hs @@ -14,6 +14,20 @@ import Utility.Env indexEnv :: String indexEnv = "GIT_INDEX_FILE" +{- Gets value to set GIT_INDEX_FILE to. Input should be absolute path, + - or relative to the CWD. + - + - When relative, GIT_INDEX_FILE is interpreted by git as being + - relative to the top of the work tree of the git repository, + - not to the CWD. Worse, other environment variables (GIT_WORK_TREE) + - or git options (--work-tree) or configuration (core.worktree) + - can change what the relative path is interpreted relative to. + - + - So, an absolute path is the only safe option for this to return. + -} +indexEnvVal :: FilePath -> IO String +indexEnvVal = absPath + {- Forces git to use the specified index file. - - Returns an action that will reset back to the default @@ -21,10 +35,11 @@ indexEnv = "GIT_INDEX_FILE" - - Warning: Not thread safe. -} -override :: FilePath -> IO (IO ()) -override index = do +override :: FilePath -> Repo -> IO (IO ()) +override index _r = do res <- getEnv var - setEnv var index True + val <- indexEnvVal index + setEnv var val True return $ reset res where var = "GIT_INDEX_FILE" diff --git a/Git/LsTree.hs b/Git/LsTree.hs index 1ed6247..2060fa7 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -1,16 +1,19 @@ {- git ls-tree interface - - - Copyright 2011 Joey Hess + - Copyright 2011-2016 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE BangPatterns #-} + module Git.LsTree ( TreeItem(..), lsTree, + lsTree', lsTreeParams, lsTreeFiles, - parseLsTree + parseLsTree, ) where import Common @@ -26,15 +29,19 @@ import System.Posix.Types data TreeItem = TreeItem { mode :: FileMode , typeobj :: String - , sha :: String + , sha :: Ref , file :: TopFilePath } deriving Show {- Lists the complete contents of a tree, recursing into sub-trees, - with lazy output. -} -lsTree :: Ref -> Repo -> IO [TreeItem] -lsTree t repo = map parseLsTree - <$> pipeNullSplitZombie (lsTreeParams t []) repo +lsTree :: Ref -> Repo -> IO ([TreeItem], IO Bool) +lsTree = lsTree' [] + +lsTree' :: [CommandParam] -> Ref -> Repo -> IO ([TreeItem], IO Bool) +lsTree' ps t repo = do + (l, cleanup) <- pipeNullSplit (lsTreeParams t ps) repo + return (map parseLsTree l, cleanup) lsTreeParams :: Ref -> [CommandParam] -> [CommandParam] lsTreeParams r ps = @@ -63,16 +70,18 @@ lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo - (The --long format is not currently supported.) -} parseLsTree :: String -> TreeItem parseLsTree l = TreeItem - { mode = fst $ Prelude.head $ readOct m + { mode = smode , typeobj = t - , sha = s - , file = asTopFilePath $ Git.Filename.decode f + , sha = Ref s + , file = sfile } where -- l = SP SP TAB -- All fields are fixed, so we can pull them out of -- specific positions in the line. (m, past_m) = splitAt 7 l - (t, past_t) = splitAt 4 past_m - (s, past_s) = splitAt shaSize $ Prelude.tail past_t - f = Prelude.tail past_s + (!t, past_t) = splitAt 4 past_m + (!s, past_s) = splitAt shaSize $ Prelude.tail past_t + !f = Prelude.tail past_s + !smode = fst $ Prelude.head $ readOct m + !sfile = asTopFilePath $ Git.Filename.decode f diff --git a/Git/Ref.hs b/Git/Ref.hs index 6bc47d5..5b3b853 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -18,12 +18,20 @@ import Data.Char (chr) headRef :: Ref headRef = Ref "HEAD" +headFile :: Repo -> FilePath +headFile r = localGitDir r "HEAD" + +setHeadRef :: Ref -> Repo -> IO () +setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref) + {- Converts a fully qualified git ref into a user-visible string. -} describe :: Ref -> String describe = fromRef . base -{- Often git refs are fully qualified (eg: refs/heads/master). - - Converts such a fully qualified ref into a base ref (eg: master). -} +{- Often git refs are fully qualified + - (eg refs/heads/master or refs/remotes/origin/master). + - Converts such a fully qualified ref into a base ref + - (eg: master or origin/master). -} base :: Ref -> Ref base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef where @@ -31,12 +39,6 @@ base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef | prefix `isPrefixOf` s = drop (length prefix) s | otherwise = s -{- Given a directory and any ref, takes the basename of the ref and puts - - it under the directory. -} -under :: String -> Ref -> Ref -under dir r = Ref $ dir ++ "/" ++ - (reverse $ takeWhile (/= '/') $ reverse $ fromRef r) - {- Given a directory such as "refs/remotes/origin", and a ref such as - refs/heads/master, yields a version of that ref under the directory, - such as refs/remotes/origin/master. -} diff --git a/Git/Repair.hs b/Git/Repair.hs index b441f13..fcfc036 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -342,8 +342,8 @@ verifyTree missing treesha r | S.member treesha missing = return False | otherwise = do (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams treesha []) r - let objshas = map (extractSha . LsTree.sha . LsTree.parseLsTree) ls - if any isNothing objshas || any (`S.member` missing) (catMaybes objshas) + let objshas = map (LsTree.sha . LsTree.parseLsTree) ls + if any (`S.member` missing) objshas then do void cleanup return False diff --git a/Git/Types.hs b/Git/Types.hs index bb91a17..327c1d7 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -11,7 +11,6 @@ import Network.URI import qualified Data.Map as M import System.Posix.Types import Utility.SafeCommand -import Utility.URI () {- Support repositories on local disk, and repositories accessed via an URL. - @@ -40,6 +39,7 @@ data Repo = Repo , remoteName :: Maybe RemoteName -- alternate environment to use when running git commands , gitEnv :: Maybe [(String, String)] + , gitEnvOverridesGitDir :: Bool -- global options to pass to git when running git commands , gitGlobalOpts :: [CommandParam] } deriving (Show, Eq, Ord) @@ -98,3 +98,24 @@ toBlobType 0o100644 = Just FileBlob toBlobType 0o100755 = Just ExecutableBlob toBlobType 0o120000 = Just SymlinkBlob toBlobType _ = Nothing + +fromBlobType :: BlobType -> FileMode +fromBlobType FileBlob = 0o100644 +fromBlobType ExecutableBlob = 0o100755 +fromBlobType SymlinkBlob = 0o120000 + +data Commit = Commit + { commitTree :: Sha + , commitParent :: [Sha] + , commitAuthorMetaData :: CommitMetaData + , commitCommitterMetaData :: CommitMetaData + , commitMessage :: String + } + deriving (Show) + +data CommitMetaData = CommitMetaData + { commitName :: Maybe String + , commitEmail :: Maybe String + , commitDate :: Maybe String -- In raw git form, "epoch -tzoffset" + } + deriving (Show) diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs index 9854b47..94d5ac3 100644 --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -13,7 +13,6 @@ module Utility.CoProcess ( start, stop, query, - rawMode ) where import Common @@ -44,7 +43,15 @@ start numrestarts cmd params environ = do start' :: CoProcessSpec -> IO CoProcessState start' s = do (pid, from, to) <- startInteractiveProcess (coProcessCmd s) (coProcessParams s) (coProcessEnv s) + rawMode from + rawMode to return $ CoProcessState pid to from s + where + rawMode h = do + fileEncoding h +#ifdef mingw32_HOST_OS + hSetNewlineMode h noNewlineTranslation +#endif stop :: CoProcessHandle -> IO () stop ch = do @@ -79,16 +86,3 @@ query ch send receive = do { coProcessNumRestarts = coProcessNumRestarts (coProcessSpec s) - 1 } putMVar ch s' query ch send receive - -rawMode :: CoProcessHandle -> IO CoProcessHandle -rawMode ch = do - s <- readMVar ch - raw $ coProcessFrom s - raw $ coProcessTo s - return ch - where - raw h = do - fileEncoding h -#ifdef mingw32_HOST_OS - hSetNewlineMode h noNewlineTranslation -#endif diff --git a/Utility/Exception.hs b/Utility/Exception.hs index 8b110ae..0ffc710 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -5,7 +5,7 @@ - License: BSD-2-clause -} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Exception ( @@ -21,12 +21,18 @@ module Utility.Exception ( tryNonAsync, tryWhenExists, catchIOErrorType, - IOErrorType(..) + IOErrorType(..), + catchPermissionDenied, ) where import Control.Monad.Catch as X hiding (Handler) import qualified Control.Monad.Catch as M import Control.Exception (IOException, AsyncException) +#ifdef MIN_VERSION_GLASGOW_HASKELL +#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) +import Control.Exception (SomeAsyncException) +#endif +#endif import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError, ioeGetErrorType) @@ -73,6 +79,11 @@ bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup) catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchNonAsync a onerr = a `catches` [ M.Handler (\ (e :: AsyncException) -> throwM e) +#ifdef MIN_VERSION_GLASGOW_HASKELL +#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) + , M.Handler (\ (e :: SomeAsyncException) -> throwM e) +#endif +#endif , M.Handler (\ (e :: SomeException) -> onerr e) ] @@ -97,3 +108,6 @@ catchIOErrorType errtype onmatchingerr a = catchIO a onlymatching onlymatching e | ioeGetErrorType e == errtype = onmatchingerr e | otherwise = throwM e + +catchPermissionDenied :: MonadCatch m => (IOException -> m a) -> m a -> m a +catchPermissionDenied = catchIOErrorType PermissionDenied diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index efef5fa..bb3780c 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -18,9 +18,10 @@ import System.PosixCompat.Types import Utility.PosixFiles #ifndef mingw32_HOST_OS import System.Posix.Files +import Control.Monad.IO.Class (liftIO) #endif +import Control.Monad.IO.Class (MonadIO) import Foreign (complement) -import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Catch import Utility.Exception diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs index 1055754..5f89cff 100644 --- a/Utility/FileSize.hs +++ b/Utility/FileSize.hs @@ -13,13 +13,15 @@ import Control.Exception (bracket) import System.IO #endif +type FileSize = Integer + {- Gets the size of a file. - - This is better than using fileSize, because on Windows that returns a - FileOffset which maxes out at 2 gb. - See https://github.com/jystic/unix-compat/issues/16 -} -getFileSize :: FilePath -> IO Integer +getFileSize :: FilePath -> IO FileSize #ifndef mingw32_HOST_OS getFileSize f = fmap (fromIntegral . fileSize) (getFileStatus f) #else @@ -27,7 +29,7 @@ getFileSize f = bracket (openFile f ReadMode) hClose hFileSize #endif {- Gets the size of the file, when its FileStatus is already known. -} -getFileSize' :: FilePath -> FileStatus -> IO Integer +getFileSize' :: FilePath -> FileStatus -> IO FileSize #ifndef mingw32_HOST_OS getFileSize' _ s = return $ fromIntegral $ fileSize s #else diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index 67341d3..eab9833 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -19,6 +19,7 @@ module Utility.FileSystemEncoding ( encodeW8NUL, decodeW8NUL, truncateFilePath, + setConsoleEncoding, ) where import qualified GHC.Foreign as GHC @@ -164,3 +165,10 @@ truncateFilePath n = reverse . go [] n . L8.fromString 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/Format.hs b/Utility/Format.hs index 7844963..1ebf68d 100644 --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -103,7 +103,7 @@ empty _ = False {- Decodes a C-style encoding, where \n is a newline, \NNN is an octal - encoded character, and \xNN is a hex encoded character. -} -decode_c :: FormatString -> FormatString +decode_c :: FormatString -> String decode_c [] = [] decode_c s = unescape ("", s) where @@ -141,14 +141,14 @@ decode_c s = unescape ("", s) handle n = ("", n) {- Inverse of decode_c. -} -encode_c :: FormatString -> FormatString +encode_c :: String -> FormatString encode_c = encode_c' (const False) {- Encodes more strictly, including whitespace. -} -encode_c_strict :: FormatString -> FormatString +encode_c_strict :: String -> FormatString encode_c_strict = encode_c' isSpace -encode_c' :: (Char -> Bool) -> FormatString -> FormatString +encode_c' :: (Char -> Bool) -> String -> FormatString encode_c' p = concatMap echar where e c = '\\' : [c] diff --git a/Utility/Metered.hs b/Utility/Metered.hs index da83fd8..440aa3f 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -1,6 +1,6 @@ {- Metered IO and actions - - - Copyright 2012-2105 Joey Hess + - Copyright 2012-2106 Joey Hess - - License: BSD-2-clause -} @@ -21,6 +21,8 @@ import Data.Bits.Utils import Control.Concurrent import Control.Concurrent.Async import Control.Monad.IO.Class (MonadIO) +import Data.Time.Clock +import Data.Time.Clock.POSIX {- An action that can be run repeatedly, updating it on the bytes processed. - @@ -259,3 +261,24 @@ outputFilter cmd params environ outfilter errfilter = catchBoolIO $ do where p = (proc cmd (toCommand params)) { env = environ } + +-- | Limit a meter to only update once per unit of time. +-- +-- It's nice to display the final update to 100%, even if it comes soon +-- after a previous update. To make that happen, a total size has to be +-- provided. +rateLimitMeterUpdate :: NominalDiffTime -> Maybe Integer -> MeterUpdate -> IO MeterUpdate +rateLimitMeterUpdate delta totalsize meterupdate = do + lastupdate <- newMVar (toEnum 0 :: POSIXTime) + return $ mu lastupdate + where + mu lastupdate n@(BytesProcessed i) = case totalsize of + Just t | i >= t -> meterupdate n + _ -> do + now <- getPOSIXTime + prev <- takeMVar lastupdate + if now - prev >= delta + then do + putMVar lastupdate now + meterupdate n + else putMVar lastupdate prev diff --git a/Utility/Path.hs b/Utility/Path.hs index f3290d8..3ee5ff3 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -12,7 +12,6 @@ module Utility.Path where import Data.String.Utils import System.FilePath -import System.Directory import Data.List import Data.Maybe import Data.Char @@ -29,6 +28,7 @@ import Utility.Exception import qualified "MissingH" System.Path as MissingH import Utility.Monad import Utility.UserInfo +import Utility.Directory {- Simplifies a path, removing any "." component, collapsing "dir/..", - and removing the trailing path separator. @@ -60,7 +60,7 @@ simplifyPath path = dropTrailingPathSeparator $ {- Makes a path absolute. - - The first parameter is a base directory (ie, the cwd) to use if the path - - is not already absolute. + - is not already absolute, and should itsef be absolute. - - Does not attempt to deal with edge cases or ensure security with - untrusted inputs. @@ -252,15 +252,21 @@ dotfile file where f = takeFileName file -{- Converts a DOS style path to a Cygwin style path. Only on Windows. - - Any trailing '\' is preserved as a trailing '/' -} -toCygPath :: FilePath -> FilePath +{- Converts a DOS style path to a msys2 style path. Only on Windows. + - Any trailing '\' is preserved as a trailing '/' + - + - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i + - + - The virtual filesystem contains: + - /c, /d, ... mount points for Windows drives + -} +toMSYS2Path :: FilePath -> FilePath #ifndef mingw32_HOST_OS -toCygPath = id +toMSYS2Path = id #else -toCygPath p +toMSYS2Path p | null drive = recombine parts - | otherwise = recombine $ "/cygdrive" : driveletter drive : parts + | otherwise = recombine $ "/" : driveletter drive : parts where (drive, p') = splitDrive p parts = splitDirectories p' diff --git a/Utility/PosixFiles.hs b/Utility/PosixFiles.hs index 4550beb..37253da 100644 --- a/Utility/PosixFiles.hs +++ b/Utility/PosixFiles.hs @@ -1,6 +1,6 @@ {- POSIX files (and compatablity wrappers). - - - This is like System.PosixCompat.Files, except with a fixed rename. + - This is like System.PosixCompat.Files, but with a few fixes. - - Copyright 2014 Joey Hess - @@ -21,6 +21,7 @@ import System.PosixCompat.Files as X hiding (rename) import System.Posix.Files (rename) #else import qualified System.Win32.File as Win32 +import qualified System.Win32.HardLink as Win32 #endif {- System.PosixCompat.Files.rename on Windows calls renameFile, @@ -32,3 +33,10 @@ import qualified System.Win32.File as Win32 rename :: FilePath -> FilePath -> IO () rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING #endif + +{- System.PosixCompat.Files.createLink throws an error, but windows + - does support hard links. -} +#ifdef mingw32_HOST_OS +createLink :: FilePath -> FilePath -> IO () +createLink = Win32.createHardLink +#endif diff --git a/Utility/Process.hs b/Utility/Process.hs index c669996..ed02f49 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -18,6 +18,7 @@ module Utility.Process ( readProcessEnv, writeReadProcessEnv, forceSuccessProcess, + forceSuccessProcess', checkSuccessProcess, ignoreFailureProcess, createProcessSuccess, @@ -129,11 +130,12 @@ writeReadProcessEnv cmd args environ writestdin adjusthandle = do -- | 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 - case code of - ExitSuccess -> return () - ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n +forceSuccessProcess p pid = waitForProcess pid >>= forceSuccessProcess' p + +forceSuccessProcess' :: CreateProcess -> ExitCode -> IO () +forceSuccessProcess' _ ExitSuccess = return () +forceSuccessProcess' p (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 diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index cd408dd..0181ea9 100644 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -6,7 +6,7 @@ -} {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeSynonymInstances, CPP #-} module Utility.QuickCheck ( module X @@ -16,16 +16,20 @@ module Utility.QuickCheck import Test.QuickCheck as X import Data.Time.Clock.POSIX import System.Posix.Types +#if ! MIN_VERSION_QuickCheck(2,8,2) import qualified Data.Map as M import qualified Data.Set as S +#endif import Control.Applicative import Prelude -instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where +#if ! MIN_VERSION_QuickCheck(2,8,2) +instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) where arbitrary = M.fromList <$> arbitrary -instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where +instance (Arbitrary v, Ord v) => Arbitrary (S.Set v) where arbitrary = S.fromList <$> arbitrary +#endif {- Times before the epoch are excluded. -} instance Arbitrary POSIXTime where diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index 3aaf928..d3fe981 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -54,16 +54,16 @@ rsyncUseDestinationPermissions = Param "--chmod=ugo=rwX" rsync :: [CommandParam] -> IO Bool rsync = boolSystem "rsync" . rsyncParamsFixup -{- On Windows, rsync is from Cygwin, and expects to get Cygwin formatted +{- On Windows, rsync is from msys2, and expects to get msys2 formatted - paths to files. (It thinks that C:foo refers to a host named "C"). - Fix up the Params appropriately. -} rsyncParamsFixup :: [CommandParam] -> [CommandParam] #ifdef mingw32_HOST_OS rsyncParamsFixup = map fixup where - fixup (File f) = File (toCygPath f) + fixup (File f) = File (toMSYS2Path f) fixup (Param s) - | rsyncUrlIsPath s = Param (toCygPath s) + | rsyncUrlIsPath s = Param (toMSYS2Path s) fixup p = p #else rsyncParamsFixup = id diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index 7610f6c..6a541cf 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -11,9 +11,9 @@ module Utility.Tmp where import System.IO -import System.Directory import Control.Monad.IfElse import System.FilePath +import System.Directory import Control.Monad.IO.Class #ifndef mingw32_HOST_OS import System.Posix.Temp (mkdtemp) diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index 7e94caf..ec0b0d0 100644 --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -15,18 +15,17 @@ module Utility.UserInfo ( ) where import Utility.Env +import Utility.Data import System.PosixCompat -#ifndef mingw32_HOST_OS import Control.Applicative -#endif import Prelude {- Current user's home directory. - - getpwent will fail on LDAP or NIS, so use HOME if set. -} myHomeDir :: IO FilePath -myHomeDir = myVal env homeDirectory +myHomeDir = either error return =<< myVal env homeDirectory where #ifndef mingw32_HOST_OS env = ["HOME"] @@ -35,7 +34,7 @@ myHomeDir = myVal env homeDirectory #endif {- Current user's user name. -} -myUserName :: IO String +myUserName :: IO (Either String String) myUserName = myVal env userName where #ifndef mingw32_HOST_OS @@ -49,15 +48,15 @@ myUserGecos :: IO (Maybe String) #if defined(__ANDROID__) || defined(mingw32_HOST_OS) myUserGecos = return Nothing #else -myUserGecos = Just <$> myVal [] userGecos +myUserGecos = eitherToMaybe <$> myVal [] userGecos #endif -myVal :: [String] -> (UserEntry -> String) -> IO String +myVal :: [String] -> (UserEntry -> String) -> IO (Either String String) myVal envvars extract = go envvars where #ifndef mingw32_HOST_OS - go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID) + go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID) #else - go [] = error $ "environment not set: " ++ show envvars + go [] = return $ Left ("environment not set: " ++ show envvars) #endif - go (v:vs) = maybe (go vs) return =<< getEnv v + go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v -- cgit v1.2.3 From fc35e5f3a3b932e615b3e15eceb2c3a3da2be098 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 11 Nov 2016 15:01:55 -0400 Subject: sync makefile with git-annex's * Makefile: Support building with stack as well as cabal. * Makefile: The CABAL variable has been renamed to BUILDER. --- CHANGELOG | 2 ++ Makefile | 23 +++++++++++++++++------ debian/rules | 2 +- 3 files changed, 20 insertions(+), 7 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index c57824c..faa87c4 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -6,6 +6,8 @@ git-repair (1.20161111) unstable; urgency=medium it is NOT the full git-repair source tree. * debian/changelog: Converted to symlinks to CHANGELOG. * Merge from git-annex. + * Makefile: Support building with stack as well as cabal. + * Makefile: The CABAL variable has been renamed to BUILDER. -- Joey Hess Fri, 11 Nov 2016 14:56:14 -0400 diff --git a/Makefile b/Makefile index f4acea5..bd2ac44 100644 --- a/Makefile +++ b/Makefile @@ -1,14 +1,25 @@ +# set to "./Setup" if you lack a cabal program. Or can be set to "stack" +BUILDER?=cabal +GHC?=ghc + PREFIX=/usr -CABAL?=cabal # set to "./Setup" if you lack a cabal program build: Build/SysConfig.hs - $(CABAL) build - ln -sf dist/build/git-repair/git-repair git-repair + $(BUILDER) build $(BUILDEROPTIONS) + if [ "$(BUILDER)" = stack ]; then \ + ln -sf $$(find .stack-work/ -name git-repair -type f | grep build/git-annex/git-repair | tail -n 1) git-repair; \ + else \ + ln -sf dist/build/git-repair/git-repair git-repair; \ + fi @$(MAKE) tags >/dev/null 2>&1 & -Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs - if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi - $(CABAL) configure --ghc-options="$(shell Build/collect-ghc-options.sh)" +Build/SysConfig.hs: Build/TestConfig.hs Build/Configure.hs + if [ "$(BUILDER)" = ./Setup ]; then ghc --make Setup; fi + if [ "$(BUILDER)" = stack ]; then \ + $(BUILDER) build $(BUILDEROPTIONS); \ + else \ + $(BUILDER) configure --ghc-options="$(shell Build/collect-ghc-options.sh)"; \ + fi install: build install -d $(DESTDIR)$(PREFIX)/bin diff --git a/debian/rules b/debian/rules index 4d8fa21..9198916 100755 --- a/debian/rules +++ b/debian/rules @@ -1,7 +1,7 @@ #!/usr/bin/make -f # Avoid using cabal, as it writes to $HOME -export CABAL=./Setup +export BUILDER=./Setup # Do use the changelog's version number, rather than making one up. export RELEASE_BUILD=1 -- cgit v1.2.3 From 2cc3615f998683fbb51dcf4f48ca823216e337bd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 11 Nov 2016 15:05:04 -0400 Subject: releasing package git-repair version 1.20161111 --- git-repair.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/git-repair.cabal b/git-repair.cabal index 5076fbd..b8fc4ea 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -1,5 +1,5 @@ Name: git-repair -Version: 1.20151215 +Version: 1.20161111 Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess -- cgit v1.2.3 From c35c207ab3376cf2f23804529dd7cc8bc60f7795 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 11 Nov 2016 15:05:12 -0400 Subject: add news item for git-repair 1.20161111 --- doc/news/version_1.20161111.mdwn | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 doc/news/version_1.20161111.mdwn diff --git a/doc/news/version_1.20161111.mdwn b/doc/news/version_1.20161111.mdwn new file mode 100644 index 0000000..baba58b --- /dev/null +++ b/doc/news/version_1.20161111.mdwn @@ -0,0 +1,10 @@ +git-repair 1.20161111 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * git-repair.cabal: Add Setup-Depends. + * Updated cabal file explictly lists source files. The tarball + on hackage will include only the files needed for cabal install; + it is NOT the full git-repair source tree. + * debian/changelog: Converted to symlinks to CHANGELOG. + * Merge from git-annex. + * Makefile: Support building with stack as well as cabal. + * Makefile: The CABAL variable has been renamed to BUILDER."""]] \ No newline at end of file -- cgit v1.2.3 From 9422e5cd5f4b163114a2311ec70f62fedc18f777 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 18 Nov 2016 12:59:05 -0400 Subject: Fix build with recent versions of cabal and ghc. --- CHANGELOG | 6 ++++++ Common.hs | 3 +-- git-repair.cabal | 4 ++-- 3 files changed, 9 insertions(+), 4 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index faa87c4..fa6f44d 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,9 @@ +git-repair (1.20161118) UNRELEASED; urgency=medium + + * Fix build with recent versions of cabal and ghc. + + -- Joey Hess Fri, 18 Nov 2016 12:58:43 -0400 + git-repair (1.20161111) unstable; urgency=medium * git-repair.cabal: Add Setup-Depends. diff --git a/Common.hs b/Common.hs index a6c5d54..7710306 100644 --- a/Common.hs +++ b/Common.hs @@ -13,7 +13,6 @@ import Data.String.Utils as X hiding (join) import Data.Monoid as X import System.FilePath as X -import System.Directory as X import System.IO as X hiding (FilePath) #ifndef mingw32_HOST_OS import System.Posix.IO as X hiding (createPipe) @@ -25,12 +24,12 @@ import Utility.Exception as X import Utility.SafeCommand as X import Utility.Process as X import Utility.Path as X -import Utility.Directory as X import Utility.Monad as X import Utility.Data as X import Utility.Applicative as X import Utility.FileSystemEncoding as X import Utility.PosixFiles as X hiding (fileSize) import Utility.FileSize as X +import Utility.Directory as X import Utility.PartialPrelude as X diff --git a/git-repair.cabal b/git-repair.cabal index b8fc4ea..ccac779 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -1,5 +1,5 @@ Name: git-repair -Version: 1.20161111 +Version: 1.20161118 Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess @@ -32,7 +32,7 @@ Flag network-uri custom-setup Setup-Depends: base (>= 4.5), hslogger, MissingH, unix-compat, process, unix, filepath, exceptions, bytestring, directory, IfElse, data-default, - Cabal + mtl, Cabal source-repository head type: git -- cgit v1.2.3 From b556828ec64b9a281e5a3dc250757f18dc39ee27 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 18 Nov 2016 13:00:06 -0400 Subject: releasing package git-repair version 1.20161118 --- CHANGELOG | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index fa6f44d..d6cc186 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,8 +1,8 @@ -git-repair (1.20161118) UNRELEASED; urgency=medium +git-repair (1.20161118) unstable; urgency=medium * Fix build with recent versions of cabal and ghc. - -- Joey Hess Fri, 18 Nov 2016 12:58:43 -0400 + -- Joey Hess Fri, 18 Nov 2016 12:59:07 -0400 git-repair (1.20161111) unstable; urgency=medium -- cgit v1.2.3 From 1b18f539f2bace903c853ce828902a8061007da5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 18 Nov 2016 13:00:14 -0400 Subject: add news item for git-repair 1.20161118 --- doc/news/version_1.20161118.mdwn | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 doc/news/version_1.20161118.mdwn diff --git a/doc/news/version_1.20161118.mdwn b/doc/news/version_1.20161118.mdwn new file mode 100644 index 0000000..c687f46 --- /dev/null +++ b/doc/news/version_1.20161118.mdwn @@ -0,0 +1,3 @@ +git-repair 1.20161118 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * Fix build with recent versions of cabal and ghc."""]] \ No newline at end of file -- cgit v1.2.3 From 122b09e2f24cff55c65b84cbccd78ed640a234be Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 24 Dec 2016 14:53:58 -0400 Subject: Merge from git-annex. --- CHANGELOG | 6 ++++++ Common.hs | 6 +++--- Git/CatFile.hs | 1 + Git/Command.hs | 6 +----- Git/Config.hs | 5 ----- Git/CurrentRepo.hs | 2 +- Git/Repair.hs | 2 +- Git/UpdateIndex.hs | 1 - Utility/CoProcess.hs | 6 +++--- Utility/Exception.hs | 18 +++++++++++++++++- Utility/FileSystemEncoding.hs | 41 ++++++++++++++++++++++------------------- Utility/Metered.hs | 43 +++++++++++++++++++++++++++++-------------- Utility/Misc.hs | 17 ----------------- Utility/SystemDirectory.hs | 2 +- Utility/URI.hs | 18 ------------------ Utility/UserInfo.hs | 3 ++- git-repair.cabal | 4 ++-- git-repair.hs | 5 ++++- 18 files changed, 93 insertions(+), 93 deletions(-) delete mode 100644 Utility/URI.hs diff --git a/CHANGELOG b/CHANGELOG index d6cc186..1a17a93 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,9 @@ +git-repair (1.20161119) UNRELEASED; urgency=medium + + * Merge from git-annex. + + -- Joey Hess Sat, 24 Dec 2016 14:53:47 -0400 + git-repair (1.20161118) unstable; urgency=medium * Fix build with recent versions of cabal and ghc. diff --git a/Common.hs b/Common.hs index 7710306..9dab5dd 100644 --- a/Common.hs +++ b/Common.hs @@ -5,12 +5,13 @@ module Common (module X) where import Control.Monad as X import Control.Monad.IfElse as X import Control.Applicative as X -import "mtl" Control.Monad.State.Strict as X (liftIO) +import Control.Monad.IO.Class as X (liftIO) import Data.Maybe as X import Data.List as X hiding (head, tail, init, last) import Data.String.Utils as X hiding (join) import Data.Monoid as X +import Data.Default as X import System.FilePath as X import System.IO as X hiding (FilePath) @@ -24,12 +25,11 @@ import Utility.Exception as X import Utility.SafeCommand as X import Utility.Process as X import Utility.Path as X +import Utility.Directory as X import Utility.Monad as X import Utility.Data as X import Utility.Applicative as X -import Utility.FileSystemEncoding as X import Utility.PosixFiles as X hiding (fileSize) import Utility.FileSize as X -import Utility.Directory as X import Utility.PartialPrelude as X diff --git a/Git/CatFile.hs b/Git/CatFile.hs index 061349f..4935cdf 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -37,6 +37,7 @@ import Git.Command 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 index 2060563..adea762 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -53,7 +53,6 @@ runQuiet params repo = withQuietOutput createProcessSuccess $ 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 @@ pipeReadLazy params repo = assertLocal repo $ do 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 @@ pipeWriteRead params writer repo = assertLocal repo $ 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 index 3d62395..65bd9b7 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -79,10 +79,6 @@ global = do {- 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 @@ coreBare = "core.bare" 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/CurrentRepo.hs b/Git/CurrentRepo.hs index dab4ad2..69a679e 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -52,7 +52,7 @@ get = do curr <- getCurrentDirectory Git.Config.read $ newFrom $ Local { gitdir = absd, worktree = Just curr } - configure Nothing Nothing = error "Not in a git repository." + configure Nothing Nothing = giveup "Not in a git repository." addworktree w r = changelocation r $ Local { gitdir = gitdir (location r), worktree = w } diff --git a/Git/Repair.hs b/Git/Repair.hs index fcfc036..1baf51a 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -614,4 +614,4 @@ successfulRepair = fst safeReadFile :: FilePath -> IO String safeReadFile f = do allowRead f - readFileStrictAnyEncoding f + readFileStrict f diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 55c5b3b..7fdc945 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -55,7 +55,6 @@ startUpdateIndex :: Repo -> IO UpdateIndexHandle 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/Utility/CoProcess.hs b/Utility/CoProcess.hs index 94d5ac3..2bae40f 100644 --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -47,10 +47,10 @@ start' s = do 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 index 0ffc710..67c2e85 100644 --- 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, @@ -40,6 +41,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 catchBoolIO = catchDefaultIO False diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index eab9833..be43ace 100644 --- 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 @@ module Utility.FileSystemEncoding ( encodeW8NUL, decodeW8NUL, truncateFilePath, - setConsoleEncoding, ) where import qualified GHC.Foreign as GHC @@ -39,19 +38,30 @@ import qualified Data.ByteString.Lazy.UTF8 as L8 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 @@ truncateFilePath n = reverse . go [] n . L8.fromString 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/Metered.hs b/Utility/Metered.hs index 440aa3f..e21e18c 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -1,11 +1,11 @@ {- Metered IO and actions - - - Copyright 2012-2106 Joey Hess + - Copyright 2012-2016 Joey Hess - - License: BSD-2-clause -} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeSynonymInstances, BangPatterns #-} module Utility.Metered where @@ -85,12 +85,15 @@ streamMeteredFile f meterupdate h = withMeteredFile f meterupdate $ L.hPut h {- Writes a ByteString to a Handle, updating a meter as it's written. -} meteredWrite :: MeterUpdate -> Handle -> L.ByteString -> IO () -meteredWrite meterupdate h = go zeroBytesProcessed . L.toChunks +meteredWrite meterupdate h = void . meteredWrite' meterupdate h + +meteredWrite' :: MeterUpdate -> Handle -> L.ByteString -> IO BytesProcessed +meteredWrite' meterupdate h = go zeroBytesProcessed . L.toChunks where - go _ [] = return () + go sofar [] = return sofar go sofar (c:cs) = do S.hPut h c - let sofar' = addBytesProcessed sofar $ S.length c + let !sofar' = addBytesProcessed sofar $ S.length c meterupdate sofar' go sofar' cs @@ -112,30 +115,30 @@ offsetMeterUpdate base offset = \n -> base (offset `addBytesProcessed` n) - meter updates, so use caution. -} hGetContentsMetered :: Handle -> MeterUpdate -> IO L.ByteString -hGetContentsMetered h = hGetUntilMetered h (const True) +hGetContentsMetered h = hGetMetered h Nothing -{- Reads from the Handle, updating the meter after each chunk. +{- Reads from the Handle, updating the meter after each chunk is read. + - + - Stops at EOF, or when the requested number of bytes have been read. + - Closes the Handle at EOF, but otherwise leaves it open. - - Note that the meter update is run in unsafeInterleaveIO, which means that - it can be run at any time. It's even possible for updates to run out - of order, as different parts of the ByteString are consumed. - - - - Stops at EOF, or when keepgoing evaluates to False. - - Closes the Handle at EOF, but otherwise leaves it open. -} -hGetUntilMetered :: Handle -> (Integer -> Bool) -> MeterUpdate -> IO L.ByteString -hGetUntilMetered h keepgoing meterupdate = lazyRead zeroBytesProcessed +hGetMetered :: Handle -> Maybe Integer -> MeterUpdate -> IO L.ByteString +hGetMetered h wantsize meterupdate = lazyRead zeroBytesProcessed where lazyRead sofar = unsafeInterleaveIO $ loop sofar loop sofar = do - c <- S.hGet h defaultChunkSize + c <- S.hGet h (nextchunksize (fromBytesProcessed sofar)) if S.null c then do hClose h return $ L.empty else do - let sofar' = addBytesProcessed sofar (S.length c) + let !sofar' = addBytesProcessed sofar (S.length c) meterupdate sofar' if keepgoing (fromBytesProcessed sofar') then do @@ -145,6 +148,18 @@ hGetUntilMetered h keepgoing meterupdate = lazyRead zeroBytesProcessed cs <- lazyRead sofar' return $ L.append (L.fromChunks [c]) cs else return $ L.fromChunks [c] + + keepgoing n = case wantsize of + Nothing -> True + Just sz -> n < sz + + nextchunksize n = case wantsize of + Nothing -> defaultChunkSize + Just sz -> + let togo = sz - n + in if togo < toInteger defaultChunkSize + then fromIntegral togo + else defaultChunkSize {- Same default chunk size Lazy ByteStrings use. -} defaultChunkSize :: Int diff --git a/Utility/Misc.hs b/Utility/Misc.hs index ebb4257..4498c0a 100644 --- 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 @@ -35,20 +32,6 @@ hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s 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 index 3dd44d1..b9040fe 100644 --- a/Utility/SystemDirectory.hs +++ b/Utility/SystemDirectory.hs @@ -13,4 +13,4 @@ module Utility.SystemDirectory ( module System.Directory ) where -import System.Directory hiding (isSymbolicLink) +import System.Directory hiding (isSymbolicLink, getFileSize) diff --git a/Utility/URI.hs b/Utility/URI.hs deleted file mode 100644 index e68fda5..0000000 --- a/Utility/URI.hs +++ /dev/null @@ -1,18 +0,0 @@ -{- Network.URI - - - - Copyright 2014 Joey Hess - - - - License: BSD-2-clause - -} - -{-# LANGUAGE CPP #-} - -module Utility.URI where - --- Old versions of network lacked an Ord for URI -#if ! MIN_VERSION_network(2,4,0) -import Network.URI - -instance Ord URI where - a `compare` b = show a `compare` show b -#endif diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index ec0b0d0..dd66c33 100644 --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -16,6 +16,7 @@ module Utility.UserInfo ( import Utility.Env import Utility.Data +import Utility.Exception import System.PosixCompat import Control.Applicative @@ -25,7 +26,7 @@ import Prelude - - 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/git-repair.cabal b/git-repair.cabal index ccac779..7949439 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -44,7 +44,8 @@ Executable git-repair Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl, unix-compat, bytestring, exceptions (>= 0.6), transformers, base >= 4.5, base < 5, IfElse, text, process, time, QuickCheck, - utf8-string, async, optparse-applicative (>= 0.10.0) + utf8-string, async, optparse-applicative (>= 0.10.0), + data-default if flag(network-uri) Build-Depends: network-uri (>= 2.6), network (>= 2.6) @@ -113,5 +114,4 @@ Executable git-repair Utility.SystemDirectory Utility.ThreadScheduler Utility.Tmp - Utility.URI Utility.UserInfo diff --git a/git-repair.hs b/git-repair.hs index a82d5d6..4076c15 100644 --- a/git-repair.hs +++ b/git-repair.hs @@ -15,6 +15,7 @@ import qualified Git.Construct import qualified Git.Destroyer import qualified Git.Fsck import Utility.Tmp +import Utility.FileSystemEncoding data Settings = Settings { forced :: Bool @@ -46,7 +47,9 @@ parseSettings = Settings ) main :: IO () -main = execParser opts >>= go +main = do + useFileSystemEncoding + execParser opts >>= go where opts = info (helper <*> parseSettings) desc desc = fullDesc -- cgit v1.2.3 From c799b05deae723690bfac5e867f7985e8f800d0d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 26 Jun 2017 12:10:57 -0400 Subject: note fix --- CHANGELOG | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG b/CHANGELOG index 1a17a93..55b8281 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,6 +1,7 @@ git-repair (1.20161119) UNRELEASED; urgency=medium * Merge from git-annex. + * Fixes build with directory-1.3. -- Joey Hess Sat, 24 Dec 2016 14:53:47 -0400 -- cgit v1.2.3 From 63f9aba33b45e5bab688ffaa5e4182801c152828 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 26 Jun 2017 12:15:27 -0400 Subject: merge from git-annex Removes dependency on MissingH, adding a dependency on split instead. This commit was sponsored by Brock Spratlen on Patreon. --- CHANGELOG | 1 + Common.hs | 2 +- Git/CatFile.hs | 2 +- Git/Command.hs | 8 +- Git/Config.hs | 2 +- Git/Construct.hs | 8 +- Git/Filename.hs | 14 +++- Git/LsTree.hs | 16 ++-- Git/Ref.hs | 2 +- Git/Remote.hs | 6 +- Git/Repair.hs | 2 +- Utility/DataUnits.hs | 166 ++++++++++++++++++++++++++++++++++++++++++ Utility/Directory.hs | 4 +- Utility/DottedVersion.hs | 2 +- Utility/FileMode.hs | 22 +++++- Utility/FileSystemEncoding.hs | 41 ++++++++--- Utility/Format.hs | 21 ++++-- Utility/HumanNumber.hs | 21 ++++++ Utility/HumanTime.hs | 102 ++++++++++++++++++++++++++ Utility/Metered.hs | 104 +++++++++++++++++++++++--- Utility/PartialPrelude.hs | 2 +- Utility/Path.hs | 32 +++----- Utility/Percentage.hs | 33 +++++++++ Utility/Process.hs | 28 ++++--- Utility/QuickCheck.hs | 3 - Utility/Rsync.hs | 6 +- Utility/SafeCommand.hs | 4 +- Utility/Split.hs | 30 ++++++++ Utility/Tuple.hs | 17 +++++ git-repair.cabal | 10 ++- 30 files changed, 602 insertions(+), 109 deletions(-) create mode 100644 Utility/DataUnits.hs create mode 100644 Utility/HumanNumber.hs create mode 100644 Utility/HumanTime.hs create mode 100644 Utility/Percentage.hs create mode 100644 Utility/Split.hs create mode 100644 Utility/Tuple.hs diff --git a/CHANGELOG b/CHANGELOG index 55b8281..c6f328c 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,6 +1,7 @@ git-repair (1.20161119) UNRELEASED; urgency=medium * Merge from git-annex. + * Removes dependency on MissingH, adding a dependency on split instead. * Fixes build with directory-1.3. -- Joey Hess Sat, 24 Dec 2016 14:53:47 -0400 diff --git a/Common.hs b/Common.hs index 9dab5dd..c1890e6 100644 --- a/Common.hs +++ b/Common.hs @@ -9,7 +9,6 @@ import Control.Monad.IO.Class as X (liftIO) import Data.Maybe as X import Data.List as X hiding (head, tail, init, last) -import Data.String.Utils as X hiding (join) import Data.Monoid as X import Data.Default as X @@ -31,5 +30,6 @@ import Utility.Data as X import Utility.Applicative as X import Utility.PosixFiles as X hiding (fileSize) import Utility.FileSize as X +import Utility.Split as X import Utility.PartialPrelude as X diff --git a/Git/CatFile.hs b/Git/CatFile.hs index 4935cdf..ba68c4e 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -26,7 +26,6 @@ import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.Map as M import Data.String import Data.Char -import Data.Tuple.Utils import Numeric import System.Posix.Types @@ -38,6 +37,7 @@ import Git.Types import Git.FilePath import qualified Utility.CoProcess as CoProcess import Utility.FileSystemEncoding +import Utility.Tuple data CatFileHandle = CatFileHandle { catFileProcess :: CoProcess.CoProcessHandle diff --git a/Git/Command.hs b/Git/Command.hs index adea762..f40dfab 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -91,16 +91,16 @@ pipeWrite params repo = withHandle StdinHandle createProcessSuccess $ pipeNullSplit :: [CommandParam] -> Repo -> IO ([String], IO Bool) pipeNullSplit params repo = do (s, cleanup) <- pipeReadLazy params repo - return (filter (not . null) $ split sep s, cleanup) + return (filter (not . null) $ splitc sep s, cleanup) where - sep = "\0" + sep = '\0' pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [String] pipeNullSplitStrict params repo = do s <- pipeReadStrict params repo - return $ filter (not . null) $ split sep s + return $ filter (not . null) $ splitc sep s where - sep = "\0" + sep = '\0' pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String] pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo diff --git a/Git/Config.hs b/Git/Config.hs index 65bd9b7..9b4c342 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -132,7 +132,7 @@ parse s -- --list output will have an = in the first line | all ('=' `elem`) (take 1 ls) = sep '=' ls -- --null --list output separates keys from values with newlines - | otherwise = sep '\n' $ split "\0" s + | otherwise = sep '\n' $ splitc '\0' s where ls = lines s sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) . diff --git a/Git/Construct.hs b/Git/Construct.hs index 7655622..4ad74fd 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -26,7 +26,7 @@ module Git.Construct ( #ifndef mingw32_HOST_OS import System.Posix.User #endif -import qualified Data.Map as M hiding (map, split) +import qualified Data.Map as M import Network.URI import Common @@ -94,7 +94,7 @@ fromUrl url fromUrlStrict :: String -> IO Repo fromUrlStrict url - | startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u + | "file://" `isPrefixOf` url = fromAbsPath $ unEscapeString $ uriPath u | otherwise = pure $ newFrom $ Url u where u = fromMaybe bad $ parseURI url @@ -128,7 +128,7 @@ fromRemotes repo = mapM construct remotepairs filterconfig f = filter f $ M.toList $ config repo filterkeys f = filterconfig (\(k,_) -> f k) remotepairs = filterkeys isremote - isremote k = startswith "remote." k && endswith ".url" k + isremote k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo {- Sets the name of a remote when constructing the Repo to represent it. -} @@ -143,7 +143,7 @@ remoteNamedFromKey :: String -> IO Repo -> IO Repo remoteNamedFromKey k = remoteNamed basename where basename = intercalate "." $ - reverse $ drop 1 $ reverse $ drop 1 $ split "." k + reverse $ drop 1 $ reverse $ drop 1 $ splitc '.' k {- Constructs a new Repo for one of a Repo's remotes using a given - location (ie, an url). -} diff --git a/Git/Filename.hs b/Git/Filename.hs index ee84d48..355e75f 100644 --- a/Git/Filename.hs +++ b/Git/Filename.hs @@ -8,9 +8,10 @@ module Git.Filename where +import Common import Utility.Format (decode_c, encode_c) -import Common +import Data.Char decode :: String -> FilePath decode [] = [] @@ -23,6 +24,11 @@ decode f@(c:s) encode :: FilePath -> String encode s = "\"" ++ encode_c s ++ "\"" -{- for quickcheck -} -prop_isomorphic_deencode :: String -> Bool -prop_isomorphic_deencode s = s == decode (encode s) +{- For quickcheck. + - + - See comment on Utility.Format.prop_encode_c_decode_c_roundtrip for + - why this only tests chars < 256 -} +prop_encode_decode_roundtrip :: String -> Bool +prop_encode_decode_roundtrip s = s' == decode (encode s') + where + s' = filter (\c -> ord c < 256) s diff --git a/Git/LsTree.hs b/Git/LsTree.hs index 2060fa7..225f2ce 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -24,6 +24,7 @@ import Git.FilePath import qualified Git.Filename import Numeric +import Data.Char import System.Posix.Types data TreeItem = TreeItem @@ -66,7 +67,9 @@ lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo , File $ fromRef t ] ++ map File fs -{- Parses a line of ls-tree output. +{- Parses a line of ls-tree output, in format: + - mode SP type SP sha TAB file + - - (The --long format is not currently supported.) -} parseLsTree :: String -> TreeItem parseLsTree l = TreeItem @@ -76,12 +79,9 @@ parseLsTree l = TreeItem , file = sfile } where - -- l = SP SP TAB - -- All fields are fixed, so we can pull them out of - -- specific positions in the line. - (m, past_m) = splitAt 7 l - (!t, past_t) = splitAt 4 past_m - (!s, past_s) = splitAt shaSize $ Prelude.tail past_t - !f = Prelude.tail past_s + (m, past_m) = splitAt 7 l -- mode is 6 bytes + (!t, past_t) = separate isSpace past_m + (!s, past_s) = splitAt shaSize past_t + !f = drop 1 past_s !smode = fst $ Prelude.head $ readOct m !sfile = asTopFilePath $ Git.Filename.decode f diff --git a/Git/Ref.hs b/Git/Ref.hs index 5b3b853..2d80137 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -144,6 +144,6 @@ legal allowonelevel s = all (== False) illegal ends v = v `isSuffixOf` s begins v = v `isPrefixOf` s - pathbits = split "/" s + pathbits = splitc '/' s illegalchars = " ~^:?*[\\" ++ controlchars controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)] diff --git a/Git/Remote.hs b/Git/Remote.hs index 717b540..f6eaf93 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -74,9 +74,9 @@ parseRemoteLocation s repo = ret $ calcloc s (bestkey, bestvalue) = maximumBy longestvalue insteadofs longestvalue (_, a) (_, b) = compare b a insteadofs = filterconfig $ \(k, v) -> - startswith prefix k && - endswith suffix k && - startswith v l + prefix `isPrefixOf` k && + suffix `isSuffixOf` k && + v `isPrefixOf` l filterconfig f = filter f $ concatMap splitconfigs $ M.toList $ fullconfig repo splitconfigs (k, vs) = map (\v -> (k, v)) vs diff --git a/Git/Repair.hs b/Git/Repair.hs index 1baf51a..8e43248 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -39,10 +39,10 @@ import qualified Git.Branch as Branch import Utility.Tmp import Utility.Rsync import Utility.FileMode +import Utility.Tuple import qualified Data.Set as S import qualified Data.ByteString.Lazy as L -import Data.Tuple.Utils {- Given a set of bad objects found by git fsck, which may not - be complete, finds and removes all corrupt objects. -} diff --git a/Utility/DataUnits.hs b/Utility/DataUnits.hs new file mode 100644 index 0000000..a6c9ffc --- /dev/null +++ b/Utility/DataUnits.hs @@ -0,0 +1,166 @@ +{- data size display and parsing + - + - Copyright 2011 Joey Hess + - + - License: BSD-2-clause + - + - + - And now a rant: + - + - In the beginning, we had powers of two, and they were good. + - + - Disk drive manufacturers noticed that some powers of two were + - sorta close to some powers of ten, and that rounding down to the nearest + - power of ten allowed them to advertise their drives were bigger. This + - was sorta annoying. + - + - Then drives got big. Really, really big. This was good. + - + - Except that the small rounding error perpretrated by the drive + - manufacturers suffered the fate of a small error, and became a large + - error. This was bad. + - + - So, a committee was formed. And it arrived at a committee-like decision, + - which satisfied noone, confused everyone, and made the world an uglier + - place. As with all committees, this was meh. + - + - And the drive manufacturers happily continued selling drives that are + - increasingly smaller than you'd expect, if you don't count on your + - fingers. But that are increasingly too big for anyone to much notice. + - This caused me to need git-annex. + - + - Thus, I use units here that I loathe. Because if I didn't, people would + - be confused that their drives seem the wrong size, and other people would + - complain at me for not being standards compliant. And we call this + - progress? + -} + +module Utility.DataUnits ( + dataUnits, + storageUnits, + memoryUnits, + bandwidthUnits, + oldSchoolUnits, + Unit(..), + ByteSize, + + roughSize, + roughSize', + compareSizes, + readSize +) where + +import Data.List +import Data.Char + +import Utility.HumanNumber + +type ByteSize = Integer +type Name = String +type Abbrev = String +data Unit = Unit ByteSize Abbrev Name + deriving (Ord, Show, Eq) + +dataUnits :: [Unit] +dataUnits = storageUnits ++ memoryUnits + +{- Storage units are (stupidly) powers of ten. -} +storageUnits :: [Unit] +storageUnits = + [ Unit (p 8) "YB" "yottabyte" + , Unit (p 7) "ZB" "zettabyte" + , Unit (p 6) "EB" "exabyte" + , Unit (p 5) "PB" "petabyte" + , Unit (p 4) "TB" "terabyte" + , Unit (p 3) "GB" "gigabyte" + , Unit (p 2) "MB" "megabyte" + , Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe + , Unit (p 0) "B" "byte" + ] + where + p :: Integer -> Integer + p n = 1000^n + +{- Memory units are (stupidly named) powers of 2. -} +memoryUnits :: [Unit] +memoryUnits = + [ Unit (p 8) "YiB" "yobibyte" + , Unit (p 7) "ZiB" "zebibyte" + , Unit (p 6) "EiB" "exbibyte" + , Unit (p 5) "PiB" "pebibyte" + , Unit (p 4) "TiB" "tebibyte" + , Unit (p 3) "GiB" "gibibyte" + , Unit (p 2) "MiB" "mebibyte" + , Unit (p 1) "KiB" "kibibyte" + , Unit (p 0) "B" "byte" + ] + where + p :: Integer -> Integer + p n = 2^(n*10) + +{- Bandwidth units are only measured in bits if you're some crazy telco. -} +bandwidthUnits :: [Unit] +bandwidthUnits = error "stop trying to rip people off" + +{- Do you yearn for the days when men were men and megabytes were megabytes? -} +oldSchoolUnits :: [Unit] +oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits + where + mingle (Unit _ a n, Unit s' _ _) = Unit s' a n + +{- approximate display of a particular number of bytes -} +roughSize :: [Unit] -> Bool -> ByteSize -> String +roughSize units short i = roughSize' units short 2 i + +roughSize' :: [Unit] -> Bool -> Int -> ByteSize -> String +roughSize' units short precision i + | i < 0 = '-' : findUnit units' (negate i) + | otherwise = findUnit units' i + where + units' = sortBy (flip compare) units -- largest first + + findUnit (u@(Unit s _ _):us) i' + | i' >= s = showUnit i' u + | otherwise = findUnit us i' + findUnit [] i' = showUnit i' (last units') -- bytes + + showUnit x (Unit size abbrev name) = s ++ " " ++ unit + where + v = (fromInteger x :: Double) / fromInteger size + s = showImprecise precision v + unit + | short = abbrev + | s == "1" = name + | otherwise = name ++ "s" + +{- displays comparison of two sizes -} +compareSizes :: [Unit] -> Bool -> ByteSize -> ByteSize -> String +compareSizes units abbrev old new + | old > new = roughSize units abbrev (old - new) ++ " smaller" + | old < new = roughSize units abbrev (new - old) ++ " larger" + | otherwise = "same" + +{- Parses strings like "10 kilobytes" or "0.5tb". -} +readSize :: [Unit] -> String -> Maybe ByteSize +readSize units input + | null parsednum || null parsedunit = Nothing + | otherwise = Just $ round $ number * fromIntegral multiplier + where + (number, rest) = head parsednum + multiplier = head parsedunit + unitname = takeWhile isAlpha $ dropWhile isSpace rest + + parsednum = reads input :: [(Double, String)] + parsedunit = lookupUnit units unitname + + lookupUnit _ [] = [1] -- no unit given, assume bytes + lookupUnit [] _ = [] + lookupUnit (Unit s a n:us) v + | a ~~ v || n ~~ v = [s] + | plural n ~~ v || a ~~ byteabbrev v = [s] + | otherwise = lookupUnit us v + + a ~~ b = map toLower a == map toLower b + + plural n = n ++ "s" + byteabbrev a = a ++ "b" diff --git a/Utility/Directory.hs b/Utility/Directory.hs index 693e771..c24f36d 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -96,10 +96,10 @@ dirTreeRecursiveSkipping skipdir topdir = go [] [topdir] go c (dir:dirs) | skipdir (takeFileName dir) = go c dirs | otherwise = unsafeInterleaveIO $ do - subdirs <- go c + subdirs <- go [] =<< filterM (isDirectory <$$> getSymbolicLinkStatus) =<< catchDefaultIO [] (dirContents dir) - go (subdirs++[dir]) dirs + go (subdirs++dir:c) dirs {- Moves one filename to another. - First tries a rename, but falls back to moving across devices if needed. -} diff --git a/Utility/DottedVersion.hs b/Utility/DottedVersion.hs index ebf4c0b..3198b1c 100644 --- a/Utility/DottedVersion.hs +++ b/Utility/DottedVersion.hs @@ -25,7 +25,7 @@ instance Show DottedVersion where normalize :: String -> DottedVersion normalize v = DottedVersion v $ sum $ mult 1 $ reverse $ extend precision $ take precision $ - map readi $ split "." v + map readi $ splitc '.' v where extend n l = l ++ replicate (n - length l) 0 mult _ [] = [] diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index bb3780c..d9a2694 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -1,6 +1,6 @@ {- File mode utilities. - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2017 Joey Hess - - License: BSD-2-clause -} @@ -130,6 +130,21 @@ withUmask umask a = bracket setup cleanup go withUmask _ a = a #endif +getUmask :: IO FileMode +#ifndef mingw32_HOST_OS +getUmask = bracket setup cleanup return + where + setup = setFileCreationMask nullFileMode + cleanup = setFileCreationMask +#else +getUmask = return nullFileMode +#endif + +defaultFileMode :: IO FileMode +defaultFileMode = do + umask <- getUmask + return $ intersectFileModes (complement umask) stdFileMode + combineModes :: [FileMode] -> FileMode combineModes [] = 0 combineModes [m] = m @@ -162,7 +177,10 @@ writeFileProtected file content = writeFileProtected' file (\h -> hPutStr h content) writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO () -writeFileProtected' file writer = withUmask 0o0077 $ +writeFileProtected' file writer = protectedOutput $ withFile file WriteMode $ \h -> do void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes writer h + +protectedOutput :: IO a -> IO a +protectedOutput = withUmask 0o0077 diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index be43ace..444dc4a 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -10,8 +10,8 @@ module Utility.FileSystemEncoding ( useFileSystemEncoding, + fileEncoding, withFilePath, - md5FilePath, decodeBS, encodeBS, decodeW8, @@ -19,6 +19,10 @@ module Utility.FileSystemEncoding ( encodeW8NUL, decodeW8NUL, truncateFilePath, + s2w8, + w82s, + c2w8, + w82c, ) where import qualified GHC.Foreign as GHC @@ -26,17 +30,15 @@ import qualified GHC.IO.Encoding as Encoding import Foreign.C import System.IO import System.IO.Unsafe -import qualified Data.Hash.MD5 as MD5 import Data.Word -import Data.Bits.Utils import Data.List -import Data.List.Utils import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS import qualified Data.ByteString.Lazy.UTF8 as L8 #endif import Utility.Exception +import Utility.Split {- Makes all subsequent Handles that are opened, as well as stdio Handles, - use the filesystem encoding, instead of the encoding of the current @@ -63,6 +65,13 @@ useFileSystemEncoding = do hSetEncoding stderr e Encoding.setLocaleEncoding e +fileEncoding :: Handle -> IO () +#ifndef mingw32_HOST_OS +fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding +#else +fileEncoding h = hSetEncoding h Encoding.utf8 +#endif + {- Marshal a Haskell FilePath into a NUL terminated C string using temporary - storage. The FilePath is encoded using the filesystem encoding, - reversing the decoding that should have been done when the FilePath @@ -93,10 +102,6 @@ _encodeFilePath fp = unsafePerformIO $ do GHC.withCString enc fp (GHC.peekCString Encoding.char8) `catchNonAsync` (\_ -> return fp) -{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -} -md5FilePath :: FilePath -> MD5.Str -md5FilePath = MD5.Str . _encodeFilePath - {- Decodes a ByteString into a FilePath, applying the filesystem encoding. -} decodeBS :: L.ByteString -> FilePath #ifndef mingw32_HOST_OS @@ -137,14 +142,26 @@ decodeW8 = s2w8 . _encodeFilePath {- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -} encodeW8NUL :: [Word8] -> FilePath -encodeW8NUL = intercalate nul . map encodeW8 . split (s2w8 nul) +encodeW8NUL = intercalate [nul] . map encodeW8 . splitc (c2w8 nul) where - nul = ['\NUL'] + nul = '\NUL' decodeW8NUL :: FilePath -> [Word8] -decodeW8NUL = intercalate (s2w8 nul) . map decodeW8 . split nul +decodeW8NUL = intercalate [c2w8 nul] . map decodeW8 . splitc nul where - nul = ['\NUL'] + nul = '\NUL' + +c2w8 :: Char -> Word8 +c2w8 = fromIntegral . fromEnum + +w82c :: Word8 -> Char +w82c = toEnum . fromIntegral + +s2w8 :: String -> [Word8] +s2w8 = map c2w8 + +w82s :: [Word8] -> String +w82s = map w82c {- Truncates a FilePath to the given number of bytes (or less), - as represented on disk. diff --git a/Utility/Format.hs b/Utility/Format.hs index 1ebf68d..3670cd7 100644 --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -11,7 +11,7 @@ module Utility.Format ( format, decode_c, encode_c, - prop_isomorphic_deencode + prop_encode_c_decode_c_roundtrip ) where import Text.Printf (printf) @@ -100,8 +100,8 @@ empty :: Frag -> Bool empty (Const "") = True empty _ = False -{- Decodes a C-style encoding, where \n is a newline, \NNN is an octal - - encoded character, and \xNN is a hex encoded character. +{- Decodes a C-style encoding, where \n is a newline (etc), + - \NNN is an octal encoded character, and \xNN is a hex encoded character. -} decode_c :: FormatString -> String decode_c [] = [] @@ -173,6 +173,15 @@ encode_c' p = concatMap echar e_asc c = showoctal $ ord c showoctal i = '\\' : printf "%03o" i -{- for quickcheck -} -prop_isomorphic_deencode :: String -> Bool -prop_isomorphic_deencode s = s == decode_c (encode_c s) +{- For quickcheck. + - + - Encoding and then decoding roundtrips only when + - the string does not contain high unicode, because eg, + - both "\12345" and "\227\128\185" are encoded to "\343\200\271". + - + - This property papers over the problem, by only testing chars < 256. + -} +prop_encode_c_decode_c_roundtrip :: String -> Bool +prop_encode_c_decode_c_roundtrip s = s' == decode_c (encode_c s') + where + s' = filter (\c -> ord c < 256) s diff --git a/Utility/HumanNumber.hs b/Utility/HumanNumber.hs new file mode 100644 index 0000000..c3fede9 --- /dev/null +++ b/Utility/HumanNumber.hs @@ -0,0 +1,21 @@ +{- numbers for humans + - + - Copyright 2012-2013 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.HumanNumber where + +{- Displays a fractional value as a string with a limited number + - of decimal digits. -} +showImprecise :: RealFrac a => Int -> a -> String +showImprecise precision n + | precision == 0 || remainder == 0 = show (round n :: Integer) + | otherwise = show int ++ "." ++ striptrailing0s (pad0s $ show remainder) + where + int :: Integer + (int, frac) = properFraction n + remainder = round (frac * 10 ^ precision) :: Integer + pad0s s = replicate (precision - length s) '0' ++ s + striptrailing0s = reverse . dropWhile (== '0') . reverse diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs new file mode 100644 index 0000000..fe7cf22 --- /dev/null +++ b/Utility/HumanTime.hs @@ -0,0 +1,102 @@ +{- Time for humans. + - + - Copyright 2012-2013 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.HumanTime ( + Duration(..), + durationSince, + durationToPOSIXTime, + durationToDays, + daysToDuration, + parseDuration, + fromDuration, + prop_duration_roundtrips +) where + +import Utility.PartialPrelude +import Utility.QuickCheck + +import qualified Data.Map as M +import Data.Time.Clock +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Char +import Control.Applicative +import Prelude + +newtype Duration = Duration { durationSeconds :: Integer } + deriving (Eq, Ord, Read, Show) + +durationSince :: UTCTime -> IO Duration +durationSince pasttime = do + now <- getCurrentTime + return $ Duration $ round $ diffUTCTime now pasttime + +durationToPOSIXTime :: Duration -> POSIXTime +durationToPOSIXTime = fromIntegral . durationSeconds + +durationToDays :: Duration -> Integer +durationToDays d = durationSeconds d `div` dsecs + +daysToDuration :: Integer -> Duration +daysToDuration i = Duration $ i * dsecs + +{- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -} +parseDuration :: Monad m => String -> m Duration +parseDuration = maybe parsefail (return . Duration) . go 0 + where + go n [] = return n + go n s = do + num <- readish s :: Maybe Integer + case dropWhile isDigit s of + (c:rest) -> do + u <- M.lookup c unitmap + go (n + num * u) rest + _ -> return $ n + num + parsefail = fail "duration parse error; expected eg \"5m\" or \"1h5m\"" + +fromDuration :: Duration -> String +fromDuration Duration { durationSeconds = d } + | d == 0 = "0s" + | otherwise = concatMap showunit $ go [] units d + where + showunit (u, n) + | n > 0 = show n ++ [u] + | otherwise = "" + go c [] _ = reverse c + go c ((u, n):us) v = + let (q,r) = v `quotRem` n + in go ((u, q):c) us r + +units :: [(Char, Integer)] +units = + [ ('y', ysecs) + , ('d', dsecs) + , ('h', hsecs) + , ('m', msecs) + , ('s', 1) + ] + +unitmap :: M.Map Char Integer +unitmap = M.fromList units + +ysecs :: Integer +ysecs = dsecs * 365 + +dsecs :: Integer +dsecs = hsecs * 24 + +hsecs :: Integer +hsecs = msecs * 60 + +msecs :: Integer +msecs = 60 + +-- Durations cannot be negative. +instance Arbitrary Duration where + arbitrary = Duration <$> nonNegative arbitrary + +prop_duration_roundtrips :: Duration -> Bool +prop_duration_roundtrips d = parseDuration (fromDuration d) == Just d diff --git a/Utility/Metered.hs b/Utility/Metered.hs index e21e18c..a5dda54 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -10,6 +10,10 @@ module Utility.Metered where import Common +import Utility.FileSystemEncoding +import Utility.Percentage +import Utility.DataUnits +import Utility.HumanTime import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S @@ -17,7 +21,6 @@ import System.IO.Unsafe import Foreign.Storable (Storable(sizeOf)) import System.Posix.Types import Data.Int -import Data.Bits.Utils import Control.Concurrent import Control.Concurrent.Async import Control.Monad.IO.Class (MonadIO) @@ -168,22 +171,27 @@ defaultChunkSize = 32 * k - chunkOverhead k = 1024 chunkOverhead = 2 * sizeOf (1 :: Int) -- GHC specific -{- Runs an action, watching a file as it grows and updating the meter. -} +{- Runs an action, watching a file as it grows and updating the meter. + - + - The file may already exist, and the action could throw the original file + - away and start over. To avoid reporting the original file size followed + - by a smaller size in that case, wait until the file starts growing + - before updating the meter for the first time. + -} watchFileSize :: (MonadIO m, MonadMask m) => FilePath -> MeterUpdate -> m a -> m a watchFileSize f p a = bracket - (liftIO $ forkIO $ watcher zeroBytesProcessed) + (liftIO $ forkIO $ watcher =<< getsz) (liftIO . void . tryIO . killThread) (const a) where watcher oldsz = do - v <- catchMaybeIO $ toBytesProcessed <$> getFileSize f - newsz <- case v of - Just sz | sz /= oldsz -> do - p sz - return sz - _ -> return oldsz threadDelay 500000 -- 0.5 seconds - watcher newsz + sz <- getsz + when (sz > oldsz) $ + p sz + watcher sz + getsz = catchDefaultIO zeroBytesProcessed $ + toBytesProcessed <$> getFileSize f data OutputHandler = OutputHandler { quietMode :: Bool @@ -216,7 +224,7 @@ commandMeter progressparser oh meterupdate cmd params = unless (quietMode oh) $ do S.hPut stdout b hFlush stdout - let s = w82s (S.unpack b) + let s = encodeW8 (S.unpack b) let (mbytes, buf') = progressparser (buf++s) case mbytes of Nothing -> feedprogress prev buf' h @@ -297,3 +305,77 @@ rateLimitMeterUpdate delta totalsize meterupdate = do putMVar lastupdate now meterupdate n else putMVar lastupdate prev + +data Meter = Meter (Maybe Integer) (MVar MeterState) (MVar String) RenderMeter DisplayMeter + +type MeterState = (BytesProcessed, POSIXTime) + +type DisplayMeter = MVar String -> String -> IO () + +type RenderMeter = Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> String + +-- | Make a meter. Pass the total size, if it's known. +mkMeter :: Maybe Integer -> RenderMeter -> DisplayMeter -> IO Meter +mkMeter totalsize rendermeter displaymeter = Meter + <$> pure totalsize + <*> ((\t -> newMVar (zeroBytesProcessed, t)) =<< getPOSIXTime) + <*> newMVar "" + <*> pure rendermeter + <*> pure displaymeter + +-- | Updates the meter, displaying it if necessary. +updateMeter :: Meter -> BytesProcessed -> IO () +updateMeter (Meter totalsize sv bv rendermeter displaymeter) new = do + now <- getPOSIXTime + (old, before) <- swapMVar sv (new, now) + when (old /= new) $ + displaymeter bv $ + rendermeter totalsize (old, before) (new, now) + +-- | Display meter to a Handle. +displayMeterHandle :: Handle -> DisplayMeter +displayMeterHandle h v s = do + olds <- swapMVar v s + -- Avoid writing when the rendered meter has not changed. + when (olds /= s) $ do + let padding = replicate (length olds - length s) ' ' + hPutStr h ('\r':s ++ padding) + hFlush h + +-- | Clear meter displayed by displayMeterHandle. +clearMeterHandle :: Meter -> Handle -> IO () +clearMeterHandle (Meter _ _ v _ _) h = do + olds <- readMVar v + hPutStr h $ '\r' : replicate (length olds) ' ' ++ "\r" + hFlush h + +-- | Display meter in the form: +-- 10% 300 KiB/s 16m40s +-- or when total size is not known: +-- 1.3 MiB 300 KiB/s +bandwidthMeter :: RenderMeter +bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) = + unwords $ catMaybes + [ Just percentoramount + -- Pad enough for max width: "xxxx.xx KiB xxxx KiB/s" + , Just $ replicate (23 - length percentoramount - length rate) ' ' + , Just rate + , estimatedcompletion + ] + where + percentoramount = case mtotalsize of + Just totalsize -> showPercentage 0 $ + percentage totalsize (min new totalsize) + Nothing -> roughSize' memoryUnits True 2 new + rate = roughSize' memoryUnits True 0 bytespersecond ++ "/s" + bytespersecond + | duration == 0 = fromIntegral transferred + | otherwise = floor $ fromIntegral transferred / duration + transferred = max 0 (new - old) + duration = max 0 (now - before) + estimatedcompletion = case mtotalsize of + Just totalsize + | bytespersecond > 0 -> + Just $ fromDuration $ Duration $ + totalsize `div` bytespersecond + _ -> Nothing diff --git a/Utility/PartialPrelude.hs b/Utility/PartialPrelude.hs index 5579556..47e9831 100644 --- a/Utility/PartialPrelude.hs +++ b/Utility/PartialPrelude.hs @@ -2,7 +2,7 @@ - bugs. - - This exports functions that conflict with the prelude, which avoids - - them being accidentially used. + - them being accidentally used. -} {-# OPTIONS_GHC -fno-warn-tabs #-} diff --git a/Utility/Path.hs b/Utility/Path.hs index 3ee5ff3..0779d16 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -10,7 +10,6 @@ module Utility.Path where -import Data.String.Utils import System.FilePath import Data.List import Data.Maybe @@ -25,10 +24,10 @@ import System.Posix.Files import Utility.Exception #endif -import qualified "MissingH" System.Path as MissingH import Utility.Monad import Utility.UserInfo import Utility.Directory +import Utility.Split {- Simplifies a path, removing any "." component, collapsing "dir/..", - and removing the trailing path separator. @@ -68,18 +67,6 @@ simplifyPath path = dropTrailingPathSeparator $ absPathFrom :: FilePath -> FilePath -> FilePath 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. -} -absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath -#ifndef mingw32_HOST_OS -absNormPathUnix dir path = MissingH.absNormPath dir path -#else -absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path) - where - fromdos = replace "\\" "/" - todos = replace "/" "\\" -#endif - {- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -} parentDir :: FilePath -> FilePath parentDir = takeDirectory . dropTrailingPathSeparator @@ -89,12 +76,13 @@ parentDir = takeDirectory . dropTrailingPathSeparator upFrom :: FilePath -> Maybe FilePath upFrom dir | length dirs < 2 = Nothing - | otherwise = Just $ joinDrive drive (intercalate s $ init dirs) + | otherwise = Just $ joinDrive drive $ intercalate s $ init dirs where - -- on Unix, the drive will be "/" when the dir is absolute, otherwise "" + -- on Unix, the drive will be "/" when the dir is absolute, + -- otherwise "" (drive, path) = splitDrive dir - dirs = filter (not . null) $ split s path s = [pathSeparator] + dirs = filter (not . null) $ split s path prop_upFrom_basics :: FilePath -> Bool prop_upFrom_basics dir @@ -149,11 +137,11 @@ relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to relPathDirToFileAbs :: FilePath -> FilePath -> FilePath relPathDirToFileAbs from to | takeDrive from /= takeDrive to = to - | otherwise = intercalate s $ dotdots ++ uncommon + | otherwise = joinPath $ dotdots ++ uncommon where - s = [pathSeparator] - pfrom = split s from - pto = split s to + pfrom = sp from + pto = sp to + sp = map dropTrailingPathSeparator . splitPath common = map fst $ takeWhile same $ zip pfrom pto same (c,d) = c == d uncommon = drop numcommon pto @@ -227,6 +215,8 @@ inPath command = isJust <$> searchPath command - - The command may be fully qualified already, in which case it will - be returned if it exists. + - + - Note that this will find commands in PATH that are not executable. -} searchPath :: String -> IO (Maybe FilePath) searchPath command diff --git a/Utility/Percentage.hs b/Utility/Percentage.hs new file mode 100644 index 0000000..a30c260 --- /dev/null +++ b/Utility/Percentage.hs @@ -0,0 +1,33 @@ +{- percentages + - + - Copyright 2012 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.Percentage ( + Percentage, + percentage, + showPercentage +) where + +import Data.Ratio + +import Utility.HumanNumber + +newtype Percentage = Percentage (Ratio Integer) + +instance Show Percentage where + show = showPercentage 0 + +{- Normally the big number comes first. But 110% is allowed if desired. :) -} +percentage :: Integer -> Integer -> Percentage +percentage 0 _ = Percentage 0 +percentage full have = Percentage $ have * 100 % full + +{- Pretty-print a Percentage, with a specified level of precision. -} +showPercentage :: Int -> Percentage -> String +showPercentage precision (Percentage p) = v ++ "%" + where + v = showImprecise precision n + n = fromRational p :: Double diff --git a/Utility/Process.hs b/Utility/Process.hs index ed02f49..6d981cb 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -174,22 +174,21 @@ createBackgroundProcess p a = a =<< createProcess p -- returns a transcript combining its stdout and stderr, and -- whether it succeeded or failed. processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) -processTranscript = processTranscript' id +processTranscript cmd opts = processTranscript' (proc cmd opts) -processTranscript' :: (CreateProcess -> CreateProcess) -> String -> [String] -> Maybe String -> IO (String, Bool) -processTranscript' modproc cmd opts input = do +processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool) +processTranscript' cp input = do #ifndef mingw32_HOST_OS {- This implementation interleves stdout and stderr in exactly the order - the process writes them. -} (readf, writef) <- System.Posix.IO.createPipe readh <- System.Posix.IO.fdToHandle readf writeh <- System.Posix.IO.fdToHandle writef - p@(_, _, _, pid) <- createProcess $ modproc $ - (proc cmd opts) - { std_in = if isJust input then CreatePipe else Inherit - , std_out = UseHandle writeh - , std_err = UseHandle writeh - } + p@(_, _, _, pid) <- createProcess $ cp + { std_in = if isJust input then CreatePipe else Inherit + , std_out = UseHandle writeh + , std_err = UseHandle writeh + } hClose writeh get <- mkreader readh @@ -200,12 +199,11 @@ processTranscript' modproc cmd opts input = do return (transcript, ok) #else {- This implementation for Windows puts stderr after stdout. -} - p@(_, _, _, pid) <- createProcess $ modproc $ - (proc cmd opts) - { std_in = if isJust input then CreatePipe else Inherit - , std_out = CreatePipe - , std_err = CreatePipe - } + p@(_, _, _, pid) <- createProcess $ cp + { std_in = if isJust input then CreatePipe else Inherit + , std_out = CreatePipe + , std_err = CreatePipe + } getout <- mkreader (stdoutHandle p) geterr <- mkreader (stderrHandle p) diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index 0181ea9..e89d103 100644 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -35,9 +35,6 @@ instance (Arbitrary v, Ord v) => Arbitrary (S.Set v) where instance Arbitrary POSIXTime where arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral -instance Arbitrary EpochTime where - arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral - {- Pids are never negative, or 0. -} instance Arbitrary ProcessID where arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0) diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index d3fe981..f190b40 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -11,10 +11,10 @@ module Utility.Rsync where import Common import Utility.Metered +import Utility.Tuple import Data.Char import System.Console.GetOpt -import Data.Tuple.Utils {- Generates parameters to make rsync use a specified command as its remote - shell. -} @@ -24,7 +24,7 @@ rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand comman {- rsync requires some weird, non-shell like quoting in - here. A doubled single quote inside the single quoted - string is a single quote. -} - escape s = "'" ++ intercalate "''" (split "'" s) ++ "'" + escape s = "'" ++ intercalate "''" (splitc '\'' s) ++ "'" {- Runs rsync in server mode to send a file. -} rsyncServerSend :: [CommandParam] -> FilePath -> IO Bool @@ -123,7 +123,7 @@ parseRsyncProgress = go [] . reverse . progresschunks {- Find chunks that each start with delim. - The first chunk doesn't start with it - (it's empty when delim is at the start of the string). -} - progresschunks = drop 1 . split [delim] + progresschunks = drop 1 . splitc delim findbytesstart s = dropWhile isSpace s parsebytes :: String -> Maybe Integer diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs index 5ce17a8..eb34d3d 100644 --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -11,7 +11,7 @@ module Utility.SafeCommand where import System.Exit import Utility.Process -import Data.String.Utils +import Utility.Split import System.FilePath import Data.Char import Data.List @@ -86,7 +86,7 @@ shellEscape :: String -> String shellEscape f = "'" ++ escaped ++ "'" where -- replace ' with '"'"' - escaped = intercalate "'\"'\"'" $ split "'" f + escaped = intercalate "'\"'\"'" $ splitc '\'' f -- | Unescapes a set of shellEscaped words or filenames. shellUnEscape :: String -> [String] diff --git a/Utility/Split.hs b/Utility/Split.hs new file mode 100644 index 0000000..decfe7d --- /dev/null +++ b/Utility/Split.hs @@ -0,0 +1,30 @@ +{- split utility functions + - + - Copyright 2017 Joey Hess + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Split where + +import Data.List (intercalate) +import Data.List.Split (splitOn) + +-- | same as Data.List.Utils.split +-- +-- intercalate x . splitOn x === id +split :: Eq a => [a] -> [a] -> [[a]] +split = splitOn + +-- | Split on a single character. This is over twice as fast as using +-- split on a list of length 1, while producing identical results. -} +splitc :: Eq c => c -> [c] -> [[c]] +splitc c s = case break (== c) s of + (i, _c:rest) -> i : splitc c rest + (i, []) -> i : [] + +-- | same as Data.List.Utils.replace +replace :: Eq a => [a] -> [a] -> [a] -> [a] +replace old new = intercalate new . split old diff --git a/Utility/Tuple.hs b/Utility/Tuple.hs new file mode 100644 index 0000000..25c6e8f --- /dev/null +++ b/Utility/Tuple.hs @@ -0,0 +1,17 @@ +{- tuple utility functions + - + - Copyright 2017 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.Tuple where + +fst3 :: (a,b,c) -> a +fst3 (a,_,_) = a + +snd3 :: (a,b,c) -> b +snd3 (_,b,_) = b + +thd3 :: (a,b,c) -> c +thd3 (_,_,c) = c diff --git a/git-repair.cabal b/git-repair.cabal index 7949439..490e69e 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -30,7 +30,7 @@ Flag network-uri Default: True custom-setup - Setup-Depends: base (>= 4.5), hslogger, MissingH, unix-compat, process, + Setup-Depends: base (>= 4.5), hslogger, split, unix-compat, process, unix, filepath, exceptions, bytestring, directory, IfElse, data-default, mtl, Cabal @@ -41,7 +41,7 @@ source-repository head Executable git-repair Main-Is: git-repair.hs GHC-Options: -threaded -Wall -fno-warn-tabs - Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl, + Build-Depends: split, hslogger, directory, filepath, containers, mtl, unix-compat, bytestring, exceptions (>= 0.6), transformers, base >= 4.5, base < 5, IfElse, text, process, time, QuickCheck, utf8-string, async, optparse-applicative (>= 0.10.0), @@ -92,6 +92,7 @@ Executable git-repair Utility.Batch Utility.CoProcess Utility.Data + Utility.DataUnits Utility.Directory Utility.DottedVersion Utility.Env @@ -100,18 +101,23 @@ Executable git-repair Utility.FileSize Utility.FileSystemEncoding Utility.Format + Utility.HumanNumber + Utility.HumanTime Utility.Metered Utility.Misc Utility.Monad Utility.PartialPrelude Utility.Path + Utility.Percentage Utility.PosixFiles Utility.Process Utility.Process.Shim Utility.QuickCheck Utility.Rsync Utility.SafeCommand + Utility.Split Utility.SystemDirectory Utility.ThreadScheduler Utility.Tmp + Utility.Tuple Utility.UserInfo -- cgit v1.2.3 From 3206d6615031baf3a53060a8d8945fed23a6cd48 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 26 Jun 2017 12:19:57 -0400 Subject: releasing package git-repair version 1.20170626 --- CHANGELOG | 4 ++-- git-repair.cabal | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index c6f328c..f3f31de 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,10 +1,10 @@ -git-repair (1.20161119) UNRELEASED; urgency=medium +git-repair (1.20170626) unstable; urgency=medium * Merge from git-annex. * Removes dependency on MissingH, adding a dependency on split instead. * Fixes build with directory-1.3. - -- Joey Hess Sat, 24 Dec 2016 14:53:47 -0400 + -- Joey Hess Mon, 26 Jun 2017 12:15:29 -0400 git-repair (1.20161118) unstable; urgency=medium diff --git a/git-repair.cabal b/git-repair.cabal index 490e69e..08b98b7 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -1,5 +1,5 @@ Name: git-repair -Version: 1.20161118 +Version: 1.20170626 Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess -- cgit v1.2.3 From e1025fbe1773d7e508b00b9800f28b8027c8f355 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 26 Jun 2017 12:20:17 -0400 Subject: add news item for git-repair 1.20170626 --- doc/news/version_1.20170626.mdwn | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 doc/news/version_1.20170626.mdwn diff --git a/doc/news/version_1.20170626.mdwn b/doc/news/version_1.20170626.mdwn new file mode 100644 index 0000000..9e9830a --- /dev/null +++ b/doc/news/version_1.20170626.mdwn @@ -0,0 +1,5 @@ +git-repair 1.20170626 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * Merge from git-annex. + * Removes dependency on MissingH, adding a dependency on split instead. + * Fixes build with directory-1.3."""]] \ No newline at end of file -- cgit v1.2.3 From 3a59749f2c0603872109a85c44234dd744d059cc Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 12 Jul 2017 17:05:34 -0400 Subject: better way of finding stack built executable --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index bd2ac44..d2cd567 100644 --- a/Makefile +++ b/Makefile @@ -7,7 +7,7 @@ PREFIX=/usr build: Build/SysConfig.hs $(BUILDER) build $(BUILDEROPTIONS) if [ "$(BUILDER)" = stack ]; then \ - ln -sf $$(find .stack-work/ -name git-repair -type f | grep build/git-annex/git-repair | tail -n 1) git-repair; \ + ln -sf $$(stack path --dist-dir)/build/git-annex/git-repair git-repair; \ else \ ln -sf dist/build/git-repair/git-repair git-repair; \ fi -- cgit v1.2.3 From 5ca81d114d7ccf0ee984cb03f56ad6ec1d9499f0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 14 Dec 2017 12:55:53 -0400 Subject: Merge from git-annex. --- .gitignore | 2 +- Build/Configure.hs | 4 ++-- Build/TestConfig.hs | 17 ++--------------- BuildInfo.hs | 12 ++++++++++++ CHANGELOG | 6 ++++++ Git/BuildVersion.hs | 4 ++-- Git/Ref.hs | 31 +++++++++++++++++++++++++++---- Utility/Directory.hs | 2 +- Utility/FileMode.hs | 2 +- Utility/Misc.hs | 2 +- Utility/Path.hs | 9 +++++++-- Utility/Tmp.hs | 4 ++-- Utility/UserInfo.hs | 9 ++++++--- git-repair.cabal | 1 + 14 files changed, 71 insertions(+), 34 deletions(-) create mode 100644 BuildInfo.hs diff --git a/.gitignore b/.gitignore index 55a966c..1ed2e9b 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,3 @@ -Build/SysConfig.hs +Build/SysConfig tags git-repair diff --git a/Build/Configure.hs b/Build/Configure.hs index d48d580..dc15141 100644 --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -1,4 +1,4 @@ -{- Checks system configuration and generates SysConfig.hs. -} +{- Checks system configuration and generates SysConfig. -} {-# OPTIONS_GHC -fno-warn-tabs #-} @@ -15,7 +15,7 @@ import Git.Version tests :: [TestCase] tests = [ TestCase "version" (Config "packageversion" . StringConfig <$> getVersion) - , TestCase "git" $ requireCmd "git" "git --version >/dev/null" + , TestCase "git" $ testCmd "git" "git --version >/dev/null" , TestCase "git version" getGitVersion ] diff --git a/Build/TestConfig.hs b/Build/TestConfig.hs index 79979c5..2f7213f 100644 --- a/Build/TestConfig.hs +++ b/Build/TestConfig.hs @@ -1,4 +1,4 @@ -{- Tests the system and generates Build.SysConfig.hs. -} +{- Tests the system and generates SysConfig. -} {-# OPTIONS_GHC -fno-warn-tabs #-} @@ -42,12 +42,11 @@ instance Show Config where valuetype (MaybeBoolConfig _) = "Maybe Bool" writeSysConfig :: [Config] -> IO () -writeSysConfig config = writeFile "Build/SysConfig.hs" body +writeSysConfig config = writeFile "Build/SysConfig" body where body = unlines $ header ++ map show config ++ footer header = [ "{- Automatically generated. -}" - , "module Build.SysConfig where" , "" ] footer = [] @@ -61,18 +60,6 @@ runTests (TestCase tname t : ts) = do rest <- runTests ts return $ c:rest -{- Tests that a command is available, aborting if not. -} -requireCmd :: ConfigKey -> String -> Test -requireCmd k cmdline = do - ret <- testCmd k cmdline - handle ret - where - handle r@(Config _ (BoolConfig True)) = return r - handle r = do - testEnd r - error $ "** the " ++ c ++ " command is required" - c = head $ words cmdline - {- Checks if a command is available by running a command line. -} testCmd :: ConfigKey -> String -> Test testCmd k cmdline = do diff --git a/BuildInfo.hs b/BuildInfo.hs new file mode 100644 index 0000000..812402c --- /dev/null +++ b/BuildInfo.hs @@ -0,0 +1,12 @@ +{- build info + - + - Copyright 2017 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module BuildInfo where + +#include "Build/SysConfig" diff --git a/CHANGELOG b/CHANGELOG index f3f31de..9c8889d 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,9 @@ +git-repair (1.20170627) UNRELEASED; urgency=medium + + * Merge from git-annex. + + -- Joey Hess Thu, 14 Dec 2017 12:55:44 -0400 + git-repair (1.20170626) unstable; urgency=medium * Merge from git-annex. diff --git a/Git/BuildVersion.hs b/Git/BuildVersion.hs index 50e4a3a..7d1c53a 100644 --- a/Git/BuildVersion.hs +++ b/Git/BuildVersion.hs @@ -8,14 +8,14 @@ module Git.BuildVersion where import Git.Version -import qualified Build.SysConfig +import qualified BuildInfo {- Using the version it was configured for avoids running git to check its - version, at the cost that upgrading git won't be noticed. - This is only acceptable because it's rare that git's version influences - code's behavior. -} buildVersion :: GitVersion -buildVersion = normalize Build.SysConfig.gitversion +buildVersion = normalize BuildInfo.gitversion older :: String -> Bool older n = buildVersion < normalize n diff --git a/Git/Ref.hs b/Git/Ref.hs index 2d80137..1986db6 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -45,6 +45,10 @@ base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef underBase :: String -> Ref -> Ref underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r) +{- Convert a branch such as "master" into a fully qualified ref. -} +branchRef :: Branch -> Ref +branchRef = underBase "refs/heads" + {- A Ref that can be used to refer to a file in the repository, as staged - in the index. - @@ -101,7 +105,7 @@ matching refs repo = matching' (map fromRef refs) repo matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)] matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo -{- List of (shas, branches) matching a given ref or refs. -} +{- List of (shas, branches) matching a given ref spec. -} matching' :: [String] -> Repo -> IO [(Sha, Branch)] matching' ps repo = map gen . lines <$> pipeReadStrict (Param "show-ref" : map Param ps) repo @@ -109,17 +113,36 @@ matching' ps repo = map gen . lines <$> gen l = let (r, b) = separate (== ' ') l in (Ref r, Ref b) -{- List of (shas, branches) matching a given ref spec. +{- List of (shas, branches) matching a given ref. - Duplicate shas are filtered out. -} matchingUniq :: [Ref] -> Repo -> IO [(Sha, Branch)] matchingUniq refs repo = nubBy uniqref <$> matching refs repo where uniqref (a, _) (b, _) = a == b +{- List of all refs. -} +list :: Repo -> IO [(Sha, Ref)] +list = matching' [] + +{- Deletes a ref. This can delete refs that are not branches, + - which git branch --delete refuses to delete. -} +delete :: Sha -> Ref -> Repo -> IO () +delete oldvalue ref = run + [ Param "update-ref" + , Param "-d" + , Param $ fromRef ref + , Param $ fromRef oldvalue + ] + {- Gets the sha of the tree a ref uses. -} tree :: Ref -> Repo -> IO (Maybe Sha) -tree ref = extractSha <$$> pipeReadStrict - [ Param "rev-parse", Param (fromRef ref ++ ":") ] +tree (Ref ref) = extractSha <$$> pipeReadStrict + [ Param "rev-parse", Param ref' ] + where + ref' = if ":" `isInfixOf` ref + then ref + -- de-reference commit objects to the tree + else ref ++ ":" {- Checks if a String is a legal git ref name. - diff --git a/Utility/Directory.hs b/Utility/Directory.hs index c24f36d..895581d 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -16,6 +16,7 @@ module Utility.Directory ( import System.IO.Error import Control.Monad import System.FilePath +import System.PosixCompat.Files import Control.Applicative import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO) @@ -31,7 +32,6 @@ import Control.Monad.IfElse #endif import Utility.SystemDirectory -import Utility.PosixFiles import Utility.Tmp import Utility.Exception import Utility.Monad diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index d9a2694..370bcf6 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -15,7 +15,7 @@ module Utility.FileMode ( import System.IO import Control.Monad import System.PosixCompat.Types -import Utility.PosixFiles +import System.PosixCompat.Files #ifndef mingw32_HOST_OS import System.Posix.Files import Control.Monad.IO.Class (liftIO) diff --git a/Utility/Misc.hs b/Utility/Misc.hs index 4498c0a..2ae9928 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -112,7 +112,7 @@ hGetSomeString h sz = do peekbytes :: Int -> Ptr Word8 -> IO [Word8] peekbytes len buf = mapM (peekElemOff buf) [0..pred len] -{- Reaps any zombie git processes. +{- Reaps any zombie processes that may be hanging around. - - Warning: Not thread safe. Anything that was expecting to wait - on a process and get back an exit status is going to be confused diff --git a/Utility/Path.hs b/Utility/Path.hs index 0779d16..dc91ce5 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -136,17 +136,22 @@ relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to -} relPathDirToFileAbs :: FilePath -> FilePath -> FilePath relPathDirToFileAbs from to - | takeDrive from /= takeDrive to = to +#ifdef mingw32_HOST_OS + | normdrive from /= normdrive to = to +#endif | otherwise = joinPath $ dotdots ++ uncommon where pfrom = sp from pto = sp to - sp = map dropTrailingPathSeparator . splitPath + sp = map dropTrailingPathSeparator . splitPath . dropDrive common = map fst $ takeWhile same $ zip pfrom pto same (c,d) = c == d uncommon = drop numcommon pto dotdots = replicate (length pfrom - numcommon) ".." numcommon = length common +#ifdef mingw32_HOST_OS + normdrive = map toLower . takeWhile (/= ':') . takeDrive +#endif prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool prop_relPathDirToFile_basics from to diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index 6a541cf..7255c14 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -15,20 +15,20 @@ import Control.Monad.IfElse import System.FilePath import System.Directory import Control.Monad.IO.Class +import System.PosixCompat.Files #ifndef mingw32_HOST_OS import System.Posix.Temp (mkdtemp) #endif import Utility.Exception import Utility.FileSystemEncoding -import Utility.PosixFiles type Template = String {- Runs an action like writeFile, writing to a temp file first and - then moving it into place. The temp file is stored in the same - directory as the final file to avoid cross-device renames. -} -viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> String -> m ()) -> FilePath -> String -> m () +viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> v -> m ()) -> FilePath -> v -> m () viaTmp a file content = bracketIO setup cleanup use where (dir, base) = splitFileName file diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index dd66c33..d504fa5 100644 --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -15,11 +15,13 @@ module Utility.UserInfo ( ) where import Utility.Env -import Utility.Data import Utility.Exception +#ifndef mingw32_HOST_OS +import Utility.Data +import Control.Applicative +#endif import System.PosixCompat -import Control.Applicative import Prelude {- Current user's home directory. @@ -58,6 +60,7 @@ myVal envvars extract = go envvars #ifndef mingw32_HOST_OS go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID) #else - go [] = return $ Left ("environment not set: " ++ show envvars) + go [] = return $ either Left (Right . extract) $ + Left ("environment not set: " ++ show envvars) #endif go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v diff --git a/git-repair.cabal b/git-repair.cabal index 08b98b7..cff316f 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -58,6 +58,7 @@ Executable git-repair Build-Depends: unix Other-Modules: + BuildInfo Build.Configure Build.TestConfig Build.Version -- cgit v1.2.3 From 16022a8b98f4bc134542e78a42538364d2f97d92 Mon Sep 17 00:00:00 2001 From: "t.fettig@d70d23fc114548bde4082eecaddafd1f488f29d6" Date: Mon, 9 Jul 2018 10:19:36 +0000 Subject: --- doc/index/discussion.mdwn | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 doc/index/discussion.mdwn diff --git a/doc/index/discussion.mdwn b/doc/index/discussion.mdwn new file mode 100644 index 0000000..dea2ec7 --- /dev/null +++ b/doc/index/discussion.mdwn @@ -0,0 +1,12 @@ +My experience with git repair: + +git repair +Running git fsck ... +Stack space overflow: current size 8388608 bytes. +Use `+RTS -Ksize -RTS' to increase it. + +git repair +RTS -K32M -RTS +git-repair: Most RTS options are disabled. Link with -rtsopts to enable them. + +Whats up guys? Are we playing catch 22 here? + -- cgit v1.2.3 From 9df8a6eb9405dde4464d27133c04f5ee539a85de Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 2 Jan 2020 12:34:10 -0400 Subject: merge from git-annex and relicense accordingly Merge git library and utility from git-annex. The former is now relicensed AGPL, so git-repair as a whole becomes AGPL. For simplicity, I am relicensing the remainder of the code in git-repair AGPL as well, per the header changes in this commit. While that code is also technically available under the GPL license, as it's been released under that license before, changes going forward will be only released by me under the AGPL. --- Build/Configure.hs | 4 +- BuildInfo.hs | 2 +- CHANGELOG | 8 +- COPYRIGHT | 695 ++++++++++++++++++++++++++++++++++++++++++ Common.hs | 3 +- GPL | 674 ---------------------------------------- Git.hs | 41 +-- Git/Branch.hs | 32 +- Git/BuildVersion.hs | 2 +- Git/CatFile.hs | 107 +++++-- Git/Command.hs | 55 ++-- Git/Config.hs | 115 ++++--- Git/Construct.hs | 40 +-- Git/CurrentRepo.hs | 44 ++- Git/Destroyer.hs | 4 +- Git/DiffTreeItem.hs | 2 +- Git/FilePath.hs | 55 ++-- Git/Filename.hs | 53 +++- Git/Fsck.hs | 61 ++-- Git/HashObject.hs | 76 +++++ Git/Index.hs | 32 +- Git/LsFiles.hs | 146 +++++---- Git/LsTree.hs | 85 ++++-- Git/Objects.hs | 4 +- Git/Ref.hs | 64 ++-- Git/RefLog.hs | 4 +- Git/Remote.hs | 33 +- Git/Repair.hs | 38 +-- Git/Sha.hs | 2 +- Git/Types.hs | 119 +++++--- Git/UpdateIndex.hs | 71 +++-- Git/Url.hs | 10 +- Git/Version.hs | 2 +- Utility/Applicative.hs | 6 +- Utility/Attoparsec.hs | 21 ++ Utility/Batch.hs | 17 +- Utility/Data.hs | 5 +- Utility/Directory.hs | 93 +----- Utility/DottedVersion.hs | 11 +- Utility/Env.hs | 33 +- Utility/Env/Basic.hs | 25 ++ Utility/Env/Set.hs | 43 +++ Utility/Exception.hs | 18 +- Utility/FileMode.hs | 3 +- Utility/FileSize.hs | 12 +- Utility/FileSystemEncoding.hs | 93 +++++- Utility/Format.hs | 10 +- Utility/HumanNumber.hs | 2 +- Utility/HumanTime.hs | 12 +- Utility/Metered.hs | 135 +++++--- Utility/Misc.hs | 42 ++- Utility/Monad.hs | 14 +- Utility/PartialPrelude.hs | 21 +- Utility/Path.hs | 92 +++--- Utility/PosixFiles.hs | 42 --- Utility/Process.hs | 91 +----- Utility/QuickCheck.hs | 32 +- Utility/Rsync.hs | 51 +++- Utility/SafeCommand.hs | 38 ++- Utility/Split.hs | 11 +- Utility/ThreadScheduler.hs | 13 +- Utility/Tmp.hs | 61 +--- Utility/Tmp/Dir.hs | 70 +++++ Utility/Tuple.hs | 6 +- Utility/UserInfo.hs | 17 +- debian/copyright | 36 +-- git-repair.cabal | 39 ++- git-repair.hs | 5 +- 68 files changed, 2191 insertions(+), 1712 deletions(-) create mode 100644 COPYRIGHT delete mode 100644 GPL create mode 100644 Git/HashObject.hs create mode 100644 Utility/Attoparsec.hs create mode 100644 Utility/Env/Basic.hs create mode 100644 Utility/Env/Set.hs delete mode 100644 Utility/PosixFiles.hs create mode 100644 Utility/Tmp/Dir.hs mode change 100644 => 120000 debian/copyright diff --git a/Build/Configure.hs b/Build/Configure.hs index dc15141..1a3527f 100644 --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -5,8 +5,9 @@ module Build.Configure where import System.Environment -import Control.Applicative import Control.Monad.IfElse +import Control.Applicative +import Prelude import Build.TestConfig import Build.Version @@ -25,7 +26,6 @@ getGitVersion = Config "gitversion" . StringConfig . show run :: [TestCase] -> IO () run ts = do - args <- getArgs config <- runTests ts writeSysConfig config whenM (isReleaseBuild) $ diff --git a/BuildInfo.hs b/BuildInfo.hs index 812402c..e54bdca 100644 --- a/BuildInfo.hs +++ b/BuildInfo.hs @@ -2,7 +2,7 @@ - - Copyright 2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/CHANGELOG b/CHANGELOG index 9c8889d..50f9332 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,8 +1,12 @@ -git-repair (1.20170627) UNRELEASED; urgency=medium +git-repair (1.20200102) unstable; urgency=medium + * Relicensed AGPL. * Merge from git-annex. + * Removed the network-uri build flag. + * Increased required version of several dependencies. + * Added dependencies on deepseq, attoparsec and filepath-bytestring. - -- Joey Hess Thu, 14 Dec 2017 12:55:44 -0400 + -- Joey Hess Thu, 02 Jan 2020 12:39:13 -0400 git-repair (1.20170626) unstable; urgency=medium diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 index 0000000..cd51274 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,695 @@ +Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ +Source: native package + +Files: * +Copyright: © 2013-2019 Joey Hess +License: AGPL-3+ + +Files: Utility/* +Copyright: 2012-2019 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. + +License: AGPL-3+ + GNU AFFERO GENERAL PUBLIC LICENSE + Version 3, 19 November 2007 + . + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + . + Preamble + . + The GNU Affero General Public License is a free, copyleft license for + software and other kinds of works, specifically designed to ensure + cooperation with the community in the case of network server software. + . + The licenses for most software and other practical works are designed + to take away your freedom to share and change the works. By contrast, + our General Public Licenses are intended to guarantee your freedom to + share and change all versions of a program--to make sure it remains free + software for all its users. + . + When we speak of free software, we are referring to freedom, not + price. Our General Public Licenses are designed to make sure that you + have the freedom to distribute copies of free software (and charge for + them if you wish), that you receive source code or can get it if you + want it, that you can change the software or use pieces of it in new + free programs, and that you know you can do these things. + . + Developers that use our General Public Licenses protect your rights + with two steps: (1) assert copyright on the software, and (2) offer + you this License which gives you legal permission to copy, distribute + and/or modify the software. + . + A secondary benefit of defending all users' freedom is that + improvements made in alternate versions of the program, if they + receive widespread use, become available for other developers to + incorporate. Many developers of free software are heartened and + encouraged by the resulting cooperation. However, in the case of + software used on network servers, this result may fail to come about. + The GNU General Public License permits making a modified version and + letting the public access it on a server without ever releasing its + source code to the public. + . + The GNU Affero General Public License is designed specifically to + ensure that, in such cases, the modified source code becomes available + to the community. It requires the operator of a network server to + provide the source code of the modified version running there to the + users of that server. Therefore, public use of a modified version, on + a publicly accessible server, gives the public access to the source + code of the modified version. + . + An older license, called the Affero General Public License and + published by Affero, was designed to accomplish similar goals. This is + a different license, not a version of the Affero GPL, but Affero has + released a new version of the Affero GPL which permits relicensing under + this license. + . + The precise terms and conditions for copying, distribution and + modification follow. + . + TERMS AND CONDITIONS + . + 0. Definitions. + . + "This License" refers to version 3 of the GNU Affero General Public License. + . + "Copyright" also means copyright-like laws that apply to other kinds of + works, such as semiconductor masks. + . + "The Program" refers to any copyrightable work licensed under this + License. Each licensee is addressed as "you". "Licensees" and + "recipients" may be individuals or organizations. + . + To "modify" a work means to copy from or adapt all or part of the work + in a fashion requiring copyright permission, other than the making of an + exact copy. The resulting work is called a "modified version" of the + earlier work or a work "based on" the earlier work. + . + A "covered work" means either the unmodified Program or a work based + on the Program. + . + To "propagate" a work means to do anything with it that, without + permission, would make you directly or secondarily liable for + infringement under applicable copyright law, except executing it on a + computer or modifying a private copy. Propagation includes copying, + distribution (with or without modification), making available to the + public, and in some countries other activities as well. + . + To "convey" a work means any kind of propagation that enables other + parties to make or receive copies. Mere interaction with a user through + a computer network, with no transfer of a copy, is not conveying. + . + An interactive user interface displays "Appropriate Legal Notices" + to the extent that it includes a convenient and prominently visible + feature that (1) displays an appropriate copyright notice, and (2) + tells the user that there is no warranty for the work (except to the + extent that warranties are provided), that licensees may convey the + work under this License, and how to view a copy of this License. If + the interface presents a list of user commands or options, such as a + menu, a prominent item in the list meets this criterion. + . + 1. Source Code. + . + The "source code" for a work means the preferred form of the work + for making modifications to it. "Object code" means any non-source + form of a work. + . + A "Standard Interface" means an interface that either is an official + standard defined by a recognized standards body, or, in the case of + interfaces specified for a particular programming language, one that + is widely used among developers working in that language. + . + The "System Libraries" of an executable work include anything, other + than the work as a whole, that (a) is included in the normal form of + packaging a Major Component, but which is not part of that Major + Component, and (b) serves only to enable use of the work with that + Major Component, or to implement a Standard Interface for which an + implementation is available to the public in source code form. A + "Major Component", in this context, means a major essential component + (kernel, window system, and so on) of the specific operating system + (if any) on which the executable work runs, or a compiler used to + produce the work, or an object code interpreter used to run it. + . + The "Corresponding Source" for a work in object code form means all + the source code needed to generate, install, and (for an executable + work) run the object code and to modify the work, including scripts to + control those activities. However, it does not include the work's + System Libraries, or general-purpose tools or generally available free + programs which are used unmodified in performing those activities but + which are not part of the work. For example, Corresponding Source + includes interface definition files associated with source files for + the work, and the source code for shared libraries and dynamically + linked subprograms that the work is specifically designed to require, + such as by intimate data communication or control flow between those + subprograms and other parts of the work. + . + The Corresponding Source need not include anything that users + can regenerate automatically from other parts of the Corresponding + Source. + . + The Corresponding Source for a work in source code form is that + same work. + . + 2. Basic Permissions. + . + All rights granted under this License are granted for the term of + copyright on the Program, and are irrevocable provided the stated + conditions are met. This License explicitly affirms your unlimited + permission to run the unmodified Program. The output from running a + covered work is covered by this License only if the output, given its + content, constitutes a covered work. This License acknowledges your + rights of fair use or other equivalent, as provided by copyright law. + . + You may make, run and propagate covered works that you do not + convey, without conditions so long as your license otherwise remains + in force. You may convey covered works to others for the sole purpose + of having them make modifications exclusively for you, or provide you + with facilities for running those works, provided that you comply with + the terms of this License in conveying all material for which you do + not control copyright. Those thus making or running the covered works + for you must do so exclusively on your behalf, under your direction + and control, on terms that prohibit them from making any copies of + your copyrighted material outside their relationship with you. + . + Conveying under any other circumstances is permitted solely under + the conditions stated below. Sublicensing is not allowed; section 10 + makes it unnecessary. + . + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + . + No covered work shall be deemed part of an effective technological + measure under any applicable law fulfilling obligations under article + 11 of the WIPO copyright treaty adopted on 20 December 1996, or + similar laws prohibiting or restricting circumvention of such + measures. + . + When you convey a covered work, you waive any legal power to forbid + circumvention of technological measures to the extent such circumvention + is effected by exercising rights under this License with respect to + the covered work, and you disclaim any intention to limit operation or + modification of the work as a means of enforcing, against the work's + users, your or third parties' legal rights to forbid circumvention of + technological measures. + . + 4. Conveying Verbatim Copies. + . + You may convey verbatim copies of the Program's source code as you + receive it, in any medium, provided that you conspicuously and + appropriately publish on each copy an appropriate copyright notice; + keep intact all notices stating that this License and any + non-permissive terms added in accord with section 7 apply to the code; + keep intact all notices of the absence of any warranty; and give all + recipients a copy of this License along with the Program. + . + You may charge any price or no price for each copy that you convey, + and you may offer support or warranty protection for a fee. + . + 5. Conveying Modified Source Versions. + . + You may convey a work based on the Program, or the modifications to + produce it from the Program, in the form of source code under the + terms of section 4, provided that you also meet all of these conditions: + . + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + . + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + . + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + . + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + . + A compilation of a covered work with other separate and independent + works, which are not by their nature extensions of the covered work, + and which are not combined with it such as to form a larger program, + in or on a volume of a storage or distribution medium, is called an + "aggregate" if the compilation and its resulting copyright are not + used to limit the access or legal rights of the compilation's users + beyond what the individual works permit. Inclusion of a covered work + in an aggregate does not cause this License to apply to the other + parts of the aggregate. + . + 6. Conveying Non-Source Forms. + . + You may convey a covered work in object code form under the terms + of sections 4 and 5, provided that you also convey the + machine-readable Corresponding Source under the terms of this License, + in one of these ways: + . + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + . + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + . + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + . + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + . + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + . + A separable portion of the object code, whose source code is excluded + from the Corresponding Source as a System Library, need not be + included in conveying the object code work. + . + A "User Product" is either (1) a "consumer product", which means any + tangible personal property which is normally used for personal, family, + or household purposes, or (2) anything designed or sold for incorporation + into a dwelling. In determining whether a product is a consumer product, + doubtful cases shall be resolved in favor of coverage. For a particular + product received by a particular user, "normally used" refers to a + typical or common use of that class of product, regardless of the status + of the particular user or of the way in which the particular user + actually uses, or expects or is expected to use, the product. A product + is a consumer product regardless of whether the product has substantial + commercial, industrial or non-consumer uses, unless such uses represent + the only significant mode of use of the product. + . + "Installation Information" for a User Product means any methods, + procedures, authorization keys, or other information required to install + and execute modified versions of a covered work in that User Product from + a modified version of its Corresponding Source. The information must + suffice to ensure that the continued functioning of the modified object + code is in no case prevented or interfered with solely because + modification has been made. + . + If you convey an object code work under this section in, or with, or + specifically for use in, a User Product, and the conveying occurs as + part of a transaction in which the right of possession and use of the + User Product is transferred to the recipient in perpetuity or for a + fixed term (regardless of how the transaction is characterized), the + Corresponding Source conveyed under this section must be accompanied + by the Installation Information. But this requirement does not apply + if neither you nor any third party retains the ability to install + modified object code on the User Product (for example, the work has + been installed in ROM). + . + The requirement to provide Installation Information does not include a + requirement to continue to provide support service, warranty, or updates + for a work that has been modified or installed by the recipient, or for + the User Product in which it has been modified or installed. Access to a + network may be denied when the modification itself materially and + adversely affects the operation of the network or violates the rules and + protocols for communication across the network. + . + Corresponding Source conveyed, and Installation Information provided, + in accord with this section must be in a format that is publicly + documented (and with an implementation available to the public in + source code form), and must require no special password or key for + unpacking, reading or copying. + . + 7. Additional Terms. + . + "Additional permissions" are terms that supplement the terms of this + License by making exceptions from one or more of its conditions. + Additional permissions that are applicable to the entire Program shall + be treated as though they were included in this License, to the extent + that they are valid under applicable law. If additional permissions + apply only to part of the Program, that part may be used separately + under those permissions, but the entire Program remains governed by + this License without regard to the additional permissions. + . + When you convey a copy of a covered work, you may at your option + remove any additional permissions from that copy, or from any part of + it. (Additional permissions may be written to require their own + removal in certain cases when you modify the work.) You may place + additional permissions on material, added by you to a covered work, + for which you have or can give appropriate copyright permission. + . + Notwithstanding any other provision of this License, for material you + add to a covered work, you may (if authorized by the copyright holders of + that material) supplement the terms of this License with terms: + . + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + . + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + . + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + . + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + . + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + . + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + . + All other non-permissive additional terms are considered "further + restrictions" within the meaning of section 10. If the Program as you + received it, or any part of it, contains a notice stating that it is + governed by this License along with a term that is a further + restriction, you may remove that term. If a license document contains + a further restriction but permits relicensing or conveying under this + License, you may add to a covered work material governed by the terms + of that license document, provided that the further restriction does + not survive such relicensing or conveying. + . + If you add terms to a covered work in accord with this section, you + must place, in the relevant source files, a statement of the + additional terms that apply to those files, or a notice indicating + where to find the applicable terms. + . + Additional terms, permissive or non-permissive, may be stated in the + form of a separately written license, or stated as exceptions; + the above requirements apply either way. + . + 8. Termination. + . + You may not propagate or modify a covered work except as expressly + provided under this License. Any attempt otherwise to propagate or + modify it is void, and will automatically terminate your rights under + this License (including any patent licenses granted under the third + paragraph of section 11). + . + However, if you cease all violation of this License, then your + license from a particular copyright holder is reinstated (a) + provisionally, unless and until the copyright holder explicitly and + finally terminates your license, and (b) permanently, if the copyright + holder fails to notify you of the violation by some reasonable means + prior to 60 days after the cessation. + . + Moreover, your license from a particular copyright holder is + reinstated permanently if the copyright holder notifies you of the + violation by some reasonable means, this is the first time you have + received notice of violation of this License (for any work) from that + copyright holder, and you cure the violation prior to 30 days after + your receipt of the notice. + . + Termination of your rights under this section does not terminate the + licenses of parties who have received copies or rights from you under + this License. If your rights have been terminated and not permanently + reinstated, you do not qualify to receive new licenses for the same + material under section 10. + . + 9. Acceptance Not Required for Having Copies. + . + You are not required to accept this License in order to receive or + run a copy of the Program. Ancillary propagation of a covered work + occurring solely as a consequence of using peer-to-peer transmission + to receive a copy likewise does not require acceptance. However, + nothing other than this License grants you permission to propagate or + modify any covered work. These actions infringe copyright if you do + not accept this License. Therefore, by modifying or propagating a + covered work, you indicate your acceptance of this License to do so. + . + 10. Automatic Licensing of Downstream Recipients. + . + Each time you convey a covered work, the recipient automatically + receives a license from the original licensors, to run, modify and + propagate that work, subject to this License. You are not responsible + for enforcing compliance by third parties with this License. + . + An "entity transaction" is a transaction transferring control of an + organization, or substantially all assets of one, or subdividing an + organization, or merging organizations. If propagation of a covered + work results from an entity transaction, each party to that + transaction who receives a copy of the work also receives whatever + licenses to the work the party's predecessor in interest had or could + give under the previous paragraph, plus a right to possession of the + Corresponding Source of the work from the predecessor in interest, if + the predecessor has it or can get it with reasonable efforts. + . + You may not impose any further restrictions on the exercise of the + rights granted or affirmed under this License. For example, you may + not impose a license fee, royalty, or other charge for exercise of + rights granted under this License, and you may not initiate litigation + (including a cross-claim or counterclaim in a lawsuit) alleging that + any patent claim is infringed by making, using, selling, offering for + sale, or importing the Program or any portion of it. + . + 11. Patents. + . + A "contributor" is a copyright holder who authorizes use under this + License of the Program or a work on which the Program is based. The + work thus licensed is called the contributor's "contributor version". + . + A contributor's "essential patent claims" are all patent claims + owned or controlled by the contributor, whether already acquired or + hereafter acquired, that would be infringed by some manner, permitted + by this License, of making, using, or selling its contributor version, + but do not include claims that would be infringed only as a + consequence of further modification of the contributor version. For + purposes of this definition, "control" includes the right to grant + patent sublicenses in a manner consistent with the requirements of + this License. + . + Each contributor grants you a non-exclusive, worldwide, royalty-free + patent license under the contributor's essential patent claims, to + make, use, sell, offer for sale, import and otherwise run, modify and + propagate the contents of its contributor version. + . + In the following three paragraphs, a "patent license" is any express + agreement or commitment, however denominated, not to enforce a patent + (such as an express permission to practice a patent or covenant not to + sue for patent infringement). To "grant" such a patent license to a + party means to make such an agreement or commitment not to enforce a + patent against the party. + . + If you convey a covered work, knowingly relying on a patent license, + and the Corresponding Source of the work is not available for anyone + to copy, free of charge and under the terms of this License, through a + publicly available network server or other readily accessible means, + then you must either (1) cause the Corresponding Source to be so + available, or (2) arrange to deprive yourself of the benefit of the + patent license for this particular work, or (3) arrange, in a manner + consistent with the requirements of this License, to extend the patent + license to downstream recipients. "Knowingly relying" means you have + actual knowledge that, but for the patent license, your conveying the + covered work in a country, or your recipient's use of the covered work + in a country, would infringe one or more identifiable patents in that + country that you have reason to believe are valid. + . + If, pursuant to or in connection with a single transaction or + arrangement, you convey, or propagate by procuring conveyance of, a + covered work, and grant a patent license to some of the parties + receiving the covered work authorizing them to use, propagate, modify + or convey a specific copy of the covered work, then the patent license + you grant is automatically extended to all recipients of the covered + work and works based on it. + . + A patent license is "discriminatory" if it does not include within + the scope of its coverage, prohibits the exercise of, or is + conditioned on the non-exercise of one or more of the rights that are + specifically granted under this License. You may not convey a covered + work if you are a party to an arrangement with a third party that is + in the business of distributing software, under which you make payment + to the third party based on the extent of your activity of conveying + the work, and under which the third party grants, to any of the + parties who would receive the covered work from you, a discriminatory + patent license (a) in connection with copies of the covered work + conveyed by you (or copies made from those copies), or (b) primarily + for and in connection with specific products or compilations that + contain the covered work, unless you entered into that arrangement, + or that patent license was granted, prior to 28 March 2007. + . + Nothing in this License shall be construed as excluding or limiting + any implied license or other defenses to infringement that may + otherwise be available to you under applicable patent law. + . + 12. No Surrender of Others' Freedom. + . + If conditions are imposed on you (whether by court order, agreement or + otherwise) that contradict the conditions of this License, they do not + excuse you from the conditions of this License. If you cannot convey a + covered work so as to satisfy simultaneously your obligations under this + License and any other pertinent obligations, then as a consequence you may + not convey it at all. For example, if you agree to terms that obligate you + to collect a royalty for further conveying from those to whom you convey + the Program, the only way you could satisfy both those terms and this + License would be to refrain entirely from conveying the Program. + . + 13. Remote Network Interaction; Use with the GNU General Public License. + . + Notwithstanding any other provision of this License, if you modify the + Program, your modified version must prominently offer all users + interacting with it remotely through a computer network (if your version + supports such interaction) an opportunity to receive the Corresponding + Source of your version by providing access to the Corresponding Source + from a network server at no charge, through some standard or customary + means of facilitating copying of software. This Corresponding Source + shall include the Corresponding Source for any work covered by version 3 + of the GNU General Public License that is incorporated pursuant to the + following paragraph. + . + Notwithstanding any other provision of this License, you have + permission to link or combine any covered work with a work licensed + under version 3 of the GNU General Public License into a single + combined work, and to convey the resulting work. The terms of this + License will continue to apply to the part which is the covered work, + but the work with which it is combined will remain governed by version + 3 of the GNU General Public License. + . + 14. Revised Versions of this License. + . + The Free Software Foundation may publish revised and/or new versions of + the GNU Affero General Public License from time to time. Such new versions + will be similar in spirit to the present version, but may differ in detail to + address new problems or concerns. + . + Each version is given a distinguishing version number. If the + Program specifies that a certain numbered version of the GNU Affero General + Public License "or any later version" applies to it, you have the + option of following the terms and conditions either of that numbered + version or of any later version published by the Free Software + Foundation. If the Program does not specify a version number of the + GNU Affero General Public License, you may choose any version ever published + by the Free Software Foundation. + . + If the Program specifies that a proxy can decide which future + versions of the GNU Affero General Public License can be used, that proxy's + public statement of acceptance of a version permanently authorizes you + to choose that version for the Program. + . + Later license versions may give you additional or different + permissions. However, no additional obligations are imposed on any + author or copyright holder as a result of your choosing to follow a + later version. + . + 15. Disclaimer of Warranty. + . + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY + APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT + HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY + OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, + THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR + PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM + IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF + ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + . + 16. Limitation of Liability. + . + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING + WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS + THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY + GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE + USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF + DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD + PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), + EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF + SUCH DAMAGES. + . + 17. Interpretation of Sections 15 and 16. + . + If the disclaimer of warranty and limitation of liability provided + above cannot be given local legal effect according to their terms, + reviewing courts shall apply local law that most closely approximates + an absolute waiver of all civil liability in connection with the + Program, unless a warranty or assumption of liability accompanies a + copy of the Program in return for a fee. + . + END OF TERMS AND CONDITIONS + . + How to Apply These Terms to Your New Programs + . + If you develop a new program, and you want it to be of the greatest + possible use to the public, the best way to achieve this is to make it + free software which everyone can redistribute and change under these terms. + . + To do so, attach the following notices to the program. It is safest + to attach them to the start of each source file to most effectively + state the exclusion of warranty; and each file should have at least + the "copyright" line and a pointer to where the full notice is found. + . + + Copyright (C) + . + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + . + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + . + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . + . + Also add information on how to contact you by electronic and paper mail. + . + If your software can interact with users remotely through a computer + network, you should also make sure that it provides a way for users to + get its source. For example, if your program is a web application, its + interface could display a "Source" link that leads users to an archive + of the code. There are many ways you could offer source, and different + solutions will be better for different programs; see section 13 for the + specific requirements. + . + You should also get your employer (if you work as a programmer) or school, + if any, to sign a "copyright disclaimer" for the program, if necessary. + For more information on this, and how to apply and follow the GNU AGPL, see + . diff --git a/Common.hs b/Common.hs index c1890e6..6bd2e7a 100644 --- a/Common.hs +++ b/Common.hs @@ -18,6 +18,7 @@ import System.IO as X hiding (FilePath) import System.Posix.IO as X hiding (createPipe) #endif import System.Exit as X +import System.PosixCompat.Files as X import Utility.Misc as X import Utility.Exception as X @@ -28,8 +29,8 @@ import Utility.Directory as X import Utility.Monad as X import Utility.Data as X import Utility.Applicative as X -import Utility.PosixFiles as X hiding (fileSize) import Utility.FileSize as X import Utility.Split as X +import Utility.FileSystemEncoding as X import Utility.PartialPrelude as X diff --git a/GPL b/GPL deleted file mode 100644 index 94a9ed0..0000000 --- a/GPL +++ /dev/null @@ -1,674 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 3, 29 June 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The GNU General Public License is a free, copyleft license for -software and other kinds of works. - - The licenses for most software and other practical works are designed -to take away your freedom to share and change the works. By contrast, -the GNU General Public License is intended to guarantee your freedom to -share and change all versions of a program--to make sure it remains free -software for all its users. We, the Free Software Foundation, use the -GNU General Public License for most of our software; it applies also to -any other work released this way by its authors. You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -them if you wish), that you receive source code or can get it if you -want it, that you can change the software or use pieces of it in new -free programs, and that you know you can do these things. - - To protect your rights, we need to prevent others from denying you -these rights or asking you to surrender the rights. Therefore, you have -certain responsibilities if you distribute copies of the software, or if -you modify it: responsibilities to respect the freedom of others. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must pass on to the recipients the same -freedoms that you received. You must make sure that they, too, receive -or can get the source code. And you must show them these terms so they -know their rights. - - Developers that use the GNU GPL protect your rights with two steps: -(1) assert copyright on the software, and (2) offer you this License -giving you legal permission to copy, distribute and/or modify it. - - For the developers' and authors' protection, the GPL clearly explains -that there is no warranty for this free software. For both users' and -authors' sake, the GPL requires that modified versions be marked as -changed, so that their problems will not be attributed erroneously to -authors of previous versions. - - Some devices are designed to deny users access to install or run -modified versions of the software inside them, although the manufacturer -can do so. This is fundamentally incompatible with the aim of -protecting users' freedom to change the software. The systematic -pattern of such abuse occurs in the area of products for individuals to -use, which is precisely where it is most unacceptable. Therefore, we -have designed this version of the GPL to prohibit the practice for those -products. If such problems arise substantially in other domains, we -stand ready to extend this provision to those domains in future versions -of the GPL, as needed to protect the freedom of users. - - Finally, every program is threatened constantly by software patents. -States should not allow patents to restrict development and use of -software on general-purpose computers, but in those that do, we wish to -avoid the special danger that patents applied to a free program could -make it effectively proprietary. To prevent this, the GPL assures that -patents cannot be used to render the program non-free. - - The precise terms and conditions for copying, distribution and -modification follow. - - TERMS AND CONDITIONS - - 0. Definitions. - - "This License" refers to version 3 of the GNU General Public License. - - "Copyright" also means copyright-like laws that apply to other kinds of -works, such as semiconductor masks. - - "The Program" refers to any copyrightable work licensed under this -License. Each licensee is addressed as "you". "Licensees" and -"recipients" may be individuals or organizations. - - To "modify" a work means to copy from or adapt all or part of the work -in a fashion requiring copyright permission, other than the making of an -exact copy. The resulting work is called a "modified version" of the -earlier work or a work "based on" the earlier work. - - A "covered work" means either the unmodified Program or a work based -on the Program. - - To "propagate" a work means to do anything with it that, without -permission, would make you directly or secondarily liable for -infringement under applicable copyright law, except executing it on a -computer or modifying a private copy. Propagation includes copying, -distribution (with or without modification), making available to the -public, and in some countries other activities as well. - - To "convey" a work means any kind of propagation that enables other -parties to make or receive copies. Mere interaction with a user through -a computer network, with no transfer of a copy, is not conveying. - - An interactive user interface displays "Appropriate Legal Notices" -to the extent that it includes a convenient and prominently visible -feature that (1) displays an appropriate copyright notice, and (2) -tells the user that there is no warranty for the work (except to the -extent that warranties are provided), that licensees may convey the -work under this License, and how to view a copy of this License. If -the interface presents a list of user commands or options, such as a -menu, a prominent item in the list meets this criterion. - - 1. Source Code. - - The "source code" for a work means the preferred form of the work -for making modifications to it. "Object code" means any non-source -form of a work. - - A "Standard Interface" means an interface that either is an official -standard defined by a recognized standards body, or, in the case of -interfaces specified for a particular programming language, one that -is widely used among developers working in that language. - - The "System Libraries" of an executable work include anything, other -than the work as a whole, that (a) is included in the normal form of -packaging a Major Component, but which is not part of that Major -Component, and (b) serves only to enable use of the work with that -Major Component, or to implement a Standard Interface for which an -implementation is available to the public in source code form. A -"Major Component", in this context, means a major essential component -(kernel, window system, and so on) of the specific operating system -(if any) on which the executable work runs, or a compiler used to -produce the work, or an object code interpreter used to run it. - - The "Corresponding Source" for a work in object code form means all -the source code needed to generate, install, and (for an executable -work) run the object code and to modify the work, including scripts to -control those activities. However, it does not include the work's -System Libraries, or general-purpose tools or generally available free -programs which are used unmodified in performing those activities but -which are not part of the work. For example, Corresponding Source -includes interface definition files associated with source files for -the work, and the source code for shared libraries and dynamically -linked subprograms that the work is specifically designed to require, -such as by intimate data communication or control flow between those -subprograms and other parts of the work. - - The Corresponding Source need not include anything that users -can regenerate automatically from other parts of the Corresponding -Source. - - The Corresponding Source for a work in source code form is that -same work. - - 2. Basic Permissions. - - All rights granted under this License are granted for the term of -copyright on the Program, and are irrevocable provided the stated -conditions are met. This License explicitly affirms your unlimited -permission to run the unmodified Program. The output from running a -covered work is covered by this License only if the output, given its -content, constitutes a covered work. This License acknowledges your -rights of fair use or other equivalent, as provided by copyright law. - - You may make, run and propagate covered works that you do not -convey, without conditions so long as your license otherwise remains -in force. You may convey covered works to others for the sole purpose -of having them make modifications exclusively for you, or provide you -with facilities for running those works, provided that you comply with -the terms of this License in conveying all material for which you do -not control copyright. Those thus making or running the covered works -for you must do so exclusively on your behalf, under your direction -and control, on terms that prohibit them from making any copies of -your copyrighted material outside their relationship with you. - - Conveying under any other circumstances is permitted solely under -the conditions stated below. Sublicensing is not allowed; section 10 -makes it unnecessary. - - 3. Protecting Users' Legal Rights From Anti-Circumvention Law. - - No covered work shall be deemed part of an effective technological -measure under any applicable law fulfilling obligations under article -11 of the WIPO copyright treaty adopted on 20 December 1996, or -similar laws prohibiting or restricting circumvention of such -measures. - - When you convey a covered work, you waive any legal power to forbid -circumvention of technological measures to the extent such circumvention -is effected by exercising rights under this License with respect to -the covered work, and you disclaim any intention to limit operation or -modification of the work as a means of enforcing, against the work's -users, your or third parties' legal rights to forbid circumvention of -technological measures. - - 4. Conveying Verbatim Copies. - - You may convey verbatim copies of the Program's source code as you -receive it, in any medium, provided that you conspicuously and -appropriately publish on each copy an appropriate copyright notice; -keep intact all notices stating that this License and any -non-permissive terms added in accord with section 7 apply to the code; -keep intact all notices of the absence of any warranty; and give all -recipients a copy of this License along with the Program. - - You may charge any price or no price for each copy that you convey, -and you may offer support or warranty protection for a fee. - - 5. Conveying Modified Source Versions. - - You may convey a work based on the Program, or the modifications to -produce it from the Program, in the form of source code under the -terms of section 4, provided that you also meet all of these conditions: - - a) The work must carry prominent notices stating that you modified - it, and giving a relevant date. - - b) The work must carry prominent notices stating that it is - released under this License and any conditions added under section - 7. This requirement modifies the requirement in section 4 to - "keep intact all notices". - - c) You must license the entire work, as a whole, under this - License to anyone who comes into possession of a copy. This - License will therefore apply, along with any applicable section 7 - additional terms, to the whole of the work, and all its parts, - regardless of how they are packaged. This License gives no - permission to license the work in any other way, but it does not - invalidate such permission if you have separately received it. - - d) If the work has interactive user interfaces, each must display - Appropriate Legal Notices; however, if the Program has interactive - interfaces that do not display Appropriate Legal Notices, your - work need not make them do so. - - A compilation of a covered work with other separate and independent -works, which are not by their nature extensions of the covered work, -and which are not combined with it such as to form a larger program, -in or on a volume of a storage or distribution medium, is called an -"aggregate" if the compilation and its resulting copyright are not -used to limit the access or legal rights of the compilation's users -beyond what the individual works permit. Inclusion of a covered work -in an aggregate does not cause this License to apply to the other -parts of the aggregate. - - 6. Conveying Non-Source Forms. - - You may convey a covered work in object code form under the terms -of sections 4 and 5, provided that you also convey the -machine-readable Corresponding Source under the terms of this License, -in one of these ways: - - a) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by the - Corresponding Source fixed on a durable physical medium - customarily used for software interchange. - - b) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by a - written offer, valid for at least three years and valid for as - long as you offer spare parts or customer support for that product - model, to give anyone who possesses the object code either (1) a - copy of the Corresponding Source for all the software in the - product that is covered by this License, on a durable physical - medium customarily used for software interchange, for a price no - more than your reasonable cost of physically performing this - conveying of source, or (2) access to copy the - Corresponding Source from a network server at no charge. - - c) Convey individual copies of the object code with a copy of the - written offer to provide the Corresponding Source. This - alternative is allowed only occasionally and noncommercially, and - only if you received the object code with such an offer, in accord - with subsection 6b. - - d) Convey the object code by offering access from a designated - place (gratis or for a charge), and offer equivalent access to the - Corresponding Source in the same way through the same place at no - further charge. You need not require recipients to copy the - Corresponding Source along with the object code. If the place to - copy the object code is a network server, the Corresponding Source - may be on a different server (operated by you or a third party) - that supports equivalent copying facilities, provided you maintain - clear directions next to the object code saying where to find the - Corresponding Source. Regardless of what server hosts the - Corresponding Source, you remain obligated to ensure that it is - available for as long as needed to satisfy these requirements. - - e) Convey the object code using peer-to-peer transmission, provided - you inform other peers where the object code and Corresponding - Source of the work are being offered to the general public at no - charge under subsection 6d. - - A separable portion of the object code, whose source code is excluded -from the Corresponding Source as a System Library, need not be -included in conveying the object code work. - - A "User Product" is either (1) a "consumer product", which means any -tangible personal property which is normally used for personal, family, -or household purposes, or (2) anything designed or sold for incorporation -into a dwelling. In determining whether a product is a consumer product, -doubtful cases shall be resolved in favor of coverage. For a particular -product received by a particular user, "normally used" refers to a -typical or common use of that class of product, regardless of the status -of the particular user or of the way in which the particular user -actually uses, or expects or is expected to use, the product. A product -is a consumer product regardless of whether the product has substantial -commercial, industrial or non-consumer uses, unless such uses represent -the only significant mode of use of the product. - - "Installation Information" for a User Product means any methods, -procedures, authorization keys, or other information required to install -and execute modified versions of a covered work in that User Product from -a modified version of its Corresponding Source. The information must -suffice to ensure that the continued functioning of the modified object -code is in no case prevented or interfered with solely because -modification has been made. - - If you convey an object code work under this section in, or with, or -specifically for use in, a User Product, and the conveying occurs as -part of a transaction in which the right of possession and use of the -User Product is transferred to the recipient in perpetuity or for a -fixed term (regardless of how the transaction is characterized), the -Corresponding Source conveyed under this section must be accompanied -by the Installation Information. But this requirement does not apply -if neither you nor any third party retains the ability to install -modified object code on the User Product (for example, the work has -been installed in ROM). - - The requirement to provide Installation Information does not include a -requirement to continue to provide support service, warranty, or updates -for a work that has been modified or installed by the recipient, or for -the User Product in which it has been modified or installed. Access to a -network may be denied when the modification itself materially and -adversely affects the operation of the network or violates the rules and -protocols for communication across the network. - - Corresponding Source conveyed, and Installation Information provided, -in accord with this section must be in a format that is publicly -documented (and with an implementation available to the public in -source code form), and must require no special password or key for -unpacking, reading or copying. - - 7. Additional Terms. - - "Additional permissions" are terms that supplement the terms of this -License by making exceptions from one or more of its conditions. -Additional permissions that are applicable to the entire Program shall -be treated as though they were included in this License, to the extent -that they are valid under applicable law. If additional permissions -apply only to part of the Program, that part may be used separately -under those permissions, but the entire Program remains governed by -this License without regard to the additional permissions. - - When you convey a copy of a covered work, you may at your option -remove any additional permissions from that copy, or from any part of -it. (Additional permissions may be written to require their own -removal in certain cases when you modify the work.) You may place -additional permissions on material, added by you to a covered work, -for which you have or can give appropriate copyright permission. - - Notwithstanding any other provision of this License, for material you -add to a covered work, you may (if authorized by the copyright holders of -that material) supplement the terms of this License with terms: - - a) Disclaiming warranty or limiting liability differently from the - terms of sections 15 and 16 of this License; or - - b) Requiring preservation of specified reasonable legal notices or - author attributions in that material or in the Appropriate Legal - Notices displayed by works containing it; or - - c) Prohibiting misrepresentation of the origin of that material, or - requiring that modified versions of such material be marked in - reasonable ways as different from the original version; or - - d) Limiting the use for publicity purposes of names of licensors or - authors of the material; or - - e) Declining to grant rights under trademark law for use of some - trade names, trademarks, or service marks; or - - f) Requiring indemnification of licensors and authors of that - material by anyone who conveys the material (or modified versions of - it) with contractual assumptions of liability to the recipient, for - any liability that these contractual assumptions directly impose on - those licensors and authors. - - All other non-permissive additional terms are considered "further -restrictions" within the meaning of section 10. If the Program as you -received it, or any part of it, contains a notice stating that it is -governed by this License along with a term that is a further -restriction, you may remove that term. If a license document contains -a further restriction but permits relicensing or conveying under this -License, you may add to a covered work material governed by the terms -of that license document, provided that the further restriction does -not survive such relicensing or conveying. - - If you add terms to a covered work in accord with this section, you -must place, in the relevant source files, a statement of the -additional terms that apply to those files, or a notice indicating -where to find the applicable terms. - - Additional terms, permissive or non-permissive, may be stated in the -form of a separately written license, or stated as exceptions; -the above requirements apply either way. - - 8. Termination. - - You may not propagate or modify a covered work except as expressly -provided under this License. Any attempt otherwise to propagate or -modify it is void, and will automatically terminate your rights under -this License (including any patent licenses granted under the third -paragraph of section 11). - - However, if you cease all violation of this License, then your -license from a particular copyright holder is reinstated (a) -provisionally, unless and until the copyright holder explicitly and -finally terminates your license, and (b) permanently, if the copyright -holder fails to notify you of the violation by some reasonable means -prior to 60 days after the cessation. - - Moreover, your license from a particular copyright holder is -reinstated permanently if the copyright holder notifies you of the -violation by some reasonable means, this is the first time you have -received notice of violation of this License (for any work) from that -copyright holder, and you cure the violation prior to 30 days after -your receipt of the notice. - - Termination of your rights under this section does not terminate the -licenses of parties who have received copies or rights from you under -this License. If your rights have been terminated and not permanently -reinstated, you do not qualify to receive new licenses for the same -material under section 10. - - 9. Acceptance Not Required for Having Copies. - - You are not required to accept this License in order to receive or -run a copy of the Program. Ancillary propagation of a covered work -occurring solely as a consequence of using peer-to-peer transmission -to receive a copy likewise does not require acceptance. However, -nothing other than this License grants you permission to propagate or -modify any covered work. These actions infringe copyright if you do -not accept this License. Therefore, by modifying or propagating a -covered work, you indicate your acceptance of this License to do so. - - 10. Automatic Licensing of Downstream Recipients. - - Each time you convey a covered work, the recipient automatically -receives a license from the original licensors, to run, modify and -propagate that work, subject to this License. You are not responsible -for enforcing compliance by third parties with this License. - - An "entity transaction" is a transaction transferring control of an -organization, or substantially all assets of one, or subdividing an -organization, or merging organizations. If propagation of a covered -work results from an entity transaction, each party to that -transaction who receives a copy of the work also receives whatever -licenses to the work the party's predecessor in interest had or could -give under the previous paragraph, plus a right to possession of the -Corresponding Source of the work from the predecessor in interest, if -the predecessor has it or can get it with reasonable efforts. - - You may not impose any further restrictions on the exercise of the -rights granted or affirmed under this License. For example, you may -not impose a license fee, royalty, or other charge for exercise of -rights granted under this License, and you may not initiate litigation -(including a cross-claim or counterclaim in a lawsuit) alleging that -any patent claim is infringed by making, using, selling, offering for -sale, or importing the Program or any portion of it. - - 11. Patents. - - A "contributor" is a copyright holder who authorizes use under this -License of the Program or a work on which the Program is based. The -work thus licensed is called the contributor's "contributor version". - - A contributor's "essential patent claims" are all patent claims -owned or controlled by the contributor, whether already acquired or -hereafter acquired, that would be infringed by some manner, permitted -by this License, of making, using, or selling its contributor version, -but do not include claims that would be infringed only as a -consequence of further modification of the contributor version. For -purposes of this definition, "control" includes the right to grant -patent sublicenses in a manner consistent with the requirements of -this License. - - Each contributor grants you a non-exclusive, worldwide, royalty-free -patent license under the contributor's essential patent claims, to -make, use, sell, offer for sale, import and otherwise run, modify and -propagate the contents of its contributor version. - - In the following three paragraphs, a "patent license" is any express -agreement or commitment, however denominated, not to enforce a patent -(such as an express permission to practice a patent or covenant not to -sue for patent infringement). To "grant" such a patent license to a -party means to make such an agreement or commitment not to enforce a -patent against the party. - - If you convey a covered work, knowingly relying on a patent license, -and the Corresponding Source of the work is not available for anyone -to copy, free of charge and under the terms of this License, through a -publicly available network server or other readily accessible means, -then you must either (1) cause the Corresponding Source to be so -available, or (2) arrange to deprive yourself of the benefit of the -patent license for this particular work, or (3) arrange, in a manner -consistent with the requirements of this License, to extend the patent -license to downstream recipients. "Knowingly relying" means you have -actual knowledge that, but for the patent license, your conveying the -covered work in a country, or your recipient's use of the covered work -in a country, would infringe one or more identifiable patents in that -country that you have reason to believe are valid. - - If, pursuant to or in connection with a single transaction or -arrangement, you convey, or propagate by procuring conveyance of, a -covered work, and grant a patent license to some of the parties -receiving the covered work authorizing them to use, propagate, modify -or convey a specific copy of the covered work, then the patent license -you grant is automatically extended to all recipients of the covered -work and works based on it. - - A patent license is "discriminatory" if it does not include within -the scope of its coverage, prohibits the exercise of, or is -conditioned on the non-exercise of one or more of the rights that are -specifically granted under this License. You may not convey a covered -work if you are a party to an arrangement with a third party that is -in the business of distributing software, under which you make payment -to the third party based on the extent of your activity of conveying -the work, and under which the third party grants, to any of the -parties who would receive the covered work from you, a discriminatory -patent license (a) in connection with copies of the covered work -conveyed by you (or copies made from those copies), or (b) primarily -for and in connection with specific products or compilations that -contain the covered work, unless you entered into that arrangement, -or that patent license was granted, prior to 28 March 2007. - - Nothing in this License shall be construed as excluding or limiting -any implied license or other defenses to infringement that may -otherwise be available to you under applicable patent law. - - 12. No Surrender of Others' Freedom. - - If conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot convey a -covered work so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you may -not convey it at all. For example, if you agree to terms that obligate you -to collect a royalty for further conveying from those to whom you convey -the Program, the only way you could satisfy both those terms and this -License would be to refrain entirely from conveying the Program. - - 13. Use with the GNU Affero General Public License. - - Notwithstanding any other provision of this License, you have -permission to link or combine any covered work with a work licensed -under version 3 of the GNU Affero General Public License into a single -combined work, and to convey the resulting work. The terms of this -License will continue to apply to the part which is the covered work, -but the special requirements of the GNU Affero General Public License, -section 13, concerning interaction through a network will apply to the -combination as such. - - 14. Revised Versions of this License. - - The Free Software Foundation may publish revised and/or new versions of -the GNU General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - - Each version is given a distinguishing version number. If the -Program specifies that a certain numbered version of the GNU General -Public License "or any later version" applies to it, you have the -option of following the terms and conditions either of that numbered -version or of any later version published by the Free Software -Foundation. If the Program does not specify a version number of the -GNU General Public License, you may choose any version ever published -by the Free Software Foundation. - - If the Program specifies that a proxy can decide which future -versions of the GNU General Public License can be used, that proxy's -public statement of acceptance of a version permanently authorizes you -to choose that version for the Program. - - Later license versions may give you additional or different -permissions. However, no additional obligations are imposed on any -author or copyright holder as a result of your choosing to follow a -later version. - - 15. Disclaimer of Warranty. - - THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY -APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT -HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY -OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, -THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM -IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF -ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. Limitation of Liability. - - IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS -THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY -GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE -USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF -DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD -PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), -EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF -SUCH DAMAGES. - - 17. Interpretation of Sections 15 and 16. - - If the disclaimer of warranty and limitation of liability provided -above cannot be given local legal effect according to their terms, -reviewing courts shall apply local law that most closely approximates -an absolute waiver of all civil liability in connection with the -Program, unless a warranty or assumption of liability accompanies a -copy of the Program in return for a fee. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -state the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . - -Also add information on how to contact you by electronic and paper mail. - - If the program does terminal interaction, make it output a short -notice like this when it starts in an interactive mode: - - Copyright (C) - This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, your program's commands -might be different; for a GUI interface, you would use an "about box". - - You should also get your employer (if you work as a programmer) or school, -if any, to sign a "copyright disclaimer" for the program, if necessary. -For more information on this, and how to apply and follow the GNU GPL, see -. - - The GNU General Public License does not permit incorporating your program -into proprietary programs. If your program is a subroutine library, you -may consider it more useful to permit linking proprietary applications with -the library. If this is what you want to do, use the GNU Lesser General -Public License instead of this License. But first, please read -. diff --git a/Git.hs b/Git.hs index b350515..87a8d19 100644 --- a/Git.hs +++ b/Git.hs @@ -5,7 +5,7 @@ - - Copyright 2010-2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -51,35 +51,35 @@ import Utility.FileMode repoDescribe :: Repo -> String repoDescribe Repo { remoteName = Just name } = name repoDescribe Repo { location = Url url } = show url -repoDescribe Repo { location = Local { worktree = Just dir } } = dir -repoDescribe Repo { location = Local { gitdir = dir } } = dir -repoDescribe Repo { location = LocalUnknown dir } = dir +repoDescribe Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir +repoDescribe Repo { location = Local { gitdir = dir } } = fromRawFilePath dir +repoDescribe Repo { location = LocalUnknown dir } = fromRawFilePath dir repoDescribe Repo { location = Unknown } = "UNKNOWN" {- Location of the repo, either as a path or url. -} repoLocation :: Repo -> String repoLocation Repo { location = Url url } = show url -repoLocation Repo { location = Local { worktree = Just dir } } = dir -repoLocation Repo { location = Local { gitdir = dir } } = dir -repoLocation Repo { location = LocalUnknown dir } = dir +repoLocation Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir +repoLocation Repo { location = Local { gitdir = dir } } = fromRawFilePath dir +repoLocation Repo { location = LocalUnknown dir } = fromRawFilePath dir 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 - host. -} -repoPath :: Repo -> FilePath -repoPath Repo { location = Url u } = unEscapeString $ uriPath u +repoPath :: Repo -> RawFilePath +repoPath Repo { location = Url u } = toRawFilePath $ unEscapeString $ uriPath u 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 } = error "unknown repoPath" -repoWorkTree :: Repo -> Maybe FilePath +repoWorkTree :: Repo -> Maybe RawFilePath repoWorkTree Repo { location = Local { worktree = Just d } } = Just d repoWorkTree _ = Nothing {- Path to a local repository's .git directory. -} -localGitDir :: Repo -> FilePath +localGitDir :: Repo -> RawFilePath localGitDir Repo { location = Local { gitdir = d } } = d localGitDir _ = error "unknown localGitDir" @@ -132,16 +132,17 @@ assertLocal repo action attributes :: Repo -> FilePath attributes repo | repoIsLocalBare repo = attributesLocal repo - | otherwise = repoPath repo ".gitattributes" + | otherwise = fromRawFilePath (repoPath repo) ".gitattributes" attributesLocal :: Repo -> FilePath -attributesLocal repo = localGitDir repo "info" "attributes" +attributesLocal repo = fromRawFilePath (localGitDir repo) + "info" "attributes" {- Path to a given hook script in a repository, only if the hook exists - and is executable. -} hookPath :: String -> Repo -> IO (Maybe FilePath) hookPath script repo = do - let hook = localGitDir repo "hooks" script + let hook = fromRawFilePath (localGitDir repo) "hooks" script ifM (catchBoolIO $ isexecutable hook) ( return $ Just hook , return Nothing ) where @@ -157,22 +158,22 @@ relPath = adjustPath torel where torel p = do p' <- relPathCwdToFile p - if null p' - then return "." - else return p' + return $ if null p' then "." else 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 + d' <- f' d + w' <- maybe (pure Nothing) (Just <$$> f') w return $ r { location = l { gitdir = d' , worktree = w' } } + where + f' v = toRawFilePath <$> f (fromRawFilePath v) adjustPath f r@(Repo { location = LocalUnknown d }) = do - d' <- f d + d' <- toRawFilePath <$> f (fromRawFilePath d) return $ r { location = LocalUnknown d' } adjustPath _ r = pure r diff --git a/Git/Branch.hs b/Git/Branch.hs index 875f20f..699fbf5 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -2,10 +2,11 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} module Git.Branch where @@ -15,13 +16,14 @@ import Git.Sha import Git.Command import qualified Git.Config import qualified Git.Ref -import qualified Git.BuildVersion + +import qualified Data.ByteString as B {- The currently checked out branch. - - In a just initialized git repo before the first commit, - symbolic-ref will show the master branch, even though that - - branch is not created yet. So, this also looks at show-ref HEAD + - branch is not created yet. So, this also looks at show-ref - to double-check. -} current :: Repo -> IO (Maybe Branch) @@ -30,19 +32,19 @@ current r = do case v of Nothing -> return Nothing Just branch -> - ifM (null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r) + ifM (B.null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r) ( return Nothing , return v ) {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Branch) -currentUnsafe r = parse . firstLine +currentUnsafe r = parse . firstLine' <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r where - parse l - | null l = Nothing - | otherwise = Just $ Git.Ref l + parse b + | B.null b = Nothing + | otherwise = Just $ Git.Ref $ decodeBS b {- Checks if the second branch has any commits not present on the first - branch. -} @@ -54,7 +56,8 @@ changed origbranch newbranch repo where changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String -changed' origbranch newbranch extraps repo = pipeReadStrict ps repo +changed' origbranch newbranch extraps repo = + decodeBS <$> pipeReadStrict ps repo where ps = [ Param "log" @@ -73,7 +76,7 @@ changedCommits origbranch newbranch extraps repo = - - This requires there to be a path from the old to the new. -} fastForwardable :: Ref -> Ref -> Repo -> IO Bool -fastForwardable old new repo = not . null <$> +fastForwardable old new repo = not . B.null <$> pipeReadStrict [ Param "log" , Param $ fromRef old ++ ".." ++ fromRef new @@ -125,8 +128,7 @@ data CommitMode = ManualCommit | AutomaticCommit {- Prevent signing automatic commits. -} applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam] applyCommitMode commitmode ps - | commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") = - Param "--no-gpg-sign" : ps + | commitmode == AutomaticCommit = Param "--no-gpg-sign" : ps | otherwise = ps {- Some versions of git commit-tree honor commit.gpgsign themselves, @@ -134,8 +136,8 @@ applyCommitMode commitmode ps applyCommitModeForCommitTree :: CommitMode -> [CommandParam] -> Repo -> [CommandParam] applyCommitModeForCommitTree commitmode ps r | commitmode == ManualCommit = - case (Git.Config.getMaybe "commit.gpgsign" r) of - Just s | Git.Config.isTrue s == Just True -> + case Git.Config.getMaybe "commit.gpgsign" r of + Just s | Git.Config.isTrueFalse' s == Just True -> Param "-S":ps _ -> ps' | otherwise = ps' @@ -162,7 +164,7 @@ commitCommand' runner commitmode ps = runner $ commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha) commit commitmode allowempty message branch parentrefs repo = do tree <- getSha "write-tree" $ - pipeReadStrict [Param "write-tree"] repo + decodeBS' <$> pipeReadStrict [Param "write-tree"] repo ifM (cancommit tree) ( do sha <- commitTree commitmode message parentrefs tree repo diff --git a/Git/BuildVersion.hs b/Git/BuildVersion.hs index 7d1c53a..f94a892 100644 --- a/Git/BuildVersion.hs +++ b/Git/BuildVersion.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.BuildVersion where diff --git a/Git/CatFile.hs b/Git/CatFile.hs index ba68c4e..6402001 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -1,8 +1,8 @@ {- git cat-file interface - - - Copyright 2011-2016 Joey Hess + - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.CatFile ( @@ -28,20 +28,23 @@ import Data.String import Data.Char import Numeric import System.Posix.Types +import Text.Read import Common import Git import Git.Sha +import qualified Git.Ref import Git.Command import Git.Types import Git.FilePath +import Git.HashObject import qualified Utility.CoProcess as CoProcess -import Utility.FileSystemEncoding import Utility.Tuple data CatFileHandle = CatFileHandle { catFileProcess :: CoProcess.CoProcessHandle , checkFileProcess :: CoProcess.CoProcessHandle + , gitRepo :: Repo } catFileStart :: Repo -> IO CatFileHandle @@ -51,6 +54,7 @@ catFileStart' :: Bool -> Repo -> IO CatFileHandle catFileStart' restartable repo = CatFileHandle <$> startp "--batch" <*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)" + <*> pure repo where startp p = gitCoProcessStart restartable [ Param "cat-file" @@ -63,13 +67,13 @@ catFileStop h = do CoProcess.stop (checkFileProcess h) {- Reads a file from a specified branch. -} -catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString +catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString catFile h branch file = catObject h $ Ref $ - fromRef branch ++ ":" ++ toInternalGitPath file + fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file) -catFileDetails :: CatFileHandle -> Branch -> FilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) +catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) catFileDetails h branch file = catObjectDetails h $ Ref $ - fromRef branch ++ ":" ++ toInternalGitPath file + fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file) {- Uses a running git cat-file read the content of an object. - Objects that do not exist will have "" returned. -} @@ -77,7 +81,7 @@ catObject :: CatFileHandle -> Ref -> IO L.ByteString catObject h object = maybe L.empty fst3 <$> catObjectDetails h object catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType)) -catObjectDetails h object = query (catFileProcess h) object $ \from -> do +catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \from -> do header <- hGetLine from case parseResp object header of Just (ParsedResp sha size objtype) -> do @@ -91,23 +95,53 @@ catObjectDetails h object = query (catFileProcess h) object $ \from -> do c <- hGetChar from when (c /= expected) $ error $ "missing " ++ (show expected) ++ " from git cat-file" + + -- Slow fallback path for filenames containing newlines. + newlinefallback = queryObjectType object (gitRepo h) >>= \case + Nothing -> return Nothing + Just objtype -> queryContent object (gitRepo h) >>= \case + Nothing -> return Nothing + Just content -> do + -- only the --batch interface allows getting + -- the sha, so have to re-hash the object + sha <- hashObject' objtype + (flip L.hPut content) + (gitRepo h) + return (Just (content, sha, objtype)) {- Gets the size and type of an object, without reading its content. -} -catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Integer, ObjectType)) -catObjectMetaData h object = query (checkFileProcess h) object $ \from -> do +catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType)) +catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do resp <- hGetLine from case parseResp object resp of - Just (ParsedResp _ size objtype) -> - return $ Just (size, objtype) + Just (ParsedResp sha size objtype) -> + return $ Just (sha, size, objtype) Just DNE -> return Nothing Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object) + where + -- Slow fallback path for filenames containing newlines. + newlinefallback = do + sha <- Git.Ref.sha object (gitRepo h) + sz <- querySize object (gitRepo h) + objtype <- queryObjectType object (gitRepo h) + return $ (,,) <$> sha <*> sz <*> objtype -data ParsedResp = ParsedResp Sha Integer ObjectType | DNE +data ParsedResp = ParsedResp Sha FileSize ObjectType | DNE -query :: CoProcess.CoProcessHandle -> Ref -> (Handle -> IO a) -> IO a -query hdl object receive = CoProcess.query hdl send receive +query :: CoProcess.CoProcessHandle -> Ref -> IO a -> (Handle -> IO a) -> IO a +query hdl object newlinefallback receive + -- git cat-file --batch uses a line based protocol, so when the + -- filename itself contains a newline, have to fall back to another + -- method of getting the information. + | '\n' `elem` s = newlinefallback + -- git strips carriage return from the end of a line, out of some + -- misplaced desire to support windows, so also use the newline + -- fallback for those. + | "\r" `isSuffixOf` s = newlinefallback + | otherwise = CoProcess.query hdl send receive where - send to = hPutStrLn to (fromRef object) + send to = hPutStrLn to s + s = fromRef object parseResp :: Ref -> String -> Maybe ParsedResp parseResp object l @@ -116,13 +150,50 @@ parseResp object l | otherwise = case words l of [sha, objtype, size] | length sha == shaSize -> - case (readObjectType objtype, reads size) of + case (readObjectType (encodeBS objtype), reads size) of (Just t, [(bytes, "")]) -> Just $ ParsedResp (Ref sha) bytes t _ -> Nothing | otherwise -> Nothing _ -> Nothing +querySingle :: CommandParam -> Ref -> Repo -> (Handle -> IO a) -> IO (Maybe a) +querySingle o r repo reader = assertLocal repo $ + -- In non-batch mode, git cat-file warns on stderr when + -- asked for an object that does not exist. + -- Squelch that warning to behave the same as batch mode. + withNullHandle $ \nullh -> do + let p = gitCreateProcess + [ Param "cat-file" + , o + , Param (fromRef r) + ] repo + let p' = p + { std_err = UseHandle nullh + , std_in = Inherit + , std_out = CreatePipe + } + pid <- createProcess p' + let h = stdoutHandle pid + output <- reader h + hClose h + ifM (checkSuccessProcess (processHandle pid)) + ( return (Just output) + , return Nothing + ) + +querySize :: Ref -> Repo -> IO (Maybe FileSize) +querySize r repo = maybe Nothing (readMaybe . takeWhile (/= '\n')) + <$> querySingle (Param "-s") r repo hGetContentsStrict + +queryObjectType :: Ref -> Repo -> IO (Maybe ObjectType) +queryObjectType r repo = maybe Nothing (readObjectType . encodeBS . takeWhile (/= '\n')) + <$> querySingle (Param "-t") r repo hGetContentsStrict + +queryContent :: Ref -> Repo -> IO (Maybe L.ByteString) +queryContent r repo = fmap (\b -> L.fromChunks [b]) + <$> querySingle (Param "-p") r repo S.hGetContents + {- Gets a list of files and directories in a tree. (Not recursive.) -} catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)] catTree h treeref = go <$> catObjectDetails h treeref @@ -141,7 +212,7 @@ catTree h treeref = go <$> catObjectDetails h treeref dropsha = L.drop 21 parsemodefile b = - let (modestr, file) = separate (== ' ') (decodeBS b) + let (modestr, file) = separate (== ' ') (decodeBL b) in (file, readmode modestr) readmode = fromMaybe 0 . fmap fst . headMaybe . readOct diff --git a/Git/Command.hs b/Git/Command.hs index f40dfab..eb20af2 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -14,6 +14,9 @@ import Git import Git.Types import qualified Utility.CoProcess as CoProcess +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S + {- Constructs a git command line operating on the specified repo. -} gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] gitCommandLine params r@(Repo { location = l@(Local { } ) }) = @@ -21,10 +24,10 @@ gitCommandLine params r@(Repo { location = l@(Local { } ) }) = where setdir | gitEnvOverridesGitDir r = [] - | otherwise = [Param $ "--git-dir=" ++ gitdir l] + | otherwise = [Param $ "--git-dir=" ++ fromRawFilePath (gitdir l)] settree = case worktree l of Nothing -> [] - Just t -> [Param $ "--work-tree=" ++ t] + Just t -> [Param $ "--work-tree=" ++ fromRawFilePath t] gitCommandLine _ repo = assertLocal repo $ error "internal" {- Runs git in the specified repo. -} @@ -47,13 +50,13 @@ runQuiet params repo = withQuietOutput createProcessSuccess $ {- Runs a git command and returns its output, lazily. - - Also returns an action that should be used when the output is all - - read (or no more is needed), that will wait on the command, and + - read, that will wait on the command, and - return True if it succeeded. Failure to wait will result in zombies. -} -pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool) +pipeReadLazy :: [CommandParam] -> Repo -> IO (L.ByteString, IO Bool) pipeReadLazy params repo = assertLocal repo $ do (_, Just h, _, pid) <- createProcess p { std_out = CreatePipe } - c <- hGetContents h + c <- L.hGetContents h return (c, checkSuccessProcess pid) where p = gitCreateProcess params repo @@ -62,10 +65,14 @@ pipeReadLazy params repo = assertLocal repo $ do - - Nonzero exit status is ignored. -} -pipeReadStrict :: [CommandParam] -> Repo -> IO String -pipeReadStrict params repo = assertLocal repo $ +pipeReadStrict :: [CommandParam] -> Repo -> IO S.ByteString +pipeReadStrict = pipeReadStrict' S.hGetContents + +{- The reader action must be strict. -} +pipeReadStrict' :: (Handle -> IO a) -> [CommandParam] -> Repo -> IO a +pipeReadStrict' reader params repo = assertLocal repo $ withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do - output <- hGetContentsStrict h + output <- reader h hClose h return output where @@ -83,28 +90,36 @@ pipeWriteRead params writer repo = assertLocal repo $ {- Runs a git command, feeding it input on a handle with an action. -} pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO () -pipeWrite params repo = withHandle StdinHandle createProcessSuccess $ - gitCreateProcess params repo +pipeWrite params repo = assertLocal repo $ + withHandle StdinHandle createProcessSuccess $ + gitCreateProcess params repo {- Reads null terminated output of a git command (as enabled by the -z - parameter), and splits it. -} -pipeNullSplit :: [CommandParam] -> Repo -> IO ([String], IO Bool) +pipeNullSplit :: [CommandParam] -> Repo -> IO ([L.ByteString], IO Bool) pipeNullSplit params repo = do (s, cleanup) <- pipeReadLazy params repo - return (filter (not . null) $ splitc sep s, cleanup) - where - sep = '\0' + return (filter (not . L.null) $ L.split 0 s, cleanup) -pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [String] +{- Reads lazily, but copies each part to a strict ByteString for + - convenience. + -} +pipeNullSplit' :: [CommandParam] -> Repo -> IO ([S.ByteString], IO Bool) +pipeNullSplit' params repo = do + (s, cleanup) <- pipeNullSplit params repo + return (map L.toStrict s, cleanup) + +pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [S.ByteString] pipeNullSplitStrict params repo = do s <- pipeReadStrict params repo - return $ filter (not . null) $ splitc sep s - where - sep = '\0' + return $ filter (not . S.null) $ S.split 0 s -pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String] +pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [L.ByteString] pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo +pipeNullSplitZombie' :: [CommandParam] -> Repo -> IO [S.ByteString] +pipeNullSplitZombie' params repo = leaveZombie <$> pipeNullSplit' params repo + {- Doesn't run the cleanup action. A zombie results. -} leaveZombie :: (a, IO Bool) -> a leaveZombie = fst diff --git a/Git/Config.hs b/Git/Config.hs index 9b4c342..4b60664 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -1,32 +1,37 @@ {- git repository configuration handling - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Config where import qualified Data.Map as M +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import Data.Char +import qualified System.FilePath.ByteString as P import Common import Git import Git.Types -import qualified Git.Construct import qualified Git.Command +import qualified Git.Construct import Utility.UserInfo -{- Returns a single git config setting, or a default value if not set. -} -get :: String -> String -> Repo -> String -get key defaultValue repo = M.findWithDefault defaultValue key (config repo) +{- Returns a single git config setting, or a fallback value if not set. -} +get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue +get key fallback repo = M.findWithDefault fallback key (config repo) -{- Returns a list with each line of a multiline config setting. -} -getList :: String -> Repo -> [String] +{- Returns a list of values. -} +getList :: ConfigKey -> Repo -> [ConfigValue] getList key repo = M.findWithDefault [] key (fullconfig repo) {- Returns a single git config setting, if set. -} -getMaybe :: String -> Repo -> Maybe String +getMaybe :: ConfigKey -> Repo -> Maybe ConfigValue getMaybe key repo = M.lookup key (config repo) {- Runs git config and populates a repo with its config. @@ -57,7 +62,7 @@ read' repo = go repo where params = ["config", "--null", "--list"] p = (proc "git" params) - { cwd = Just d + { cwd = Just (fromRawFilePath d) , env = gitEnv repo } @@ -79,22 +84,28 @@ global = do {- Reads git config from a handle and populates a repo with it. -} hRead :: Repo -> Handle -> IO Repo hRead repo h = do - val <- hGetContentsStrict h + val <- S.hGetContents h store val repo {- Stores a git config into a Repo, returning the new version of the Repo. - The git config may be multiple lines, or a single line. - Config settings can be updated incrementally. -} -store :: String -> Repo -> IO Repo +store :: S.ByteString -> Repo -> IO Repo store s repo = do let c = parse s - repo' <- updateLocation $ repo + updateLocation $ repo { config = (M.map Prelude.head c) `M.union` config repo , fullconfig = M.unionWith (++) c (fullconfig repo) } - rs <- Git.Construct.fromRemotes repo' - return $ repo' { remotes = rs } + +{- Stores a single config setting in a Repo, returning the new version of + - the Repo. Config settings can be updated incrementally. -} +store' :: ConfigKey -> ConfigValue -> Repo -> Repo +store' k v repo = repo + { config = M.singleton k v `M.union` config repo + , fullconfig = M.unionWith (++) (M.singleton k [v]) (fullconfig repo) + } {- Updates the location of a repo, based on its configuration. - @@ -104,13 +115,13 @@ store s repo = do -} updateLocation :: Repo -> IO Repo updateLocation r@(Repo { location = LocalUnknown d }) - | isBare r = ifM (doesDirectoryExist dotgit) + | isBare r = ifM (doesDirectoryExist (fromRawFilePath dotgit)) ( updateLocation' r $ Local dotgit Nothing , updateLocation' r $ Local d Nothing ) | otherwise = updateLocation' r $ Local dotgit (Just d) where - dotgit = (d ".git") + dotgit = d P. ".git" updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l updateLocation r = return r @@ -118,52 +129,66 @@ updateLocation' :: Repo -> RepoLocation -> IO Repo updateLocation' r l = do l' <- case getMaybe "core.worktree" r of Nothing -> return l - Just d -> do + Just (ConfigValue d) -> do {- core.worktree is relative to the gitdir -} - top <- absPath $ gitdir l - return $ l { worktree = Just $ absPathFrom top d } + top <- absPath $ fromRawFilePath (gitdir l) + let p = absPathFrom top (fromRawFilePath d) + return $ l { worktree = Just (toRawFilePath p) } return $ r { location = l' } {- Parses git config --list or git config --null --list output into a - config map. -} -parse :: String -> M.Map String [String] -parse [] = M.empty +parse :: S.ByteString -> M.Map ConfigKey [ConfigValue] parse s - -- --list output will have an = in the first line - | all ('=' `elem`) (take 1 ls) = sep '=' ls + | S.null s = M.empty + -- --list output will have a '=' in the first line + -- (The first line of --null --list output is the name of a key, + -- which is assumed to never contain '='.) + | S.elem eq firstline = sep eq $ S.split nl s -- --null --list output separates keys from values with newlines - | otherwise = sep '\n' $ splitc '\0' s + | otherwise = sep nl $ S.split 0 s where - ls = lines s - sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) . - map (separate (== c)) + nl = fromIntegral (ord '\n') + eq = fromIntegral (ord '=') + firstline = S.takeWhile (/= nl) s + + sep c = M.fromListWith (++) + . map (\(k,v) -> (ConfigKey k, [ConfigValue (S.drop 1 v)])) + . map (S.break (== c)) -{- Checks if a string from git config is a true value. -} -isTrue :: String -> Maybe Bool -isTrue s +{- Checks if a string from git config is a true/false value. -} +isTrueFalse :: String -> Maybe Bool +isTrueFalse = isTrueFalse' . ConfigValue . encodeBS' + +isTrueFalse' :: ConfigValue -> Maybe Bool +isTrueFalse' (ConfigValue s) | s' == "true" = Just True | s' == "false" = Just False | otherwise = Nothing where - s' = map toLower s + s' = S8.map toLower s boolConfig :: Bool -> String boolConfig True = "true" boolConfig False = "false" +boolConfig' :: Bool -> S.ByteString +boolConfig' True = "true" +boolConfig' False = "false" + isBare :: Repo -> Bool -isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r +isBare r = fromMaybe False $ isTrueFalse' =<< getMaybe coreBare r -coreBare :: String +coreBare :: ConfigKey coreBare = "core.bare" {- Runs a command to get the configuration of a repo, - and returns a repo populated with the configuration, as well as the raw - output of the command. -} -fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String)) +fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, S.ByteString)) fromPipe r cmd params = try $ withHandle StdoutHandle createProcessSuccess p $ \h -> do - val <- hGetContentsStrict h + val <- S.hGetContents h r' <- store val r return (r', val) where @@ -171,7 +196,7 @@ fromPipe r cmd params = try $ {- Reads git config from a specified file and returns the repo populated - with the configuration. -} -fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String)) +fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString)) fromFile r f = fromPipe r "git" [ Param "config" , Param "--file" @@ -181,13 +206,13 @@ fromFile r f = fromPipe r "git" {- Changes a git config setting in the specified config file. - (Creates the file if it does not already exist.) -} -changeFile :: FilePath -> String -> String -> IO Bool -changeFile f k v = boolSystem "git" +changeFile :: FilePath -> ConfigKey -> S.ByteString -> IO Bool +changeFile f (ConfigKey k) v = boolSystem "git" [ Param "config" , Param "--file" , File f - , Param k - , Param v + , Param (decodeBS' k) + , Param (decodeBS' v) ] {- Unsets a git config setting, in both the git repo, @@ -196,10 +221,10 @@ changeFile f k v = boolSystem "git" - 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) } +unset :: ConfigKey -> Repo -> IO (Maybe Repo) +unset ck@(ConfigKey k) r = ifM (Git.Command.runBool ps r) + ( return $ Just $ r { config = M.delete ck (config r) } , return Nothing ) where - ps = [Param "config", Param "--unset-all", Param k] + ps = [Param "config", Param "--unset-all", Param (decodeBS' k)] diff --git a/Git/Construct.hs b/Git/Construct.hs index 4ad74fd..5b656eb 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -58,11 +58,11 @@ fromPath dir = fromAbsPath =<< absPath dir - specified. -} fromAbsPath :: FilePath -> IO Repo fromAbsPath dir - | absoluteGitPath dir = hunt + | absoluteGitPath (encodeBS dir) = hunt | otherwise = error $ "internal error, " ++ dir ++ " is not absolute" where - ret = pure . newFrom . LocalUnknown + ret = pure . newFrom . LocalUnknown . toRawFilePath canondir = dropTrailingPathSeparator dir {- When dir == "foo/.git", git looks for "foo/.git/.git", - and failing that, uses "foo" as the repository. -} @@ -117,7 +117,7 @@ localToUrl reference r [ Url.scheme reference , "//" , auth - , repoPath r + , fromRawFilePath (repoPath r) ] in r { location = Url $ fromJust $ parseURI absurl } @@ -127,9 +127,8 @@ fromRemotes repo = mapM construct remotepairs where filterconfig f = filter f $ M.toList $ config repo filterkeys f = filterconfig (\(k,_) -> f k) - remotepairs = filterkeys isremote - isremote k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k - construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo + remotepairs = filterkeys isRemoteKey + construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (fromConfigValue v) repo) {- Sets the name of a remote when constructing the Repo to represent it. -} remoteNamed :: String -> IO Repo -> IO Repo @@ -139,11 +138,8 @@ remoteNamed n constructor = do {- Sets the name of a remote based on the git config key, such as - "remote.foo.url". -} -remoteNamedFromKey :: String -> IO Repo -> IO Repo -remoteNamedFromKey k = remoteNamed basename - where - basename = intercalate "." $ - reverse $ drop 1 $ reverse $ drop 1 $ splitc '.' k +remoteNamedFromKey :: ConfigKey -> IO Repo -> IO Repo +remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName {- Constructs a new Repo for one of a Repo's remotes using a given - location (ie, an url). -} @@ -158,7 +154,7 @@ fromRemoteLocation s repo = gen $ parseRemoteLocation s repo fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do dir' <- expandTilde dir - fromPath $ repoPath repo dir' + fromPath $ fromRawFilePath (repoPath repo) dir' {- Git remotes can have a directory that is specified relative - to the user's home directory, or that contains tilde expansions. @@ -208,20 +204,29 @@ checkForRepo dir = where check test cont = maybe cont (return . Just) =<< test checkdir c = ifM c - ( return $ Just $ LocalUnknown dir + ( return $ Just $ LocalUnknown $ toRawFilePath dir , return Nothing ) - isRepo = checkdir $ gitSignature $ ".git" "config" + isRepo = checkdir $ + gitSignature (".git" "config") + <||> + -- A git-worktree lacks .git/config, but has .git/commondir. + -- (Normally the .git is a file, not a symlink, but it can + -- be converted to a symlink and git will still work; + -- this handles that case.) + gitSignature (".git" "gitdir") isBareRepo = checkdir $ gitSignature "config" <&&> doesDirectoryExist (dir "objects") gitDirFile = do + -- git-submodule, git-worktree, and --separate-git-dir + -- make .git be a file pointing to the real git directory. c <- firstLine <$> catchDefaultIO "" (readFile $ dir ".git") return $ if gitdirprefix `isPrefixOf` c then Just $ Local - { gitdir = absPathFrom dir $ + { gitdir = toRawFilePath $ absPathFrom dir $ drop (length gitdirprefix) c - , worktree = Just dir + , worktree = Just (toRawFilePath dir) } else Nothing where @@ -233,7 +238,6 @@ newFrom l = Repo { location = l , config = M.empty , fullconfig = M.empty - , remotes = [] , remoteName = Nothing , gitEnv = Nothing , gitEnvOverridesGitDir = False diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs index 69a679e..054a81e 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.CurrentRepo where @@ -12,6 +12,7 @@ import Git.Types import Git.Construct import qualified Git.Config import Utility.Env +import Utility.Env.Set {- Gets the current git repository. - @@ -24,12 +25,20 @@ import Utility.Env - directory if necessary to ensure it is within the repository's work - tree. While not needed for git commands, this is useful for anything - else that looks for files in the worktree. + - + - Also works around a git bug when running some hooks. It + - runs the hooks in the top of the repository, but if GIT_WORK_TREE + - was relative (but not "."), it then points to the wrong directory. + - In this situation GIT_PREFIX contains the directory that + - GIT_WORK_TREE is relative to. -} get :: IO Repo get = do - gd <- pathenv "GIT_DIR" + gd <- getpathenv "GIT_DIR" r <- configure gd =<< fromCwd - wt <- maybe (worktree $ location r) Just <$> pathenv "GIT_WORK_TREE" + prefix <- getpathenv "GIT_PREFIX" + wt <- maybe (fromRawFilePath <$> worktree (location r)) Just + <$> getpathenvprefix "GIT_WORK_TREE" prefix case wt of Nothing -> return r Just d -> do @@ -38,22 +47,39 @@ get = do setCurrentDirectory d return $ addworktree wt r where - pathenv s = do + getpathenv s = do v <- getEnv s case v of Just d -> do unsetEnv s - Just <$> absPath d + return (Just d) + Nothing -> return Nothing + + getpathenvprefix s (Just prefix) | not (null prefix) = + getpathenv s >>= \case Nothing -> return Nothing + Just d + | d == "." -> return (Just d) + | otherwise -> Just <$> absPath (prefix d) + getpathenvprefix s _ = getpathenv s configure Nothing (Just r) = Git.Config.read r configure (Just d) _ = do absd <- absPath d curr <- getCurrentDirectory - Git.Config.read $ newFrom $ - Local { gitdir = absd, worktree = Just curr } + r <- Git.Config.read $ newFrom $ + Local + { gitdir = toRawFilePath absd + , worktree = Just (toRawFilePath curr) + } + return $ if Git.Config.isBare r + then r { location = (location r) { worktree = Nothing } } + else r + configure Nothing Nothing = giveup "Not in a git repository." - addworktree w r = changelocation r $ - Local { gitdir = gitdir (location r), worktree = w } + addworktree w r = changelocation r $ Local + { gitdir = gitdir (location r) + , worktree = fmap toRawFilePath w + } changelocation r l = r { location = l } diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs index e923796..3dc8529 100644 --- a/Git/Destroyer.hs +++ b/Git/Destroyer.hs @@ -4,7 +4,7 @@ - - Copyright 2013, 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Destroyer ( @@ -83,7 +83,7 @@ generateDamage = sample' (arbitrary :: Gen Damage) applyDamage :: [Damage] -> Repo -> IO () applyDamage ds r = do contents <- sort . filter (not . skipped) - <$> dirContentsRecursive (localGitDir r) + <$> dirContentsRecursive (fromRawFilePath (localGitDir r)) forM_ ds $ \d -> do let withfile s a = do let f = selectFile contents s diff --git a/Git/DiffTreeItem.hs b/Git/DiffTreeItem.hs index 859f590..ffda2e8 100644 --- a/Git/DiffTreeItem.hs +++ b/Git/DiffTreeItem.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.DiffTreeItem ( diff --git a/Git/FilePath.hs b/Git/FilePath.hs index ffa3331..66a0159 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -5,12 +5,14 @@ - top of the repository even when run in a subdirectory. Adding some - types helps keep that straight. - - - Copyright 2012-2013 Joey Hess + - Copyright 2012-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module Git.FilePath ( TopFilePath, @@ -29,30 +31,39 @@ module Git.FilePath ( import Common import Git -import qualified System.FilePath.Posix +import qualified System.FilePath.ByteString as P +import qualified System.FilePath.Posix.ByteString +import GHC.Generics +import Control.DeepSeq +import qualified Data.ByteString as S -{- A FilePath, relative to the top of the git repository. -} -newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } - deriving (Show, Eq, Ord) +{- A RawFilePath, relative to the top of the git repository. -} +newtype TopFilePath = TopFilePath { getTopFilePath :: RawFilePath } + deriving (Show, Eq, Ord, Generic) + +instance NFData TopFilePath {- A file in a branch or other treeish. -} data BranchFilePath = BranchFilePath Ref TopFilePath + deriving (Show, Eq, Ord) {- Git uses the branch:file form to refer to a BranchFilePath -} -descBranchFilePath :: BranchFilePath -> String -descBranchFilePath (BranchFilePath b f) = fromRef b ++ ':' : getTopFilePath f +descBranchFilePath :: BranchFilePath -> S.ByteString +descBranchFilePath (BranchFilePath b f) = + encodeBS' (fromRef b) <> ":" <> getTopFilePath f {- Path to a TopFilePath, within the provided git repo. -} -fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath -fromTopFilePath p repo = combine (repoPath repo) (getTopFilePath p) +fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath +fromTopFilePath p repo = P.combine (repoPath repo) (getTopFilePath p) {- The input FilePath can be absolute, or relative to the CWD. -} -toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath -toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file +toTopFilePath :: RawFilePath -> Git.Repo -> IO TopFilePath +toTopFilePath file repo = TopFilePath . toRawFilePath + <$> relPathDirToFile (fromRawFilePath (repoPath repo)) (fromRawFilePath file) -{- The input FilePath must already be relative to the top of the git +{- The input RawFilePath must already be relative to the top of the git - repository -} -asTopFilePath :: FilePath -> TopFilePath +asTopFilePath :: RawFilePath -> TopFilePath asTopFilePath file = TopFilePath file {- Git may use a different representation of a path when storing @@ -62,25 +73,25 @@ asTopFilePath file = TopFilePath file - despite Windows using '\'. - -} -type InternalGitPath = String +type InternalGitPath = RawFilePath -toInternalGitPath :: FilePath -> InternalGitPath +toInternalGitPath :: RawFilePath -> InternalGitPath #ifndef mingw32_HOST_OS toInternalGitPath = id #else -toInternalGitPath = replace "\\" "/" +toInternalGitPath = encodeBS . replace "\\" "/" . decodeBS #endif -fromInternalGitPath :: InternalGitPath -> FilePath +fromInternalGitPath :: InternalGitPath -> RawFilePath #ifndef mingw32_HOST_OS fromInternalGitPath = id #else -fromInternalGitPath = replace "/" "\\" +fromInternalGitPath = encodeBS . replace "/" "\\" . decodeBS #endif {- isAbsolute on Windows does not think "/foo" or "\foo" is absolute, - so try posix paths. -} -absoluteGitPath :: FilePath -> Bool -absoluteGitPath p = isAbsolute p || - System.FilePath.Posix.isAbsolute (toInternalGitPath p) +absoluteGitPath :: RawFilePath -> Bool +absoluteGitPath p = P.isAbsolute p || + System.FilePath.Posix.ByteString.isAbsolute (toInternalGitPath p) diff --git a/Git/Filename.hs b/Git/Filename.hs index 355e75f..010e5ba 100644 --- a/Git/Filename.hs +++ b/Git/Filename.hs @@ -3,7 +3,7 @@ - - Copyright 2010, 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Filename where @@ -12,23 +12,44 @@ import Common import Utility.Format (decode_c, encode_c) import Data.Char +import Data.Word +import qualified Data.ByteString as S -decode :: String -> FilePath -decode [] = [] -decode f@(c:s) - -- encoded strings will be inside double quotes - | c == '"' && end s == ['"'] = decode_c $ beginning s - | otherwise = f +-- encoded filenames will be inside double quotes +decode :: S.ByteString -> RawFilePath +decode b = case S.uncons b of + Nothing -> b + Just (h, t) + | h /= q -> b + | otherwise -> case S.unsnoc t of + Nothing -> b + Just (i, l) + | l /= q -> b + | otherwise -> + encodeBS $ decode_c $ decodeBS i + where + q :: Word8 + q = fromIntegral (ord '"') {- Should not need to use this, except for testing decode. -} -encode :: FilePath -> String -encode s = "\"" ++ encode_c s ++ "\"" +encode :: RawFilePath -> S.ByteString +encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\"" -{- For quickcheck. - - - - See comment on Utility.Format.prop_encode_c_decode_c_roundtrip for - - why this only tests chars < 256 -} -prop_encode_decode_roundtrip :: String -> Bool -prop_encode_decode_roundtrip s = s' == decode (encode s') +prop_encode_decode_roundtrip :: FilePath -> Bool +prop_encode_decode_roundtrip s = s' == + fromRawFilePath (decode (encode (toRawFilePath s'))) where - s' = filter (\c -> ord c < 256) s + s' = nonul (nohigh s) + -- Encoding and then decoding roundtrips only when + -- the string does not contain high unicode, because eg, + -- both "\12345" and "\227\128\185" are encoded to + -- "\343\200\271". + -- + -- This property papers over the problem, by only + -- testing ascii + nohigh = filter isAscii + -- A String can contain a NUL, but toRawFilePath + -- truncates on the NUL, which is generally fine + -- because unix filenames cannot contain NUL. + -- So the encoding only roundtrips when there is no nul. + nonul = filter (/= '\NUL') diff --git a/Git/Fsck.hs b/Git/Fsck.hs index a716b56..6f33e11 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} @@ -22,10 +22,11 @@ import Git import Git.Command import Git.Sha import Utility.Batch -import qualified Git.Version import qualified Data.Set as S import Control.Concurrent.Async +import qualified Data.Semigroup as Sem +import Prelude data FsckResults = FsckFoundMissing @@ -44,15 +45,21 @@ type MissingObjects = S.Set Sha type Truncated = Bool +appendFsckOutput :: FsckOutput -> FsckOutput -> FsckOutput +appendFsckOutput (FsckOutput s1 t1) (FsckOutput s2 t2) = + FsckOutput (S.union s1 s2) (t1 || t2) +appendFsckOutput (FsckOutput s t) _ = FsckOutput s t +appendFsckOutput _ (FsckOutput s t) = FsckOutput s t +appendFsckOutput NoFsckOutput NoFsckOutput = NoFsckOutput +appendFsckOutput AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning +appendFsckOutput AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning +appendFsckOutput NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning + +instance Sem.Semigroup FsckOutput where + (<>) = appendFsckOutput + instance Monoid FsckOutput where mempty = NoFsckOutput - mappend (FsckOutput s1 t1) (FsckOutput s2 t2) = FsckOutput (S.union s1 s2) (t1 || t2) - mappend (FsckOutput s t) _ = FsckOutput s t - mappend _ (FsckOutput s t) = FsckOutput s t - mappend NoFsckOutput NoFsckOutput = NoFsckOutput - mappend AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning - mappend AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning - mappend NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning {- Runs fsck to find some of the broken objects in the repository. - May not find all broken objects, if fsck fails on bad data in some of @@ -65,9 +72,7 @@ instance Monoid FsckOutput where -} findBroken :: Bool -> Repo -> IO FsckResults findBroken batchmode r = do - supportsNoDangling <- (>= Git.Version.normalize "1.7.10") - <$> Git.Version.installed - let (command, params) = ("git", fsckParams supportsNoDangling r) + let (command, params) = ("git", fsckParams r) (command', params') <- if batchmode then toBatchCommand (command, params) else return (command, params) @@ -78,8 +83,8 @@ findBroken batchmode r = do , std_err = CreatePipe } (o1, o2) <- concurrently - (parseFsckOutput maxobjs r supportsNoDangling (stdoutHandle p)) - (parseFsckOutput maxobjs r supportsNoDangling (stderrHandle p)) + (parseFsckOutput maxobjs r (stdoutHandle p)) + (parseFsckOutput maxobjs r (stderrHandle p)) fsckok <- checkSuccessProcess pid case mappend o1 o2 of FsckOutput badobjs truncated @@ -112,15 +117,15 @@ knownMissing (FsckFoundMissing s _) = s findMissing :: [Sha] -> Repo -> IO MissingObjects findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs -parseFsckOutput :: Int -> Repo -> Bool -> Handle -> IO FsckOutput -parseFsckOutput maxobjs r supportsNoDangling h = do +parseFsckOutput :: Int -> Repo -> Handle -> IO FsckOutput +parseFsckOutput maxobjs r h = do ls <- lines <$> hGetContents h if null ls then return NoFsckOutput else if all ("duplicateEntries" `isInfixOf`) ls then return AllDuplicateEntriesWarning else do - let shas = findShas supportsNoDangling ls + let shas = findShas ls let !truncated = length shas > maxobjs missingobjs <- findMissing (take maxobjs shas) r return $ FsckOutput missingobjs truncated @@ -133,18 +138,14 @@ isMissing s r = either (const True) (const False) <$> tryIO dump , Param (fromRef s) ] r -findShas :: Bool -> [String] -> [Sha] -findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted +findShas :: [String] -> [Sha] +findShas = catMaybes . map extractSha . concat . map words . filter wanted where - wanted l - | supportsNoDangling = True - | otherwise = not ("dangling " `isPrefixOf` l) - -fsckParams :: Bool -> Repo -> [CommandParam] -fsckParams supportsNoDangling = gitCommandLine $ map Param $ catMaybes - [ Just "fsck" - , if supportsNoDangling - then Just "--no-dangling" - else Nothing - , Just "--no-reflogs" + wanted l = not ("dangling " `isPrefixOf` l) + +fsckParams :: Repo -> [CommandParam] +fsckParams = gitCommandLine $ map Param + [ "fsck" + , "--no-dangling" + , "--no-reflogs" ] diff --git a/Git/HashObject.hs b/Git/HashObject.hs new file mode 100644 index 0000000..3787c9c --- /dev/null +++ b/Git/HashObject.hs @@ -0,0 +1,76 @@ +{- git hash-object interface + - + - Copyright 2011-2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Git.HashObject where + +import Common +import Git +import Git.Sha +import Git.Command +import Git.Types +import qualified Utility.CoProcess as CoProcess +import Utility.Tmp + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Builder + +type HashObjectHandle = CoProcess.CoProcessHandle + +hashObjectStart :: Bool -> Repo -> IO HashObjectHandle +hashObjectStart writeobject = gitCoProcessStart True $ catMaybes + [ Just (Param "hash-object") + , if writeobject then Just (Param "-w") else Nothing + , Just (Param "--stdin-paths") + , Just (Param "--no-filters") + ] + +hashObjectStop :: HashObjectHandle -> IO () +hashObjectStop = CoProcess.stop + +{- Injects a file into git, returning the Sha of the object. -} +hashFile :: HashObjectHandle -> FilePath -> IO Sha +hashFile h file = CoProcess.query h send receive + where + send to = hPutStrLn to =<< absPath file + receive from = getSha "hash-object" $ hGetLine from + +class HashableBlob t where + hashableBlobToHandle :: Handle -> t -> IO () + +instance HashableBlob L.ByteString where + hashableBlobToHandle = L.hPut + +instance HashableBlob S.ByteString where + hashableBlobToHandle = S.hPut + +instance HashableBlob Builder where + hashableBlobToHandle = hPutBuilder + +{- Injects a blob into git. Unfortunately, the current git-hash-object + - interface does not allow batch hashing without using temp files. -} +hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha +hashBlob h b = withTmpFile "hash" $ \tmp tmph -> do + hashableBlobToHandle tmph b + hClose tmph + hashFile h tmp + +{- Injects some content into git, returning its Sha. + - + - Avoids using a tmp file, but runs a new hash-object command each + - time called. -} +hashObject :: ObjectType -> String -> Repo -> IO Sha +hashObject objtype content = hashObject' objtype (flip hPutStr content) + +hashObject' :: ObjectType -> (Handle -> IO ()) -> Repo -> IO Sha +hashObject' objtype writer repo = getSha subcmd $ + pipeWriteRead (map Param params) (Just writer) repo + where + subcmd = "hash-object" + params = [subcmd, "-t", decodeBS (fmtObjectType objtype), "-w", "--stdin", "--no-filters"] diff --git a/Git/Index.hs b/Git/Index.hs index 85ea480..afd29c2 100644 --- a/Git/Index.hs +++ b/Git/Index.hs @@ -1,8 +1,8 @@ {- git index file stuff - - - Copyright 2011 Joey Hess + - Copyright 2011-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Index where @@ -10,6 +10,7 @@ module Git.Index where import Common import Git import Utility.Env +import Utility.Env.Set indexEnv :: String indexEnv = "GIT_INDEX_FILE" @@ -46,25 +47,14 @@ override index _r = do reset (Just v) = setEnv indexEnv v True reset _ = unsetEnv var +{- The normal index file. Does not check GIT_INDEX_FILE. -} indexFile :: Repo -> FilePath -indexFile r = localGitDir r "index" +indexFile r = fromRawFilePath (localGitDir r) "index" -{- Git locks the index by creating this file. -} -indexFileLock :: Repo -> FilePath -indexFileLock r = indexFile r ++ ".lock" +{- The index file git will currently use, checking GIT_INDEX_FILE. -} +currentIndexFile :: Repo -> IO FilePath +currentIndexFile r = fromMaybe (indexFile r) <$> getEnv indexEnv -{- When the pre-commit hook is run, and git commit has been run with - - a file or files specified to commit, rather than committing the staged - - index, git provides the pre-commit hook with a "false index file". - - - - Changes made to this index will influence the commit, but won't - - affect the real index file. - - - - This detects when we're in this situation, using a heuristic, which - - might be broken by changes to git. Any use of this should have a test - - case to make sure it works. - -} -haveFalseIndex :: IO Bool -haveFalseIndex = maybe (False) check <$> getEnv indexEnv - where - check f = "next-index" `isPrefixOf` takeFileName f +{- Git locks the index by creating this file. -} +indexFileLock :: FilePath -> FilePath +indexFileLock f = f ++ ".lock" diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index f945838..5534307 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -1,13 +1,15 @@ {- git ls-files interface - - - Copyright 2010,2012 Joey Hess + - Copyright 2010-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.LsFiles ( inRepo, + inRepoOrBranch, notInRepo, + notInRepoIncludingEmptyDirectories, allFiles, deleted, modified, @@ -32,69 +34,89 @@ import Git.Sha import Numeric import System.Posix.Types +import qualified Data.ByteString.Lazy as L -{- Scans for files that are checked into git at the specified locations. -} -inRepo :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -inRepo l = pipeNullSplit $ - Param "ls-files" : - Param "--cached" : - Param "-z" : - Param "--" : - map File l +{- Scans for files that are checked into git's index at the specified locations. -} +inRepo :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +inRepo = inRepo' [] + +inRepo' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +inRepo' ps l repo = pipeNullSplit' params repo + where + params = + Param "ls-files" : + Param "--cached" : + Param "-z" : + ps ++ + (Param "--" : map (File . fromRawFilePath) l) + +{- Files that are checked into the index or have been committed to a + - branch. -} +inRepoOrBranch :: Branch -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +inRepoOrBranch (Ref b) = inRepo' [Param $ "--with-tree=" ++ b] {- Scans for files at the specified locations that are not checked into git. -} -notInRepo :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) -notInRepo include_ignored l repo = pipeNullSplit params repo +notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +notInRepo = notInRepo' [] + +notInRepo' :: [CommandParam] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +notInRepo' ps include_ignored l repo = pipeNullSplit' params repo where params = concat [ [ Param "ls-files", Param "--others"] + , ps , exclude , [ Param "-z", Param "--" ] - , map File l + , map (File . fromRawFilePath) l ] exclude | include_ignored = [] | otherwise = [Param "--exclude-standard"] +{- Scans for files at the specified locations that are not checked into + - git. Empty directories are included in the result. -} +notInRepoIncludingEmptyDirectories :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"] + {- Finds all files in the specified locations, whether checked into git or - not. -} -allFiles :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -allFiles l = pipeNullSplit $ +allFiles :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +allFiles l = pipeNullSplit' $ Param "ls-files" : Param "--cached" : Param "--others" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l {- Returns a list of files in the specified locations that have been - deleted. -} -deleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -deleted l repo = pipeNullSplit params repo +deleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +deleted l repo = pipeNullSplit' params repo where params = Param "ls-files" : Param "--deleted" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l {- Returns a list of files in the specified locations that have been - modified. -} -modified :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -modified l repo = pipeNullSplit params repo +modified :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +modified l repo = pipeNullSplit' params repo where params = Param "ls-files" : Param "--modified" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l {- Files that have been modified or are not checked into git (and are not - ignored). -} -modifiedOthers :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -modifiedOthers l repo = pipeNullSplit params repo +modifiedOthers :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +modifiedOthers l repo = pipeNullSplit' params repo where params = Param "ls-files" : @@ -103,69 +125,69 @@ modifiedOthers l repo = pipeNullSplit params repo Param "--exclude-standard" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l {- Returns a list of all files that are staged for commit. -} -staged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +staged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) staged = staged' [] {- Returns a list of the files, staged for commit, that are being added, - moved, or changed (but not deleted), from the specified locations. -} -stagedNotDeleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +stagedNotDeleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"] -staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) -staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix +staged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +staged' ps l repo = pipeNullSplit' (prefix ++ ps ++ suffix) repo where prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] - suffix = Param "--" : map File l + suffix = Param "--" : map (File . fromRawFilePath) l -type StagedDetails = (FilePath, Maybe Sha, Maybe FileMode) +type StagedDetails = (RawFilePath, Maybe Sha, Maybe FileMode) {- Returns details about files that are staged in the index, - as well as files not yet in git. Skips ignored files. -} -stagedOthersDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool) +stagedOthersDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedOthersDetails = stagedDetails' [Param "--others", Param "--exclude-standard"] {- Returns details about all files that are staged in the index. -} -stagedDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool) +stagedDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedDetails = stagedDetails' [] {- Gets details about staged files, including the Sha of their staged - contents. -} -stagedDetails' :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedDetails], IO Bool) +stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedDetails' ps l repo = do (ls, cleanup) <- pipeNullSplit params repo return (map parse ls, cleanup) where params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ - Param "--" : map File l + Param "--" : map (File . fromRawFilePath) l parse s - | null file = (s, Nothing, Nothing) - | otherwise = (file, extractSha $ take shaSize rest, readmode mode) + | null file = (L.toStrict s, Nothing, Nothing) + | otherwise = (toRawFilePath file, extractSha $ take shaSize rest, readmode mode) where - (metadata, file) = separate (== '\t') s + (metadata, file) = separate (== '\t') (decodeBL' s) (mode, rest) = separate (== ' ') metadata readmode = fst <$$> headMaybe . readOct {- Returns a list of the files in the specified locations that are staged - for commit, and whose type has changed. -} -typeChangedStaged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +typeChangedStaged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChangedStaged = typeChanged' [Param "--cached"] {- Returns a list of the files in the specified locations whose type has - changed. Files only staged for commit will not be included. -} -typeChanged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +typeChanged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChanged = typeChanged' [] -typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) +typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChanged' ps l repo = do (fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo -- git diff returns filenames relative to the top of the git repo; -- convert to filenames relative to the cwd, like git ls-files. - top <- absPath (repoPath repo) + top <- absPath (fromRawFilePath (repoPath repo)) currdir <- getCurrentDirectory - return (map (\f -> relPathDirToFileAbs currdir $ top f) fs, cleanup) + return (map (\f -> toRawFilePath (relPathDirToFileAbs currdir $ top decodeBL' f)) fs, cleanup) where prefix = [ Param "diff" @@ -173,7 +195,7 @@ typeChanged' ps l repo = do , Param "--diff-filter=T" , Param "-z" ] - suffix = Param "--" : (if null l then [File "."] else map File l) + suffix = Param "--" : (if null l then [File "."] else map (File . fromRawFilePath) l) {- A item in conflict has two possible values. - Either can be Nothing, when that side deleted the file. -} @@ -183,10 +205,10 @@ data Conflicting v = Conflicting } deriving (Show) data Unmerged = Unmerged - { unmergedFile :: FilePath - , unmergedBlobType :: Conflicting BlobType + { unmergedFile :: RawFilePath + , unmergedTreeItemType :: Conflicting TreeItemType , unmergedSha :: Conflicting Sha - } deriving (Show) + } {- Returns a list of the files in the specified locations that have - unresolved merge conflicts. @@ -198,38 +220,38 @@ data Unmerged = Unmerged - 3 = them - If a line is omitted, that side removed the file. -} -unmerged :: [FilePath] -> Repo -> IO ([Unmerged], IO Bool) +unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool) unmerged l repo = do (fs, cleanup) <- pipeNullSplit params repo - return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup) + return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup) where params = Param "ls-files" : Param "--unmerged" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l data InternalUnmerged = InternalUnmerged { isus :: Bool - , ifile :: FilePath - , iblobtype :: Maybe BlobType + , ifile :: RawFilePath + , itreeitemtype :: Maybe TreeItemType , isha :: Maybe Sha - } deriving (Show) + } parseUnmerged :: String -> Maybe InternalUnmerged parseUnmerged s | null file = Nothing | otherwise = case words metadata of - (rawblobtype:rawsha:rawstage:_) -> do + (rawtreeitemtype:rawsha:rawstage:_) -> do stage <- readish rawstage :: Maybe Int if stage /= 2 && stage /= 3 then Nothing else do - blobtype <- readBlobType rawblobtype + treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype) sha <- extractSha rawsha - return $ InternalUnmerged (stage == 2) file - (Just blobtype) (Just sha) + return $ InternalUnmerged (stage == 2) (toRawFilePath file) + (Just treeitemtype) (Just sha) _ -> Nothing where (metadata, file) = separate (== '\t') s @@ -239,12 +261,12 @@ reduceUnmerged c [] = c reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest where (rest, sibi) = findsib i is - (blobtypeA, blobtypeB, shaA, shaB) - | isus i = (iblobtype i, iblobtype sibi, isha i, isha sibi) - | otherwise = (iblobtype sibi, iblobtype i, isha sibi, isha i) + (treeitemtypeA, treeitemtypeB, shaA, shaB) + | isus i = (itreeitemtype i, itreeitemtype sibi, isha i, isha sibi) + | otherwise = (itreeitemtype sibi, itreeitemtype i, isha sibi, isha i) new = Unmerged { unmergedFile = ifile i - , unmergedBlobType = Conflicting blobtypeA blobtypeB + , unmergedTreeItemType = Conflicting treeitemtypeA treeitemtypeB , unmergedSha = Conflicting shaA shaB } findsib templatei [] = ([], removed templatei) @@ -253,6 +275,6 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest | otherwise = (l:ls, removed templatei) removed templatei = templatei { isus = not (isus templatei) - , iblobtype = Nothing + , itreeitemtype = Nothing , isha = Nothing } diff --git a/Git/LsTree.hs b/Git/LsTree.hs index 225f2ce..a3d8383 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -1,19 +1,21 @@ {- git ls-tree interface - - - Copyright 2011-2016 Joey Hess + - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} module Git.LsTree ( TreeItem(..), + LsTreeMode(..), lsTree, lsTree', lsTreeParams, lsTreeFiles, parseLsTree, + formatLsTree, ) where import Common @@ -22,42 +24,52 @@ import Git.Command import Git.Sha import Git.FilePath import qualified Git.Filename +import Utility.Attoparsec import Numeric -import Data.Char +import Data.Either import System.Posix.Types +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Attoparsec.ByteString.Lazy as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 data TreeItem = TreeItem { mode :: FileMode - , typeobj :: String + , typeobj :: S.ByteString , sha :: Ref , file :: TopFilePath } deriving Show -{- Lists the complete contents of a tree, recursing into sub-trees, - - with lazy output. -} -lsTree :: Ref -> Repo -> IO ([TreeItem], IO Bool) +data LsTreeMode = LsTreeRecursive | LsTreeNonRecursive + +{- Lists the contents of a tree, with lazy output. -} +lsTree :: LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool) lsTree = lsTree' [] -lsTree' :: [CommandParam] -> Ref -> Repo -> IO ([TreeItem], IO Bool) -lsTree' ps t repo = do - (l, cleanup) <- pipeNullSplit (lsTreeParams t ps) repo - return (map parseLsTree l, cleanup) +lsTree' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool) +lsTree' ps lsmode t repo = do + (l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo + return (rights (map parseLsTree l), cleanup) -lsTreeParams :: Ref -> [CommandParam] -> [CommandParam] -lsTreeParams r ps = +lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam] +lsTreeParams lsmode r ps = [ Param "ls-tree" , Param "--full-tree" , Param "-z" - , Param "-r" - ] ++ ps ++ + ] ++ recursiveparams ++ ps ++ [ Param "--" , File $ fromRef r ] + where + recursiveparams = case lsmode of + LsTreeRecursive -> [ Param "-r" ] + LsTreeNonRecursive -> [] {- Lists specified files in a tree. -} lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem] -lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo +lsTreeFiles t fs repo = rights . map (parseLsTree . L.fromStrict) + <$> pipeNullSplitStrict ps repo where ps = [ Param "ls-tree" @@ -67,21 +79,34 @@ lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo , File $ fromRef t ] ++ map File fs +parseLsTree :: L.ByteString -> Either String TreeItem +parseLsTree b = case A.parse parserLsTree b of + A.Done _ r -> Right r + A.Fail _ _ err -> Left err + {- Parses a line of ls-tree output, in format: - mode SP type SP sha TAB file - - (The --long format is not currently supported.) -} -parseLsTree :: String -> TreeItem -parseLsTree l = TreeItem - { mode = smode - , typeobj = t - , sha = Ref s - , file = sfile - } - where - (m, past_m) = splitAt 7 l -- mode is 6 bytes - (!t, past_t) = separate isSpace past_m - (!s, past_s) = splitAt shaSize past_t - !f = drop 1 past_s - !smode = fst $ Prelude.head $ readOct m - !sfile = asTopFilePath $ Git.Filename.decode f +parserLsTree :: A.Parser TreeItem +parserLsTree = TreeItem + -- mode + <$> octal + <* A8.char ' ' + -- type + <*> A.takeTill (== 32) + <* A8.char ' ' + -- sha + <*> (Ref . decodeBS' <$> A.take shaSize) + <* A8.char '\t' + -- file + <*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString) + +{- Inverse of parseLsTree -} +formatLsTree :: TreeItem -> String +formatLsTree ti = unwords + [ showOct (mode ti) "" + , decodeBS (typeobj ti) + , fromRef (sha ti) + , fromRawFilePath (getTopFilePath (file ti)) + ] diff --git a/Git/Objects.hs b/Git/Objects.hs index bda220b..c9ede4d 100644 --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Objects where @@ -12,7 +12,7 @@ import Git import Git.Sha objectsDir :: Repo -> FilePath -objectsDir r = localGitDir r "objects" +objectsDir r = fromRawFilePath (localGitDir r) "objects" packDir :: Repo -> FilePath packDir r = objectsDir r "pack" diff --git a/Git/Ref.hs b/Git/Ref.hs index 1986db6..621e328 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -1,10 +1,12 @@ {- git ref stuff - - - Copyright 2011-2013 Joey Hess + - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Ref where import Common @@ -13,13 +15,14 @@ import Git.Command import Git.Sha import Git.Types -import Data.Char (chr) +import Data.Char (chr, ord) +import qualified Data.ByteString as S headRef :: Ref headRef = Ref "HEAD" headFile :: Repo -> FilePath -headFile r = localGitDir r "HEAD" +headFile r = fromRawFilePath (localGitDir r) "HEAD" setHeadRef :: Ref -> Repo -> IO () setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref) @@ -33,11 +36,18 @@ describe = fromRef . base - Converts such a fully qualified ref into a base ref - (eg: master or origin/master). -} base :: Ref -> Ref -base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef +base = removeBase "refs/heads/" . removeBase "refs/remotes/" + +{- Removes a directory such as "refs/heads/master" from a + - fully qualified ref. Any ref not starting with it is left as-is. -} +removeBase :: String -> Ref -> Ref +removeBase dir (Ref r) + | prefix `isPrefixOf` r = Ref (drop (length prefix) r) + | otherwise = Ref r where - remove prefix s - | prefix `isPrefixOf` s = drop (length prefix) s - | otherwise = s + prefix = case end dir of + ['/'] -> dir + _ -> dir ++ "/" {- Given a directory such as "refs/remotes/origin", and a ref such as - refs/heads/master, yields a version of that ref under the directory, @@ -55,8 +65,8 @@ branchRef = underBase "refs/heads" - Prefixing the file with ./ makes this work even if in a subdirectory - of a repo. -} -fileRef :: FilePath -> Ref -fileRef f = Ref $ ":./" ++ f +fileRef :: RawFilePath -> Ref +fileRef f = Ref $ ":./" ++ fromRawFilePath f {- Converts a Ref to refer to the content of the Ref on a given date. -} dateRef :: Ref -> RefDate -> Ref @@ -64,7 +74,7 @@ dateRef (Ref r) (RefDate d) = Ref $ r ++ "@" ++ d {- A Ref that can be used to refer to a file in the repository as it - appears in a given Ref. -} -fileFromRef :: Ref -> FilePath -> Ref +fileFromRef :: Ref -> RawFilePath -> Ref fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr) {- Checks if a ref exists. -} @@ -75,24 +85,29 @@ exists ref = runBool {- The file used to record a ref. (Git also stores some refs in a - packed-refs file.) -} file :: Ref -> Repo -> FilePath -file ref repo = localGitDir repo fromRef ref +file ref repo = fromRawFilePath (localGitDir repo) fromRef ref {- Checks if HEAD exists. It generally will, except for in a repository - that was just created. -} headExists :: Repo -> IO Bool headExists repo = do - ls <- lines <$> pipeReadStrict [Param "show-ref", Param "--head"] repo - return $ any (" HEAD" `isSuffixOf`) ls + ls <- S.split nl <$> pipeReadStrict [Param "show-ref", Param "--head"] repo + return $ any (" HEAD" `S.isSuffixOf`) ls + where + nl = fromIntegral (ord '\n') {- Get the sha of a fully qualified git ref, if it exists. -} sha :: Branch -> Repo -> IO (Maybe Sha) sha branch repo = process <$> showref repo where - showref = pipeReadStrict [Param "show-ref", - Param "--hash", -- get the hash - Param $ fromRef branch] - process [] = Nothing - process s = Just $ Ref $ firstLine s + showref = pipeReadStrict + [ Param "show-ref" + , Param "--hash" -- get the hash + , Param $ fromRef branch + ] + process s + | S.null s = Nothing + | otherwise = Just $ Ref $ decodeBS' $ firstLine' s headSha :: Repo -> IO (Maybe Sha) headSha = sha headRef @@ -107,7 +122,7 @@ matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo {- List of (shas, branches) matching a given ref spec. -} matching' :: [String] -> Repo -> IO [(Sha, Branch)] -matching' ps repo = map gen . lines <$> +matching' ps repo = map gen . lines . decodeBS' <$> pipeReadStrict (Param "show-ref" : map Param ps) repo where gen l = let (r, b) = separate (== ' ') l @@ -134,10 +149,13 @@ delete oldvalue ref = run , Param $ fromRef oldvalue ] -{- Gets the sha of the tree a ref uses. -} +{- Gets the sha of the tree a ref uses. + - + - The ref may be something like a branch name, and it could contain + - ":subdir" if a subtree is wanted. -} tree :: Ref -> Repo -> IO (Maybe Sha) -tree (Ref ref) = extractSha <$$> pipeReadStrict - [ Param "rev-parse", Param ref' ] +tree (Ref ref) = extractSha . decodeBS <$$> pipeReadStrict + [ Param "rev-parse", Param "--verify", Param "--quiet", Param ref' ] where ref' = if ":" `isInfixOf` ref then ref diff --git a/Git/RefLog.hs b/Git/RefLog.hs index 57f35e9..7ba8713 100644 --- a/Git/RefLog.hs +++ b/Git/RefLog.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.RefLog where @@ -21,7 +21,7 @@ getMulti :: [Branch] -> Repo -> IO [Sha] getMulti bs = get' (map (Param . fromRef) bs) get' :: [CommandParam] -> Repo -> IO [Sha] -get' ps = mapMaybe extractSha . lines <$$> pipeReadStrict ps' +get' ps = mapMaybe extractSha . lines . decodeBS <$$> pipeReadStrict ps' where ps' = catMaybes [ Just $ Param "log" diff --git a/Git/Remote.hs b/Git/Remote.hs index f6eaf93..69d6b52 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -2,10 +2,11 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Git.Remote where @@ -15,11 +16,22 @@ import Git.Types import Data.Char import qualified Data.Map as M +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import Network.URI #ifdef mingw32_HOST_OS import Git.FilePath #endif +{- Is a git config key one that specifies the location of a remote? -} +isRemoteKey :: ConfigKey -> Bool +isRemoteKey (ConfigKey k) = "remote." `S.isPrefixOf` k && ".url" `S.isSuffixOf` k + +{- Get a remote's name from the config key that specifies its location. -} +remoteKeyToRemoteName :: ConfigKey -> RemoteName +remoteKeyToRemoteName (ConfigKey k) = decodeBS' $ + S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k + {- Construct a legal git remote name out of an arbitrary input string. - - There seems to be no formal definition of this in the git source, @@ -43,6 +55,7 @@ makeLegalName s = case filter legal $ replace "/" "_" s of legal c = isAlphaNum c data RemoteLocation = RemoteUrl String | RemotePath FilePath + deriving (Eq) remoteLocationIsUrl :: RemoteLocation -> Bool remoteLocationIsUrl (RemoteUrl _) = True @@ -67,16 +80,16 @@ parseRemoteLocation s repo = ret $ calcloc s -- insteadof config can rewrite remote location calcloc l | null insteadofs = l - | otherwise = replacement ++ drop (length bestvalue) l + | otherwise = replacement ++ drop (S.length bestvalue) l where - replacement = drop (length prefix) $ - take (length bestkey - length suffix) bestkey - (bestkey, bestvalue) = maximumBy longestvalue insteadofs + replacement = decodeBS' $ S.drop (S.length prefix) $ + S.take (S.length bestkey - S.length suffix) bestkey + (ConfigKey bestkey, ConfigValue bestvalue) = maximumBy longestvalue insteadofs longestvalue (_, a) (_, b) = compare b a - insteadofs = filterconfig $ \(k, v) -> - prefix `isPrefixOf` k && - suffix `isSuffixOf` k && - v `isPrefixOf` l + insteadofs = filterconfig $ \(ConfigKey k, ConfigValue v) -> + prefix `S.isPrefixOf` k && + suffix `S.isSuffixOf` k && + v `S.isPrefixOf` encodeBS l filterconfig f = filter f $ concatMap splitconfigs $ M.toList $ fullconfig repo splitconfigs (k, vs) = map (\v -> (k, v)) vs @@ -104,5 +117,5 @@ parseRemoteLocation s repo = ret $ calcloc s -- git on Windows will write a path to .git/config with "drive:", -- which is not to be confused with a "host:" dosstyle = hasDrive - dospath = fromInternalGitPath + dospath = fromRawFilePath . fromInternalGitPath . toRawFilePath #endif diff --git a/Git/Repair.hs b/Git/Repair.hs index 8e43248..66e6811 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Repair ( @@ -11,7 +11,6 @@ module Git.Repair ( removeBadBranches, successfulRepair, cleanCorruptObjects, - retrieveMissingObjects, resetLocalBranches, checkIndex, checkIndexFast, @@ -36,7 +35,7 @@ import qualified Git.Ref as Ref import qualified Git.RefLog as RefLog import qualified Git.UpdateIndex as UpdateIndex import qualified Git.Branch as Branch -import Utility.Tmp +import Utility.Tmp.Dir import Utility.Rsync import Utility.FileMode import Utility.Tuple @@ -102,10 +101,11 @@ retrieveMissingObjects missing referencerepo r unlessM (boolSystem "git" [Param "init", File tmpdir]) $ error $ "failed to create temp repository in " ++ tmpdir tmpr <- Config.read =<< Construct.fromAbsPath tmpdir - stillmissing <- pullremotes tmpr (remotes r) fetchrefstags missing + rs <- Construct.fromRemotes r + stillmissing <- pullremotes tmpr rs fetchrefstags missing if S.null (knownMissing stillmissing) then return stillmissing - else pullremotes tmpr (remotes r) fetchallrefs stillmissing + else pullremotes tmpr rs fetchallrefs stillmissing where pullremotes tmpr [] fetchrefs stillmissing = case referencerepo of Nothing -> return stillmissing @@ -227,7 +227,7 @@ badBranches missing r = filterM isbad =<< getAllRefs r - Relies on packed refs being exploded before it's called. -} getAllRefs :: Repo -> IO [Ref] -getAllRefs r = getAllRefs' (localGitDir r "refs") +getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) "refs") getAllRefs' :: FilePath -> IO [Ref] getAllRefs' refdir = do @@ -245,13 +245,13 @@ explodePackedRefsFile r = do nukeFile f where makeref (sha, ref) = do - let dest = localGitDir r fromRef ref + let dest = fromRawFilePath (localGitDir r) fromRef ref createDirectoryIfMissing True (parentDir dest) unlessM (doesFileExist dest) $ writeFile dest (fromRef sha) packedRefsFile :: Repo -> FilePath -packedRefsFile r = localGitDir r "packed-refs" +packedRefsFile r = fromRawFilePath (localGitDir r) "packed-refs" parsePacked :: String -> Maybe (Sha, Ref) parsePacked l = case words l of @@ -263,7 +263,7 @@ parsePacked l = case words l of {- git-branch -d cannot be used to remove a branch that is directly - pointing to a corrupt commit. -} nukeBranchRef :: Branch -> Repo -> IO () -nukeBranchRef b r = nukeFile $ localGitDir r fromRef b +nukeBranchRef b r = nukeFile $ fromRawFilePath (localGitDir r) fromRef b {- Finds the most recent commit to a branch that does not need any - of the missing objects. If the input branch is good as-is, returns it. @@ -284,7 +284,7 @@ findUncorruptedCommit missing goodcommits branch r = do , Param "--format=%H" , Param (fromRef branch) ] r - let branchshas = catMaybes $ map extractSha ls + let branchshas = catMaybes $ map (extractSha . decodeBL) ls reflogshas <- RefLog.get branch r -- XXX Could try a bit harder here, and look -- for uncorrupted old commits in branches in the @@ -313,7 +313,7 @@ verifyCommit missing goodcommits commit r , Param "--format=%H %T" , Param (fromRef commit) ] r - let committrees = map parse ls + let committrees = map (parse . decodeBL) ls if any isNothing committrees || null committrees then do void cleanup @@ -341,8 +341,8 @@ verifyTree :: MissingObjects -> Sha -> Repo -> IO Bool verifyTree missing treesha r | S.member treesha missing = return False | otherwise = do - (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams treesha []) r - let objshas = map (LsTree.sha . LsTree.parseLsTree) ls + (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive treesha []) r + let objshas = mapMaybe (LsTree.sha <$$> eitherToMaybe . LsTree.parseLsTree) ls if any (`S.member` missing) objshas then do void cleanup @@ -370,7 +370,7 @@ checkIndexFast r = do length indexcontents `seq` cleanup missingIndex :: Repo -> IO Bool -missingIndex r = not <$> doesFileExist (localGitDir r "index") +missingIndex r = not <$> doesFileExist (fromRawFilePath (localGitDir r) "index") {- Finds missing and ok files staged in the index. -} partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool) @@ -394,12 +394,12 @@ rewriteIndex r UpdateIndex.streamUpdateIndex r =<< (catMaybes <$> mapM reinject good) void cleanup - return $ map fst3 bad + return $ map (fromRawFilePath . fst3) bad where - reinject (file, Just sha, Just mode) = case toBlobType mode of + reinject (file, Just sha, Just mode) = case toTreeItemType mode of Nothing -> return Nothing - Just blobtype -> Just <$> - UpdateIndex.stageFile sha blobtype file r + Just treeitemtype -> Just <$> + UpdateIndex.stageFile sha treeitemtype (fromRawFilePath file) r reinject _ = return Nothing newtype GoodCommits = GoodCommits (S.Set Sha) @@ -446,7 +446,7 @@ preRepair g = do let f = indexFile g void $ tryIO $ allowWrite f where - headfile = localGitDir g "HEAD" + headfile = fromRawFilePath (localGitDir g) "HEAD" validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s) {- Put it all together. -} diff --git a/Git/Sha.hs b/Git/Sha.hs index b802c85..cc33cac 100644 --- a/Git/Sha.hs +++ b/Git/Sha.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Sha where diff --git a/Git/Types.hs b/Git/Types.hs index 327c1d7..9c2754a 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -1,16 +1,23 @@ {- git data types - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Git.Types where import Network.URI +import Data.String +import Data.Default import qualified Data.Map as M +import qualified Data.ByteString as S import System.Posix.Types import Utility.SafeCommand +import Utility.FileSystemEncoding {- Support repositories on local disk, and repositories accessed via an URL. - @@ -23,19 +30,19 @@ import Utility.SafeCommand - else known about it. -} data RepoLocation - = Local { gitdir :: FilePath, worktree :: Maybe FilePath } - | LocalUnknown FilePath + = Local { gitdir :: RawFilePath, worktree :: Maybe RawFilePath } + | LocalUnknown RawFilePath | Url URI | Unknown deriving (Show, Eq, Ord) data Repo = Repo { location :: RepoLocation - , config :: M.Map String String + , config :: M.Map ConfigKey ConfigValue -- a given git config key can actually have multiple values - , fullconfig :: M.Map String [String] - , remotes :: [Repo] - -- remoteName holds the name used for this repo in remotes + , fullconfig :: M.Map ConfigKey [ConfigValue] + -- remoteName holds the name used for this repo in some other + -- repo's list of remotes, when this repo is such a remote , remoteName :: Maybe RemoteName -- alternate environment to use when running git commands , gitEnv :: Maybe [(String, String)] @@ -44,6 +51,33 @@ data Repo = Repo , gitGlobalOpts :: [CommandParam] } deriving (Show, Eq, Ord) +newtype ConfigKey = ConfigKey S.ByteString + deriving (Ord, Eq) + +newtype ConfigValue = ConfigValue S.ByteString + deriving (Ord, Eq, Semigroup, Monoid) + +instance Default ConfigValue where + def = ConfigValue mempty + +fromConfigKey :: ConfigKey -> String +fromConfigKey (ConfigKey s) = decodeBS' s + +instance Show ConfigKey where + show = fromConfigKey + +fromConfigValue :: ConfigValue -> String +fromConfigValue (ConfigValue s) = decodeBS' s + +instance Show ConfigValue where + show = fromConfigValue + +instance IsString ConfigKey where + fromString = ConfigKey . encodeBS' + +instance IsString ConfigValue where + fromString = ConfigValue . encodeBS' + type RemoteName = String {- A git ref. Can be a sha1, or a branch or tag name. -} @@ -64,45 +98,48 @@ newtype RefDate = RefDate String {- Types of objects that can be stored in git. -} data ObjectType = BlobObject | CommitObject | TreeObject - deriving (Eq) - -instance Show ObjectType where - show BlobObject = "blob" - show CommitObject = "commit" - show TreeObject = "tree" -readObjectType :: String -> Maybe ObjectType +readObjectType :: S.ByteString -> Maybe ObjectType readObjectType "blob" = Just BlobObject readObjectType "commit" = Just CommitObject readObjectType "tree" = Just TreeObject readObjectType _ = Nothing -{- Types of blobs. -} -data BlobType = FileBlob | ExecutableBlob | SymlinkBlob - deriving (Eq) - -{- Git uses magic numbers to denote the type of a blob. -} -instance Show BlobType where - show FileBlob = "100644" - show ExecutableBlob = "100755" - show SymlinkBlob = "120000" - -readBlobType :: String -> Maybe BlobType -readBlobType "100644" = Just FileBlob -readBlobType "100755" = Just ExecutableBlob -readBlobType "120000" = Just SymlinkBlob -readBlobType _ = Nothing - -toBlobType :: FileMode -> Maybe BlobType -toBlobType 0o100644 = Just FileBlob -toBlobType 0o100755 = Just ExecutableBlob -toBlobType 0o120000 = Just SymlinkBlob -toBlobType _ = Nothing - -fromBlobType :: BlobType -> FileMode -fromBlobType FileBlob = 0o100644 -fromBlobType ExecutableBlob = 0o100755 -fromBlobType SymlinkBlob = 0o120000 +fmtObjectType :: ObjectType -> S.ByteString +fmtObjectType BlobObject = "blob" +fmtObjectType CommitObject = "commit" +fmtObjectType TreeObject = "tree" + +{- Types of items in a tree. -} +data TreeItemType = TreeFile | TreeExecutable | TreeSymlink | TreeSubmodule + deriving (Eq, Show) + +{- Git uses magic numbers to denote the type of a tree item. -} +readTreeItemType :: S.ByteString -> Maybe TreeItemType +readTreeItemType "100644" = Just TreeFile +readTreeItemType "100755" = Just TreeExecutable +readTreeItemType "120000" = Just TreeSymlink +readTreeItemType "160000" = Just TreeSubmodule +readTreeItemType _ = Nothing + +fmtTreeItemType :: TreeItemType -> S.ByteString +fmtTreeItemType TreeFile = "100644" +fmtTreeItemType TreeExecutable = "100755" +fmtTreeItemType TreeSymlink = "120000" +fmtTreeItemType TreeSubmodule = "160000" + +toTreeItemType :: FileMode -> Maybe TreeItemType +toTreeItemType 0o100644 = Just TreeFile +toTreeItemType 0o100755 = Just TreeExecutable +toTreeItemType 0o120000 = Just TreeSymlink +toTreeItemType 0o160000 = Just TreeSubmodule +toTreeItemType _ = Nothing + +fromTreeItemType :: TreeItemType -> FileMode +fromTreeItemType TreeFile = 0o100644 +fromTreeItemType TreeExecutable = 0o100755 +fromTreeItemType TreeSymlink = 0o120000 +fromTreeItemType TreeSubmodule = 0o160000 data Commit = Commit { commitTree :: Sha diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 7fdc945..9f07cf5 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -1,11 +1,11 @@ {- git-update-index library - - - Copyright 2011-2013 Joey Hess + - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE BangPatterns, CPP #-} +{-# LANGUAGE BangPatterns, OverloadedStrings, CPP #-} module Git.UpdateIndex ( Streamer, @@ -21,6 +21,7 @@ module Git.UpdateIndex ( unstageFile, stageSymlink, stageDiffTreeItem, + refreshIndex, ) where import Common @@ -31,12 +32,14 @@ import Git.FilePath import Git.Sha import qualified Git.DiffTreeItem as Diff +import qualified Data.ByteString.Lazy as L + {- 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 () +type Streamer = (L.ByteString -> IO ()) -> IO () {- A streamer with a precalculated value. -} -pureStreamer :: String -> Streamer +pureStreamer :: L.ByteString -> Streamer pureStreamer !s = \streamer -> streamer s {- Streams content into update-index from a list of Streamers. -} @@ -48,8 +51,8 @@ data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO () streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do - hPutStr h s - hPutStr h "\0" + L.hPutStr h s + L.hPutStr h "\0" startUpdateIndex :: Repo -> IO UpdateIndexHandle startUpdateIndex repo = do @@ -83,38 +86,66 @@ lsSubTree (Ref x) p repo streamer = do {- Generates a line suitable to be fed into update-index, to add - a given file with a given sha. -} -updateIndexLine :: Sha -> BlobType -> TopFilePath -> String -updateIndexLine sha filetype file = - show filetype ++ " blob " ++ fromRef sha ++ "\t" ++ indexPath file - -stageFile :: Sha -> BlobType -> FilePath -> Repo -> IO Streamer -stageFile sha filetype file repo = do - p <- toTopFilePath file repo - return $ pureStreamer $ updateIndexLine sha filetype p +updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> L.ByteString +updateIndexLine sha treeitemtype file = L.fromStrict $ + fmtTreeItemType treeitemtype + <> " blob " + <> encodeBS (fromRef sha) + <> "\t" + <> indexPath file + +stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer +stageFile sha treeitemtype file repo = do + p <- toTopFilePath (toRawFilePath file) repo + return $ pureStreamer $ updateIndexLine sha treeitemtype p {- A streamer that removes a file from the index. -} unstageFile :: FilePath -> Repo -> IO Streamer unstageFile file repo = do - p <- toTopFilePath file repo + p <- toTopFilePath (toRawFilePath file) repo return $ unstageFile' p unstageFile' :: TopFilePath -> Streamer -unstageFile' p = pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p +unstageFile' p = pureStreamer $ L.fromStrict $ + "0 " + <> encodeBS' (fromRef nullSha) + <> "\t" + <> indexPath p {- A streamer that adds a symlink to the index. -} stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer stageSymlink file sha repo = do !line <- updateIndexLine <$> pure sha - <*> pure SymlinkBlob - <*> toTopFilePath file repo + <*> pure TreeSymlink + <*> toTopFilePath (toRawFilePath file) repo return $ pureStreamer line {- A streamer that applies a DiffTreeItem to the index. -} stageDiffTreeItem :: Diff.DiffTreeItem -> Streamer -stageDiffTreeItem d = case toBlobType (Diff.dstmode d) of +stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of Nothing -> unstageFile' (Diff.file d) Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d) indexPath :: TopFilePath -> InternalGitPath indexPath = toInternalGitPath . getTopFilePath + +{- Refreshes the index, by checking file stat information. -} +refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool +refreshIndex repo feeder = do + (Just h, _, _, p) <- createProcess (gitCreateProcess params repo) + { std_in = CreatePipe } + feeder $ \f -> do + hPutStr h f + hPutStr h "\0" + hFlush h + hClose h + checkSuccessProcess p + where + params = + [ Param "update-index" + , Param "-q" + , Param "--refresh" + , Param "-z" + , Param "--stdin" + ] diff --git a/Git/Url.hs b/Git/Url.hs index fa7d200..8430655 100644 --- a/Git/Url.hs +++ b/Git/Url.hs @@ -2,7 +2,7 @@ - - Copyright 2010, 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Url ( @@ -11,9 +11,10 @@ module Git.Url ( port, hostuser, authority, + path, ) where -import Network.URI hiding (scheme, authority) +import Network.URI hiding (scheme, authority, path) import Common import Git.Types @@ -66,6 +67,11 @@ authpart :: (URIAuth -> a) -> Repo -> Maybe a authpart a Repo { location = Url u } = a <$> uriAuthority u authpart _ repo = notUrl repo +{- Path part of an URL repo. -} +path :: Repo -> FilePath +path Repo { location = Url u } = uriPath u +path repo = notUrl repo + notUrl :: Repo -> a notUrl repo = error $ "acting on local git repo " ++ repoDescribe repo ++ " not supported" diff --git a/Git/Version.hs b/Git/Version.hs index 19ff945..5ecaca0 100644 --- a/Git/Version.hs +++ b/Git/Version.hs @@ -2,7 +2,7 @@ - - Copyright 2011, 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# OPTIONS_GHC -fno-warn-tabs #-} diff --git a/Utility/Applicative.hs b/Utility/Applicative.hs index fce3c04..fcd6932 100644 --- a/Utility/Applicative.hs +++ b/Utility/Applicative.hs @@ -5,7 +5,11 @@ - License: BSD-2-clause -} -module Utility.Applicative where +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Applicative ( + (<$$>), +) where {- Like <$> , but supports one level of currying. - diff --git a/Utility/Attoparsec.hs b/Utility/Attoparsec.hs new file mode 100644 index 0000000..bd20e8e --- /dev/null +++ b/Utility/Attoparsec.hs @@ -0,0 +1,21 @@ +{- attoparsec utility functions + - + - Copyright 2019 Joey Hess + - Copyright 2007-2015 Bryan O'Sullivan + - + - License: BSD-3-clause + -} + +module Utility.Attoparsec where + +import qualified Data.Attoparsec.ByteString as A +import qualified Data.ByteString as B + +-- | Parse and decode an unsigned octal number. +-- +-- This parser does not accept a leading @\"0o\"@ string. +octal :: Integral a => A.Parser a +octal = B.foldl' step 0 `fmap` A.takeWhile1 isOctDigit + where + isOctDigit w = w >= 48 && w <= 55 + step a w = a * 8 + fromIntegral (w - 48) diff --git a/Utility/Batch.hs b/Utility/Batch.hs index d96f9d3..1d66881 100644 --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -7,11 +7,18 @@ {-# LANGUAGE CPP #-} -module Utility.Batch where +module Utility.Batch ( + batch, + BatchCommandMaker, + getBatchCommandMaker, + toBatchCommand, + batchCommand, + batchCommandEnv, +) where import Common -#if defined(linux_HOST_OS) || defined(__ANDROID__) +#if defined(linux_HOST_OS) import Control.Concurrent.Async import System.Posix.Process #endif @@ -29,7 +36,7 @@ import qualified Control.Exception as E - systems, the action is simply ran. -} batch :: IO a -> IO a -#if defined(linux_HOST_OS) || defined(__ANDROID__) +#if defined(linux_HOST_OS) batch a = wait =<< batchthread where batchthread = asyncBound $ do @@ -51,11 +58,7 @@ getBatchCommandMaker = do #ifndef mingw32_HOST_OS nicers <- filterM (inPath . fst) [ ("nice", []) -#ifndef __ANDROID__ - -- Android's ionice does not allow specifying a command, - -- so don't use it. , ("ionice", ["-c3"]) -#endif , ("nocache", []) ] return $ \(command, params) -> diff --git a/Utility/Data.hs b/Utility/Data.hs index 27c0a82..5510845 100644 --- a/Utility/Data.hs +++ b/Utility/Data.hs @@ -7,7 +7,10 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Data where +module Utility.Data ( + firstJust, + eitherToMaybe, +) where {- First item in the list that is not Nothing. -} firstJust :: Eq a => [Maybe a] -> Maybe a diff --git a/Utility/Directory.hs b/Utility/Directory.hs index 895581d..e2c6a94 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -18,15 +18,11 @@ import Control.Monad import System.FilePath import System.PosixCompat.Files import Control.Applicative -import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO) import Data.Maybe import Prelude -#ifdef mingw32_HOST_OS -import qualified System.Win32 as Win32 -#else -import qualified System.Posix as Posix +#ifndef mingw32_HOST_OS import Utility.SafeCommand import Control.Monad.IfElse #endif @@ -158,90 +154,3 @@ nukeFile file = void $ tryWhenExists go #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/DottedVersion.hs b/Utility/DottedVersion.hs index 3198b1c..dff3717 100644 --- a/Utility/DottedVersion.hs +++ b/Utility/DottedVersion.hs @@ -7,7 +7,11 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.DottedVersion where +module Utility.DottedVersion ( + DottedVersion, + fromDottedVersion, + normalize, +) where import Common @@ -18,7 +22,10 @@ instance Ord DottedVersion where compare (DottedVersion _ x) (DottedVersion _ y) = compare x y instance Show DottedVersion where - show (DottedVersion s _) = s + show = fromDottedVersion + +fromDottedVersion :: DottedVersion -> String +fromDottedVersion (DottedVersion s _) = s {- To compare dotted versions like 1.7.7 and 1.8, they are normalized to - a somewhat arbitrary integer representation. -} diff --git a/Utility/Env.hs b/Utility/Env.hs index c56f4ec..9847326 100644 --- a/Utility/Env.hs +++ b/Utility/Env.hs @@ -8,7 +8,14 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Env where +module Utility.Env ( + getEnv, + getEnvDefault, + getEnvironment, + addEntry, + addEntries, + delEntry, +) where #ifdef mingw32_HOST_OS import Utility.Exception @@ -16,7 +23,6 @@ import Control.Applicative import Data.Maybe import Prelude import qualified System.Environment as E -import qualified System.SetEnv #else import qualified System.Posix.Env as PE #endif @@ -42,29 +48,6 @@ getEnvironment = PE.getEnvironment getEnvironment = E.getEnvironment #endif -{- Sets an environment variable. To overwrite an existing variable, - - overwrite must be True. - - - - On Windows, setting a variable to "" unsets it. -} -setEnv :: String -> String -> Bool -> IO () -#ifndef mingw32_HOST_OS -setEnv var val overwrite = PE.setEnv var val overwrite -#else -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 - -unsetEnv :: String -> IO () -#ifndef mingw32_HOST_OS -unsetEnv = PE.unsetEnv -#else -unsetEnv = System.SetEnv.unsetEnv -#endif - {- Adds the environment variable to the input environment. If already - present in the list, removes the old value. - diff --git a/Utility/Env/Basic.hs b/Utility/Env/Basic.hs new file mode 100644 index 0000000..db73827 --- /dev/null +++ b/Utility/Env/Basic.hs @@ -0,0 +1,25 @@ +{- portable environment variables, without any dependencies + - + - Copyright 2013 Joey Hess + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Env.Basic ( + getEnv, + getEnvDefault, +) where + +import Utility.Exception +import Control.Applicative +import Data.Maybe +import Prelude +import qualified System.Environment as E + +getEnv :: String -> IO (Maybe String) +getEnv = catchMaybeIO . E.getEnv + +getEnvDefault :: String -> String -> IO String +getEnvDefault var fallback = fromMaybe fallback <$> getEnv var diff --git a/Utility/Env/Set.hs b/Utility/Env/Set.hs new file mode 100644 index 0000000..f14674c --- /dev/null +++ b/Utility/Env/Set.hs @@ -0,0 +1,43 @@ +{- portable environment variables + - + - Copyright 2013 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.Env.Set ( + setEnv, + unsetEnv, +) where + +#ifdef mingw32_HOST_OS +import qualified System.SetEnv +import Utility.Env +#else +import qualified System.Posix.Env as PE +#endif + +{- Sets an environment variable. To overwrite an existing variable, + - overwrite must be True. + - + - On Windows, setting a variable to "" unsets it. -} +setEnv :: String -> String -> Bool -> IO () +#ifndef mingw32_HOST_OS +setEnv var val overwrite = PE.setEnv var val overwrite +#else +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 + +unsetEnv :: String -> IO () +#ifndef mingw32_HOST_OS +unsetEnv = PE.unsetEnv +#else +unsetEnv = System.SetEnv.unsetEnv +#endif diff --git a/Utility/Exception.hs b/Utility/Exception.hs index 67c2e85..bcadb78 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -5,7 +5,7 @@ - License: BSD-2-clause -} -{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Exception ( @@ -29,11 +29,7 @@ module Utility.Exception ( import Control.Monad.Catch as X hiding (Handler) import qualified Control.Monad.Catch as M import Control.Exception (IOException, AsyncException) -#ifdef MIN_VERSION_GLASGOW_HASKELL -#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) import Control.Exception (SomeAsyncException) -#endif -#endif import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError, ioeGetErrorType) @@ -46,15 +42,7 @@ import Utility.Data - 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 @@ -95,11 +83,7 @@ bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup) catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchNonAsync a onerr = a `catches` [ M.Handler (\ (e :: AsyncException) -> throwM e) -#ifdef MIN_VERSION_GLASGOW_HASKELL -#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) , M.Handler (\ (e :: SomeAsyncException) -> throwM e) -#endif -#endif , M.Handler (\ (e :: SomeException) -> onerr e) ] diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index 370bcf6..7d36c55 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -17,7 +17,7 @@ import Control.Monad import System.PosixCompat.Types import System.PosixCompat.Files #ifndef mingw32_HOST_OS -import System.Posix.Files +import System.Posix.Files (symbolicLinkMode) import Control.Monad.IO.Class (liftIO) #endif import Control.Monad.IO.Class (MonadIO) @@ -69,6 +69,7 @@ otherGroupModes :: [FileMode] otherGroupModes = [ groupReadMode, otherReadMode , groupWriteMode, otherWriteMode + , groupExecuteMode, otherExecuteMode ] {- Removes the write bits from a file. -} diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs index 5f89cff..8544ad4 100644 --- a/Utility/FileSize.hs +++ b/Utility/FileSize.hs @@ -4,8 +4,13 @@ -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.FileSize where +module Utility.FileSize ( + FileSize, + getFileSize, + getFileSize', +) where import System.PosixCompat.Files #ifdef mingw32_HOST_OS @@ -28,7 +33,10 @@ getFileSize f = fmap (fromIntegral . fileSize) (getFileStatus f) getFileSize f = bracket (openFile f ReadMode) hClose hFileSize #endif -{- Gets the size of the file, when its FileStatus is already known. -} +{- Gets the size of the file, when its FileStatus is already known. + - + - On windows, uses getFileSize. Otherwise, the FileStatus contains the + - size, so this does not do any work. -} getFileSize' :: FilePath -> FileStatus -> IO FileSize #ifndef mingw32_HOST_OS getFileSize' _ s = return $ fromIntegral $ fileSize s diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index 444dc4a..f9e9814 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -12,12 +12,17 @@ module Utility.FileSystemEncoding ( useFileSystemEncoding, fileEncoding, withFilePath, + RawFilePath, + fromRawFilePath, + toRawFilePath, + decodeBL, + encodeBL, decodeBS, encodeBS, - decodeW8, - encodeW8, - encodeW8NUL, - decodeW8NUL, + decodeBL', + encodeBL', + decodeBS', + encodeBS', truncateFilePath, s2w8, w82s, @@ -32,8 +37,10 @@ import System.IO import System.IO.Unsafe import Data.Word import Data.List +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS +import qualified Data.ByteString.UTF8 as S8 import qualified Data.ByteString.Lazy.UTF8 as L8 #endif @@ -103,31 +110,91 @@ _encodeFilePath fp = unsafePerformIO $ do `catchNonAsync` (\_ -> return fp) {- Decodes a ByteString into a FilePath, applying the filesystem encoding. -} -decodeBS :: L.ByteString -> FilePath +decodeBL :: L.ByteString -> FilePath #ifndef mingw32_HOST_OS -decodeBS = encodeW8NUL . L.unpack +decodeBL = encodeW8NUL . L.unpack #else {- On Windows, we assume that the ByteString is utf-8, since Windows - only uses unicode for filenames. -} -decodeBS = L8.toString +decodeBL = L8.toString #endif {- Encodes a FilePath into a ByteString, applying the filesystem encoding. -} -encodeBS :: FilePath -> L.ByteString +encodeBL :: FilePath -> L.ByteString #ifndef mingw32_HOST_OS -encodeBS = L.pack . decodeW8NUL +encodeBL = L.pack . decodeW8NUL #else -encodeBS = L8.fromString +encodeBL = L8.fromString #endif +decodeBS :: S.ByteString -> FilePath +#ifndef mingw32_HOST_OS +decodeBS = encodeW8NUL . S.unpack +#else +decodeBS = S8.toString +#endif + +encodeBS :: FilePath -> S.ByteString +#ifndef mingw32_HOST_OS +encodeBS = S.pack . decodeW8NUL +#else +encodeBS = S8.fromString +#endif + +{- Faster version that assumes the string does not contain NUL; + - if it does it will be truncated before the NUL. -} +decodeBS' :: S.ByteString -> FilePath +#ifndef mingw32_HOST_OS +decodeBS' = encodeW8 . S.unpack +#else +decodeBS' = S8.toString +#endif + +encodeBS' :: FilePath -> S.ByteString +#ifndef mingw32_HOST_OS +encodeBS' = S.pack . decodeW8 +#else +encodeBS' = S8.fromString +#endif + +decodeBL' :: L.ByteString -> FilePath +#ifndef mingw32_HOST_OS +decodeBL' = encodeW8 . L.unpack +#else +decodeBL' = L8.toString +#endif + +encodeBL' :: FilePath -> L.ByteString +#ifndef mingw32_HOST_OS +encodeBL' = L.pack . decodeW8 +#else +encodeBL' = L8.fromString +#endif + +{- Recent versions of the unix package have this alias; defined here + - for backwards compatibility. -} +type RawFilePath = S.ByteString + +{- Note that the RawFilePath is assumed to never contain NUL, + - since filename's don't. This should only be used with actual + - RawFilePaths not arbitrary ByteString that may contain NUL. -} +fromRawFilePath :: RawFilePath -> FilePath +fromRawFilePath = decodeBS' + +{- Note that the FilePath is assumed to never contain NUL, + - since filename's don't. This should only be used with actual FilePaths + - not arbitrary String that may contain NUL. -} +toRawFilePath :: FilePath -> RawFilePath +toRawFilePath = encodeBS' + {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding. - - - w82c produces a String, which may contain Chars that are invalid + - w82s 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. + - cannot contain embedded NUL, but Haskell Strings may. -} {-# NOINLINE encodeW8 #-} encodeW8 :: [Word8] -> FilePath @@ -135,8 +202,6 @@ encodeW8 w8 = unsafePerformIO $ do enc <- Encoding.getFileSystemEncoding GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc -{- Useful when you want the actual number of bytes that will be used to - - represent the FilePath on disk. -} decodeW8 :: FilePath -> [Word8] decodeW8 = s2w8 . _encodeFilePath diff --git a/Utility/Format.hs b/Utility/Format.hs index 3670cd7..a2470fa 100644 --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -15,7 +15,7 @@ module Utility.Format ( ) where import Text.Printf (printf) -import Data.Char (isAlphaNum, isOctDigit, isHexDigit, isSpace, chr, ord) +import Data.Char (isAlphaNum, isOctDigit, isHexDigit, isSpace, chr, ord, isAscii) import Data.Maybe (fromMaybe) import Data.Word (Word8) import Data.List (isPrefixOf) @@ -176,12 +176,12 @@ encode_c' p = concatMap echar {- For quickcheck. - - Encoding and then decoding roundtrips only when - - the string does not contain high unicode, because eg, - - both "\12345" and "\227\128\185" are encoded to "\343\200\271". + - the string is ascii because eg, both "\12345" and + - "\227\128\185" are encoded to "\343\200\271". - - - This property papers over the problem, by only testing chars < 256. + - This property papers over the problem, by only testing ascii. -} prop_encode_c_decode_c_roundtrip :: String -> Bool prop_encode_c_decode_c_roundtrip s = s' == decode_c (encode_c s') where - s' = filter (\c -> ord c < 256) s + s' = filter isAscii s diff --git a/Utility/HumanNumber.hs b/Utility/HumanNumber.hs index c3fede9..6143cef 100644 --- a/Utility/HumanNumber.hs +++ b/Utility/HumanNumber.hs @@ -5,7 +5,7 @@ - License: BSD-2-clause -} -module Utility.HumanNumber where +module Utility.HumanNumber (showImprecise) where {- Displays a fractional value as a string with a limited number - of decimal digits. -} diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs index fe7cf22..01fbeac 100644 --- a/Utility/HumanTime.hs +++ b/Utility/HumanTime.hs @@ -60,15 +60,17 @@ parseDuration = maybe parsefail (return . Duration) . go 0 fromDuration :: Duration -> String fromDuration Duration { durationSeconds = d } | d == 0 = "0s" - | otherwise = concatMap showunit $ go [] units d + | otherwise = concatMap showunit $ take 2 $ go [] units d where - showunit (u, n) - | n > 0 = show n ++ [u] - | otherwise = "" + showunit (u, n) = show n ++ [u] go c [] _ = reverse c go c ((u, n):us) v = let (q,r) = v `quotRem` n - in go ((u, q):c) us r + in if q > 0 + then go ((u, q):c) us r + else if null c + then go c us r + else reverse c units :: [(Char, Integer)] units = diff --git a/Utility/Metered.hs b/Utility/Metered.hs index a5dda54..ec16e33 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -1,16 +1,48 @@ {- Metered IO and actions - - - Copyright 2012-2016 Joey Hess + - Copyright 2012-2018 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE TypeSynonymInstances, BangPatterns #-} -module Utility.Metered where +module Utility.Metered ( + MeterUpdate, + nullMeterUpdate, + combineMeterUpdate, + BytesProcessed(..), + toBytesProcessed, + fromBytesProcessed, + addBytesProcessed, + zeroBytesProcessed, + withMeteredFile, + meteredWrite, + meteredWrite', + meteredWriteFile, + offsetMeterUpdate, + hGetContentsMetered, + hGetMetered, + defaultChunkSize, + watchFileSize, + OutputHandler(..), + ProgressParser, + commandMeter, + commandMeter', + demeterCommand, + demeterCommandEnv, + avoidProgress, + rateLimitMeterUpdate, + Meter, + mkMeter, + setMeterTotalSize, + updateMeter, + displayMeterHandle, + clearMeterHandle, + bandwidthMeter, +) where import Common -import Utility.FileSystemEncoding import Utility.Percentage import Utility.DataUnits import Utility.HumanTime @@ -81,11 +113,6 @@ withMeteredFile :: FilePath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a withMeteredFile f meterupdate a = withBinaryFile f ReadMode $ \h -> hGetContentsMetered h meterupdate >>= a -{- Sends the content of a file to a Handle, updating the meter as it's - - written. -} -streamMeteredFile :: FilePath -> MeterUpdate -> Handle -> IO () -streamMeteredFile f meterupdate h = withMeteredFile f meterupdate $ L.hPut h - {- Writes a ByteString to a Handle, updating a meter as it's written. -} meteredWrite :: MeterUpdate -> Handle -> L.ByteString -> IO () meteredWrite meterupdate h = void . meteredWrite' meterupdate h @@ -211,7 +238,14 @@ type ProgressParser = String -> (Maybe BytesProcessed, String) - to update a meter. -} commandMeter :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool -commandMeter progressparser oh meterupdate cmd params = +commandMeter progressparser oh meterupdate cmd params = do + ret <- commandMeter' progressparser oh meterupdate cmd params + return $ case ret of + Just ExitSuccess -> True + _ -> False + +commandMeter' :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO (Maybe ExitCode) +commandMeter' progressparser oh meterupdate cmd params = outputFilter cmd params Nothing (feedprogress zeroBytesProcessed []) handlestderr @@ -224,7 +258,7 @@ commandMeter progressparser oh meterupdate cmd params = unless (quietMode oh) $ do S.hPut stdout b hFlush stdout - let s = encodeW8 (S.unpack b) + let s = decodeBS b let (mbytes, buf') = progressparser (buf++s) case mbytes of Nothing -> feedprogress prev buf' h @@ -246,9 +280,13 @@ demeterCommand :: OutputHandler -> FilePath -> [CommandParam] -> IO Bool demeterCommand oh cmd params = demeterCommandEnv oh cmd params Nothing demeterCommandEnv :: OutputHandler -> FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool -demeterCommandEnv oh cmd params environ = outputFilter cmd params environ - (\outh -> avoidProgress True outh stdouthandler) - (\errh -> avoidProgress True errh $ stderrHandler oh) +demeterCommandEnv oh cmd params environ = do + ret <- outputFilter cmd params environ + (\outh -> avoidProgress True outh stdouthandler) + (\errh -> avoidProgress True errh $ stderrHandler oh) + return $ case ret of + Just ExitSuccess -> True + _ -> False where stdouthandler l = unless (quietMode oh) $ @@ -271,16 +309,15 @@ outputFilter -> Maybe [(String, String)] -> (Handle -> IO ()) -> (Handle -> IO ()) - -> IO Bool -outputFilter cmd params environ outfilter errfilter = catchBoolIO $ do + -> IO (Maybe ExitCode) +outputFilter cmd params environ outfilter errfilter = catchMaybeIO $ do (_, Just outh, Just errh, pid) <- createProcess p { std_out = CreatePipe , std_err = CreatePipe } void $ async $ tryIO (outfilter outh) >> hClose outh void $ async $ tryIO (errfilter errh) >> hClose errh - ret <- checkSuccessProcess pid - return ret + waitForProcess pid where p = (proc cmd (toCommand params)) { env = environ } @@ -288,14 +325,14 @@ outputFilter cmd params environ outfilter errfilter = catchBoolIO $ do -- | Limit a meter to only update once per unit of time. -- -- It's nice to display the final update to 100%, even if it comes soon --- after a previous update. To make that happen, a total size has to be --- provided. -rateLimitMeterUpdate :: NominalDiffTime -> Maybe Integer -> MeterUpdate -> IO MeterUpdate -rateLimitMeterUpdate delta totalsize meterupdate = do +-- after a previous update. To make that happen, the Meter has to know +-- its total size. +rateLimitMeterUpdate :: NominalDiffTime -> Meter -> MeterUpdate -> IO MeterUpdate +rateLimitMeterUpdate delta (Meter totalsizev _ _ _) meterupdate = do lastupdate <- newMVar (toEnum 0 :: POSIXTime) return $ mu lastupdate where - mu lastupdate n@(BytesProcessed i) = case totalsize of + mu lastupdate n@(BytesProcessed i) = readMVar totalsizev >>= \case Just t | i >= t -> meterupdate n _ -> do now <- getPOSIXTime @@ -306,35 +343,38 @@ rateLimitMeterUpdate delta totalsize meterupdate = do meterupdate n else putMVar lastupdate prev -data Meter = Meter (Maybe Integer) (MVar MeterState) (MVar String) RenderMeter DisplayMeter +data Meter = Meter (MVar (Maybe Integer)) (MVar MeterState) (MVar String) DisplayMeter type MeterState = (BytesProcessed, POSIXTime) -type DisplayMeter = MVar String -> String -> IO () +type DisplayMeter = MVar String -> Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> IO () type RenderMeter = Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> String -- | Make a meter. Pass the total size, if it's known. -mkMeter :: Maybe Integer -> RenderMeter -> DisplayMeter -> IO Meter -mkMeter totalsize rendermeter displaymeter = Meter - <$> pure totalsize +mkMeter :: Maybe Integer -> DisplayMeter -> IO Meter +mkMeter totalsize displaymeter = Meter + <$> newMVar totalsize <*> ((\t -> newMVar (zeroBytesProcessed, t)) =<< getPOSIXTime) <*> newMVar "" - <*> pure rendermeter <*> pure displaymeter +setMeterTotalSize :: Meter -> Integer -> IO () +setMeterTotalSize (Meter totalsizev _ _ _) = void . swapMVar totalsizev . Just + -- | Updates the meter, displaying it if necessary. -updateMeter :: Meter -> BytesProcessed -> IO () -updateMeter (Meter totalsize sv bv rendermeter displaymeter) new = do +updateMeter :: Meter -> MeterUpdate +updateMeter (Meter totalsizev sv bv displaymeter) new = do now <- getPOSIXTime (old, before) <- swapMVar sv (new, now) - when (old /= new) $ - displaymeter bv $ - rendermeter totalsize (old, before) (new, now) + when (old /= new) $ do + totalsize <- readMVar totalsizev + displaymeter bv totalsize (old, before) (new, now) -- | Display meter to a Handle. -displayMeterHandle :: Handle -> DisplayMeter -displayMeterHandle h v s = do +displayMeterHandle :: Handle -> RenderMeter -> DisplayMeter +displayMeterHandle h rendermeter v msize old new = do + let s = rendermeter msize old new olds <- swapMVar v s -- Avoid writing when the rendered meter has not changed. when (olds /= s) $ do @@ -344,29 +384,32 @@ displayMeterHandle h v s = do -- | Clear meter displayed by displayMeterHandle. clearMeterHandle :: Meter -> Handle -> IO () -clearMeterHandle (Meter _ _ v _ _) h = do +clearMeterHandle (Meter _ _ v _) h = do olds <- readMVar v hPutStr h $ '\r' : replicate (length olds) ' ' ++ "\r" hFlush h -- | Display meter in the form: --- 10% 300 KiB/s 16m40s +-- 10% 1.3MiB 300 KiB/s 16m40s -- or when total size is not known: --- 1.3 MiB 300 KiB/s +-- 1.3 MiB 300 KiB/s bandwidthMeter :: RenderMeter bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) = unwords $ catMaybes - [ Just percentoramount - -- Pad enough for max width: "xxxx.xx KiB xxxx KiB/s" - , Just $ replicate (23 - length percentoramount - length rate) ' ' + [ Just percentamount + -- Pad enough for max width: "100% xxxx.xx KiB xxxx KiB/s" + , Just $ replicate (29 - length percentamount - length rate) ' ' , Just rate , estimatedcompletion ] where - percentoramount = case mtotalsize of - Just totalsize -> showPercentage 0 $ - percentage totalsize (min new totalsize) - Nothing -> roughSize' memoryUnits True 2 new + amount = roughSize' memoryUnits True 2 new + percentamount = case mtotalsize of + Just totalsize -> + let p = showPercentage 0 $ + percentage totalsize (min new totalsize) + in p ++ replicate (6 - length p) ' ' ++ amount + Nothing -> amount rate = roughSize' memoryUnits True 0 bytespersecond ++ "/s" bytespersecond | duration == 0 = fromIntegral transferred @@ -377,5 +420,5 @@ bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) Just totalsize | bytespersecond > 0 -> Just $ fromDuration $ Duration $ - totalsize `div` bytespersecond + (totalsize - new) `div` bytespersecond _ -> Nothing diff --git a/Utility/Misc.hs b/Utility/Misc.hs index 2ae9928..2f1766e 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -5,10 +5,22 @@ - License: BSD-2-clause -} -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Misc where +module Utility.Misc ( + hGetContentsStrict, + readFileStrict, + separate, + firstLine, + firstLine', + segment, + segmentDelim, + massReplace, + hGetSomeString, + exitBool, + + prop_segment_regressionTest, +) where import System.IO import Control.Monad @@ -16,11 +28,8 @@ import Foreign import Data.Char import Data.List import System.Exit -#ifndef mingw32_HOST_OS -import System.Posix.Process (getAnyProcessStatus) -import Utility.Exception -#endif import Control.Applicative +import qualified Data.ByteString as S import Prelude {- A version of hgetContents that is not lazy. Ensures file is @@ -49,6 +58,11 @@ separate c l = unbreak $ break c l firstLine :: String -> String firstLine = takeWhile (/= '\n') +firstLine' :: S.ByteString -> S.ByteString +firstLine' = S.takeWhile (/= nl) + where + nl = fromIntegral (ord '\n') + {- Splits a list into segments that are delimited by items matching - a predicate. (The delimiters are not included in the segments.) - Segments may be empty. -} @@ -112,22 +126,6 @@ hGetSomeString h sz = do peekbytes :: Int -> Ptr Word8 -> IO [Word8] peekbytes len buf = mapM (peekElemOff buf) [0..pred len] -{- Reaps any zombie processes that may be hanging around. - - - - Warning: Not thread safe. Anything that was expecting to wait - - on a process and get back an exit status is going to be confused - - if this reap gets there first. -} -reapZombies :: IO () -#ifndef mingw32_HOST_OS -reapZombies = - -- throws an exception when there are no child processes - catchDefaultIO Nothing (getAnyProcessStatus False True) - >>= maybe (return ()) (const reapZombies) - -#else -reapZombies = return () -#endif - exitBool :: Bool -> IO a exitBool False = exitFailure exitBool True = exitSuccess diff --git a/Utility/Monad.hs b/Utility/Monad.hs index ac75104..abe06f3 100644 --- a/Utility/Monad.hs +++ b/Utility/Monad.hs @@ -7,7 +7,19 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Monad where +module Utility.Monad ( + firstM, + getM, + anyM, + allM, + untilTrue, + ifM, + (<||>), + (<&&>), + observe, + after, + noop, +) where import Data.Maybe import Control.Monad diff --git a/Utility/PartialPrelude.hs b/Utility/PartialPrelude.hs index 47e9831..90c67ff 100644 --- a/Utility/PartialPrelude.hs +++ b/Utility/PartialPrelude.hs @@ -7,7 +7,18 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.PartialPrelude where +module Utility.PartialPrelude ( + Utility.PartialPrelude.read, + Utility.PartialPrelude.head, + Utility.PartialPrelude.tail, + Utility.PartialPrelude.init, + Utility.PartialPrelude.last, + Utility.PartialPrelude.readish, + Utility.PartialPrelude.headMaybe, + Utility.PartialPrelude.lastMaybe, + Utility.PartialPrelude.beginning, + Utility.PartialPrelude.end, +) where import qualified Data.Maybe @@ -38,11 +49,9 @@ last = Prelude.last {- Attempts to read a value from a String. - - - Ignores leading/trailing whitespace, and throws away any trailing - - text after the part that can be read. - - - - readMaybe is available in Text.Read in new versions of GHC, - - but that one requires the entire string to be consumed. + - Unlike Text.Read.readMaybe, this ignores some trailing text + - after the part that can be read. However, if the trailing text looks + - like another readable value, it fails. -} readish :: Read a => String -> Maybe a readish s = case reads s of diff --git a/Utility/Path.hs b/Utility/Path.hs index dc91ce5..ecc752c 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -5,10 +5,32 @@ - License: BSD-2-clause -} -{-# LANGUAGE PackageImports, CPP #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Path where +module Utility.Path ( + simplifyPath, + absPathFrom, + parentDir, + upFrom, + dirContains, + absPath, + relPathCwdToFile, + relPathDirToFile, + relPathDirToFileAbs, + segmentPaths, + runSegmentPaths, + relHome, + inPath, + searchPath, + dotfile, + sanitizeFilePath, + splitShortExtensions, + + prop_upFrom_basics, + prop_relPathDirToFile_basics, + prop_relPathDirToFile_regressionTest, +) where import System.FilePath import Data.List @@ -17,17 +39,11 @@ import Data.Char import Control.Applicative import Prelude -#ifdef mingw32_HOST_OS -import qualified System.FilePath.Posix as Posix -#else -import System.Posix.Files -import Utility.Exception -#endif - import Utility.Monad import Utility.UserInfo import Utility.Directory import Utility.Split +import Utility.FileSystemEncoding {- Simplifies a path, removing any "." component, collapsing "dir/..", - and removing the trailing path separator. @@ -97,7 +113,10 @@ prop_upFrom_basics dir - are all equivilant. -} dirContains :: FilePath -> FilePath -> Bool -dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b' +dirContains a b = a == b + || a' == b' + || (addTrailingPathSeparator a') `isPrefixOf` b' + || a' == "." && normalise ("." b') == b' where a' = norm a b' = norm b @@ -185,20 +204,21 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference - 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 :: [RawFilePath] -> [RawFilePath] -> [[RawFilePath]] segmentPaths [] new = [new] segmentPaths [_] new = [new] -- optimisation segmentPaths (l:ls) new = found : segmentPaths ls rest where (found, rest) = if length ls < 100 - then partition (l `dirContains`) new - else break (\p -> not (l `dirContains` p)) new + then partition inl new + else break (not . inl) new + inl f = fromRawFilePath l `dirContains` fromRawFilePath f {- 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 - the case of git file list commands, that assumption tends to hold. -} -runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]] +runSegmentPaths :: ([RawFilePath] -> IO [RawFilePath]) -> [RawFilePath] -> IO [[RawFilePath]] runSegmentPaths a paths = segmentPaths paths <$> a paths {- Converts paths in the home directory to use ~/ -} @@ -247,50 +267,6 @@ dotfile file where f = takeFileName file -{- Converts a DOS style path to a msys2 style path. Only on Windows. - - Any trailing '\' is preserved as a trailing '/' - - - - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i - - - - The virtual filesystem contains: - - /c, /d, ... mount points for Windows drives - -} -toMSYS2Path :: FilePath -> FilePath -#ifndef mingw32_HOST_OS -toMSYS2Path = id -#else -toMSYS2Path p - | null drive = recombine parts - | otherwise = recombine $ "/" : driveletter drive : parts - where - (drive, p') = splitDrive p - parts = splitDirectories p' - driveletter = map toLower . takeWhile (/= ':') - recombine = fixtrailing . Posix.joinPath - fixtrailing s - | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s - | otherwise = s -#endif - -{- Maximum size to use for a file in a specified directory. - - - - Many systems have a 255 byte limit to the name of a file, - - so that's taken as the max if the system has a larger limit, or has no - - limit. - -} -fileNameLengthLimit :: FilePath -> IO Int -#ifdef mingw32_HOST_OS -fileNameLengthLimit _ = return 255 -#else -fileNameLengthLimit dir = do - -- getPathVar can fail due to statfs(2) overflow - l <- catchDefaultIO 0 $ - fromIntegral <$> getPathVar dir FileNameLimit - if l <= 0 - then return 255 - else return $ minimum [l, 255] -#endif - {- Given a string that we'd like to use as the basis for FilePath, but that - was provided by a third party and is not to be trusted, returns the closest - sane FilePath. diff --git a/Utility/PosixFiles.hs b/Utility/PosixFiles.hs deleted file mode 100644 index 37253da..0000000 --- a/Utility/PosixFiles.hs +++ /dev/null @@ -1,42 +0,0 @@ -{- POSIX files (and compatablity wrappers). - - - - This is like System.PosixCompat.Files, but with a few fixes. - - - - Copyright 2014 Joey Hess - - - - License: BSD-2-clause - -} - -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} - -module Utility.PosixFiles ( - module X, - rename -) where - -import System.PosixCompat.Files as X hiding (rename) - -#ifndef mingw32_HOST_OS -import System.Posix.Files (rename) -#else -import qualified System.Win32.File as Win32 -import qualified System.Win32.HardLink as Win32 -#endif - -{- System.PosixCompat.Files.rename on Windows calls renameFile, - - so cannot rename directories. - - - - Instead, use Win32 moveFile, which can. It needs to be told to overwrite - - any existing file. -} -#ifdef mingw32_HOST_OS -rename :: FilePath -> FilePath -> IO () -rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING -#endif - -{- System.PosixCompat.Files.createLink throws an error, but windows - - does support hard links. -} -#ifdef mingw32_HOST_OS -createLink :: FilePath -> FilePath -> IO () -createLink = Win32.createHardLink -#endif diff --git a/Utility/Process.hs b/Utility/Process.hs index 6d981cb..af3a5f4 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -24,11 +24,10 @@ module Utility.Process ( createProcessSuccess, createProcessChecked, createBackgroundProcess, - processTranscript, - processTranscript', withHandle, withIOHandles, withOEHandles, + withNullHandle, withQuietOutput, feedWithQuietOutput, createProcess, @@ -54,13 +53,6 @@ import System.Log.Logger import Control.Concurrent import qualified Control.Exception as E import Control.Monad -#ifndef mingw32_HOST_OS -import qualified System.Posix.IO -#else -import Control.Applicative -#endif -import Data.Maybe -import Prelude type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a @@ -170,68 +162,6 @@ createProcessChecked checker p a = do createBackgroundProcess :: CreateProcessRunner createBackgroundProcess p a = a =<< createProcess p --- | Runs a process, optionally feeding it some input, and --- returns a transcript combining its stdout and stderr, and --- whether it succeeded or failed. -processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) -processTranscript cmd opts = processTranscript' (proc cmd opts) - -processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool) -processTranscript' cp input = do -#ifndef mingw32_HOST_OS -{- This implementation interleves stdout and stderr in exactly the order - - the process writes them. -} - (readf, writef) <- System.Posix.IO.createPipe - readh <- System.Posix.IO.fdToHandle readf - writeh <- System.Posix.IO.fdToHandle writef - p@(_, _, _, pid) <- createProcess $ cp - { std_in = if isJust input then CreatePipe else Inherit - , std_out = UseHandle writeh - , std_err = UseHandle writeh - } - hClose writeh - - get <- mkreader readh - writeinput input p - transcript <- get - - ok <- checkSuccessProcess pid - return (transcript, ok) -#else -{- This implementation for Windows puts stderr after stdout. -} - p@(_, _, _, pid) <- createProcess $ cp - { std_in = if isJust input then CreatePipe else Inherit - , std_out = CreatePipe - , std_err = CreatePipe - } - - getout <- mkreader (stdoutHandle p) - geterr <- mkreader (stderrHandle p) - writeinput input p - transcript <- (++) <$> getout <*> geterr - - ok <- checkSuccessProcess pid - return (transcript, ok) -#endif - where - mkreader h = do - s <- hGetContents h - v <- newEmptyMVar - void $ forkIO $ do - void $ E.evaluate (length s) - putMVar v () - return $ do - takeMVar v - return s - - writeinput (Just s) p = do - let inh = stdinHandle p - unless (null s) $ do - hPutStr inh s - hFlush inh - 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. @@ -248,13 +178,10 @@ withHandle h creator p a = creator p' $ a . select , std_out = Inherit , std_err = Inherit } - (select, p') - | h == StdinHandle = - (stdinHandle, base { std_in = CreatePipe }) - | h == StdoutHandle = - (stdoutHandle, base { std_out = CreatePipe }) - | h == StderrHandle = - (stderrHandle, base { std_err = CreatePipe }) + (select, p') = case h of + StdinHandle -> (stdinHandle, base { std_in = CreatePipe }) + StdoutHandle -> (stdoutHandle, base { std_out = CreatePipe }) + StderrHandle -> (stderrHandle, base { std_err = CreatePipe }) -- | Like withHandle, but passes (stdin, stdout) handles to the action. withIOHandles @@ -284,13 +211,16 @@ withOEHandles creator p a = creator p' $ a . oeHandles , std_err = CreatePipe } +withNullHandle :: (Handle -> IO a) -> IO a +withNullHandle = withFile devNull WriteMode + -- | Forces the CreateProcessRunner to run quietly; -- both stdout and stderr are discarded. withQuietOutput :: CreateProcessRunner -> CreateProcess -> IO () -withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do +withQuietOutput creator p = withNullHandle $ \nullh -> do let p' = p { std_out = UseHandle nullh , std_err = UseHandle nullh @@ -316,7 +246,8 @@ devNull :: FilePath #ifndef mingw32_HOST_OS devNull = "/dev/null" #else -devNull = "NUL" +-- Use device namespace to prevent GHC from rewriting path +devNull = "\\\\.\\NUL" #endif -- | Extract a desired handle from createProcess's tuple. diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index e89d103..b0a39f3 100644 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -6,7 +6,7 @@ -} {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TypeSynonymInstances, CPP #-} +{-# LANGUAGE TypeSynonymInstances #-} module Utility.QuickCheck ( module X @@ -15,29 +15,24 @@ module Utility.QuickCheck import Test.QuickCheck as X import Data.Time.Clock.POSIX +import Data.Ratio import System.Posix.Types -#if ! MIN_VERSION_QuickCheck(2,8,2) -import qualified Data.Map as M -import qualified Data.Set as S -#endif -import Control.Applicative +import Data.List.NonEmpty (NonEmpty(..)) import Prelude -#if ! MIN_VERSION_QuickCheck(2,8,2) -instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) where - arbitrary = M.fromList <$> arbitrary - -instance (Arbitrary v, Ord v) => Arbitrary (S.Set v) where - arbitrary = S.fromList <$> arbitrary -#endif - -{- Times before the epoch are excluded. -} +{- Times before the epoch are excluded. Half with decimal and half without. -} instance Arbitrary POSIXTime where - arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral + arbitrary = do + n <- nonNegative arbitrarySizedBoundedIntegral :: Gen Int + d <- nonNegative arbitrarySizedIntegral + withd <- arbitrary + return $ if withd + then fromIntegral n + fromRational (1 % max d 1) + else fromIntegral n {- Pids are never negative, or 0. -} instance Arbitrary ProcessID where - arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0) + arbitrary = positive arbitrarySizedBoundedIntegral {- Inodes are never negative. -} instance Arbitrary FileID where @@ -47,6 +42,9 @@ instance Arbitrary FileID where instance Arbitrary FileOffset where arbitrary = nonNegative arbitrarySizedIntegral +instance Arbitrary l => Arbitrary (NonEmpty l) where + arbitrary = (:|) <$> arbitrary <*> arbitrary + nonNegative :: (Num a, Ord a) => Gen a -> Gen a nonNegative g = g `suchThat` (>= 0) diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index f190b40..c6881b7 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -7,12 +7,26 @@ {-# LANGUAGE CPP #-} -module Utility.Rsync where +module Utility.Rsync ( + rsyncShell, + rsyncServerSend, + rsyncServerReceive, + rsyncUseDestinationPermissions, + rsync, + rsyncUrlIsShell, + rsyncUrlIsPath, + rsyncProgress, + filterRsyncSafeOptions, +) where import Common import Utility.Metered import Utility.Tuple +#ifdef mingw32_HOST_OS +import qualified System.FilePath.Posix as Posix +#endif + import Data.Char import System.Console.GetOpt @@ -99,7 +113,16 @@ rsyncUrlIsPath s - The params must enable rsync's --progress mode for this to work. -} rsyncProgress :: OutputHandler -> MeterUpdate -> [CommandParam] -> IO Bool -rsyncProgress oh meter = commandMeter parseRsyncProgress oh meter "rsync" . rsyncParamsFixup +rsyncProgress oh meter ps = + commandMeter' parseRsyncProgress oh meter "rsync" (rsyncParamsFixup ps) >>= \case + Just ExitSuccess -> return True + Just (ExitFailure exitcode) -> do + when (exitcode /= 1) $ + hPutStrLn stderr $ "rsync exited " ++ show exitcode + return False + Nothing -> do + hPutStrLn stderr $ "unable to run rsync" + return False {- Strategy: Look for chunks prefixed with \r (rsync writes a \r before - the first progress output, and each thereafter). The first number @@ -139,3 +162,27 @@ filterRsyncSafeOptions = fst3 . getOpt Permute [ Option [] ["bwlimit"] (reqArgLong "bwlimit") "" ] where reqArgLong x = ReqArg (\v -> "--" ++ x ++ "=" ++ v) "" + +{- Converts a DOS style path to a msys2 style path. Only on Windows. + - Any trailing '\' is preserved as a trailing '/' + - + - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i + - + - The virtual filesystem contains: + - /c, /d, ... mount points for Windows drives + -} +#ifdef mingw32_HOST_OS +toMSYS2Path :: FilePath -> FilePath +toMSYS2Path p + | null drive = recombine parts + | otherwise = recombine $ "/" : driveletter drive : parts + where + (drive, p') = splitDrive p + parts = splitDirectories p' + driveletter = map toLower . takeWhile (/= ':') + recombine = fixtrailing . Posix.joinPath + fixtrailing s + | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s + | otherwise = s +#endif + diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs index eb34d3d..19d5f20 100644 --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -7,7 +7,23 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.SafeCommand where +module Utility.SafeCommand ( + CommandParam(..), + toCommand, + boolSystem, + boolSystem', + boolSystemEnv, + safeSystem, + safeSystem', + safeSystemEnv, + shellWrap, + shellEscape, + shellUnEscape, + segmentXargsOrdered, + segmentXargsUnordered, + prop_isomorphic_shellEscape, + prop_isomorphic_shellEscape_multiword, +) where import System.Exit import Utility.Process @@ -27,19 +43,21 @@ data CommandParam -- | Used to pass a list of CommandParams to a function that runs -- a command and expects Strings. -} toCommand :: [CommandParam] -> [String] -toCommand = map unwrap +toCommand = map toCommand' + +toCommand' :: CommandParam -> String +toCommand' (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. +toCommand' (File s@(h:_)) + | isAlphaNum h || h `elem` pathseps = s + | otherwise = "./" ++ s where - 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 -- '/' is explicitly included because it's an alternative -- path separator on Windows. pathseps = pathSeparator:"./" +toCommand' (File s) = s -- | Run a system command, and returns True or False if it succeeded or failed. -- diff --git a/Utility/Split.hs b/Utility/Split.hs index decfe7d..028218e 100644 --- a/Utility/Split.hs +++ b/Utility/Split.hs @@ -7,7 +7,12 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Split where +module Utility.Split ( + split, + splitc, + replace, + dropFromEnd, +) where import Data.List (intercalate) import Data.List.Split (splitOn) @@ -28,3 +33,7 @@ splitc c s = case break (== c) s of -- | same as Data.List.Utils.replace replace :: Eq a => [a] -> [a] -> [a] -> [a] replace old new = intercalate new . split old + +-- | Only traverses the list once while dropping the last n items. +dropFromEnd :: Int -> [a] -> [a] +dropFromEnd n l = zipWith const l (drop n l) diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs index da05e99..ef69ead 100644 --- a/Utility/ThreadScheduler.hs +++ b/Utility/ThreadScheduler.hs @@ -8,7 +8,14 @@ {-# LANGUAGE CPP #-} -module Utility.ThreadScheduler where +module Utility.ThreadScheduler ( + Seconds(..), + Microseconds, + runEvery, + threadDelaySeconds, + waitForTermination, + oneSecond, +) where import Control.Monad import Control.Concurrent @@ -18,10 +25,8 @@ import System.Posix.IO #endif #ifndef mingw32_HOST_OS import System.Posix.Signals -#ifndef __ANDROID__ import System.Posix.Terminal #endif -#endif newtype Seconds = Seconds { fromSeconds :: Int } deriving (Eq, Ord, Show) @@ -63,10 +68,8 @@ waitForTermination = do let check sig = void $ installHandler sig (CatchOnce $ putMVar lock ()) Nothing check softwareTermination -#ifndef __ANDROID__ whenM (queryTerminal stdInput) $ check keyboardSignal -#endif takeMVar lock #endif diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index 7255c14..6ee592b 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -1,4 +1,4 @@ -{- Temporary files and directories. +{- Temporary files. - - Copyright 2010-2013 Joey Hess - @@ -8,17 +8,19 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Tmp where +module Utility.Tmp ( + Template, + viaTmp, + withTmpFile, + withTmpFileIn, + relatedTemplate, +) where import System.IO -import Control.Monad.IfElse import System.FilePath import System.Directory import Control.Monad.IO.Class import System.PosixCompat.Files -#ifndef mingw32_HOST_OS -import System.Posix.Temp (mkdtemp) -#endif import Utility.Exception import Utility.FileSystemEncoding @@ -32,7 +34,7 @@ viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> v -> m ()) -> FilePath -> v - viaTmp a file content = bracketIO setup cleanup use where (dir, base) = splitFileName file - template = base ++ ".tmp" + template = relatedTemplate (base ++ ".tmp") setup = do createDirectoryIfMissing True dir openTempFile dir template @@ -62,51 +64,6 @@ withTmpFileIn tmpdir template a = bracket create remove use catchBoolIO (removeFile name >> return True) 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 - - directory and all its contents. -} -withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a -withTmpDir template a = do - topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory -#ifndef mingw32_HOST_OS - -- Use mkdtemp to create a temp directory securely in /tmp. - bracket - (liftIO $ mkdtemp $ topleveltmpdir template) - removeTmpDir - a -#else - withTmpDirIn topleveltmpdir template a -#endif - -{- Runs an action with a tmp directory located within a specified directory, - - then removes the tmp directory and all its contents. -} -withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a -withTmpDirIn tmpdir template = bracketIO create removeTmpDir - where - create = do - createDirectoryIfMissing True tmpdir - makenewdir (tmpdir template) (0 :: Int) - makenewdir t n = do - let dir = t ++ "." ++ show n - catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do - createDirectory dir - return dir - -{- Deletes the entire contents of the the temporary directory, if it - - exists. -} -removeTmpDir :: MonadIO m => FilePath -> m () -removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do -#if mingw32_HOST_OS - -- Windows will often refuse to delete a file - -- after a process has just written to it and exited. - -- Because it's crap, presumably. So, ignore failure - -- to delete the temp directory. - _ <- tryIO $ removeDirectoryRecursive tmpdir - return () -#else - removeDirectoryRecursive tmpdir -#endif - {- It's not safe to use a FilePath of an existing file as the template - for openTempFile, because if the FilePath is really long, the tmpfile - will be longer, and may exceed the maximum filename length. diff --git a/Utility/Tmp/Dir.hs b/Utility/Tmp/Dir.hs new file mode 100644 index 0000000..c68ef86 --- /dev/null +++ b/Utility/Tmp/Dir.hs @@ -0,0 +1,70 @@ +{- Temporary directories + - + - Copyright 2010-2013 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Tmp.Dir ( + withTmpDir, + withTmpDirIn, +) where + +import Control.Monad.IfElse +import System.FilePath +import System.Directory +import Control.Monad.IO.Class +#ifndef mingw32_HOST_OS +import System.Posix.Temp (mkdtemp) +#endif + +import Utility.Exception +import Utility.Tmp (Template) + +{- Runs an action with a tmp directory located within the system's tmp + - directory (or within "." if there is none), then removes the tmp + - directory and all its contents. -} +withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a +withTmpDir template a = do + topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory +#ifndef mingw32_HOST_OS + -- Use mkdtemp to create a temp directory securely in /tmp. + bracket + (liftIO $ mkdtemp $ topleveltmpdir template) + removeTmpDir + a +#else + withTmpDirIn topleveltmpdir template a +#endif + +{- Runs an action with a tmp directory located within a specified directory, + - then removes the tmp directory and all its contents. -} +withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a +withTmpDirIn tmpdir template = bracketIO create removeTmpDir + where + create = do + createDirectoryIfMissing True tmpdir + makenewdir (tmpdir template) (0 :: Int) + makenewdir t n = do + let dir = t ++ "." ++ show n + catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do + createDirectory dir + return dir + +{- Deletes the entire contents of the the temporary directory, if it + - exists. -} +removeTmpDir :: MonadIO m => FilePath -> m () +removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do +#if mingw32_HOST_OS + -- Windows will often refuse to delete a file + -- after a process has just written to it and exited. + -- Because it's crap, presumably. So, ignore failure + -- to delete the temp directory. + _ <- tryIO $ removeDirectoryRecursive tmpdir + return () +#else + removeDirectoryRecursive tmpdir +#endif diff --git a/Utility/Tuple.hs b/Utility/Tuple.hs index 25c6e8f..9638bcc 100644 --- a/Utility/Tuple.hs +++ b/Utility/Tuple.hs @@ -5,7 +5,11 @@ - License: BSD-2-clause -} -module Utility.Tuple where +module Utility.Tuple ( + fst3, + snd3, + thd3, +) where fst3 :: (a,b,c) -> a fst3 (a,_,_) = a diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index d504fa5..17ce8db 100644 --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -14,7 +14,7 @@ module Utility.UserInfo ( myUserGecos, ) where -import Utility.Env +import Utility.Env.Basic import Utility.Exception #ifndef mingw32_HOST_OS import Utility.Data @@ -47,8 +47,8 @@ myUserName = myVal env userName #endif myUserGecos :: IO (Maybe String) --- userGecos crashes on Android and is not available on Windows. -#if defined(__ANDROID__) || defined(mingw32_HOST_OS) +-- userGecos is not available on Windows. +#if defined(mingw32_HOST_OS) myUserGecos = return Nothing #else myUserGecos = eitherToMaybe <$> myVal [] userGecos @@ -57,10 +57,13 @@ myUserGecos = eitherToMaybe <$> myVal [] userGecos myVal :: [String] -> (UserEntry -> String) -> IO (Either String String) myVal envvars extract = go envvars where + go [] = either (const $ envnotset) (Right . extract) <$> get + go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v #ifndef mingw32_HOST_OS - go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID) + -- This may throw an exception if the system doesn't have a + -- passwd file etc; don't let it crash. + get = tryNonAsync $ getUserEntryForID =<< getEffectiveUserID #else - go [] = return $ either Left (Right . extract) $ - Left ("environment not set: " ++ show envvars) + get = return envnotset #endif - go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v + envnotset = Left ("environment not set: " ++ show envvars) diff --git a/debian/copyright b/debian/copyright deleted file mode 100644 index 33f85b4..0000000 --- a/debian/copyright +++ /dev/null @@ -1,35 +0,0 @@ -Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ -Source: native package - -Files: * -Copyright: © 2013 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/debian/copyright b/debian/copyright new file mode 120000 index 0000000..dc5f40a --- /dev/null +++ b/debian/copyright @@ -0,0 +1 @@ +../COPYRIGHT \ No newline at end of file diff --git a/git-repair.cabal b/git-repair.cabal index cff316f..f273cb3 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -1,12 +1,12 @@ Name: git-repair -Version: 1.20170626 +Version: 1.20200102 Cabal-Version: >= 1.8 -License: GPL +License: AGPL-3 Maintainer: Joey Hess Author: Joey Hess Stability: Stable Copyright: 2013 Joey Hess -License-File: GPL +License-File: COPYRIGHT Build-Type: Custom Homepage: http://git-repair.branchable.com/ Category: Utility @@ -25,13 +25,10 @@ Extra-Source-Files: TODO git-repair.1 -Flag network-uri - Description: Get Network.URI from the network-uri package - Default: True - custom-setup - Setup-Depends: base (>= 4.5), hslogger, split, unix-compat, process, - unix, filepath, exceptions, bytestring, directory, IfElse, data-default, + Setup-Depends: base (>= 4.11.1.0 && < 5.0), + hslogger, split, unix-compat, process, unix, filepath, + exceptions, bytestring, directory, IfElse, data-default, mtl, Cabal source-repository head @@ -41,21 +38,19 @@ source-repository head Executable git-repair Main-Is: git-repair.hs GHC-Options: -threaded -Wall -fno-warn-tabs + Extensions: LambdaCase Build-Depends: split, hslogger, directory, filepath, containers, mtl, - unix-compat, bytestring, exceptions (>= 0.6), transformers, - base >= 4.5, base < 5, IfElse, text, process, time, QuickCheck, - utf8-string, async, optparse-applicative (>= 0.10.0), - data-default - - if flag(network-uri) - Build-Depends: network-uri (>= 2.6), network (>= 2.6) - else - Build-Depends: network (< 2.6), network (>= 2.0) + unix-compat (>= 0.5), bytestring, exceptions (>= 0.6), transformers, + base (>= 4.11.1.0 && < 5.0), IfElse, text, process, time, QuickCheck, + utf8-string, async, optparse-applicative (>= 0.14.1), + data-default, deepseq, attoparsec, + network-uri (>= 2.6), network (>= 2.6), + filepath-bytestring (>= 1.4.2.1.0) if (os(windows)) Build-Depends: setenv else - Build-Depends: unix + Build-Depends: unix (>= 2.7.2) Other-Modules: BuildInfo @@ -76,6 +71,7 @@ Executable git-repair Git.FilePath Git.Filename Git.Fsck + Git.HashObject Git.Index Git.LsFiles Git.LsTree @@ -89,6 +85,7 @@ Executable git-repair Git.UpdateIndex Git.Url Git.Version + Utility.Attoparsec Utility.Applicative Utility.Batch Utility.CoProcess @@ -97,6 +94,8 @@ Executable git-repair Utility.Directory Utility.DottedVersion Utility.Env + Utility.Env.Basic + Utility.Env.Set Utility.Exception Utility.FileMode Utility.FileSize @@ -110,7 +109,6 @@ Executable git-repair Utility.PartialPrelude Utility.Path Utility.Percentage - Utility.PosixFiles Utility.Process Utility.Process.Shim Utility.QuickCheck @@ -120,5 +118,6 @@ Executable git-repair Utility.SystemDirectory Utility.ThreadScheduler Utility.Tmp + Utility.Tmp.Dir Utility.Tuple Utility.UserInfo diff --git a/git-repair.hs b/git-repair.hs index 4076c15..ce4d16a 100644 --- a/git-repair.hs +++ b/git-repair.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} import Options.Applicative @@ -14,8 +14,7 @@ import qualified Git.Config import qualified Git.Construct import qualified Git.Destroyer import qualified Git.Fsck -import Utility.Tmp -import Utility.FileSystemEncoding +import Utility.Tmp.Dir data Settings = Settings { forced :: Bool -- cgit v1.2.3 From 50a5a7b101cc9c30a5a04b4c20cbf7f99fcab0ef Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 2 Jan 2020 12:44:30 -0400 Subject: gitignore dist --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 1ed2e9b..720dded 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ Build/SysConfig tags git-repair +dist -- cgit v1.2.3