From 7c12f0ac9224246dac308e837bccb5b2157062ee Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 15 Dec 2015 17:47:59 -0700 Subject: Import git-repair_1.20151215.orig.tar.xz [dgit import orig git-repair_1.20151215.orig.tar.xz] --- .gitignore | 3 + Build/Configure.hs | 30 ++ Build/TestConfig.hs | 141 ++++++++ Build/Version.hs | 69 ++++ Build/collect-ghc-options.sh | 12 + Build/make-sdist.sh | 21 ++ CHANGELOG | 1 + Common.hs | 36 ++ GPL | 674 ++++++++++++++++++++++++++++++++++++ Git.hs | 169 +++++++++ Git/Branch.hs | 195 +++++++++++ Git/BuildVersion.hs | 21 ++ Git/CatFile.hs | 113 ++++++ Git/Command.hs | 128 +++++++ Git/Config.hs | 210 +++++++++++ Git/Construct.hs | 241 +++++++++++++ Git/CurrentRepo.hs | 59 ++++ Git/Destroyer.hs | 148 ++++++++ Git/DiffTreeItem.hs | 24 ++ Git/FilePath.hs | 77 ++++ Git/Filename.hs | 28 ++ Git/Fsck.hs | 117 +++++++ Git/Index.hs | 55 +++ Git/LsFiles.hs | 258 ++++++++++++++ Git/LsTree.hs | 78 +++++ Git/Objects.hs | 49 +++ Git/Ref.hs | 147 ++++++++ Git/RefLog.hs | 30 ++ Git/Remote.hs | 108 ++++++ Git/Repair.hs | 617 +++++++++++++++++++++++++++++++++ Git/Sha.hs | 43 +++ Git/Types.hs | 100 ++++++ Git/UpdateIndex.hs | 121 +++++++ Git/Url.hs | 71 ++++ Git/Version.hs | 32 ++ Makefile | 34 ++ Setup.hs | 14 + TODO | 2 + Utility/Applicative.hs | 16 + Utility/Batch.hs | 96 +++++ Utility/CoProcess.hs | 94 +++++ Utility/Data.hs | 19 + Utility/Directory.hs | 242 +++++++++++++ Utility/DottedVersion.hs | 38 ++ Utility/Env.hs | 84 +++++ Utility/Exception.hs | 99 ++++++ Utility/FileMode.hs | 167 +++++++++ Utility/FileSize.hs | 35 ++ Utility/FileSystemEncoding.hs | 166 +++++++++ Utility/Format.hs | 178 ++++++++++ Utility/Metered.hs | 261 ++++++++++++++ Utility/Misc.hs | 150 ++++++++ Utility/Monad.hs | 71 ++++ Utility/PartialPrelude.hs | 70 ++++ Utility/Path.hs | 322 +++++++++++++++++ Utility/PosixFiles.hs | 34 ++ Utility/Process.hs | 397 +++++++++++++++++++++ Utility/Process/Shim.hs | 3 + Utility/QuickCheck.hs | 53 +++ Utility/Rsync.hs | 141 ++++++++ Utility/SafeCommand.hs | 136 ++++++++ Utility/ThreadScheduler.hs | 74 ++++ Utility/Tmp.hs | 124 +++++++ Utility/URI.hs | 18 + Utility/UserInfo.hs | 63 ++++ configure.hs | 6 + debian/changelog | 105 ++++++ debian/compat | 1 + debian/control | 36 ++ debian/copyright | 35 ++ debian/git-repair.lintian-overrides | 1 + debian/manpages | 1 + debian/rules | 10 + doc/index.mdwn | 55 +++ doc/news/version_1.20141027.mdwn | 1 + git-repair.1 | 49 +++ git-repair.cabal | 49 +++ git-repair.hs | 119 +++++++ 78 files changed, 7895 insertions(+) create mode 100644 .gitignore create mode 100644 Build/Configure.hs create mode 100644 Build/TestConfig.hs create mode 100644 Build/Version.hs create mode 100755 Build/collect-ghc-options.sh create mode 100755 Build/make-sdist.sh create mode 120000 CHANGELOG create mode 100644 Common.hs create mode 100644 GPL create mode 100644 Git.hs create mode 100644 Git/Branch.hs create mode 100644 Git/BuildVersion.hs create mode 100644 Git/CatFile.hs create mode 100644 Git/Command.hs create mode 100644 Git/Config.hs create mode 100644 Git/Construct.hs create mode 100644 Git/CurrentRepo.hs create mode 100644 Git/Destroyer.hs create mode 100644 Git/DiffTreeItem.hs create mode 100644 Git/FilePath.hs create mode 100644 Git/Filename.hs create mode 100644 Git/Fsck.hs create mode 100644 Git/Index.hs create mode 100644 Git/LsFiles.hs create mode 100644 Git/LsTree.hs create mode 100644 Git/Objects.hs create mode 100644 Git/Ref.hs create mode 100644 Git/RefLog.hs create mode 100644 Git/Remote.hs create mode 100644 Git/Repair.hs create mode 100644 Git/Sha.hs create mode 100644 Git/Types.hs create mode 100644 Git/UpdateIndex.hs create mode 100644 Git/Url.hs create mode 100644 Git/Version.hs create mode 100644 Makefile create mode 100644 Setup.hs create mode 100644 TODO create mode 100644 Utility/Applicative.hs create mode 100644 Utility/Batch.hs create mode 100644 Utility/CoProcess.hs create mode 100644 Utility/Data.hs create mode 100644 Utility/Directory.hs create mode 100644 Utility/DottedVersion.hs create mode 100644 Utility/Env.hs create mode 100644 Utility/Exception.hs create mode 100644 Utility/FileMode.hs create mode 100644 Utility/FileSize.hs create mode 100644 Utility/FileSystemEncoding.hs create mode 100644 Utility/Format.hs create mode 100644 Utility/Metered.hs create mode 100644 Utility/Misc.hs create mode 100644 Utility/Monad.hs create mode 100644 Utility/PartialPrelude.hs create mode 100644 Utility/Path.hs create mode 100644 Utility/PosixFiles.hs create mode 100644 Utility/Process.hs create mode 100644 Utility/Process/Shim.hs create mode 100644 Utility/QuickCheck.hs create mode 100644 Utility/Rsync.hs create mode 100644 Utility/SafeCommand.hs create mode 100644 Utility/ThreadScheduler.hs create mode 100644 Utility/Tmp.hs create mode 100644 Utility/URI.hs create mode 100644 Utility/UserInfo.hs create mode 100644 configure.hs create mode 100644 debian/changelog create mode 100644 debian/compat create mode 100644 debian/control create mode 100644 debian/copyright create mode 100644 debian/git-repair.lintian-overrides create mode 100644 debian/manpages create mode 100755 debian/rules create mode 100644 doc/index.mdwn create mode 100644 doc/news/version_1.20141027.mdwn create mode 100644 git-repair.1 create mode 100644 git-repair.cabal create mode 100644 git-repair.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..55a966c --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +Build/SysConfig.hs +tags +git-repair diff --git a/Build/Configure.hs b/Build/Configure.hs new file mode 100644 index 0000000..e488ee1 --- /dev/null +++ b/Build/Configure.hs @@ -0,0 +1,30 @@ +{- Checks system configuration and generates SysConfig.hs. -} + +module Build.Configure where + +import System.Environment +import Control.Applicative +import Control.Monad.IfElse + +import Build.TestConfig +import Build.Version +import Git.Version + +tests :: [TestCase] +tests = + [ TestCase "version" (Config "packageversion" . StringConfig <$> getVersion) + , TestCase "git" $ requireCmd "git" "git --version >/dev/null" + , TestCase "git version" getGitVersion + ] + +getGitVersion :: Test +getGitVersion = Config "gitversion" . StringConfig . show + <$> Git.Version.installed + +run :: [TestCase] -> IO () +run ts = do + args <- getArgs + config <- runTests ts + writeSysConfig config + whenM (isReleaseBuild) $ + cabalSetup "git-repair.cabal" diff --git a/Build/TestConfig.hs b/Build/TestConfig.hs new file mode 100644 index 0000000..e55641f --- /dev/null +++ b/Build/TestConfig.hs @@ -0,0 +1,141 @@ +{- Tests the system and generates Build.SysConfig.hs. -} + +module Build.TestConfig where + +import Utility.Path +import Utility.Monad +import Utility.SafeCommand + +import System.IO +import System.FilePath +import System.Directory + +type ConfigKey = String +data ConfigValue = + BoolConfig Bool | + StringConfig String | + MaybeStringConfig (Maybe String) | + MaybeBoolConfig (Maybe Bool) +data Config = Config ConfigKey ConfigValue + +type Test = IO Config +type TestName = String +data TestCase = TestCase TestName Test + +instance Show ConfigValue where + show (BoolConfig b) = show b + show (StringConfig s) = show s + show (MaybeStringConfig s) = show s + show (MaybeBoolConfig s) = show s + +instance Show Config where + show (Config key value) = unlines + [ key ++ " :: " ++ valuetype value + , key ++ " = " ++ show value + ] + where + valuetype (BoolConfig _) = "Bool" + valuetype (StringConfig _) = "String" + valuetype (MaybeStringConfig _) = "Maybe String" + valuetype (MaybeBoolConfig _) = "Maybe Bool" + +writeSysConfig :: [Config] -> IO () +writeSysConfig config = writeFile "Build/SysConfig.hs" body + where + body = unlines $ header ++ map show config ++ footer + header = [ + "{- Automatically generated. -}" + , "module Build.SysConfig where" + , "" + ] + footer = [] + +runTests :: [TestCase] -> IO [Config] +runTests [] = return [] +runTests (TestCase tname t : ts) = do + testStart tname + c <- t + testEnd c + 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 + ok <- boolSystem "sh" [ Param "-c", Param $ quiet cmdline ] + return $ Config k (BoolConfig ok) + +{- Ensures that one of a set of commands is available by running each in + - turn. The Config is set to the first one found. -} +selectCmd :: ConfigKey -> [(String, String)] -> Test +selectCmd k = searchCmd + (return . Config k . StringConfig) + (\cmds -> do + testEnd $ Config k $ BoolConfig False + error $ "* need one of these commands, but none are available: " ++ show cmds + ) + +maybeSelectCmd :: ConfigKey -> [(String, String)] -> Test +maybeSelectCmd k = searchCmd + (return . Config k . MaybeStringConfig . Just) + (\_ -> return $ Config k $ MaybeStringConfig Nothing) + +searchCmd :: (String -> Test) -> ([String] -> Test) -> [(String, String)] -> Test +searchCmd success failure cmdsparams = search cmdsparams + where + search [] = failure $ fst $ unzip cmdsparams + search ((c, params):cs) = do + ok <- boolSystem "sh" [ Param "-c", Param $ quiet $ c ++ " " ++ params ] + if ok + then success c + else search cs + +{- Finds a command, either in PATH or perhaps in a sbin directory not in + - PATH. If it's in PATH the config is set to just the command name, + - but if it's found outside PATH, the config is set to the full path to + - the command. -} +findCmdPath :: ConfigKey -> String -> Test +findCmdPath k command = do + ifM (inPath command) + ( return $ Config k $ MaybeStringConfig $ Just command + , do + r <- getM find ["/usr/sbin", "/sbin", "/usr/local/sbin"] + return $ Config k $ MaybeStringConfig r + ) + where + find d = + let f = d command + in ifM (doesFileExist f) ( return (Just f), return Nothing ) + +quiet :: String -> String +quiet s = s ++ " >/dev/null 2>&1" + +testStart :: TestName -> IO () +testStart s = do + putStr $ " checking " ++ s ++ "..." + hFlush stdout + +testEnd :: Config -> IO () +testEnd (Config _ (BoolConfig True)) = status "yes" +testEnd (Config _ (BoolConfig False)) = status "no" +testEnd (Config _ (StringConfig s)) = status s +testEnd (Config _ (MaybeStringConfig (Just s))) = status s +testEnd (Config _ (MaybeStringConfig Nothing)) = status "not available" +testEnd (Config _ (MaybeBoolConfig (Just True))) = status "yes" +testEnd (Config _ (MaybeBoolConfig (Just False))) = status "no" +testEnd (Config _ (MaybeBoolConfig Nothing)) = status "unknown" + +status :: String -> IO () +status s = putStrLn $ ' ':s diff --git a/Build/Version.hs b/Build/Version.hs new file mode 100644 index 0000000..da9d1bb --- /dev/null +++ b/Build/Version.hs @@ -0,0 +1,69 @@ +{- Package version determination, for configure script. -} + +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 Utility.Monad +import Utility.Exception + +type Version = String + +{- Set when making an official release. (Distribution vendors should set + - this too.) -} +isReleaseBuild :: IO Bool +isReleaseBuild = isJust <$> catchMaybeIO (getEnv "RELEASE_BUILD") + +{- 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. + - This works for autobuilds, ad-hoc builds, etc. + - + - If git or a git repo is not available, or something goes wrong, + - or this is a release build, just use the version from the changelog. -} +getVersion :: IO Version +getVersion = do + changelogversion <- getChangelogVersion + ifM (isReleaseBuild) + ( return changelogversion + , catchDefaultIO changelogversion $ do + let major = takeWhile (/= '.') changelogversion + autoversion <- takeWhile (\c -> isAlphaNum c || c == '-') <$> readProcess "sh" + [ "-c" + , "git log -n 1 --format=format:'%ci %h'| sed -e 's/-//g' -e 's/ .* /-g/'" + ] "" + if null autoversion + then return changelogversion + else return $ concat [ major, ".", autoversion ] + ) + +getChangelogVersion :: IO Version +getChangelogVersion = do + changelog <- readFile "debian/changelog" + let verline = takeWhile (/= '\n') changelog + return $ middle (words verline !! 1) + where + middle = drop 1 . init + +{- Set up cabal file with version. -} +cabalSetup :: FilePath -> IO () +cabalSetup cabalfile = do + version <- takeWhile (\c -> isDigit c || c == '.') + <$> getChangelogVersion + cabal <- readFile cabalfile + writeFile tmpcabalfile $ unlines $ + map (setfield "Version" version) $ + lines cabal + renameFile tmpcabalfile cabalfile + where + tmpcabalfile = cabalfile++".tmp" + setfield field value s + | fullfield `isPrefixOf` s = fullfield ++ value + | otherwise = s + where + fullfield = field ++ ": " diff --git a/Build/collect-ghc-options.sh b/Build/collect-ghc-options.sh new file mode 100755 index 0000000..4f75a72 --- /dev/null +++ b/Build/collect-ghc-options.sh @@ -0,0 +1,12 @@ +#!/bin/sh +# Generate --ghc-options to pass LDFLAGS, CFLAGS, and CPPFLAGS through ghc +# and on to ld, cc, and cpp. +for w in $LDFLAGS; do + printf -- "-optl%s\n" "$w" +done +for w in $CFLAGS; do + printf -- "-optc%s\n" "$w" +done +for w in $CPPFLAGS; do + printf -- "-optc-Wp,%s\n" "$w" +done diff --git a/Build/make-sdist.sh b/Build/make-sdist.sh new file mode 100755 index 0000000..d4dbdb9 --- /dev/null +++ b/Build/make-sdist.sh @@ -0,0 +1,21 @@ +#!/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 new file mode 120000 index 0000000..d526672 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1 @@ +debian/changelog \ No newline at end of file diff --git a/Common.hs b/Common.hs new file mode 100644 index 0000000..a6c5d54 --- /dev/null +++ b/Common.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE PackageImports, CPP #-} + +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 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 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) +#endif +import System.Exit as X + +import Utility.Misc as X +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.PartialPrelude as X diff --git a/GPL b/GPL new file mode 100644 index 0000000..94a9ed0 --- /dev/null +++ b/GPL @@ -0,0 +1,674 @@ + 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 new file mode 100644 index 0000000..1bc789f --- /dev/null +++ b/Git.hs @@ -0,0 +1,169 @@ +{- git repository handling + - + - This is written to be completely independant of git-annex and should be + - suitable for other uses. + - + - Copyright 2010-2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Git ( + Repo(..), + Ref(..), + fromRef, + Branch, + Sha, + Tag, + repoIsUrl, + repoIsSsh, + repoIsHttp, + repoIsLocal, + repoIsLocalBare, + repoIsLocalUnknown, + repoDescribe, + repoLocation, + repoPath, + localGitDir, + attributes, + hookPath, + assertLocal, + adjustPath, + relPath, +) where + +import Network.URI (uriPath, uriScheme, unEscapeString) +#ifndef mingw32_HOST_OS +import System.Posix.Files +#endif + +import Common +import Git.Types +#ifndef mingw32_HOST_OS +import Utility.FileMode +#endif + +{- User-visible description of a git repo. -} +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 = 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 = 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 { 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" + +{- Path to a local repository's .git directory. -} +localGitDir :: Repo -> FilePath +localGitDir Repo { location = Local { gitdir = d } } = d +localGitDir _ = error "unknown localGitDir" + +{- Some code needs to vary between URL and normal repos, + - or bare and non-bare, these functions help with that. -} +repoIsUrl :: Repo -> Bool +repoIsUrl Repo { location = Url _ } = True +repoIsUrl _ = False + +repoIsSsh :: Repo -> Bool +repoIsSsh Repo { location = Url url } + | scheme == "ssh:" = True + -- git treats these the same as ssh + | scheme == "git+ssh:" = True + | scheme == "ssh+git:" = True + | otherwise = False + where + scheme = uriScheme url +repoIsSsh _ = False + +repoIsHttp :: Repo -> Bool +repoIsHttp Repo { location = Url url } + | uriScheme url == "http:" = True + | uriScheme url == "https:" = True + | otherwise = False +repoIsHttp _ = False + +repoIsLocal :: Repo -> Bool +repoIsLocal Repo { location = Local { } } = True +repoIsLocal _ = False + +repoIsLocalBare :: Repo -> Bool +repoIsLocalBare Repo { location = Local { worktree = Nothing } } = True +repoIsLocalBare _ = False + +repoIsLocalUnknown :: Repo -> Bool +repoIsLocalUnknown Repo { location = LocalUnknown { } } = True +repoIsLocalUnknown _ = False + +assertLocal :: Repo -> a -> a +assertLocal repo action + | repoIsUrl repo = error $ unwords + [ "acting on non-local git repo" + , repoDescribe repo + , "not supported" + ] + | otherwise = action + +{- Path to a repository's gitattributes file. -} +attributes :: Repo -> FilePath +attributes repo + | repoIsLocalBare repo = repoPath repo ++ "/info/.gitattributes" + | otherwise = repoPath repo ++ "/.gitattributes" + +{- 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 + ifM (catchBoolIO $ isexecutable hook) + ( return $ Just hook , return Nothing ) + where +#if mingw32_HOST_OS + isexecutable f = doesFileExist f +#else + isexecutable f = isExecutable . fileMode <$> getFileStatus f +#endif + +{- Makes the path to a local Repo be relative to the cwd. -} +relPath :: Repo -> IO Repo +relPath = adjustPath torel + where + torel p = do + p' <- relPathCwdToFile p + if null p' + then return "." + else return p' + +{- Adusts the path to a local Repo using the provided function. -} +adjustPath :: (FilePath -> IO FilePath) -> Repo -> IO Repo +adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do + d' <- f d + w' <- maybe (pure Nothing) (Just <$$> f) w + return $ r + { location = l + { gitdir = d' + , worktree = w' + } + } +adjustPath f r@(Repo { location = LocalUnknown d }) = do + d' <- f d + return $ r { location = LocalUnknown d' } +adjustPath _ r = pure r diff --git a/Git/Branch.hs b/Git/Branch.hs new file mode 100644 index 0000000..a2225dc --- /dev/null +++ b/Git/Branch.hs @@ -0,0 +1,195 @@ +{- git branch stuff + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns #-} + +module Git.Branch where + +import Common +import Git +import Git.Sha +import Git.Command +import qualified Git.Ref +import qualified Git.BuildVersion + +{- 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 + - to double-check. + -} +current :: Repo -> IO (Maybe Git.Ref) +current r = do + v <- currentUnsafe r + case v of + Nothing -> return Nothing + Just branch -> + ifM (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 Git.Ref) +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 + +{- Checks if the second branch has any commits not present on the first + - branch. -} +changed :: Branch -> Branch -> Repo -> IO Bool +changed origbranch newbranch repo + | origbranch == newbranch = return False + | otherwise = not . null <$> diffs + where + diffs = pipeReadStrict + [ Param "log" + , Param (fromRef origbranch ++ ".." ++ fromRef newbranch) + , Param "-n1" + , Param "--pretty=%H" + ] repo + +{- Check if it's possible to fast-forward from the old + - ref to the new ref. + - + - 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 <$> + pipeReadStrict + [ Param "log" + , Param $ fromRef old ++ ".." ++ fromRef new + , Param "-n1" + , Param "--pretty=%H" + , Param "--ancestry-path" + ] repo + +{- Given a set of refs that are all known to have commits not + - on the branch, tries to update the branch by a fast-forward. + - + - In order for that to be possible, one of the refs must contain + - every commit present in all the other refs. + -} +fastForward :: Branch -> [Ref] -> Repo -> IO Bool +fastForward _ [] _ = return True +fastForward branch (first:rest) repo = + -- First, check that the branch does not contain any + -- new commits that are not in the first ref. If it does, + -- cannot fast-forward. + ifM (changed first branch repo) + ( no_ff + , maybe no_ff do_ff =<< findbest first rest + ) + where + no_ff = return False + do_ff to = do + update branch to repo + return True + findbest c [] = return $ Just c + findbest c (r:rs) + | c == r = findbest c rs + | otherwise = do + better <- changed c r repo + worse <- changed r c repo + case (better, worse) of + (True, True) -> return Nothing -- divergent fail + (True, False) -> findbest r rs -- better + (False, True) -> findbest c rs -- worse + (False, False) -> findbest c rs -- same + +{- The user may have set commit.gpgsign, indending 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) + +applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam] +applyCommitMode commitmode ps + | commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") = + Param "--no-gpg-sign" : ps + | otherwise = ps + +{- Commit via the usual git command. -} +commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool +commitCommand = commitCommand' runBool + +{- 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 + +{- Commits the index into the specified branch (or other ref), + - with the specified parent refs, and returns the committed sha. + - + - Without allowempy set, avoids making a commit if there is exactly + - one parent, and it has the same tree that would be committed. + - + - Unlike git-commit, does not run any hooks, or examine the work tree + - in any way. + -} +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 + ifM (cancommit tree) + ( do + sha <- getSha "commit-tree" $ + pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) sendmsg repo + update branch sha repo + return $ Just sha + , return Nothing + ) + where + ps = 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 + +{- 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 + [ Param "update-ref" + , Param $ fromRef branch + , Param $ fromRef sha + ] + +{- Checks out a branch, creating it if necessary. -} +checkout :: Branch -> Repo -> IO () +checkout branch = run + [ Param "checkout" + , Param "-q" + , Param "-B" + , Param $ fromRef $ Git.Ref.base branch + ] + +{- Removes a branch. -} +delete :: Branch -> Repo -> IO () +delete branch = run + [ Param "branch" + , Param "-q" + , Param "-D" + , Param $ fromRef $ Git.Ref.base branch + ] diff --git a/Git/BuildVersion.hs b/Git/BuildVersion.hs new file mode 100644 index 0000000..50e4a3a --- /dev/null +++ b/Git/BuildVersion.hs @@ -0,0 +1,21 @@ +{- git build version + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.BuildVersion where + +import Git.Version +import qualified Build.SysConfig + +{- 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 + +older :: String -> Bool +older n = buildVersion < normalize n diff --git a/Git/CatFile.hs b/Git/CatFile.hs new file mode 100644 index 0000000..c63a064 --- /dev/null +++ b/Git/CatFile.hs @@ -0,0 +1,113 @@ +{- git cat-file interface + - + - Copyright 2011, 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.CatFile ( + CatFileHandle, + catFileStart, + catFileStart', + catFileStop, + catFile, + catFileDetails, + catTree, + catObject, + catObjectDetails, +) where + +import System.IO +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Tuple.Utils +import Numeric +import System.Posix.Types + +import Common +import Git +import Git.Sha +import Git.Command +import Git.Types +import Git.FilePath +import qualified Utility.CoProcess as CoProcess + +data CatFileHandle = CatFileHandle CoProcess.CoProcessHandle Repo + +catFileStart :: Repo -> IO CatFileHandle +catFileStart = catFileStart' True + +catFileStart' :: Bool -> Repo -> IO CatFileHandle +catFileStart' restartable repo = do + coprocess <- CoProcess.rawMode =<< gitCoProcessStart restartable + [ Param "cat-file" + , Param "--batch" + ] repo + return $ CatFileHandle coprocess repo + +catFileStop :: CatFileHandle -> IO () +catFileStop (CatFileHandle p _) = CoProcess.stop p + +{- Reads a file from a specified branch. -} +catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString +catFile h branch file = catObject h $ Ref $ + fromRef branch ++ ":" ++ toInternalGitPath file + +catFileDetails :: CatFileHandle -> Branch -> FilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) +catFileDetails h branch file = catObjectDetails h $ Ref $ + fromRef branch ++ ":" ++ toInternalGitPath file + +{- Uses a running git cat-file read the content of an object. + - Objects that do not exist will have "" returned. -} +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 + 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 a list of files and directories in a tree. (Not recursive.) -} +catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)] +catTree h treeref = go <$> catObjectDetails h treeref + where + go (Just (b, _, TreeObject)) = parsetree [] b + go _ = [] + + parsetree c b = case L.break (== 0) b of + (modefile, rest) + | L.null modefile -> c + | otherwise -> parsetree + (parsemodefile modefile:c) + (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 diff --git a/Git/Command.hs b/Git/Command.hs new file mode 100644 index 0000000..02e3e5a --- /dev/null +++ b/Git/Command.hs @@ -0,0 +1,128 @@ +{- running git commands + - + - Copyright 2010-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Git.Command where + +import Common +import Git +import Git.Types +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 + where + setdir = Param $ "--git-dir=" ++ gitdir l + settree = case worktree l of + Nothing -> [] + Just t -> [Param $ "--work-tree=" ++ t] +gitCommandLine _ repo = assertLocal repo $ error "internal" + +{- Runs git in the specified repo. -} +runBool :: [CommandParam] -> Repo -> IO Bool +runBool params repo = assertLocal repo $ + boolSystemEnv "git" (gitCommandLine params repo) (gitEnv repo) + +{- Runs git in the specified repo, throwing an error if it fails. -} +run :: [CommandParam] -> Repo -> IO () +run params repo = assertLocal repo $ + unlessM (runBool params repo) $ + error $ "git " ++ show params ++ " failed" + +{- Runs git and forces it to be quiet, throwing an error if it fails. -} +runQuiet :: [CommandParam] -> Repo -> IO () +runQuiet params repo = withQuietOutput createProcessSuccess $ + (proc "git" $ toCommand $ gitCommandLine (params) repo) + { env = gitEnv repo } + +{- 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 + - return True if it succeeded. Failure to wait will result in zombies. + -} +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 + p = gitCreateProcess params repo + +{- Runs a git command, and returns its output, strictly. + - + - Nonzero exit status is ignored. + -} +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 + where + p = gitCreateProcess params repo + +{- Runs a git command, feeding it an input, and returning its output, + - which is expected to be fairly small, since it's all read into memory + - strictly. -} +pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO String +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 + +{- 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 + +{- 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 params repo = do + (s, cleanup) <- pipeReadLazy params repo + return (filter (not . null) $ split sep s, cleanup) + where + sep = "\0" + +pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [String] +pipeNullSplitStrict params repo = do + s <- pipeReadStrict params repo + return $ filter (not . null) $ split sep s + where + sep = "\0" + +pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String] +pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo + +{- Doesn't run the cleanup action. A zombie results. -} +leaveZombie :: (a, IO Bool) -> a +leaveZombie = fst + +{- Runs a git command as a coprocess. -} +gitCoProcessStart :: Bool -> [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle +gitCoProcessStart restartable params repo = CoProcess.start numrestarts "git" + (toCommand $ gitCommandLine params repo) + (gitEnv repo) + where + {- If a long-running git command like cat-file --batch + - crashes, it will likely start up again ok. If it keeps crashing + - 10 times, something is badly wrong. -} + numrestarts = if restartable then 10 else 0 + +gitCreateProcess :: [CommandParam] -> Repo -> CreateProcess +gitCreateProcess params repo = + (proc "git" $ toCommand $ gitCommandLine params repo) + { env = gitEnv repo } diff --git a/Git/Config.hs b/Git/Config.hs new file mode 100644 index 0000000..3d62395 --- /dev/null +++ b/Git/Config.hs @@ -0,0 +1,210 @@ +{- git repository configuration handling + - + - Copyright 2010-2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Config where + +import qualified Data.Map as M +import Data.Char + +import Common +import Git +import Git.Types +import qualified Git.Construct +import qualified Git.Command +import Utility.UserInfo + +{- Returns a single git config setting, or a default value if not set. -} +get :: String -> String -> Repo -> String +get key defaultValue repo = M.findWithDefault defaultValue key (config repo) + +{- Returns a list with each line of a multiline config setting. -} +getList :: String -> Repo -> [String] +getList key repo = M.findWithDefault [] key (fullconfig repo) + +{- Returns a single git config setting, if set. -} +getMaybe :: String -> Repo -> Maybe String +getMaybe key repo = M.lookup key (config repo) + +{- Runs git config and populates a repo with its config. + - Avoids re-reading config when run repeatedly. -} +read :: Repo -> IO Repo +read repo@(Repo { config = c }) + | c == M.empty = read' repo + | otherwise = return repo + +{- Reads config even if it was read before. -} +reRead :: Repo -> IO Repo +reRead r = read' $ r + { config = M.empty + , fullconfig = M.empty + } + +{- Cannot use pipeRead because it relies on the config having been already + - read. Instead, chdir to the repo and run git config. + -} +read' :: Repo -> IO Repo +read' repo = go repo + where + go Repo { location = Local { gitdir = d } } = git_config d + go Repo { location = LocalUnknown d } = git_config d + go _ = assertLocal repo $ error "internal" + git_config d = withHandle StdoutHandle createProcessSuccess p $ + hRead repo + where + params = ["config", "--null", "--list"] + p = (proc "git" params) + { cwd = Just d + , env = gitEnv repo + } + +{- Gets the global git config, returning a dummy Repo containing it. -} +global :: IO (Maybe Repo) +global = do + home <- myHomeDir + ifM (doesFileExist $ home ".gitconfig") + ( do + repo <- withHandle StdoutHandle createProcessSuccess p $ + hRead (Git.Construct.fromUnknown) + return $ Just repo + , return Nothing + ) + where + params = ["config", "--null", "--list", "--global"] + p = (proc "git" params) + +{- 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 + +{- 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 repo = do + let c = parse s + 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 } + +{- Updates the location of a repo, based on its configuration. + - + - Git.Construct makes LocalUknown repos, of which only a directory is + - known. Once the config is read, this can be fixed up to a Local repo, + - based on the core.bare and core.worktree settings. + -} +updateLocation :: Repo -> IO Repo +updateLocation r@(Repo { location = LocalUnknown d }) + | isBare r = ifM (doesDirectoryExist dotgit) + ( updateLocation' r $ Local dotgit Nothing + , updateLocation' r $ Local d Nothing + ) + | otherwise = updateLocation' r $ Local dotgit (Just d) + where + dotgit = (d ".git") +updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l +updateLocation r = return r + +updateLocation' :: Repo -> RepoLocation -> IO Repo +updateLocation' r l = do + l' <- case getMaybe "core.worktree" r of + Nothing -> return l + Just d -> do + {- core.worktree is relative to the gitdir -} + top <- absPath $ gitdir l + return $ l { worktree = Just $ absPathFrom top d } + 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 + -- --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 + where + ls = lines s + sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) . + map (separate (== c)) + +{- Checks if a string from git config is a true value. -} +isTrue :: String -> Maybe Bool +isTrue s + | s' == "true" = Just True + | s' == "false" = Just False + | otherwise = Nothing + where + s' = map toLower s + +boolConfig :: Bool -> String +boolConfig True = "true" +boolConfig False = "false" + +isBare :: Repo -> Bool +isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r + +coreBare :: String +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 r cmd params = try $ + withHandle StdoutHandle createProcessSuccess p $ \h -> do + fileEncoding h + val <- hGetContentsStrict h + r' <- store val r + return (r', val) + where + p = proc cmd $ toCommand params + +{- Reads git config from a specified file and returns the repo populated + - with the configuration. -} +fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String)) +fromFile r f = fromPipe r "git" + [ Param "config" + , Param "--file" + , File f + , Param "--list" + ] + +{- 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" + [ Param "config" + , Param "--file" + , File f + , Param k + , Param v + ] + +{- Unsets a git config setting, in both the git repo, + - and the cached config in the Repo. + - + - If unsetting the config fails, including in a read-only repo, or + - when the config is not set, returns Nothing. + -} +unset :: String -> Repo -> IO (Maybe Repo) +unset k r = ifM (Git.Command.runBool ps r) + ( return $ Just $ r { config = M.delete k (config r) } + , return Nothing + ) + where + ps = [Param "config", Param "--unset-all", Param k] diff --git a/Git/Construct.hs b/Git/Construct.hs new file mode 100644 index 0000000..03dd29f --- /dev/null +++ b/Git/Construct.hs @@ -0,0 +1,241 @@ +{- Construction of Git Repo objects + - + - Copyright 2010-2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Git.Construct ( + fromCwd, + fromAbsPath, + fromPath, + fromUrl, + fromUnknown, + localToUrl, + remoteNamed, + remoteNamedFromKey, + fromRemotes, + fromRemoteLocation, + repoAbsPath, + checkForRepo, + newFrom, +) where + +#ifndef mingw32_HOST_OS +import System.Posix.User +#endif +import qualified Data.Map as M hiding (map, split) +import Network.URI + +import Common +import Git.Types +import Git +import Git.Remote +import Git.FilePath +import qualified Git.Url as Url +import Utility.UserInfo + +{- Finds the git repository used for the cwd, which may be in a parent + - directory. -} +fromCwd :: IO (Maybe Repo) +fromCwd = getCurrentDirectory >>= seekUp + where + seekUp dir = do + r <- checkForRepo dir + case r of + Nothing -> case upFrom dir of + Nothing -> return Nothing + Just d -> seekUp d + Just loc -> pure $ Just $ newFrom loc + +{- Local Repo constructor, accepts a relative or absolute path. -} +fromPath :: FilePath -> IO Repo +fromPath dir = fromAbsPath =<< absPath dir + +{- Local Repo constructor, requires an absolute path to the repo be + - specified. -} +fromAbsPath :: FilePath -> IO Repo +fromAbsPath dir + | absoluteGitPath dir = hunt + | otherwise = + error $ "internal error, " ++ dir ++ " is not absolute" + where + ret = pure . newFrom . LocalUnknown + canondir = dropTrailingPathSeparator dir + {- When dir == "foo/.git", git looks for "foo/.git/.git", + - and failing that, uses "foo" as the repository. -} + hunt + | (pathSeparator:".git") `isSuffixOf` canondir = + ifM (doesDirectoryExist $ dir ".git") + ( ret dir + , ret (takeDirectory canondir) + ) + | otherwise = ifM (doesDirectoryExist dir) + ( ret dir + -- git falls back to dir.git when dir doesn't + -- exist, as long as dir didn't end with a + -- path separator + , if dir == canondir + then ret (dir ++ ".git") + else ret dir + ) + +{- Remote Repo constructor. Throws exception on invalid url. + - + - Git is somewhat forgiving about urls to repositories, allowing + - eg spaces that are not normally allowed unescaped in urls. + -} +fromUrl :: String -> IO Repo +fromUrl url + | not (isURI url) = fromUrlStrict $ escapeURIString isUnescapedInURI url + | otherwise = fromUrlStrict url + +fromUrlStrict :: String -> IO Repo +fromUrlStrict url + | startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u + | otherwise = pure $ newFrom $ Url u + where + u = fromMaybe bad $ parseURI url + bad = error $ "bad url " ++ url + +{- Creates a repo that has an unknown location. -} +fromUnknown :: Repo +fromUnknown = newFrom Unknown + +{- Converts a local Repo into a remote repo, using the reference repo + - which is assumed to be on the same host. -} +localToUrl :: Repo -> Repo -> Repo +localToUrl reference r + | not $ repoIsUrl reference = error "internal error; reference repo not url" + | repoIsUrl r = r + | otherwise = case Url.authority reference of + Nothing -> r + Just auth -> + let absurl = concat + [ Url.scheme reference + , "//" + , auth + , repoPath r + ] + in r { location = Url $ fromJust $ parseURI absurl } + +{- Calculates a list of a repo's configured remotes, by parsing its config. -} +fromRemotes :: Repo -> IO [Repo] +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 = startswith "remote." k && endswith ".url" k + construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo + +{- Sets the name of a remote when constructing the Repo to represent it. -} +remoteNamed :: String -> IO Repo -> IO Repo +remoteNamed n constructor = do + r <- constructor + return $ r { remoteName = Just n } + +{- 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 $ split "." k + +{- Constructs a new Repo for one of a Repo's remotes using a given + - location (ie, an url). -} +fromRemoteLocation :: String -> Repo -> IO Repo +fromRemoteLocation s repo = gen $ parseRemoteLocation s repo + where + gen (RemotePath p) = fromRemotePath p repo + gen (RemoteUrl u) = fromUrl u + +{- Constructs a Repo from the path specified in the git remotes of + - another Repo. -} +fromRemotePath :: FilePath -> Repo -> IO Repo +fromRemotePath dir repo = do + dir' <- expandTilde dir + fromPath $ repoPath repo dir' + +{- Git remotes can have a directory that is specified relative + - to the user's home directory, or that contains tilde expansions. + - This converts such a directory to an absolute path. + - Note that it has to run on the system where the remote is. + -} +repoAbsPath :: FilePath -> IO FilePath +repoAbsPath d = do + d' <- expandTilde d + h <- myHomeDir + return $ h d' + +expandTilde :: FilePath -> IO FilePath +#ifdef mingw32_HOST_OS +expandTilde = return +#else +expandTilde = expandt True + where + expandt _ [] = return "" + expandt _ ('/':cs) = do + v <- expandt True cs + return ('/':v) + expandt True ('~':'/':cs) = do + h <- myHomeDir + return $ h cs + expandt True ('~':cs) = do + let (name, rest) = findname "" cs + u <- getUserEntryForName name + return $ homeDirectory u rest + expandt _ (c:cs) = do + v <- expandt False cs + return (c:v) + findname n [] = (n, "") + findname n (c:cs) + | c == '/' = (n, cs) + | otherwise = findname (n++[c]) cs +#endif + +{- Checks if a git repository exists in a directory. Does not find + - git repositories in parent directories. -} +checkForRepo :: FilePath -> IO (Maybe RepoLocation) +checkForRepo dir = + check isRepo $ + check gitDirFile $ + check isBareRepo $ + return Nothing + where + check test cont = maybe cont (return . Just) =<< test + checkdir c = ifM c + ( return $ Just $ LocalUnknown dir + , return Nothing + ) + isRepo = checkdir $ gitSignature $ ".git" "config" + isBareRepo = checkdir $ gitSignature "config" + <&&> doesDirectoryExist (dir "objects") + gitDirFile = do + c <- firstLine <$> + catchDefaultIO "" (readFile $ dir ".git") + return $ if gitdirprefix `isPrefixOf` c + then Just $ Local + { gitdir = absPathFrom dir $ + drop (length gitdirprefix) c + , worktree = Just dir + } + else Nothing + where + gitdirprefix = "gitdir: " + gitSignature file = doesFileExist $ dir file + +newFrom :: RepoLocation -> Repo +newFrom l = Repo + { location = l + , config = M.empty + , fullconfig = M.empty + , remotes = [] + , remoteName = Nothing + , gitEnv = Nothing + , gitGlobalOpts = [] + } + diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs new file mode 100644 index 0000000..dab4ad2 --- /dev/null +++ b/Git/CurrentRepo.hs @@ -0,0 +1,59 @@ +{- The current git repository. + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.CurrentRepo where + +import Common +import Git.Types +import Git.Construct +import qualified Git.Config +import Utility.Env + +{- Gets the current git repository. + - + - Honors GIT_DIR and GIT_WORK_TREE. + - Both environment variables are unset, to avoid confusing other git + - commands that also look at them. Instead, the Git module passes + - --work-tree and --git-dir to git commands it runs. + - + - When GIT_WORK_TREE or core.worktree are set, changes the working + - 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. + -} +get :: IO Repo +get = do + gd <- pathenv "GIT_DIR" + r <- configure gd =<< fromCwd + wt <- maybe (worktree $ location r) Just <$> pathenv "GIT_WORK_TREE" + case wt of + Nothing -> return r + Just d -> do + curr <- getCurrentDirectory + unless (d `dirContains` curr) $ + setCurrentDirectory d + return $ addworktree wt r + where + pathenv s = do + v <- getEnv s + case v of + Just d -> do + unsetEnv s + Just <$> absPath d + Nothing -> return Nothing + + 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 } + configure Nothing Nothing = error "Not in a git repository." + + addworktree w r = changelocation r $ + Local { gitdir = gitdir (location r), worktree = w } + changelocation r l = r { location = l } diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs new file mode 100644 index 0000000..e923796 --- /dev/null +++ b/Git/Destroyer.hs @@ -0,0 +1,148 @@ +{- git repository destroyer + - + - Use with caution! + - + - Copyright 2013, 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Destroyer ( + Damage(..), + generateDamage, + applyDamage +) where + +import Common +import Git +import Utility.QuickCheck +import Utility.FileMode +import Utility.Tmp + +import qualified Data.ByteString as B +import Data.Word + +{- Ways to damange a git repository. -} +data Damage + = Empty FileSelector + | Delete FileSelector + | Reverse FileSelector + | AppendGarbage FileSelector B.ByteString + | PrependGarbage FileSelector B.ByteString + | CorruptByte FileSelector Int Word8 + | ScrambleFileMode FileSelector FileMode + | SwapFiles FileSelector FileSelector + deriving (Read, Show) + +instance Arbitrary Damage where + arbitrary = oneof + [ Empty <$> arbitrary + , Delete <$> arbitrary + , Reverse <$> arbitrary + , AppendGarbage <$> arbitrary <*> garbage + , PrependGarbage <$> arbitrary <*> garbage + , CorruptByte + <$> arbitrary + <*> nonNegative arbitraryBoundedIntegral + <*> arbitrary + , ScrambleFileMode + <$> arbitrary + <*> nonNegative arbitrarySizedIntegral + , SwapFiles + <$> arbitrary + <*> arbitrary + ] + where + garbage = B.pack <$> arbitrary `suchThat` (not . null) + +{- To select a given file in a git repository, all files in the repository + - are enumerated, sorted, and this is used as an index + - into the list. (Wrapping around if higher than the length.) -} +data FileSelector = FileSelector Int + deriving (Read, Show, Eq) + +instance Arbitrary FileSelector where + arbitrary = FileSelector <$> oneof + -- An early file in the git tree, tends to be the most + -- interesting when there are lots of files. + [ nonNegative arbitrarySizedIntegral + -- Totally random choice from any of the files in + -- the git tree, to ensure good coverage. + , nonNegative arbitraryBoundedIntegral + ] + +selectFile :: [FilePath] -> FileSelector -> FilePath +selectFile sortedfs (FileSelector n) = sortedfs !! (n `mod` length sortedfs) + +{- Generates random Damage. -} +generateDamage :: IO [Damage] +generateDamage = sample' (arbitrary :: Gen Damage) + +{- Applies Damage to a Repo, in a reproducible fashion + - (as long as the Repo contains the same files each time). -} +applyDamage :: [Damage] -> Repo -> IO () +applyDamage ds r = do + contents <- sort . filter (not . skipped) + <$> dirContentsRecursive (localGitDir r) + forM_ ds $ \d -> do + let withfile s a = do + let f = selectFile contents s + -- Symlinks might be dangling, so are skipped. + -- If the file was already removed by a previous Damage, + -- it's skipped. + whenM (doesFileExist f) $ + a f `catchIO` \e -> error ("Failed to apply damage " ++ show d ++ " to " ++ show f ++ ": " ++ show e ++ "(total damage: " ++ show ds ++ ")") + case d of + Empty s -> withfile s $ \f -> + withSaneMode f $ do + nukeFile f + writeFile f "" + Reverse s -> withfile s $ \f -> + withSaneMode f $ + B.writeFile f =<< B.reverse <$> B.readFile f + Delete s -> withfile s $ nukeFile + AppendGarbage s garbage -> + withfile s $ \f -> + withSaneMode f $ + B.appendFile f garbage + PrependGarbage s garbage -> + withfile s $ \f -> + withSaneMode f $ do + b <- B.readFile f + B.writeFile f $ B.concat [garbage, b] + -- When the byte is past the end of the + -- file, wrap around. Does nothing to empty file. + CorruptByte s n garbage -> + withfile s $ \f -> + withSaneMode f $ do + b <- B.readFile f + let len = B.length b + unless (len == 0) $ do + let n' = n `mod` len + let (prefix, rest) = B.splitAt n' b + B.writeFile f $ B.concat + [prefix + , B.singleton garbage + , B.drop 1 rest + ] + ScrambleFileMode s mode -> + withfile s $ \f -> + setFileMode f mode + SwapFiles a b -> + withfile a $ \fa -> + withfile b $ \fb -> + unless (fa == fb) $ + withTmpFile "swap" $ \tmp _ -> do + moveFile fa tmp + moveFile fb fa + moveFile tmp fa + where + -- A broken .git/config is not recoverable. + -- Don't damage hook scripts, to avoid running arbitrary code. ;) + skipped f = or + [ takeFileName f == "config" + , "hooks" `isPrefixOf` f + ] + +withSaneMode :: FilePath -> IO () -> IO () +withSaneMode f = withModifiedFileMode f (addModes [ownerWriteMode, ownerReadMode]) diff --git a/Git/DiffTreeItem.hs b/Git/DiffTreeItem.hs new file mode 100644 index 0000000..859f590 --- /dev/null +++ b/Git/DiffTreeItem.hs @@ -0,0 +1,24 @@ +{- git diff-tree item + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.DiffTreeItem ( + DiffTreeItem(..), +) where + +import System.Posix.Types + +import Git.FilePath +import Git.Types + +data DiffTreeItem = DiffTreeItem + { srcmode :: FileMode + , dstmode :: FileMode + , srcsha :: Sha -- nullSha if file was added + , dstsha :: Sha -- nullSha if file was deleted + , status :: String + , file :: TopFilePath + } deriving Show diff --git a/Git/FilePath.hs b/Git/FilePath.hs new file mode 100644 index 0000000..edc3c0f --- /dev/null +++ b/Git/FilePath.hs @@ -0,0 +1,77 @@ +{- git FilePath library + - + - Different git commands use different types of FilePaths to refer to + - files in the repository. Some commands use paths relative to the + - top of the repository even when run in a subdirectory. Adding some + - types helps keep that straight. + - + - Copyright 2012-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Git.FilePath ( + TopFilePath, + fromTopFilePath, + getTopFilePath, + toTopFilePath, + asTopFilePath, + InternalGitPath, + toInternalGitPath, + fromInternalGitPath, + absoluteGitPath +) where + +import Common +import Git + +import qualified System.FilePath.Posix + +{- A FilePath, relative to the top of the git repository. -} +newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } + deriving (Show) + +{- Returns an absolute FilePath. -} +fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath +fromTopFilePath p repo = absPathFrom (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 + +{- The input FilePath must already be relative to the top of the git + - repository -} +asTopFilePath :: FilePath -> TopFilePath +asTopFilePath file = TopFilePath file + +{- Git may use a different representation of a path when storing + - it internally. + - + - On Windows, git uses '/' to separate paths stored in the repository, + - despite Windows using '\'. + - + -} +type InternalGitPath = String + +toInternalGitPath :: FilePath -> InternalGitPath +#ifndef mingw32_HOST_OS +toInternalGitPath = id +#else +toInternalGitPath = replace "\\" "/" +#endif + +fromInternalGitPath :: InternalGitPath -> FilePath +#ifndef mingw32_HOST_OS +fromInternalGitPath = id +#else +fromInternalGitPath = replace "/" "\\" +#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) diff --git a/Git/Filename.hs b/Git/Filename.hs new file mode 100644 index 0000000..ee84d48 --- /dev/null +++ b/Git/Filename.hs @@ -0,0 +1,28 @@ +{- Some git commands output encoded filenames, in a rather annoyingly complex + - C-style encoding. + - + - Copyright 2010, 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Filename where + +import Utility.Format (decode_c, encode_c) + +import Common + +decode :: String -> FilePath +decode [] = [] +decode f@(c:s) + -- encoded strings will be inside double quotes + | c == '"' && end s == ['"'] = decode_c $ beginning s + | otherwise = f + +{- Should not need to use this, except for testing decode. -} +encode :: FilePath -> String +encode s = "\"" ++ encode_c s ++ "\"" + +{- for quickcheck -} +prop_isomorphic_deencode :: String -> Bool +prop_isomorphic_deencode s = s == decode (encode s) diff --git a/Git/Fsck.hs b/Git/Fsck.hs new file mode 100644 index 0000000..f3e6db9 --- /dev/null +++ b/Git/Fsck.hs @@ -0,0 +1,117 @@ +{- git fsck interface + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Fsck ( + FsckResults(..), + MissingObjects, + findBroken, + foundBroken, + findMissing, + isMissing, + knownMissing, +) where + +import Common +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 + +type MissingObjects = S.Set Sha + +data FsckResults + = FsckFoundMissing + { missingObjects :: MissingObjects + , missingObjectsTruncated :: Bool + } + | FsckFailed + deriving (Show) + +{- 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. + - + - Strategy: Rather than parsing fsck's current specific output, + - look for anything in its output (both stdout and stderr) that appears + - to be a git sha. Not all such shas are of broken objects, so ask git + - to try to cat the object, and see if it fails. + -} +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) + (command', params') <- if batchmode + then toBatchCommand (command, params) + else return (command, params) + + p@(_, _, _, pid) <- createProcess $ + (proc command' (toCommand params')) + { std_out = CreatePipe + , std_err = CreatePipe + } + (bad1, bad2) <- concurrently + (readMissingObjs maxobjs r supportsNoDangling (stdoutHandle p)) + (readMissingObjs 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 + where + maxobjs = 10000 + +foundBroken :: FsckResults -> Bool +foundBroken FsckFailed = True +foundBroken (FsckFoundMissing s _) = not (S.null s) + +knownMissing :: FsckResults -> MissingObjects +knownMissing FsckFailed = S.empty +knownMissing (FsckFoundMissing s _) = s + +{- Finds objects that are missing from the git repsitory, or are corrupt. + - + - This does not use git cat-file --batch, because catting a corrupt + - object can cause it to crash, or to report incorrect size information. + -} +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 + +isMissing :: Sha -> Repo -> IO Bool +isMissing s r = either (const True) (const False) <$> tryIO dump + where + dump = runQuiet + [ Param "show" + , Param (fromRef s) + ] r + +findShas :: Bool -> String -> [Sha] +findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted . lines + 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" + ] diff --git a/Git/Index.hs b/Git/Index.hs new file mode 100644 index 0000000..551fd98 --- /dev/null +++ b/Git/Index.hs @@ -0,0 +1,55 @@ +{- git index file stuff + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Index where + +import Common +import Git +import Utility.Env + +indexEnv :: String +indexEnv = "GIT_INDEX_FILE" + +{- Forces git to use the specified index file. + - + - Returns an action that will reset back to the default + - index file. + - + - Warning: Not thread safe. + -} +override :: FilePath -> IO (IO ()) +override index = do + res <- getEnv var + setEnv var index True + return $ reset res + where + var = "GIT_INDEX_FILE" + reset (Just v) = setEnv indexEnv v True + reset _ = unsetEnv var + +indexFile :: Repo -> FilePath +indexFile r = localGitDir r "index" + +{- Git locks the index by creating this file. -} +indexFileLock :: Repo -> FilePath +indexFileLock r = indexFile r ++ ".lock" + +{- 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 diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs new file mode 100644 index 0000000..f945838 --- /dev/null +++ b/Git/LsFiles.hs @@ -0,0 +1,258 @@ +{- git ls-files interface + - + - Copyright 2010,2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.LsFiles ( + inRepo, + notInRepo, + allFiles, + deleted, + modified, + modifiedOthers, + staged, + stagedNotDeleted, + stagedOthersDetails, + stagedDetails, + typeChanged, + typeChangedStaged, + Conflicting(..), + Unmerged(..), + unmerged, + StagedDetails, +) where + +import Common +import Git +import Git.Command +import Git.Types +import Git.Sha + +import Numeric +import System.Posix.Types + +{- 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 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 + where + params = concat + [ [ Param "ls-files", Param "--others"] + , exclude + , [ Param "-z", Param "--" ] + , map File l + ] + exclude + | include_ignored = [] + | otherwise = [Param "--exclude-standard"] + +{- Finds all files in the specified locations, whether checked into git or + - not. -} +allFiles :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +allFiles l = pipeNullSplit $ + Param "ls-files" : + Param "--cached" : + Param "--others" : + Param "-z" : + Param "--" : + map File 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 + where + params = + Param "ls-files" : + Param "--deleted" : + Param "-z" : + Param "--" : + map File 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 + where + params = + Param "ls-files" : + Param "--modified" : + Param "-z" : + Param "--" : + map File 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 + where + params = + Param "ls-files" : + Param "--modified" : + Param "--others" : + Param "--exclude-standard" : + Param "-z" : + Param "--" : + map File l + +{- Returns a list of all files that are staged for commit. -} +staged :: [FilePath] -> Repo -> IO ([FilePath], 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 = staged' [Param "--diff-filter=ACMRT"] + +staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) +staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix + where + prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] + suffix = Param "--" : map File l + +type StagedDetails = (FilePath, 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 = 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 = stagedDetails' [] + +{- Gets details about staged files, including the Sha of their staged + - contents. -} +stagedDetails' :: [CommandParam] -> [FilePath] -> 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 + parse s + | null file = (s, Nothing, Nothing) + | otherwise = (file, extractSha $ take shaSize rest, readmode mode) + where + (metadata, file) = separate (== '\t') 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 = 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 = typeChanged' [] + +typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], 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) + currdir <- getCurrentDirectory + return (map (\f -> relPathDirToFileAbs currdir $ top f) fs, cleanup) + where + prefix = + [ Param "diff" + , Param "--name-only" + , Param "--diff-filter=T" + , Param "-z" + ] + suffix = Param "--" : (if null l then [File "."] else map File l) + +{- A item in conflict has two possible values. + - Either can be Nothing, when that side deleted the file. -} +data Conflicting v = Conflicting + { valUs :: Maybe v + , valThem :: Maybe v + } deriving (Show) + +data Unmerged = Unmerged + { unmergedFile :: FilePath + , unmergedBlobType :: Conflicting BlobType + , unmergedSha :: Conflicting Sha + } deriving (Show) + +{- Returns a list of the files in the specified locations that have + - unresolved merge conflicts. + - + - ls-files outputs multiple lines per conflicting file, each with its own + - stage number: + - 1 = old version, can be ignored + - 2 = us + - 3 = them + - If a line is omitted, that side removed the file. + -} +unmerged :: [FilePath] -> Repo -> IO ([Unmerged], IO Bool) +unmerged l repo = do + (fs, cleanup) <- pipeNullSplit params repo + return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup) + where + params = + Param "ls-files" : + Param "--unmerged" : + Param "-z" : + Param "--" : + map File l + +data InternalUnmerged = InternalUnmerged + { isus :: Bool + , ifile :: FilePath + , iblobtype :: Maybe BlobType + , isha :: Maybe Sha + } deriving (Show) + +parseUnmerged :: String -> Maybe InternalUnmerged +parseUnmerged s + | null file = Nothing + | otherwise = case words metadata of + (rawblobtype:rawsha:rawstage:_) -> do + stage <- readish rawstage :: Maybe Int + if stage /= 2 && stage /= 3 + then Nothing + else do + blobtype <- readBlobType rawblobtype + sha <- extractSha rawsha + return $ InternalUnmerged (stage == 2) file + (Just blobtype) (Just sha) + _ -> Nothing + where + (metadata, file) = separate (== '\t') s + +reduceUnmerged :: [Unmerged] -> [InternalUnmerged] -> [Unmerged] +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) + new = Unmerged + { unmergedFile = ifile i + , unmergedBlobType = Conflicting blobtypeA blobtypeB + , unmergedSha = Conflicting shaA shaB + } + findsib templatei [] = ([], removed templatei) + findsib templatei (l:ls) + | ifile l == ifile templatei = (ls, l) + | otherwise = (l:ls, removed templatei) + removed templatei = templatei + { isus = not (isus templatei) + , iblobtype = Nothing + , isha = Nothing + } diff --git a/Git/LsTree.hs b/Git/LsTree.hs new file mode 100644 index 0000000..1ed6247 --- /dev/null +++ b/Git/LsTree.hs @@ -0,0 +1,78 @@ +{- git ls-tree interface + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.LsTree ( + TreeItem(..), + lsTree, + lsTreeParams, + lsTreeFiles, + parseLsTree +) where + +import Common +import Git +import Git.Command +import Git.Sha +import Git.FilePath +import qualified Git.Filename + +import Numeric +import System.Posix.Types + +data TreeItem = TreeItem + { mode :: FileMode + , typeobj :: String + , sha :: String + , 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 + +lsTreeParams :: Ref -> [CommandParam] -> [CommandParam] +lsTreeParams r ps = + [ Param "ls-tree" + , Param "--full-tree" + , Param "-z" + , Param "-r" + ] ++ ps ++ + [ Param "--" + , File $ fromRef r + ] + +{- Lists specified files in a tree. -} +lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem] +lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo + where + ps = + [ Param "ls-tree" + , Param "--full-tree" + , Param "-z" + , Param "--" + , File $ fromRef t + ] ++ map File fs + +{- Parses a line of ls-tree output. + - (The --long format is not currently supported.) -} +parseLsTree :: String -> TreeItem +parseLsTree l = TreeItem + { mode = fst $ Prelude.head $ readOct m + , typeobj = t + , sha = s + , file = asTopFilePath $ Git.Filename.decode f + } + 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 diff --git a/Git/Objects.hs b/Git/Objects.hs new file mode 100644 index 0000000..bda220b --- /dev/null +++ b/Git/Objects.hs @@ -0,0 +1,49 @@ +{- .git/objects + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Objects where + +import Common +import Git +import Git.Sha + +objectsDir :: Repo -> FilePath +objectsDir r = localGitDir r "objects" + +packDir :: Repo -> FilePath +packDir r = objectsDir r "pack" + +packIdxFile :: FilePath -> FilePath +packIdxFile = flip replaceExtension "idx" + +listPackFiles :: Repo -> IO [FilePath] +listPackFiles r = filter (".pack" `isSuffixOf`) + <$> catchDefaultIO [] (dirContents $ packDir r) + +listLooseObjectShas :: Repo -> IO [Sha] +listLooseObjectShas r = catchDefaultIO [] $ + mapMaybe (extractSha . concat . reverse . take 2 . reverse . splitDirectories) + <$> dirContentsRecursiveSkipping (== "pack") True (objectsDir r) + +looseObjectFile :: Repo -> Sha -> FilePath +looseObjectFile r sha = objectsDir r prefix rest + where + (prefix, rest) = splitAt 2 (fromRef sha) + +listAlternates :: Repo -> IO [FilePath] +listAlternates r = catchDefaultIO [] (lines <$> readFile alternatesfile) + where + alternatesfile = objectsDir r "info" "alternates" + +{- A repository recently cloned with --shared will have one or more + - alternates listed, and contain no loose objects or packs. -} +isSharedClone :: Repo -> IO Bool +isSharedClone r = allM id + [ not . null <$> listAlternates r + , null <$> listLooseObjectShas r + , null <$> listPackFiles r + ] diff --git a/Git/Ref.hs b/Git/Ref.hs new file mode 100644 index 0000000..6bc47d5 --- /dev/null +++ b/Git/Ref.hs @@ -0,0 +1,147 @@ +{- git ref stuff + - + - Copyright 2011-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Ref where + +import Common +import Git +import Git.Command +import Git.Sha +import Git.Types + +import Data.Char (chr) + +headRef :: Ref +headRef = Ref "HEAD" + +{- 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). -} +base :: Ref -> Ref +base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef + where + remove prefix s + | 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. -} +underBase :: String -> Ref -> Ref +underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r) + +{- A Ref that can be used to refer to a file in the repository, as staged + - in the index. + - + - Prefixing the file with ./ makes this work even if in a subdirectory + - of a repo. + -} +fileRef :: FilePath -> Ref +fileRef f = Ref $ ":./" ++ f + +{- Converts a Ref to refer to the content of the Ref on a given date. -} +dateRef :: Ref -> RefDate -> Ref +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 r) f = let (Ref fr) = fileRef f in Ref (r ++ fr) + +{- Checks if a ref exists. -} +exists :: Ref -> Repo -> IO Bool +exists ref = runBool + [Param "show-ref", Param "--verify", Param "-q", Param $ fromRef ref] + +{- 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 + +{- 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 + +{- 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 + +headSha :: Repo -> IO (Maybe Sha) +headSha = sha headRef + +{- List of (shas, branches) matching a given ref or refs. -} +matching :: [Ref] -> Repo -> IO [(Sha, Branch)] +matching refs repo = matching' (map fromRef refs) repo + +{- Includes HEAD in the output, if asked for it. -} +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. -} +matching' :: [String] -> Repo -> IO [(Sha, Branch)] +matching' ps repo = map gen . lines <$> + pipeReadStrict (Param "show-ref" : map Param ps) repo + where + gen l = let (r, b) = separate (== ' ') l + in (Ref r, Ref b) + +{- List of (shas, branches) matching a given ref spec. + - 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 + +{- 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 ++ ":") ] + +{- Checks if a String is a legal git ref name. + - + - The rules for this are complex; see git-check-ref-format(1) -} +legal :: Bool -> String -> Bool +legal allowonelevel s = all (== False) illegal + where + illegal = + [ any ("." `isPrefixOf`) pathbits + , any (".lock" `isSuffixOf`) pathbits + , not allowonelevel && length pathbits < 2 + , contains ".." + , any (\c -> contains [c]) illegalchars + , begins "/" + , ends "/" + , contains "//" + , ends "." + , contains "@{" + , null s + ] + contains v = v `isInfixOf` s + ends v = v `isSuffixOf` s + begins v = v `isPrefixOf` s + + pathbits = split "/" s + illegalchars = " ~^:?*[\\" ++ controlchars + controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)] diff --git a/Git/RefLog.hs b/Git/RefLog.hs new file mode 100644 index 0000000..57f35e9 --- /dev/null +++ b/Git/RefLog.hs @@ -0,0 +1,30 @@ +{- git reflog interface + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.RefLog where + +import Common +import Git +import Git.Command +import Git.Sha + +{- Gets the reflog for a given branch. -} +get :: Branch -> Repo -> IO [Sha] +get b = getMulti [b] + +{- Gets reflogs for multiple branches. -} +getMulti :: [Branch] -> Repo -> IO [Sha] +getMulti bs = get' (map (Param . fromRef) bs) + +get' :: [CommandParam] -> Repo -> IO [Sha] +get' ps = mapMaybe extractSha . lines <$$> pipeReadStrict ps' + where + ps' = catMaybes + [ Just $ Param "log" + , Just $ Param "-g" + , Just $ Param "--format=%H" + ] ++ ps diff --git a/Git/Remote.hs b/Git/Remote.hs new file mode 100644 index 0000000..717b540 --- /dev/null +++ b/Git/Remote.hs @@ -0,0 +1,108 @@ +{- git remote stuff + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Git.Remote where + +import Common +import Git +import Git.Types + +import Data.Char +import qualified Data.Map as M +import Network.URI +#ifdef mingw32_HOST_OS +import Git.FilePath +#endif + +{- 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, + - just some ad-hoc checks, and some other things that fail with certian + - types of names (like ones starting with '-'). + -} +makeLegalName :: String -> RemoteName +makeLegalName s = case filter legal $ replace "/" "_" s of + -- it can't be empty + [] -> "unnamed" + -- it can't start with / or - or . + '.':s' -> makeLegalName s' + '/':s' -> makeLegalName s' + '-':s' -> makeLegalName s' + s' -> s' + where + {- Only alphanumerics, and a few common bits of punctuation common + - in hostnames. -} + legal '_' = True + legal '.' = True + legal c = isAlphaNum c + +data RemoteLocation = RemoteUrl String | RemotePath FilePath + +remoteLocationIsUrl :: RemoteLocation -> Bool +remoteLocationIsUrl (RemoteUrl _) = True +remoteLocationIsUrl _ = False + +remoteLocationIsSshUrl :: RemoteLocation -> Bool +remoteLocationIsSshUrl (RemoteUrl u) = "ssh://" `isPrefixOf` u +remoteLocationIsSshUrl _ = False + +{- Determines if a given remote location is an url, or a local + - path. Takes the repository's insteadOf configuration into account. -} +parseRemoteLocation :: String -> Repo -> RemoteLocation +parseRemoteLocation s repo = ret $ calcloc s + where + ret v +#ifdef mingw32_HOST_OS + | dosstyle v = RemotePath (dospath v) +#endif + | scpstyle v = RemoteUrl (scptourl v) + | urlstyle v = RemoteUrl v + | otherwise = RemotePath v + -- insteadof config can rewrite remote location + calcloc l + | null insteadofs = l + | otherwise = replacement ++ drop (length bestvalue) l + where + replacement = drop (length prefix) $ + take (length bestkey - length suffix) bestkey + (bestkey, bestvalue) = maximumBy longestvalue insteadofs + longestvalue (_, a) (_, b) = compare b a + insteadofs = filterconfig $ \(k, v) -> + startswith prefix k && + endswith suffix k && + startswith v l + filterconfig f = filter f $ + concatMap splitconfigs $ M.toList $ fullconfig repo + splitconfigs (k, vs) = map (\v -> (k, v)) vs + (prefix, suffix) = ("url." , ".insteadof") + urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v + -- git remotes can be written scp style -- [user@]host:dir + -- but foo::bar is a git-remote-helper location instead + scpstyle v = ":" `isInfixOf` v + && not ("//" `isInfixOf` v) + && not ("::" `isInfixOf` v) + scptourl v = "ssh://" ++ host ++ slash dir + where + (host, dir) + -- handle ipv6 address inside [] + | "[" `isPrefixOf` v = case break (== ']') v of + (h, ']':':':d) -> (h ++ "]", d) + (h, ']':d) -> (h ++ "]", d) + (h, d) -> (h, d) + | otherwise = separate (== ':') v + slash d | d == "" = "/~/" ++ d + | "/" `isPrefixOf` d = d + | "~" `isPrefixOf` d = '/':d + | otherwise = "/~/" ++ d +#ifdef mingw32_HOST_OS + -- 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 +#endif diff --git a/Git/Repair.hs b/Git/Repair.hs new file mode 100644 index 0000000..b441f13 --- /dev/null +++ b/Git/Repair.hs @@ -0,0 +1,617 @@ +{- git repository recovery + - + - Copyright 2013-2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Repair ( + runRepair, + runRepairOf, + removeBadBranches, + successfulRepair, + cleanCorruptObjects, + retrieveMissingObjects, + resetLocalBranches, + checkIndex, + checkIndexFast, + missingIndex, + emptyGoodCommits, + isTrackingBranch, +) where + +import Common +import Git +import Git.Command +import Git.Objects +import Git.Sha +import Git.Types +import Git.Fsck +import Git.Index +import qualified Git.Config as Config +import qualified Git.Construct as Construct +import qualified Git.LsTree as LsTree +import qualified Git.LsFiles as LsFiles +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.Rsync +import Utility.FileMode + +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. -} +cleanCorruptObjects :: FsckResults -> Repo -> IO () +cleanCorruptObjects fsckresults r = do + void $ explodePacks r + mapM_ removeLoose (S.toList $ knownMissing fsckresults) + mapM_ removeBad =<< listLooseObjectShas r + where + removeLoose s = nukeFile (looseObjectFile r s) + removeBad s = do + void $ tryIO $ allowRead $ looseObjectFile r s + whenM (isMissing s r) $ + removeLoose s + +{- Explodes all pack files, and deletes them. + - + - First moves all pack files to a temp dir, before unpacking them each in + - turn. + - + - This is because unpack-objects will not unpack a pack file if it's in the + - git repo. + - + - Also, this prevents unpack-objects from possibly looking at corrupt + - pack files to see if they contain an object, while unpacking a + - non-corrupt pack file. + -} +explodePacks :: Repo -> IO Bool +explodePacks r = go =<< listPackFiles r + where + go [] = return False + go packs = withTmpDir "packs" $ \tmpdir -> do + putStrLn "Unpacking all pack files." + forM_ packs $ \packfile -> do + moveFile packfile (tmpdir takeFileName packfile) + nukeFile $ packIdxFile packfile + forM_ packs $ \packfile -> do + let tmp = tmpdir takeFileName packfile + allowRead tmp + -- May fail, if pack file is corrupt. + void $ tryIO $ + pipeWrite [Param "unpack-objects", Param "-r"] r $ \h -> + L.hPut h =<< L.readFile tmp + return True + +{- Try to retrieve a set of missing objects, from the remotes of a + - repository. Returns any that could not be retreived. + - + - If another clone of the repository exists locally, which might not be a + - remote of the repo being repaired, its path can be passed as a reference + - repository. + -} +retrieveMissingObjects :: FsckResults -> Maybe FilePath -> Repo -> IO FsckResults +retrieveMissingObjects missing referencerepo r + | not (foundBroken missing) = return missing + | otherwise = withTmpDir "tmprepo" $ \tmpdir -> do + 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 + if S.null (knownMissing stillmissing) + then return stillmissing + else pullremotes tmpr (remotes r) fetchallrefs stillmissing + where + pullremotes tmpr [] fetchrefs stillmissing = case referencerepo of + Nothing -> return stillmissing + Just p -> ifM (fetchfrom p fetchrefs tmpr) + ( do + void $ explodePacks tmpr + void $ copyObjects tmpr r + case stillmissing of + FsckFailed -> return $ FsckFailed + FsckFoundMissing s t -> FsckFoundMissing + <$> findMissing (S.toList s) r + <*> pure t + , return stillmissing + ) + pullremotes tmpr (rmt:rmts) fetchrefs ms + | not (foundBroken ms) = return ms + | otherwise = do + putStrLn $ "Trying to recover missing objects from remote " ++ repoDescribe rmt ++ "." + ifM (fetchfrom (repoLocation rmt) fetchrefs tmpr) + ( do + void $ explodePacks tmpr + void $ copyObjects tmpr r + case ms of + FsckFailed -> pullremotes tmpr rmts fetchrefs ms + FsckFoundMissing s t -> do + stillmissing <- findMissing (S.toList s) r + pullremotes tmpr rmts fetchrefs (FsckFoundMissing stillmissing t) + , pullremotes tmpr rmts fetchrefs ms + ) + fetchfrom fetchurl ps fetchr = runBool ps' fetchr' + where + ps' = + [ Param "fetch" + , Param fetchurl + , Param "--force" + , Param "--update-head-ok" + , Param "--quiet" + ] ++ ps + fetchr' = fetchr { gitGlobalOpts = gitGlobalOpts fetchr ++ nogc } + nogc = [ Param "-c", Param "gc.auto=0" ] + + -- fetch refs and tags + fetchrefstags = [ Param "+refs/heads/*:refs/heads/*", Param "--tags"] + -- Fetch all available refs (more likely to fail, + -- as the remote may have refs it refuses to send). + fetchallrefs = [ Param "+*:*" ] + +{- Copies all objects from the src repository to the dest repository. + - This is done using rsync, so it copies all missing objects, and all + - objects they rely on. -} +copyObjects :: Repo -> Repo -> IO Bool +copyObjects srcr destr = rsync + [ Param "-qr" + , File $ addTrailingPathSeparator $ objectsDir srcr + , File $ addTrailingPathSeparator $ objectsDir destr + ] + +{- To deal with missing objects that cannot be recovered, resets any + - local branches to point to an old commit before the missing + - objects. Returns all branches that were changed, and deleted. + -} +resetLocalBranches :: MissingObjects -> GoodCommits -> Repo -> IO ([Branch], [Branch], GoodCommits) +resetLocalBranches missing goodcommits r = + go [] [] goodcommits =<< filter islocalbranch <$> getAllRefs r + where + islocalbranch b = "refs/heads/" `isPrefixOf` fromRef b + go changed deleted gcs [] = return (changed, deleted, gcs) + go changed deleted gcs (b:bs) = do + (mc, gcs') <- findUncorruptedCommit missing gcs b r + case mc of + Just c + | c == b -> go changed deleted gcs' bs + | otherwise -> do + reset b c + go (b:changed) deleted gcs' bs + Nothing -> do + nukeBranchRef b r + go changed (b:deleted) gcs' bs + reset b c = do + nukeBranchRef b r + void $ runBool + [ Param "branch" + , Param (fromRef $ Ref.base b) + , Param (fromRef c) + ] r + +isTrackingBranch :: Ref -> Bool +isTrackingBranch b = "refs/remotes/" `isPrefixOf` fromRef b + +{- To deal with missing objects that cannot be recovered, removes + - any branches (filtered by a predicate) that reference them + - Returns a list of all removed branches. + -} +removeBadBranches :: (Ref -> Bool) -> Repo -> IO [Branch] +removeBadBranches removablebranch r = fst <$> removeBadBranches' removablebranch S.empty emptyGoodCommits r + +removeBadBranches' :: (Ref -> Bool) -> MissingObjects -> GoodCommits -> Repo -> IO ([Branch], GoodCommits) +removeBadBranches' removablebranch missing goodcommits r = + go [] goodcommits =<< filter removablebranch <$> getAllRefs r + where + go removed gcs [] = return (removed, gcs) + go removed gcs (b:bs) = do + (ok, gcs') <- verifyCommit missing gcs b r + if ok + then go removed gcs' bs + else do + nukeBranchRef b r + go (b:removed) gcs' bs + +badBranches :: MissingObjects -> Repo -> IO [Branch] +badBranches missing r = filterM isbad =<< getAllRefs r + where + isbad b = not . fst <$> verifyCommit missing emptyGoodCommits b r + +{- Gets all refs, including ones that are corrupt. + - git show-ref does not output refs to commits that are directly + - corrupted, so it is not used. + - + - Relies on packed refs being exploded before it's called. + -} +getAllRefs :: Repo -> IO [Ref] +getAllRefs r = getAllRefs' (localGitDir r "refs") + +getAllRefs' :: FilePath -> IO [Ref] +getAllRefs' refdir = do + let topsegs = length (splitPath refdir) - 1 + let toref = Ref . joinPath . drop topsegs . splitPath + map toref <$> dirContentsRecursive refdir + +explodePackedRefsFile :: Repo -> IO () +explodePackedRefsFile r = do + let f = packedRefsFile r + whenM (doesFileExist f) $ do + rs <- mapMaybe parsePacked . lines + <$> catchDefaultIO "" (safeReadFile f) + forM_ rs makeref + nukeFile f + where + makeref (sha, ref) = do + let dest = localGitDir r fromRef ref + createDirectoryIfMissing True (parentDir dest) + unlessM (doesFileExist dest) $ + writeFile dest (fromRef sha) + +packedRefsFile :: Repo -> FilePath +packedRefsFile r = localGitDir r "packed-refs" + +parsePacked :: String -> Maybe (Sha, Ref) +parsePacked l = case words l of + (sha:ref:[]) + | isJust (extractSha sha) && Ref.legal True ref -> + Just (Ref sha, Ref ref) + _ -> Nothing + +{- 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 + +{- 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. + - Otherwise, tries to traverse the commits in the branch to find one + - that is ok. That might fail, if one of them is corrupt, or if an object + - at the root of the branch is missing. Finally, looks for an old version + - of the branch from the reflog. + -} +findUncorruptedCommit :: MissingObjects -> GoodCommits -> Branch -> Repo -> IO (Maybe Sha, GoodCommits) +findUncorruptedCommit missing goodcommits branch r = do + (ok, goodcommits') <- verifyCommit missing goodcommits branch r + if ok + then return (Just branch, goodcommits') + else do + (ls, cleanup) <- pipeNullSplit + [ Param "log" + , Param "-z" + , Param "--format=%H" + , Param (fromRef branch) + ] r + let branchshas = catMaybes $ map extractSha ls + reflogshas <- RefLog.get branch r + -- XXX Could try a bit harder here, and look + -- for uncorrupted old commits in branches in the + -- reflog. + cleanup `after` findfirst goodcommits (branchshas ++ reflogshas) + where + findfirst gcs [] = return (Nothing, gcs) + findfirst gcs (c:cs) = do + (ok, gcs') <- verifyCommit missing gcs c r + if ok + then return (Just c, gcs') + else findfirst gcs' cs + +{- Verifies that none of the missing objects in the set are used by + - the commit. Also adds to a set of commit shas that have been verified to + - be good, which can be passed into subsequent calls to avoid + - redundant work when eg, chasing down branches to find the first + - uncorrupted commit. -} +verifyCommit :: MissingObjects -> GoodCommits -> Sha -> Repo -> IO (Bool, GoodCommits) +verifyCommit missing goodcommits commit r + | checkGoodCommit commit goodcommits = return (True, goodcommits) + | otherwise = do + (ls, cleanup) <- pipeNullSplit + [ Param "log" + , Param "-z" + , Param "--format=%H %T" + , Param (fromRef commit) + ] r + let committrees = map parse ls + if any isNothing committrees || null committrees + then do + void cleanup + return (False, goodcommits) + else do + let cts = catMaybes committrees + ifM (cleanup <&&> check cts) + ( return (True, addGoodCommits (map fst cts) goodcommits) + , return (False, goodcommits) + ) + where + parse l = case words l of + (commitsha:treesha:[]) -> (,) + <$> extractSha commitsha + <*> extractSha treesha + _ -> Nothing + check [] = return True + check ((c, t):rest) + | checkGoodCommit c goodcommits = return True + | otherwise = verifyTree missing t r <&&> check rest + +{- Verifies that a tree is good, including all trees and blobs + - referenced by it. -} +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 (extractSha . LsTree.sha . LsTree.parseLsTree) ls + if any isNothing objshas || any (`S.member` missing) (catMaybes objshas) + then do + void cleanup + return False + -- as long as ls-tree succeeded, we're good + else cleanup + +{- Checks that the index file only refers to objects that are not missing, + - and is not itself corrupt. Note that a missing index file is not + - considered a problem (repo may be new). -} +checkIndex :: Repo -> IO Bool +checkIndex r = do + (bad, _good, cleanup) <- partitionIndex r + if null bad + then cleanup + else do + void cleanup + return False + +{- Does not check every object the index refers to, but only that the index + - itself is not corrupt. -} +checkIndexFast :: Repo -> IO Bool +checkIndexFast r = do + (indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r + length indexcontents `seq` cleanup + +missingIndex :: Repo -> IO Bool +missingIndex r = not <$> doesFileExist (localGitDir r "index") + +{- Finds missing and ok files staged in the index. -} +partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool) +partitionIndex r = do + (indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r + l <- forM indexcontents $ \i -> case i of + (_file, Just sha, Just _mode) -> (,) <$> isMissing sha r <*> pure i + _ -> pure (False, i) + let (bad, good) = partition fst l + return (map snd bad, map snd good, cleanup) + +{- Rewrites the index file, removing from it any files whose blobs are + - missing. Returns the list of affected files. -} +rewriteIndex :: Repo -> IO [FilePath] +rewriteIndex r + | repoIsLocalBare r = return [] + | otherwise = do + (bad, good, cleanup) <- partitionIndex r + unless (null bad) $ do + nukeFile (indexFile r) + UpdateIndex.streamUpdateIndex r + =<< (catMaybes <$> mapM reinject good) + void cleanup + return $ map fst3 bad + where + reinject (file, Just sha, Just mode) = case toBlobType mode of + Nothing -> return Nothing + Just blobtype -> Just <$> + UpdateIndex.stageFile sha blobtype file r + reinject _ = return Nothing + +newtype GoodCommits = GoodCommits (S.Set Sha) + +emptyGoodCommits :: GoodCommits +emptyGoodCommits = GoodCommits S.empty + +checkGoodCommit :: Sha -> GoodCommits -> Bool +checkGoodCommit sha (GoodCommits s) = S.member sha s + +addGoodCommits :: [Sha] -> GoodCommits -> GoodCommits +addGoodCommits shas (GoodCommits s) = GoodCommits $ + S.union s (S.fromList shas) + +displayList :: [String] -> String -> IO () +displayList items header + | null items = return () + | otherwise = do + putStrLn header + putStr $ unlines $ map (\i -> "\t" ++ i) truncateditems + where + numitems = length items + truncateditems + | numitems > 10 = take 10 items ++ ["(and " ++ show (numitems - 10) ++ " more)"] + | otherwise = items + +{- Fix problems that would prevent repair from working at all + - + - A missing or corrupt .git/HEAD makes git not treat the repository as a + - git repo. If there is a git repo in a parent directory, it may move up + - the tree and use that one instead. So, cannot use `git show-ref HEAD` to + - test it. + - + - Explode the packed refs file, to simplify dealing with refs, and because + - fsck can complain about bad refs in it. + -} +preRepair :: Repo -> IO () +preRepair g = do + unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do + nukeFile headfile + writeFile headfile "ref: refs/heads/master" + explodePackedRefsFile g + unless (repoIsLocalBare g) $ do + let f = indexFile g + void $ tryIO $ allowWrite f + where + headfile = localGitDir g "HEAD" + validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s) + +{- Put it all together. -} +runRepair :: (Ref -> Bool) -> Bool -> Repo -> IO (Bool, [Branch]) +runRepair removablebranch forced g = do + preRepair g + putStrLn "Running git fsck ..." + fsckresult <- findBroken False g + if foundBroken fsckresult + then runRepair' removablebranch fsckresult forced Nothing g + else do + bad <- badBranches S.empty g + if null bad + then do + putStrLn "No problems found." + return (True, []) + else runRepair' removablebranch fsckresult forced Nothing g + +runRepairOf :: FsckResults -> (Ref -> Bool) -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch]) +runRepairOf fsckresult removablebranch forced referencerepo g = do + preRepair g + runRepair' removablebranch fsckresult forced referencerepo g + +runRepair' :: (Ref -> Bool) -> FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch]) +runRepair' removablebranch fsckresult forced referencerepo g = do + cleanCorruptObjects fsckresult g + missing <- findBroken False g + stillmissing <- retrieveMissingObjects missing referencerepo g + case stillmissing of + FsckFoundMissing s t + | S.null s -> if repoIsLocalBare g + then checkbadbranches s + else ifM (checkIndex g) + ( checkbadbranches s + , do + putStrLn "No missing objects found, but the index file is corrupt!" + if forced + then corruptedindex + else needforce + ) + | otherwise -> if forced + then ifM (checkIndex g) + ( forcerepair s t + , corruptedindex + ) + else do + putStrLn $ unwords + [ show (S.size s) + , "missing objects could not be recovered!" + ] + unsuccessfulfinish + FsckFailed + | forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex g) + ( do + cleanCorruptObjects FsckFailed g + stillmissing' <- findBroken False g + case stillmissing' of + FsckFailed -> return (False, []) + FsckFoundMissing s t -> forcerepair s t + , corruptedindex + ) + | otherwise -> unsuccessfulfinish + where + repairbranches missing = do + (removedbranches, goodcommits) <- removeBadBranches' removablebranch missing emptyGoodCommits g + let remotebranches = filter isTrackingBranch removedbranches + unless (null remotebranches) $ + putStrLn $ unwords + [ "Removed" + , show (length remotebranches) + , "remote tracking branches that referred to missing objects." + ] + (resetbranches, deletedbranches, _) <- resetLocalBranches missing goodcommits g + displayList (map fromRef resetbranches) + "Reset these local branches to old versions before the missing objects were committed:" + displayList (map fromRef deletedbranches) + "Deleted these local branches, which could not be recovered due to missing objects:" + return (resetbranches ++ deletedbranches) + + checkbadbranches missing = do + bad <- badBranches missing g + case (null bad, forced) of + (True, _) -> successfulfinish [] + (False, False) -> do + displayList (map fromRef bad) + "Some git branches refer to missing objects:" + unsuccessfulfinish + (False, True) -> successfulfinish =<< repairbranches missing + + forcerepair missing fscktruncated = do + modifiedbranches <- repairbranches missing + deindexedfiles <- rewriteIndex g + displayList deindexedfiles + "Removed these missing files from the index. You should look at what files are present in your working tree and git add them back to the index when appropriate." + + -- When the fsck results were truncated, try + -- fscking again, and as long as different + -- missing objects are found, continue + -- the repair process. + if fscktruncated + then do + fsckresult' <- findBroken False g + case fsckresult' of + FsckFailed -> do + putStrLn "git fsck is failing" + return (False, modifiedbranches) + FsckFoundMissing s _ + | S.null s -> successfulfinish modifiedbranches + | S.null (s `S.difference` missing) -> do + putStrLn $ unwords + [ show (S.size s) + , "missing objects could not be recovered!" + ] + return (False, modifiedbranches) + | otherwise -> do + (ok, modifiedbranches') <- runRepairOf fsckresult' removablebranch forced referencerepo g + return (ok, modifiedbranches++modifiedbranches') + else successfulfinish modifiedbranches + + corruptedindex = do + nukeFile (indexFile g) + -- The corrupted index can prevent fsck from finding other + -- problems, so re-run repair. + fsckresult' <- findBroken False g + result <- runRepairOf fsckresult' removablebranch forced referencerepo g + putStrLn "Removed the corrupted index file. You should look at what files are present in your working tree and git add them back to the index when appropriate." + return result + + successfulfinish modifiedbranches + | null modifiedbranches = do + mapM_ putStrLn + [ "Successfully recovered repository!" + , "You should run \"git fsck\" to make sure, but it looks like everything was recovered ok." + ] + return (True, modifiedbranches) + | otherwise = do + unless (repoIsLocalBare g) $ do + mcurr <- Branch.currentUnsafe g + case mcurr of + Nothing -> return () + Just curr -> when (any (== curr) modifiedbranches) $ do + putStrLn $ unwords + [ "You currently have" + , fromRef curr + , "checked out. You may have staged changes in the index that can be committed to recover the lost state of this branch!" + ] + putStrLn "Successfully recovered repository!" + putStrLn "Please carefully check that the changes mentioned above are ok.." + return (True, modifiedbranches) + + unsuccessfulfinish = do + if repoIsLocalBare g + then do + putStrLn "If you have a clone of this bare repository, you should add it as a remote of this repository, and retry." + putStrLn "If there are no clones of this repository, you can instead retry with the --force parameter to force recovery to a possibly usable state." + return (False, []) + else needforce + needforce = do + putStrLn "To force a recovery to a usable state, retry with the --force parameter." + return (False, []) + +successfulRepair :: (Bool, [Branch]) -> Bool +successfulRepair = fst + +safeReadFile :: FilePath -> IO String +safeReadFile f = do + allowRead f + readFileStrictAnyEncoding f diff --git a/Git/Sha.hs b/Git/Sha.hs new file mode 100644 index 0000000..b802c85 --- /dev/null +++ b/Git/Sha.hs @@ -0,0 +1,43 @@ +{- git SHA stuff + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Sha where + +import Common +import Git.Types + +{- Runs an action that causes a git subcommand to emit a Sha, and strips + - any trailing newline, returning the sha. -} +getSha :: String -> IO String -> IO Sha +getSha subcommand a = maybe bad return =<< extractSha <$> a + where + bad = error $ "failed to read sha from git " ++ subcommand + +{- Extracts the Sha from a string. There can be a trailing newline after + - it, but nothing else. -} +extractSha :: String -> Maybe Sha +extractSha s + | len == shaSize = val s + | len == shaSize + 1 && length s' == shaSize = val s' + | otherwise = Nothing + where + len = length s + s' = firstLine s + val v + | all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v + | otherwise = Nothing + +{- Size of a git sha. -} +shaSize :: Int +shaSize = 40 + +nullSha :: Ref +nullSha = Ref $ replicate shaSize '0' + +{- Git's magic empty tree. -} +emptyTree :: Ref +emptyTree = Ref "4b825dc642cb6eb9a060e54bf8d69288fbee4904" diff --git a/Git/Types.hs b/Git/Types.hs new file mode 100644 index 0000000..bb91a17 --- /dev/null +++ b/Git/Types.hs @@ -0,0 +1,100 @@ +{- git data types + - + - Copyright 2010-2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Types where + +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. + - + - Repos on local disk have a git directory, and unless bare, a worktree. + - + - A local repo may not have had its config read yet, in which case all + - that's known about it is its path. + - + - Finally, an Unknown repository may be known to exist, but nothing + - else known about it. + -} +data RepoLocation + = Local { gitdir :: FilePath, worktree :: Maybe FilePath } + | LocalUnknown FilePath + | Url URI + | Unknown + deriving (Show, Eq, Ord) + +data Repo = Repo + { location :: RepoLocation + , config :: M.Map String String + -- 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 + , remoteName :: Maybe RemoteName + -- alternate environment to use when running git commands + , gitEnv :: Maybe [(String, String)] + -- global options to pass to git when running git commands + , gitGlobalOpts :: [CommandParam] + } deriving (Show, Eq, Ord) + +type RemoteName = String + +{- A git ref. Can be a sha1, or a branch or tag name. -} +newtype Ref = Ref String + deriving (Eq, Ord, Read, Show) + +fromRef :: Ref -> String +fromRef (Ref s) = s + +{- Aliases for Ref. -} +type Branch = Ref +type Sha = Ref +type Tag = Ref + +{- A date in the format described in gitrevisions. Includes the + - braces, eg, "{yesterday}" -} +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 "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 diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs new file mode 100644 index 0000000..55c5b3b --- /dev/null +++ b/Git/UpdateIndex.hs @@ -0,0 +1,121 @@ +{- git-update-index library + - + - Copyright 2011-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns, CPP #-} + +module Git.UpdateIndex ( + Streamer, + pureStreamer, + streamUpdateIndex, + streamUpdateIndex', + startUpdateIndex, + stopUpdateIndex, + lsTree, + lsSubTree, + updateIndexLine, + stageFile, + unstageFile, + stageSymlink, + stageDiffTreeItem, +) where + +import Common +import Git +import Git.Types +import Git.Command +import Git.FilePath +import Git.Sha +import qualified Git.DiffTreeItem as Diff + +{- 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 () + +{- A streamer with a precalculated value. -} +pureStreamer :: String -> Streamer +pureStreamer !s = \streamer -> streamer s + +{- Streams content into update-index from a list of Streamers. -} +streamUpdateIndex :: Repo -> [Streamer] -> IO () +streamUpdateIndex repo as = bracket (startUpdateIndex repo) stopUpdateIndex $ + (\h -> forM_ as $ streamUpdateIndex' h) + +data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle + +streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO () +streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do + hPutStr h s + hPutStr h "\0" + +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"] + +stopUpdateIndex :: UpdateIndexHandle -> IO Bool +stopUpdateIndex (UpdateIndexHandle p h) = do + hClose h + checkSuccessProcess p + +{- A streamer that adds the current tree for a ref. Useful for eg, copying + - and modifying branches. -} +lsTree :: Ref -> Repo -> Streamer +lsTree (Ref x) repo streamer = do + (s, cleanup) <- pipeNullSplit params repo + mapM_ streamer s + void $ cleanup + where + params = map Param ["ls-tree", "-z", "-r", "--full-tree", x] +lsSubTree :: Ref -> FilePath -> Repo -> Streamer +lsSubTree (Ref x) p repo streamer = do + (s, cleanup) <- pipeNullSplit params repo + mapM_ streamer s + void $ cleanup + where + params = map Param ["ls-tree", "-z", "-r", "--full-tree", x, p] + +{- 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 + +{- A streamer that removes a file from the index. -} +unstageFile :: FilePath -> Repo -> IO Streamer +unstageFile file repo = do + p <- toTopFilePath file repo + return $ unstageFile' p + +unstageFile' :: TopFilePath -> Streamer +unstageFile' p = pureStreamer $ "0 " ++ 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 + return $ pureStreamer line + +{- A streamer that applies a DiffTreeItem to the index. -} +stageDiffTreeItem :: Diff.DiffTreeItem -> Streamer +stageDiffTreeItem d = case toBlobType (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 diff --git a/Git/Url.hs b/Git/Url.hs new file mode 100644 index 0000000..fa7d200 --- /dev/null +++ b/Git/Url.hs @@ -0,0 +1,71 @@ +{- git repository urls + - + - Copyright 2010, 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Url ( + scheme, + host, + port, + hostuser, + authority, +) where + +import Network.URI hiding (scheme, authority) + +import Common +import Git.Types +import Git + +{- Scheme of an URL repo. -} +scheme :: Repo -> String +scheme Repo { location = Url u } = uriScheme u +scheme repo = notUrl repo + +{- Work around a bug in the real uriRegName + - -} +uriRegName' :: URIAuth -> String +uriRegName' a = fixup $ uriRegName a + where + fixup x@('[':rest) + | rest !! len == ']' = take len rest + | otherwise = x + where + len = length rest - 1 + fixup x = x + +{- Hostname of an URL repo. -} +host :: Repo -> Maybe String +host = authpart uriRegName' + +{- Port of an URL repo, if it has a nonstandard one. -} +port :: Repo -> Maybe Integer +port r = + case authpart uriPort r of + Nothing -> Nothing + Just ":" -> Nothing + Just (':':p) -> readish p + Just _ -> Nothing + +{- Hostname of an URL repo, including any username (ie, "user@host") -} +hostuser :: Repo -> Maybe String +hostuser r = (++) + <$> authpart uriUserInfo r + <*> authpart uriRegName' r + +{- The full authority portion an URL repo. (ie, "user@host:port") -} +authority :: Repo -> Maybe String +authority = authpart assemble + where + assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a + +{- Applies a function to extract part of the uriAuthority of an URL repo. -} +authpart :: (URIAuth -> a) -> Repo -> Maybe a +authpart a Repo { location = Url u } = a <$> uriAuthority u +authpart _ 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 new file mode 100644 index 0000000..19ff945 --- /dev/null +++ b/Git/Version.hs @@ -0,0 +1,32 @@ +{- git versions + - + - Copyright 2011, 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Git.Version ( + installed, + older, + normalize, + GitVersion, +) where + +import Common +import Utility.DottedVersion + +type GitVersion = DottedVersion + +installed :: IO GitVersion +installed = normalize . extract <$> readProcess "git" ["--version"] + where + extract s = case lines s of + [] -> "" + (l:_) -> unwords $ drop 2 $ words l + +older :: String -> IO Bool +older n = do + v <- installed + return $ v < normalize n diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..dcdcbbb --- /dev/null +++ b/Makefile @@ -0,0 +1,34 @@ +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 + @$(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)" + +install: build + install -d $(DESTDIR)$(PREFIX)/bin + install git-repair $(DESTDIR)$(PREFIX)/bin + install -d $(DESTDIR)$(PREFIX)/share/man/man1 + install -m 0644 git-repair.1 $(DESTDIR)$(PREFIX)/share/man/man1 + +clean: + rm -rf git-repair git-repair-test.log \ + dist configure Build/SysConfig.hs Setup tags + find . -name \*.o -exec rm {} \; + find . -name \*.hi -exec rm {} \; + +# Upload to hackage. +hackage: clean + ./Build/make-sdist.sh + @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 + +.PHONY: tags diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..03c23a3 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,14 @@ +{- cabal setup file -} + +import Distribution.Simple +import Distribution.Simple.Setup + +import qualified Build.Configure as Configure + +main = defaultMainWithHooks simpleUserHooks + { preConf = configure + } + +configure _ _ = do + Configure.run Configure.tests + return (Nothing, []) diff --git a/TODO b/TODO new file mode 100644 index 0000000..0c61948 --- /dev/null +++ b/TODO @@ -0,0 +1,2 @@ +* git-reflog can fail if HEAD is missing. + Manually parse the reflog in this case (or supply a dummy HEAD?) diff --git a/Utility/Applicative.hs b/Utility/Applicative.hs new file mode 100644 index 0000000..fce3c04 --- /dev/null +++ b/Utility/Applicative.hs @@ -0,0 +1,16 @@ +{- applicative stuff + - + - Copyright 2012 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.Applicative where + +{- Like <$> , but supports one level of currying. + - + - foo v = bar <$> action v == foo = bar <$$> action + -} +(<$$>) :: Functor f => (a -> b) -> (c -> f a) -> c -> f b +f <$$> v = fmap f . v +infixr 4 <$$> diff --git a/Utility/Batch.hs b/Utility/Batch.hs new file mode 100644 index 0000000..d96f9d3 --- /dev/null +++ b/Utility/Batch.hs @@ -0,0 +1,96 @@ +{- Running a long or expensive batch operation niced. + - + - Copyright 2013 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.Batch where + +import Common + +#if defined(linux_HOST_OS) || defined(__ANDROID__) +import Control.Concurrent.Async +import System.Posix.Process +#endif +import qualified Control.Exception as E + +{- Runs an operation, at batch priority. + - + - This is done by running it in a bound thread, which on Linux can be set + - to have a different nice level than the rest of the program. Note that + - due to running in a bound thread, some operations may be more expensive + - to perform. Also note that if the action calls forkIO or forkOS itself, + - that will make a new thread that does not have the batch priority. + - + - POSIX threads do not support separate nice levels, so on other operating + - systems, the action is simply ran. + -} +batch :: IO a -> IO a +#if defined(linux_HOST_OS) || defined(__ANDROID__) +batch a = wait =<< batchthread + where + batchthread = asyncBound $ do + setProcessPriority 0 maxNice + a +#else +batch a = a +#endif + +maxNice :: Int +maxNice = 19 + +{- Makes a command be run by whichever of nice, ionice, and nocache + - are available in the path. -} +type BatchCommandMaker = (String, [CommandParam]) -> (String, [CommandParam]) + +getBatchCommandMaker :: IO BatchCommandMaker +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) -> + case nicers of + [] -> (command, params) + (first:rest) -> (fst first, map Param (snd first ++ concatMap (\p -> fst p : snd p) rest ++ [command]) ++ params) +#else + return id +#endif + +toBatchCommand :: (String, [CommandParam]) -> IO (String, [CommandParam]) +toBatchCommand v = do + batchmaker <- getBatchCommandMaker + return $ batchmaker v + +{- Runs a command in a way that's suitable for batch jobs that can be + - interrupted. + - + - If the calling thread receives an async exception, it sends the + - command a SIGTERM, and after the command finishes shuttting down, + - it re-raises the async exception. -} +batchCommand :: String -> [CommandParam] -> IO Bool +batchCommand command params = batchCommandEnv command params Nothing + +batchCommandEnv :: String -> [CommandParam] -> Maybe [(String, String)] -> IO Bool +batchCommandEnv command params environ = do + batchmaker <- getBatchCommandMaker + let (command', params') = batchmaker (command, params) + let p = proc command' $ toCommand params' + (_, _, _, pid) <- createProcess $ p { env = environ } + r <- E.try (waitForProcess pid) :: IO (Either E.SomeException ExitCode) + case r of + Right ExitSuccess -> return True + Right _ -> return False + Left asyncexception -> do + terminateProcess pid + void $ waitForProcess pid + E.throwIO asyncexception diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs new file mode 100644 index 0000000..9854b47 --- /dev/null +++ b/Utility/CoProcess.hs @@ -0,0 +1,94 @@ +{- Interface for running a shell command as a coprocess, + - sending it queries and getting back results. + - + - Copyright 2012-2013 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.CoProcess ( + CoProcessHandle, + start, + stop, + query, + rawMode +) where + +import Common + +import Control.Concurrent.MVar + +type CoProcessHandle = MVar CoProcessState + +data CoProcessState = CoProcessState + { coProcessPid :: ProcessHandle + , coProcessTo :: Handle + , coProcessFrom :: Handle + , coProcessSpec :: CoProcessSpec + } + +data CoProcessSpec = CoProcessSpec + { coProcessNumRestarts :: Int + , coProcessCmd :: FilePath + , coProcessParams :: [String] + , coProcessEnv :: Maybe [(String, String)] + } + +start :: Int -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle +start numrestarts cmd params environ = do + s <- start' $ CoProcessSpec numrestarts cmd params environ + newMVar s + +start' :: CoProcessSpec -> IO CoProcessState +start' s = do + (pid, from, to) <- startInteractiveProcess (coProcessCmd s) (coProcessParams s) (coProcessEnv s) + return $ CoProcessState pid to from s + +stop :: CoProcessHandle -> IO () +stop ch = do + s <- readMVar ch + hClose $ coProcessTo s + hClose $ coProcessFrom s + let p = proc (coProcessCmd $ coProcessSpec s) (coProcessParams $ coProcessSpec s) + forceSuccessProcess p (coProcessPid s) + +{- To handle a restartable process, any IO exception thrown by the send and + - receive actions are assumed to mean communication with the process + - failed, and the failed action is re-run with a new process. -} +query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b +query ch send receive = do + s <- readMVar ch + restartable s (send $ coProcessTo s) $ const $ + restartable s (hFlush $ coProcessTo s) $ const $ + restartable s (receive $ coProcessFrom s) + return + where + restartable s a cont + | coProcessNumRestarts (coProcessSpec s) > 0 = + maybe restart cont =<< catchMaybeIO a + | otherwise = cont =<< a + restart = do + s <- takeMVar ch + void $ catchMaybeIO $ do + hClose $ coProcessTo s + hClose $ coProcessFrom s + void $ waitForProcess $ coProcessPid s + s' <- start' $ (coProcessSpec s) + { 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/Data.hs b/Utility/Data.hs new file mode 100644 index 0000000..27c0a82 --- /dev/null +++ b/Utility/Data.hs @@ -0,0 +1,19 @@ +{- utilities for simple data types + - + - Copyright 2013 Joey Hess + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Data where + +{- First item in the list that is not Nothing. -} +firstJust :: Eq a => [Maybe a] -> Maybe a +firstJust ms = case dropWhile (== Nothing) ms of + [] -> Nothing + (md:_) -> md + +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe = either (const Nothing) Just diff --git a/Utility/Directory.hs b/Utility/Directory.hs new file mode 100644 index 0000000..fae33b5 --- /dev/null +++ b/Utility/Directory.hs @@ -0,0 +1,242 @@ +{- directory traversal and manipulation + - + - Copyright 2011-2014 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Directory where + +import System.IO.Error +import System.Directory +import Control.Monad +import System.FilePath +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 +import Utility.SafeCommand +import Control.Monad.IfElse +#endif + +import Utility.PosixFiles +import Utility.Tmp +import Utility.Exception +import Utility.Monad +import Utility.Applicative + +dirCruft :: FilePath -> Bool +dirCruft "." = True +dirCruft ".." = True +dirCruft _ = False + +{- Lists the contents of a directory. + - Unlike getDirectoryContents, paths are not relative to the directory. -} +dirContents :: FilePath -> IO [FilePath] +dirContents d = map (d ) . filter (not . dirCruft) <$> getDirectoryContents d + +{- Gets files in a directory, and then its subdirectories, recursively, + - and lazily. + - + - Does not follow symlinks to other subdirectories. + - + - When the directory does not exist, no exception is thrown, + - instead, [] is returned. -} +dirContentsRecursive :: FilePath -> IO [FilePath] +dirContentsRecursive = dirContentsRecursiveSkipping (const False) True + +{- Skips directories whose basenames match the skipdir. -} +dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath] +dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir] + where + go [] = return [] + go (dir:dirs) + | skipdir (takeFileName dir) = go dirs + | otherwise = unsafeInterleaveIO $ do + (files, dirs') <- collect [] [] + =<< catchDefaultIO [] (dirContents dir) + files' <- go (dirs' ++ dirs) + return (files ++ files') + collect files dirs' [] = return (reverse files, reverse dirs') + collect files dirs' (entry:entries) + | dirCruft entry = collect files dirs' entries + | otherwise = do + let skip = collect (entry:files) dirs' entries + let recurse = collect files (entry:dirs') entries + ms <- catchMaybeIO $ getSymbolicLinkStatus entry + case ms of + (Just s) + | isDirectory s -> recurse + | isSymbolicLink s && followsubdirsymlinks -> + ifM (doesDirectoryExist entry) + ( recurse + , skip + ) + _ -> skip + +{- Gets the directory tree from a point, recursively and lazily, + - with leaf directories **first**, skipping any whose basenames + - match the skipdir. Does not follow symlinks. -} +dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath] +dirTreeRecursiveSkipping skipdir topdir = go [] [topdir] + where + go c [] = return c + go c (dir:dirs) + | skipdir (takeFileName dir) = go c dirs + | otherwise = unsafeInterleaveIO $ do + subdirs <- go c + =<< filterM (isDirectory <$$> getSymbolicLinkStatus) + =<< catchDefaultIO [] (dirContents dir) + go (subdirs++[dir]) dirs + +{- Moves one filename to another. + - First tries a rename, but falls back to moving across devices if needed. -} +moveFile :: FilePath -> FilePath -> IO () +moveFile src dest = tryIO (rename src dest) >>= onrename + where + onrename (Right _) = noop + onrename (Left e) + | isPermissionError e = rethrow + | isDoesNotExistError e = rethrow + | otherwise = viaTmp mv dest "" + where + rethrow = throwM e + + mv tmp _ = do + -- copyFile is likely not as optimised as + -- the mv command, so we'll use the command. + -- + -- But, while Windows has a "mv", it does not seem very + -- reliable, so use copyFile there. +#ifndef mingw32_HOST_OS + -- If dest is a directory, mv would move the file + -- into it, which is not desired. + whenM (isdir dest) rethrow + ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] + let e' = e +#else + r <- tryIO $ copyFile src tmp + let (ok, e') = case r of + Left err -> (False, err) + Right _ -> (True, e) +#endif + unless ok $ do + -- delete any partial + _ <- tryIO $ removeFile tmp + throwM e' + + isdir f = do + r <- tryIO $ getFileStatus f + case r of + (Left _) -> return False + (Right s) -> return $ isDirectory s + +{- Removes a file, which may or may not exist, and does not have to + - be a regular file. + - + - Note that an exception is thrown if the file exists but + - cannot be removed. -} +nukeFile :: FilePath -> IO () +nukeFile file = void $ tryWhenExists go + where +#ifndef mingw32_HOST_OS + go = removeLink file +#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 new file mode 100644 index 0000000..ebf4c0b --- /dev/null +++ b/Utility/DottedVersion.hs @@ -0,0 +1,38 @@ +{- dotted versions, such as 1.0.1 + - + - Copyright 2011-2014 Joey Hess + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.DottedVersion where + +import Common + +data DottedVersion = DottedVersion String Integer + deriving (Eq) + +instance Ord DottedVersion where + compare (DottedVersion _ x) (DottedVersion _ y) = compare x y + +instance Show DottedVersion where + show (DottedVersion s _) = s + +{- To compare dotted versions like 1.7.7 and 1.8, they are normalized to + - a somewhat arbitrary integer representation. -} +normalize :: String -> DottedVersion +normalize v = DottedVersion v $ + sum $ mult 1 $ reverse $ extend precision $ take precision $ + map readi $ split "." v + where + extend n l = l ++ replicate (n - length l) 0 + mult _ [] = [] + mult n (x:xs) = (n*x) : mult (n*10^width) xs + readi :: String -> Integer + readi s = case reads s of + ((x,_):_) -> x + _ -> 0 + precision = 10 -- number of segments of the version to compare + width = length "yyyymmddhhmmss" -- maximum width of a segment diff --git a/Utility/Env.hs b/Utility/Env.hs new file mode 100644 index 0000000..c56f4ec --- /dev/null +++ b/Utility/Env.hs @@ -0,0 +1,84 @@ +{- portable environment variables + - + - Copyright 2013 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Env where + +#ifdef mingw32_HOST_OS +import Utility.Exception +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 + +getEnv :: String -> IO (Maybe String) +#ifndef mingw32_HOST_OS +getEnv = PE.getEnv +#else +getEnv = catchMaybeIO . E.getEnv +#endif + +getEnvDefault :: String -> String -> IO String +#ifndef mingw32_HOST_OS +getEnvDefault = PE.getEnvDefault +#else +getEnvDefault var fallback = fromMaybe fallback <$> getEnv var +#endif + +getEnvironment :: IO [(String, String)] +#ifndef mingw32_HOST_OS +getEnvironment = PE.getEnvironment +#else +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. + - + - This does not really belong here, but Data.AssocList is for some reason + - buried inside hxt. + -} +addEntry :: Eq k => k -> v -> [(k, v)] -> [(k, v)] +addEntry k v l = ( (k,v) : ) $! delEntry k l + +addEntries :: Eq k => [(k, v)] -> [(k, v)] -> [(k, v)] +addEntries = foldr (.) id . map (uncurry addEntry) . reverse + +delEntry :: Eq k => k -> [(k, v)] -> [(k, v)] +delEntry _ [] = [] +delEntry k (x@(k1,_) : rest) + | k == k1 = rest + | otherwise = ( x : ) $! delEntry k rest diff --git a/Utility/Exception.hs b/Utility/Exception.hs new file mode 100644 index 0000000..8b110ae --- /dev/null +++ b/Utility/Exception.hs @@ -0,0 +1,99 @@ +{- Simple IO exception handling (and some more) + - + - Copyright 2011-2015 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Exception ( + module X, + catchBoolIO, + catchMaybeIO, + catchDefaultIO, + catchMsgIO, + catchIO, + tryIO, + bracketIO, + catchNonAsync, + tryNonAsync, + tryWhenExists, + catchIOErrorType, + IOErrorType(..) +) where + +import Control.Monad.Catch as X hiding (Handler) +import qualified Control.Monad.Catch as M +import Control.Exception (IOException, AsyncException) +import Control.Monad +import Control.Monad.IO.Class (liftIO, MonadIO) +import System.IO.Error (isDoesNotExistError, ioeGetErrorType) +import GHC.IO.Exception (IOErrorType(..)) + +import Utility.Data + +{- Catches IO errors and returns a Bool -} +catchBoolIO :: MonadCatch m => m Bool -> m Bool +catchBoolIO = catchDefaultIO False + +{- Catches IO errors and returns a Maybe -} +catchMaybeIO :: MonadCatch m => m a -> m (Maybe a) +catchMaybeIO a = catchDefaultIO Nothing $ a >>= (return . Just) + +{- Catches IO errors and returns a default value. -} +catchDefaultIO :: MonadCatch m => a -> m a -> m a +catchDefaultIO def a = catchIO a (const $ return def) + +{- Catches IO errors and returns the error message. -} +catchMsgIO :: MonadCatch m => m a -> m (Either String a) +catchMsgIO a = do + v <- tryIO a + return $ either (Left . show) Right v + +{- catch specialized for IO errors only -} +catchIO :: MonadCatch m => m a -> (IOException -> m a) -> m a +catchIO = M.catch + +{- try specialized for IO errors only -} +tryIO :: MonadCatch m => m a -> m (Either IOException a) +tryIO = M.try + +{- bracket with setup and cleanup actions lifted to IO. + - + - Note that unlike catchIO and tryIO, this catches all exceptions. -} +bracketIO :: (MonadMask m, MonadIO m) => IO v -> (v -> IO b) -> (v -> m a) -> m a +bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup) + +{- Catches all exceptions except for async exceptions. + - This is often better to use than catching them all, so that + - ThreadKilled and UserInterrupt get through. + -} +catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a +catchNonAsync a onerr = a `catches` + [ M.Handler (\ (e :: AsyncException) -> throwM e) + , M.Handler (\ (e :: SomeException) -> onerr e) + ] + +tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a) +tryNonAsync a = go `catchNonAsync` (return . Left) + where + go = do + v <- a + return (Right v) + +{- Catches only DoesNotExist exceptions, and lets all others through. -} +tryWhenExists :: MonadCatch m => m a -> m (Maybe a) +tryWhenExists a = do + v <- tryJust (guard . isDoesNotExistError) a + return (eitherToMaybe v) + +{- Catches only IO exceptions of a particular type. + - Ie, use HardwareFault to catch disk IO errors. -} +catchIOErrorType :: MonadCatch m => IOErrorType -> (IOException -> m a) -> m a -> m a +catchIOErrorType errtype onmatchingerr a = catchIO a onlymatching + where + onlymatching e + | ioeGetErrorType e == errtype = onmatchingerr e + | otherwise = throwM e diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs new file mode 100644 index 0000000..efef5fa --- /dev/null +++ b/Utility/FileMode.hs @@ -0,0 +1,167 @@ +{- File mode utilities. + - + - Copyright 2010-2012 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.FileMode ( + module Utility.FileMode, + FileMode, +) where + +import System.IO +import Control.Monad +import System.PosixCompat.Types +import Utility.PosixFiles +#ifndef mingw32_HOST_OS +import System.Posix.Files +#endif +import Foreign (complement) +import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Monad.Catch + +import Utility.Exception + +{- Applies a conversion function to a file's mode. -} +modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO () +modifyFileMode f convert = void $ modifyFileMode' f convert + +modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode +modifyFileMode' f convert = do + s <- getFileStatus f + let old = fileMode s + let new = convert old + when (new /= old) $ + setFileMode f new + return old + +{- Runs an action after changing a file's mode, then restores the old mode. -} +withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a +withModifiedFileMode file convert a = bracket setup cleanup go + where + setup = modifyFileMode' file convert + cleanup oldmode = modifyFileMode file (const oldmode) + go _ = a + +{- Adds the specified FileModes to the input mode, leaving the rest + - unchanged. -} +addModes :: [FileMode] -> FileMode -> FileMode +addModes ms m = combineModes (m:ms) + +{- Removes the specified FileModes from the input mode. -} +removeModes :: [FileMode] -> FileMode -> FileMode +removeModes ms m = m `intersectFileModes` complement (combineModes ms) + +writeModes :: [FileMode] +writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode] + +readModes :: [FileMode] +readModes = [ownerReadMode, groupReadMode, otherReadMode] + +executeModes :: [FileMode] +executeModes = [ownerExecuteMode, groupExecuteMode, otherExecuteMode] + +otherGroupModes :: [FileMode] +otherGroupModes = + [ groupReadMode, otherReadMode + , groupWriteMode, otherWriteMode + ] + +{- Removes the write bits from a file. -} +preventWrite :: FilePath -> IO () +preventWrite f = modifyFileMode f $ removeModes writeModes + +{- Turns a file's owner write bit back on. -} +allowWrite :: FilePath -> IO () +allowWrite f = modifyFileMode f $ addModes [ownerWriteMode] + +{- Turns a file's owner read bit back on. -} +allowRead :: FilePath -> IO () +allowRead f = modifyFileMode f $ addModes [ownerReadMode] + +{- Allows owner and group to read and write to a file. -} +groupSharedModes :: [FileMode] +groupSharedModes = + [ ownerWriteMode, groupWriteMode + , ownerReadMode, groupReadMode + ] + +groupWriteRead :: FilePath -> IO () +groupWriteRead f = modifyFileMode f $ addModes groupSharedModes + +checkMode :: FileMode -> FileMode -> Bool +checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor + +{- Checks if a file mode indicates it's a symlink. -} +isSymLink :: FileMode -> Bool +#ifdef mingw32_HOST_OS +isSymLink _ = False +#else +isSymLink = checkMode symbolicLinkMode +#endif + +{- Checks if a file has any executable bits set. -} +isExecutable :: FileMode -> Bool +isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0 + +{- Runs an action without that pesky umask influencing it, unless the + - passed FileMode is the standard one. -} +noUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a +#ifndef mingw32_HOST_OS +noUmask mode a + | mode == stdFileMode = a + | otherwise = withUmask nullFileMode a +#else +noUmask _ a = a +#endif + +withUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a +#ifndef mingw32_HOST_OS +withUmask umask a = bracket setup cleanup go + where + setup = liftIO $ setFileCreationMask umask + cleanup = liftIO . setFileCreationMask + go _ = a +#else +withUmask _ a = a +#endif + +combineModes :: [FileMode] -> FileMode +combineModes [] = 0 +combineModes [m] = m +combineModes (m:ms) = foldl unionFileModes m ms + +isSticky :: FileMode -> Bool +#ifdef mingw32_HOST_OS +isSticky _ = False +#else +isSticky = checkMode stickyMode + +stickyMode :: FileMode +stickyMode = 512 + +setSticky :: FilePath -> IO () +setSticky f = modifyFileMode f $ addModes [stickyMode] +#endif + +{- Writes a file, ensuring that its modes do not allow it to be read + - or written by anyone other than the current user, + - before any content is written. + - + - When possible, this is done using the umask. + - + - On a filesystem that does not support file permissions, this is the same + - as writeFile. + -} +writeFileProtected :: FilePath -> String -> IO () +writeFileProtected file content = writeFileProtected' file + (\h -> hPutStr h content) + +writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO () +writeFileProtected' file writer = withUmask 0o0077 $ + withFile file WriteMode $ \h -> do + void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes + writer h diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs new file mode 100644 index 0000000..1055754 --- /dev/null +++ b/Utility/FileSize.hs @@ -0,0 +1,35 @@ +{- File size. + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.FileSize where + +import System.PosixCompat.Files +#ifdef mingw32_HOST_OS +import Control.Exception (bracket) +import System.IO +#endif + +{- 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 +#ifndef mingw32_HOST_OS +getFileSize f = fmap (fromIntegral . fileSize) (getFileStatus f) +#else +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 +#ifndef mingw32_HOST_OS +getFileSize' _ s = return $ fromIntegral $ fileSize s +#else +getFileSize' f _ = getFileSize f +#endif diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs new file mode 100644 index 0000000..67341d3 --- /dev/null +++ b/Utility/FileSystemEncoding.hs @@ -0,0 +1,166 @@ +{- GHC File system encoding handling. + - + - Copyright 2012-2014 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.FileSystemEncoding ( + fileEncoding, + withFilePath, + md5FilePath, + decodeBS, + encodeBS, + decodeW8, + encodeW8, + encodeW8NUL, + decodeW8NUL, + truncateFilePath, +) where + +import qualified GHC.Foreign as GHC +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 + +{- 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". + -} +fileEncoding :: Handle -> IO () +#ifndef mingw32_HOST_OS +fileEncoding h = hSetEncoding h =<< 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 +#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 + - was obtained. -} +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath fp f = Encoding.getFileSystemEncoding + >>= \enc -> GHC.withCString enc fp f + +{- Encodes a FilePath into a String, applying the filesystem encoding. + - + - There are very few things it makes sense to do with such an encoded + - string. It's not a legal filename; it should not be displayed. + - So this function is not exported, but instead used by the few functions + - that can usefully consume it. + - + - This use of unsafePerformIO is belived to be safe; GHC's interface + - only allows doing this conversion with CStrings, and the CString buffer + - is allocated, used, and deallocated within the call, with no side + - effects. + - + - If the FilePath contains a value that is not legal in the filesystem + - encoding, rather than thowing an exception, it will be returned as-is. + -} +{-# NOINLINE _encodeFilePath #-} +_encodeFilePath :: FilePath -> String +_encodeFilePath fp = unsafePerformIO $ do + enc <- Encoding.getFileSystemEncoding + 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 +decodeBS = encodeW8NUL . L.unpack +#else +{- On Windows, we assume that the ByteString is utf-8, since Windows + - only uses unicode for filenames. -} +decodeBS = L8.toString +#endif + +{- Encodes a FilePath into a ByteString, applying the filesystem encoding. -} +encodeBS :: FilePath -> L.ByteString +#ifndef mingw32_HOST_OS +encodeBS = L.pack . decodeW8NUL +#else +encodeBS = L8.fromString +#endif + +{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding. + - + - w82c produces a String, which may contain Chars that are invalid + - unicode. From there, this is really a simple matter of applying the + - file system encoding, only complicated by GHC's interface to doing so. + - + - Note that the encoding stops at any NUL in the input. FilePaths + - do not normally contain embedded NUL, but Haskell Strings may. + -} +{-# NOINLINE encodeW8 #-} +encodeW8 :: [Word8] -> FilePath +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 + +{- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -} +encodeW8NUL :: [Word8] -> FilePath +encodeW8NUL = intercalate nul . map encodeW8 . split (s2w8 nul) + where + nul = ['\NUL'] + +decodeW8NUL :: FilePath -> [Word8] +decodeW8NUL = intercalate (s2w8 nul) . map decodeW8 . split nul + where + nul = ['\NUL'] + +{- Truncates a FilePath to the given number of bytes (or less), + - as represented on disk. + - + - Avoids returning an invalid part of a unicode byte sequence, at the + - cost of efficiency when running on a large FilePath. + -} +truncateFilePath :: Int -> FilePath -> FilePath +#ifndef mingw32_HOST_OS +truncateFilePath n = go . reverse + where + go f = + let bytes = decodeW8 f + in if length bytes <= n + then reverse f + else go (drop 1 f) +#else +{- On Windows, count the number of bytes used by each utf8 character. -} +truncateFilePath n = reverse . go [] n . L8.fromString + where + go coll cnt bs + | cnt <= 0 = coll + | otherwise = case L8.decode bs of + Just (c, x) | c /= L8.replacement_char -> + let x' = fromIntegral x + in if cnt - x' < 0 + then coll + else go (c:coll) (cnt - x') (L8.drop 1 bs) + _ -> coll +#endif diff --git a/Utility/Format.hs b/Utility/Format.hs new file mode 100644 index 0000000..7844963 --- /dev/null +++ b/Utility/Format.hs @@ -0,0 +1,178 @@ +{- Formatted string handling. + - + - Copyright 2010, 2011 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.Format ( + Format, + gen, + format, + decode_c, + encode_c, + prop_isomorphic_deencode +) where + +import Text.Printf (printf) +import Data.Char (isAlphaNum, isOctDigit, isHexDigit, isSpace, chr, ord) +import Data.Maybe (fromMaybe) +import Data.Word (Word8) +import Data.List (isPrefixOf) +import qualified Codec.Binary.UTF8.String +import qualified Data.Map as M + +import Utility.PartialPrelude + +type FormatString = String + +{- A format consists of a list of fragments. -} +type Format = [Frag] + +{- A fragment is either a constant string, + - or a variable, with a justification. -} +data Frag = Const String | Var String Justify + deriving (Show) + +data Justify = LeftJustified Int | RightJustified Int | UnJustified + deriving (Show) + +type Variables = M.Map String String + +{- Expands a Format using some variables, generating a formatted string. + - This can be repeatedly called, efficiently. -} +format :: Format -> Variables -> String +format f vars = concatMap expand f + where + expand (Const s) = s + expand (Var name j) + | "escaped_" `isPrefixOf` name = + justify j $ encode_c_strict $ + getvar $ drop (length "escaped_") name + | otherwise = justify j $ getvar name + getvar name = fromMaybe "" $ M.lookup name vars + justify UnJustified s = s + justify (LeftJustified i) s = s ++ pad i s + justify (RightJustified i) s = pad i s ++ s + pad i s = take (i - length s) spaces + spaces = repeat ' ' + +{- Generates a Format that can be used to expand variables in a + - format string, such as "${foo} ${bar;10} ${baz;-10}\n" + - + - (This is the same type of format string used by dpkg-query.) + -} +gen :: FormatString -> Format +gen = filter (not . empty) . fuse [] . scan [] . decode_c + where + -- The Format is built up in reverse, for efficiency, + -- and can have many adjacent Consts. Fusing it fixes both + -- problems. + fuse f [] = f + fuse f (Const c1:Const c2:vs) = fuse f $ Const (c2++c1) : vs + fuse f (v:vs) = fuse (v:f) vs + + scan f (a:b:cs) + | a == '$' && b == '{' = invar f [] cs + | otherwise = scan (Const [a] : f ) (b:cs) + scan f v = Const v : f + + invar f var [] = Const (novar var) : f + invar f var (c:cs) + | c == '}' = foundvar f var UnJustified cs + | isAlphaNum c || c == '_' = invar f (c:var) cs + | c == ';' = inpad "" f var cs + | otherwise = scan ((Const $ novar $ c:var):f) cs + + inpad p f var (c:cs) + | c == '}' = foundvar f var (readjustify $ reverse p) cs + | otherwise = inpad (c:p) f var cs + inpad p f var [] = Const (novar $ p++";"++var) : f + readjustify = getjustify . fromMaybe 0 . readish + getjustify i + | i == 0 = UnJustified + | i < 0 = LeftJustified (-1 * i) + | otherwise = RightJustified i + novar v = "${" ++ reverse v + foundvar f v p = scan (Var (reverse v) p : f) + +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. + -} +decode_c :: FormatString -> FormatString +decode_c [] = [] +decode_c s = unescape ("", s) + where + e = '\\' + unescape (b, []) = b + -- look for escapes starting with '\' + unescape (b, v) = b ++ fst pair ++ unescape (handle $ snd pair) + where + pair = span (/= e) v + isescape x = x == e + handle (x:'x':n1:n2:rest) + | isescape x && allhex = (fromhex, rest) + where + allhex = isHexDigit n1 && isHexDigit n2 + fromhex = [chr $ readhex [n1, n2]] + readhex h = Prelude.read $ "0x" ++ h :: Int + handle (x:n1:n2:n3:rest) + | isescape x && alloctal = (fromoctal, rest) + where + alloctal = isOctDigit n1 && isOctDigit n2 && isOctDigit n3 + fromoctal = [chr $ readoctal [n1, n2, n3]] + readoctal o = Prelude.read $ "0o" ++ o :: Int + -- \C is used for a few special characters + handle (x:nc:rest) + | isescape x = ([echar nc], rest) + where + echar 'a' = '\a' + echar 'b' = '\b' + echar 'f' = '\f' + echar 'n' = '\n' + echar 'r' = '\r' + echar 't' = '\t' + echar 'v' = '\v' + echar a = a + handle n = ("", n) + +{- Inverse of decode_c. -} +encode_c :: FormatString -> FormatString +encode_c = encode_c' (const False) + +{- Encodes more strictly, including whitespace. -} +encode_c_strict :: FormatString -> FormatString +encode_c_strict = encode_c' isSpace + +encode_c' :: (Char -> Bool) -> FormatString -> FormatString +encode_c' p = concatMap echar + where + e c = '\\' : [c] + echar '\a' = e 'a' + echar '\b' = e 'b' + echar '\f' = e 'f' + echar '\n' = e 'n' + echar '\r' = e 'r' + echar '\t' = e 't' + echar '\v' = e 'v' + echar '\\' = e '\\' + echar '"' = e '"' + echar c + | ord c < 0x20 = e_asc c -- low ascii + | ord c >= 256 = e_utf c -- unicode + | ord c > 0x7E = e_asc c -- high ascii + | p c = e_asc c -- unprintable ascii + | otherwise = [c] -- printable ascii + -- unicode character is decomposed to individual Word8s, + -- and each is shown in octal + e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8]) + 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) diff --git a/Utility/Metered.hs b/Utility/Metered.hs new file mode 100644 index 0000000..da83fd8 --- /dev/null +++ b/Utility/Metered.hs @@ -0,0 +1,261 @@ +{- Metered IO and actions + - + - Copyright 2012-2105 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE TypeSynonymInstances #-} + +module Utility.Metered where + +import Common + +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S +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) + +{- An action that can be run repeatedly, updating it on the bytes processed. + - + - Note that each call receives the total number of bytes processed, so + - far, *not* an incremental amount since the last call. -} +type MeterUpdate = (BytesProcessed -> IO ()) + +nullMeterUpdate :: MeterUpdate +nullMeterUpdate _ = return () + +combineMeterUpdate :: MeterUpdate -> MeterUpdate -> MeterUpdate +combineMeterUpdate a b = \n -> a n >> b n + +{- Total number of bytes processed so far. -} +newtype BytesProcessed = BytesProcessed Integer + deriving (Eq, Ord, Show) + +class AsBytesProcessed a where + toBytesProcessed :: a -> BytesProcessed + fromBytesProcessed :: BytesProcessed -> a + +instance AsBytesProcessed BytesProcessed where + toBytesProcessed = id + fromBytesProcessed = id + +instance AsBytesProcessed Integer where + toBytesProcessed i = BytesProcessed i + fromBytesProcessed (BytesProcessed i) = i + +instance AsBytesProcessed Int where + toBytesProcessed i = BytesProcessed $ toInteger i + fromBytesProcessed (BytesProcessed i) = fromInteger i + +instance AsBytesProcessed Int64 where + toBytesProcessed i = BytesProcessed $ toInteger i + fromBytesProcessed (BytesProcessed i) = fromInteger i + +instance AsBytesProcessed FileOffset where + toBytesProcessed sz = BytesProcessed $ toInteger sz + fromBytesProcessed (BytesProcessed sz) = fromInteger sz + +addBytesProcessed :: AsBytesProcessed v => BytesProcessed -> v -> BytesProcessed +addBytesProcessed (BytesProcessed i) v = + let (BytesProcessed n) = toBytesProcessed v + in BytesProcessed $! i + n + +zeroBytesProcessed :: BytesProcessed +zeroBytesProcessed = BytesProcessed 0 + +{- Sends the content of a file to an action, updating the meter as it's + - consumed. -} +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 = go zeroBytesProcessed . L.toChunks + where + go _ [] = return () + go sofar (c:cs) = do + S.hPut h c + let sofar' = addBytesProcessed sofar $ S.length c + meterupdate sofar' + go sofar' cs + +meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO () +meteredWriteFile meterupdate f b = withBinaryFile f WriteMode $ \h -> + meteredWrite meterupdate h b + +{- Applies an offset to a MeterUpdate. This can be useful when + - performing a sequence of actions, such as multiple meteredWriteFiles, + - that all update a common meter progressively. Or when resuming. + -} +offsetMeterUpdate :: MeterUpdate -> BytesProcessed -> MeterUpdate +offsetMeterUpdate base offset = \n -> base (offset `addBytesProcessed` n) + +{- This is like L.hGetContents, but after each chunk is read, a meter + - is updated based on the size of the chunk. + - + - All the usual caveats about using unsafeInterleaveIO apply to the + - meter updates, so use caution. + -} +hGetContentsMetered :: Handle -> MeterUpdate -> IO L.ByteString +hGetContentsMetered h = hGetUntilMetered h (const True) + +{- Reads from the Handle, updating the meter after each chunk. + - + - 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 + where + lazyRead sofar = unsafeInterleaveIO $ loop sofar + + loop sofar = do + c <- S.hGet h defaultChunkSize + if S.null c + then do + hClose h + return $ L.empty + else do + let sofar' = addBytesProcessed sofar (S.length c) + meterupdate sofar' + if keepgoing (fromBytesProcessed sofar') + then do + {- unsafeInterleaveIO causes this to be + - deferred until the data is read from the + - ByteString. -} + cs <- lazyRead sofar' + return $ L.append (L.fromChunks [c]) cs + else return $ L.fromChunks [c] + +{- Same default chunk size Lazy ByteStrings use. -} +defaultChunkSize :: Int +defaultChunkSize = 32 * k - chunkOverhead + where + k = 1024 + chunkOverhead = 2 * sizeOf (1 :: Int) -- GHC specific + +{- Runs an action, watching a file as it grows and updating the meter. -} +watchFileSize :: (MonadIO m, MonadMask m) => FilePath -> MeterUpdate -> m a -> m a +watchFileSize f p a = bracket + (liftIO $ forkIO $ watcher zeroBytesProcessed) + (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 + +data OutputHandler = OutputHandler + { quietMode :: Bool + , stderrHandler :: String -> IO () + } + +{- Parses the String looking for a command's progress output, and returns + - Maybe the number of bytes done so far, and any any remainder of the + - string that could be an incomplete progress output. That remainder + - should be prepended to future output, and fed back in. This interface + - allows the command's output to be read in any desired size chunk, or + - even one character at a time. + -} +type ProgressParser = String -> (Maybe BytesProcessed, String) + +{- Runs a command and runs a ProgressParser on its output, in order + - to update a meter. + -} +commandMeter :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool +commandMeter progressparser oh meterupdate cmd params = + outputFilter cmd params Nothing + (feedprogress zeroBytesProcessed []) + handlestderr + where + feedprogress prev buf h = do + b <- S.hGetSome h 80 + if S.null b + then return () + else do + unless (quietMode oh) $ do + S.hPut stdout b + hFlush stdout + let s = w82s (S.unpack b) + let (mbytes, buf') = progressparser (buf++s) + case mbytes of + Nothing -> feedprogress prev buf' h + (Just bytes) -> do + when (bytes /= prev) $ + meterupdate bytes + feedprogress bytes buf' h + + handlestderr h = unlessM (hIsEOF h) $ do + stderrHandler oh =<< hGetLine h + handlestderr h + +{- Runs a command, that may display one or more progress meters on + - either stdout or stderr, and prevents the meters from being displayed. + - + - The other command output is handled as configured by the OutputHandler. + -} +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) + where + stdouthandler l = + unless (quietMode oh) $ + putStrLn l + +{- To suppress progress output, while displaying other messages, + - filter out lines that contain \r (typically used to reset to the + - beginning of the line when updating a progress display). + -} +avoidProgress :: Bool -> Handle -> (String -> IO ()) -> IO () +avoidProgress doavoid h emitter = unlessM (hIsEOF h) $ do + s <- hGetLine h + unless (doavoid && '\r' `elem` s) $ + emitter s + avoidProgress doavoid h emitter + +outputFilter + :: FilePath + -> [CommandParam] + -> Maybe [(String, String)] + -> (Handle -> IO ()) + -> (Handle -> IO ()) + -> IO Bool +outputFilter cmd params environ outfilter errfilter = catchBoolIO $ 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 + where + p = (proc cmd (toCommand params)) + { env = environ } diff --git a/Utility/Misc.hs b/Utility/Misc.hs new file mode 100644 index 0000000..ebb4257 --- /dev/null +++ b/Utility/Misc.hs @@ -0,0 +1,150 @@ +{- misc utility functions + - + - Copyright 2010-2011 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Misc where + +import Utility.FileSystemEncoding +import Utility.Monad + +import System.IO +import Control.Monad +import Foreign +import Data.Char +import Data.List +import System.Exit +#ifndef mingw32_HOST_OS +import System.Posix.Process (getAnyProcessStatus) +import Utility.Exception +#endif +import Control.Applicative +import Prelude + +{- A version of hgetContents that is not lazy. Ensures file is + - all read before it gets closed. -} +hGetContentsStrict :: Handle -> IO String +hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s + +{- A version of readFile that is not lazy. -} +readFileStrict :: FilePath -> IO String +readFileStrict = readFile >=> \s -> length s `seq` return s + +{- Reads a file strictly, and using the FileSystemEncoding, so it will + - never crash on a badly encoded file. -} +readFileStrictAnyEncoding :: FilePath -> IO String +readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do + fileEncoding h + hClose h `after` hGetContentsStrict h + +{- Writes a file, using the FileSystemEncoding so it will never crash + - on a badly encoded content string. -} +writeFileAnyEncoding :: FilePath -> String -> IO () +writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do + fileEncoding h + hPutStr h content + +{- Like break, but the item matching the condition is not included + - in the second result list. + - + - separate (== ':') "foo:bar" = ("foo", "bar") + - separate (== ':') "foobar" = ("foobar", "") + -} +separate :: (a -> Bool) -> [a] -> ([a], [a]) +separate c l = unbreak $ break c l + where + unbreak r@(a, b) + | null b = r + | otherwise = (a, tail b) + +{- Breaks out the first line. -} +firstLine :: String -> String +firstLine = takeWhile (/= '\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. -} +segment :: (a -> Bool) -> [a] -> [[a]] +segment p l = map reverse $ go [] [] l + where + go c r [] = reverse $ c:r + go c r (i:is) + | p i = go [] (c:r) is + | otherwise = go (i:c) r is + +prop_segment_regressionTest :: Bool +prop_segment_regressionTest = all id + -- Even an empty list is a segment. + [ segment (== "--") [] == [[]] + -- There are two segements in this list, even though the first is empty. + , segment (== "--") ["--", "foo", "bar"] == [[],["foo","bar"]] + ] + +{- Includes the delimiters as segments of their own. -} +segmentDelim :: (a -> Bool) -> [a] -> [[a]] +segmentDelim p l = map reverse $ go [] [] l + where + go c r [] = reverse $ c:r + go c r (i:is) + | p i = go [] ([i]:c:r) is + | otherwise = go (i:c) r is + +{- Replaces multiple values in a string. + - + - Takes care to skip over just-replaced values, so that they are not + - mangled. For example, massReplace [("foo", "new foo")] does not + - replace the "new foo" with "new new foo". + -} +massReplace :: [(String, String)] -> String -> String +massReplace vs = go [] vs + where + + go acc _ [] = concat $ reverse acc + go acc [] (c:cs) = go ([c]:acc) vs cs + go acc ((val, replacement):rest) s + | val `isPrefixOf` s = + go (replacement:acc) vs (drop (length val) s) + | otherwise = go acc rest s + +{- Wrapper around hGetBufSome that returns a String. + - + - The null string is returned on eof, otherwise returns whatever + - data is currently available to read from the handle, or waits for + - data to be written to it if none is currently available. + - + - Note on encodings: The normal encoding of the Handle is ignored; + - each byte is converted to a Char. Not unicode clean! + -} +hGetSomeString :: Handle -> Int -> IO String +hGetSomeString h sz = do + fp <- mallocForeignPtrBytes sz + len <- withForeignPtr fp $ \buf -> hGetBufSome h buf sz + map (chr . fromIntegral) <$> withForeignPtr fp (peekbytes len) + where + peekbytes :: Int -> Ptr Word8 -> IO [Word8] + peekbytes len buf = mapM (peekElemOff buf) [0..pred len] + +{- Reaps any zombie git processes. + - + - 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 new file mode 100644 index 0000000..ac75104 --- /dev/null +++ b/Utility/Monad.hs @@ -0,0 +1,71 @@ +{- monadic stuff + - + - Copyright 2010-2012 Joey Hess + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Monad where + +import Data.Maybe +import Control.Monad + +{- Return the first value from a list, if any, satisfying the given + - predicate -} +firstM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) +firstM _ [] = return Nothing +firstM p (x:xs) = ifM (p x) (return $ Just x , firstM p xs) + +{- Runs the action on values from the list until it succeeds, returning + - its result. -} +getM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b) +getM _ [] = return Nothing +getM p (x:xs) = maybe (getM p xs) (return . Just) =<< p x + +{- Returns true if any value in the list satisfies the predicate, + - stopping once one is found. -} +anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool +anyM p = liftM isJust . firstM p + +allM :: Monad m => (a -> m Bool) -> [a] -> m Bool +allM _ [] = return True +allM p (x:xs) = p x <&&> allM p xs + +{- Runs an action on values from a list until it succeeds. -} +untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool +untilTrue = flip anyM + +{- if with a monadic conditional. -} +ifM :: Monad m => m Bool -> (m a, m a) -> m a +ifM cond (thenclause, elseclause) = do + c <- cond + if c then thenclause else elseclause + +{- short-circuiting monadic || -} +(<||>) :: Monad m => m Bool -> m Bool -> m Bool +ma <||> mb = ifM ma ( return True , mb ) + +{- short-circuiting monadic && -} +(<&&>) :: Monad m => m Bool -> m Bool -> m Bool +ma <&&> mb = ifM ma ( mb , return False ) + +{- Same fixity as && and || -} +infixr 3 <&&> +infixr 2 <||> + +{- Runs an action, passing its value to an observer before returning it. -} +observe :: Monad m => (a -> m b) -> m a -> m a +observe observer a = do + r <- a + _ <- observer r + return r + +{- b `after` a runs first a, then b, and returns the value of a -} +after :: Monad m => m b -> m a -> m a +after = observe . const + +{- do nothing -} +noop :: Monad m => m () +noop = return () diff --git a/Utility/PartialPrelude.hs b/Utility/PartialPrelude.hs new file mode 100644 index 0000000..5579556 --- /dev/null +++ b/Utility/PartialPrelude.hs @@ -0,0 +1,70 @@ +{- Parts of the Prelude are partial functions, which are a common source of + - bugs. + - + - This exports functions that conflict with the prelude, which avoids + - them being accidentially used. + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.PartialPrelude where + +import qualified Data.Maybe + +{- read should be avoided, as it throws an error + - Instead, use: readish -} +read :: Read a => String -> a +read = Prelude.read + +{- head is a partial function; head [] is an error + - Instead, use: take 1 or headMaybe -} +head :: [a] -> a +head = Prelude.head + +{- tail is also partial + - Instead, use: drop 1 -} +tail :: [a] -> [a] +tail = Prelude.tail + +{- init too + - Instead, use: beginning -} +init :: [a] -> [a] +init = Prelude.init + +{- last too + - Instead, use: end or lastMaybe -} +last :: [a] -> a +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. + -} +readish :: Read a => String -> Maybe a +readish s = case reads s of + ((x,_):_) -> Just x + _ -> Nothing + +{- Like head but Nothing on empty list. -} +headMaybe :: [a] -> Maybe a +headMaybe = Data.Maybe.listToMaybe + +{- Like last but Nothing on empty list. -} +lastMaybe :: [a] -> Maybe a +lastMaybe [] = Nothing +lastMaybe v = Just $ Prelude.last v + +{- All but the last element of a list. + - (Like init, but no error on an empty list.) -} +beginning :: [a] -> [a] +beginning [] = [] +beginning l = Prelude.init l + +{- Like last, but no error on an empty list. -} +end :: [a] -> [a] +end [] = [] +end l = [Prelude.last l] diff --git a/Utility/Path.hs b/Utility/Path.hs new file mode 100644 index 0000000..f3290d8 --- /dev/null +++ b/Utility/Path.hs @@ -0,0 +1,322 @@ +{- path manipulation + - + - Copyright 2010-2014 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE PackageImports, CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Path where + +import Data.String.Utils +import System.FilePath +import System.Directory +import Data.List +import Data.Maybe +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 qualified "MissingH" System.Path as MissingH +import Utility.Monad +import Utility.UserInfo + +{- Simplifies a path, removing any "." component, collapsing "dir/..", + - and removing the trailing path separator. + - + - On Windows, preserves whichever style of path separator might be used in + - the input FilePaths. This is done because some programs in Windows + - demand a particular path separator -- and which one actually varies! + - + - This does not guarantee that two paths that refer to the same location, + - and are both relative to the same location (or both absolute) will + - yeild the same result. Run both through normalise from System.FilePath + - to ensure that. + -} +simplifyPath :: FilePath -> FilePath +simplifyPath path = dropTrailingPathSeparator $ + joinDrive drive $ joinPath $ norm [] $ splitPath path' + where + (drive, path') = splitDrive path + + norm c [] = reverse c + norm c (p:ps) + | p' == ".." && not (null c) && dropTrailingPathSeparator (c !! 0) /= ".." = + norm (drop 1 c) ps + | p' == "." = norm c ps + | otherwise = norm (p:c) ps + where + p' = dropTrailingPathSeparator p + +{- Makes a path absolute. + - + - The first parameter is a base directory (ie, the cwd) to use if the path + - is not already absolute. + - + - Does not attempt to deal with edge cases or ensure security with + - untrusted inputs. + -} +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 + +{- Just the parent directory of a path, or Nothing if the path has no +- parent (ie for "/" or ".") -} +upFrom :: FilePath -> Maybe FilePath +upFrom dir + | length dirs < 2 = Nothing + | otherwise = Just $ joinDrive drive (intercalate s $ init dirs) + where + -- 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] + +prop_upFrom_basics :: FilePath -> Bool +prop_upFrom_basics dir + | null dir = True + | dir == "/" = p == Nothing + | otherwise = p /= Just dir + where + p = upFrom dir + +{- Checks if the first FilePath is, or could be said to contain the second. + - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc + - are all equivilant. + -} +dirContains :: FilePath -> FilePath -> Bool +dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b' + where + a' = norm a + b' = norm b + norm = normalise . simplifyPath + +{- Converts a filename into an absolute path. + - + - Unlike Directory.canonicalizePath, this does not require the path + - already exists. -} +absPath :: FilePath -> IO FilePath +absPath file = do + cwd <- getCurrentDirectory + return $ absPathFrom cwd file + +{- Constructs a relative path from the CWD to a file. + - + - For example, assuming CWD is /tmp/foo/bar: + - relPathCwdToFile "/tmp/foo" == ".." + - relPathCwdToFile "/tmp/foo/bar" == "" + -} +relPathCwdToFile :: FilePath -> IO FilePath +relPathCwdToFile f = do + c <- getCurrentDirectory + relPathDirToFile c f + +{- Constructs a relative path from a directory to a file. -} +relPathDirToFile :: FilePath -> FilePath -> IO FilePath +relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to + +{- This requires the first path to be absolute, and the + - second path cannot contain ../ or ./ + - + - On Windows, if the paths are on different drives, + - a relative path is not possible and the path is simply + - returned as-is. + -} +relPathDirToFileAbs :: FilePath -> FilePath -> FilePath +relPathDirToFileAbs from to + | takeDrive from /= takeDrive to = to + | otherwise = intercalate s $ dotdots ++ uncommon + where + s = [pathSeparator] + pfrom = split s from + pto = split s to + 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 + +prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool +prop_relPathDirToFile_basics from to + | null from || null to = True + | from == to = null r + | otherwise = not (null r) + where + r = relPathDirToFileAbs from to + +prop_relPathDirToFile_regressionTest :: Bool +prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference + where + {- Two paths have the same directory component at the same + - location, but it's not really the same directory. + - Code used to get this wrong. -} + same_dir_shortcurcuits_at_difference = + relPathDirToFileAbs (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"]) + (joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]) + == joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"] + +{- Given an original list of paths, and an expanded list derived from it, + - which may be arbitrarily reordered, generates a list of lists, where + - each sublist corresponds to one of the original paths. + - + - When the original path is a directory, any items in the expanded list + - that are contained in that directory will appear in its segment. + - + - The order of the original list of paths is attempted to be preserved in + - the order of the returned segments. However, doing so has a O^NM + - growth factor. So, if the original list has more than 100 paths on it, + - we stop preserving ordering at that point. Presumably a user passing + - that many paths in doesn't care too much about order of the later ones. + -} +segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]] +segmentPaths [] new = [new] +segmentPaths [_] new = [new] -- optimisation +segmentPaths (l:ls) new = found : segmentPaths ls rest + where + (found, rest) = if length ls < 100 + then partition (l `dirContains`) new + else break (\p -> not (l `dirContains` p)) new + +{- This assumes that it's cheaper to call segmentPaths on the result, + - than it would be to run the action separately with each path. In + - the case of git file list commands, that assumption tends to hold. + -} +runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]] +runSegmentPaths a paths = segmentPaths paths <$> a paths + +{- Converts paths in the home directory to use ~/ -} +relHome :: FilePath -> IO String +relHome path = do + home <- myHomeDir + return $ if dirContains home path + then "~/" ++ relPathDirToFileAbs home path + else path + +{- Checks if a command is available in PATH. + - + - The command may be fully-qualified, in which case, this succeeds as + - long as it exists. -} +inPath :: String -> IO Bool +inPath command = isJust <$> searchPath command + +{- Finds a command in PATH and returns the full path to it. + - + - The command may be fully qualified already, in which case it will + - be returned if it exists. + -} +searchPath :: String -> IO (Maybe FilePath) +searchPath command + | isAbsolute command = check command + | otherwise = getSearchPath >>= getM indir + where + indir d = check $ d command + check f = firstM doesFileExist +#ifdef mingw32_HOST_OS + [f, f ++ ".exe"] +#else + [f] +#endif + +{- Checks if a filename is a unix dotfile. All files inside dotdirs + - count as dotfiles. -} +dotfile :: FilePath -> Bool +dotfile file + | f == "." = False + | f == ".." = False + | f == "" = False + | otherwise = "." `isPrefixOf` f || dotfile (takeDirectory 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 +#ifndef mingw32_HOST_OS +toCygPath = id +#else +toCygPath p + | null drive = recombine parts + | otherwise = recombine $ "/cygdrive" : 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. + - + - All spaces and punctuation and other wacky stuff are replaced + - with '_', except for '.' + - "../" will thus turn into ".._", which is safe. + -} +sanitizeFilePath :: String -> FilePath +sanitizeFilePath = map sanitize + where + sanitize c + | c == '.' = c + | isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_' + | otherwise = c + +{- Similar to splitExtensions, but knows that some things in FilePaths + - after a dot are too long to be extensions. -} +splitShortExtensions :: FilePath -> (FilePath, [String]) +splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg" +splitShortExtensions' :: Int -> FilePath -> (FilePath, [String]) +splitShortExtensions' maxextension = go [] + where + go c f + | len > 0 && len <= maxextension && not (null base) = + go (ext:c) base + | otherwise = (f, c) + where + (base, ext) = splitExtension f + len = length ext diff --git a/Utility/PosixFiles.hs b/Utility/PosixFiles.hs new file mode 100644 index 0000000..4550beb --- /dev/null +++ b/Utility/PosixFiles.hs @@ -0,0 +1,34 @@ +{- POSIX files (and compatablity wrappers). + - + - This is like System.PosixCompat.Files, except with a fixed rename. + - + - 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 +#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 diff --git a/Utility/Process.hs b/Utility/Process.hs new file mode 100644 index 0000000..c669996 --- /dev/null +++ b/Utility/Process.hs @@ -0,0 +1,397 @@ +{- System.Process enhancements, including additional ways of running + - processes, and logging. + - + - Copyright 2012-2015 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP, Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Process ( + module X, + CreateProcess(..), + StdHandle(..), + readProcess, + readProcess', + readProcessEnv, + writeReadProcessEnv, + forceSuccessProcess, + checkSuccessProcess, + ignoreFailureProcess, + createProcessSuccess, + createProcessChecked, + createBackgroundProcess, + processTranscript, + processTranscript', + withHandle, + withIOHandles, + withOEHandles, + withQuietOutput, + feedWithQuietOutput, + createProcess, + waitForProcess, + startInteractiveProcess, + stdinHandle, + stdoutHandle, + stderrHandle, + ioHandles, + processHandle, + devNull, +) where + +import qualified Utility.Process.Shim +import qualified Utility.Process.Shim as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess) +import Utility.Process.Shim hiding (createProcess, readProcess, waitForProcess) +import Utility.Misc +import Utility.Exception + +import System.Exit +import System.IO +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 + +data StdHandle = StdinHandle | StdoutHandle | StderrHandle + deriving (Eq) + +-- | Normally, when reading from a process, it does not need to be fed any +-- standard input. +readProcess :: FilePath -> [String] -> IO String +readProcess cmd args = readProcessEnv cmd args Nothing + +readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String +readProcessEnv cmd args environ = readProcess' p + where + p = (proc cmd args) + { std_out = CreatePipe + , env = environ + } + +readProcess' :: CreateProcess -> IO String +readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do + output <- hGetContentsStrict h + hClose h + return output + +-- | Runs an action to write to a process on its stdin, +-- returns its output, and also allows specifying the environment. +writeReadProcessEnv + :: FilePath + -> [String] + -> Maybe [(String, String)] + -> (Maybe (Handle -> IO ())) + -> (Maybe (Handle -> IO ())) + -> IO String +writeReadProcessEnv cmd args environ writestdin adjusthandle = do + (Just inh, Just outh, _, pid) <- createProcess p + + maybe (return ()) (\a -> a inh) adjusthandle + maybe (return ()) (\a -> a outh) adjusthandle + + -- fork off a thread to start consuming the output + output <- hGetContents outh + outMVar <- newEmptyMVar + _ <- forkIO $ E.evaluate (length output) >> putMVar outMVar () + + -- now write and flush any input + maybe (return ()) (\a -> a inh >> hFlush inh) writestdin + hClose inh -- done with stdin + + -- wait on the output + takeMVar outMVar + hClose outh + + -- wait on the process + forceSuccessProcess p pid + + return output + + where + p = (proc cmd args) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = Inherit + , env = environ + } + +-- | 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 + +-- | Waits for a ProcessHandle and returns True if it exited successfully. +-- Note that using this with createProcessChecked will throw away +-- the Bool, and is only useful to ignore the exit code of a process, +-- while still waiting for it. -} +checkSuccessProcess :: ProcessHandle -> IO Bool +checkSuccessProcess pid = do + code <- waitForProcess pid + return $ code == ExitSuccess + +ignoreFailureProcess :: ProcessHandle -> IO Bool +ignoreFailureProcess pid = do + void $ waitForProcess pid + return True + +-- | Runs createProcess, then an action on its handles, and then +-- forceSuccessProcess. +createProcessSuccess :: CreateProcessRunner +createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a + +-- | Runs createProcess, then an action on its handles, and then +-- a checker action on its exit code, which must wait for the process. +createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner +createProcessChecked checker p a = do + t@(_, _, _, pid) <- createProcess p + r <- tryNonAsync $ a t + _ <- checker pid + either E.throw return r + +-- | Leaves the process running, suitable for lazy streaming. +-- Note: Zombies will result, and must be waited on. +createBackgroundProcess :: CreateProcessRunner +createBackgroundProcess p a = a =<< createProcess p + +-- | Runs a process, optionally feeding it some input, and +-- returns a transcript combining its stdout and stderr, and +-- whether it succeeded or failed. +processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) +processTranscript = processTranscript' id + +processTranscript' :: (CreateProcess -> CreateProcess) -> String -> [String] -> Maybe String -> IO (String, Bool) +processTranscript' modproc cmd opts 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 + } + 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 $ modproc $ + (proc cmd opts) + { 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. +withHandle + :: StdHandle + -> CreateProcessRunner + -> CreateProcess + -> (Handle -> IO a) + -> IO a +withHandle h creator p a = creator p' $ a . select + where + base = p + { std_in = Inherit + , 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 }) + +-- | Like withHandle, but passes (stdin, stdout) handles to the action. +withIOHandles + :: CreateProcessRunner + -> CreateProcess + -> ((Handle, Handle) -> IO a) + -> IO a +withIOHandles creator p a = creator p' $ a . ioHandles + where + p' = p + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = Inherit + } + +-- | Like withHandle, but passes (stdout, stderr) handles to the action. +withOEHandles + :: CreateProcessRunner + -> CreateProcess + -> ((Handle, Handle) -> IO a) + -> IO a +withOEHandles creator p a = creator p' $ a . oeHandles + where + p' = p + { std_in = Inherit + , std_out = CreatePipe + , std_err = CreatePipe + } + +-- | Forces the CreateProcessRunner to run quietly; +-- both stdout and stderr are discarded. +withQuietOutput + :: CreateProcessRunner + -> CreateProcess + -> IO () +withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do + let p' = p + { std_out = UseHandle nullh + , std_err = UseHandle nullh + } + creator p' $ const $ return () + +-- | Stdout and stderr are discarded, while the process is fed stdin +-- from the handle. +feedWithQuietOutput + :: CreateProcessRunner + -> CreateProcess + -> (Handle -> IO a) + -> IO a +feedWithQuietOutput creator p a = withFile devNull WriteMode $ \nullh -> do + let p' = p + { std_in = CreatePipe + , std_out = UseHandle nullh + , std_err = UseHandle nullh + } + creator p' $ a . stdinHandle + +devNull :: FilePath +#ifndef mingw32_HOST_OS +devNull = "/dev/null" +#else +devNull = "NUL" +#endif + +-- | Extract a desired handle from createProcess's tuple. +-- These partial functions are safe as long as createProcess is run +-- with appropriate parameters to set up the desired handle. +-- Get it wrong and the runtime crash will always happen, so should be +-- easily noticed. +type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle +stdinHandle :: HandleExtractor +stdinHandle (Just h, _, _, _) = h +stdinHandle _ = error "expected stdinHandle" +stdoutHandle :: HandleExtractor +stdoutHandle (_, Just h, _, _) = h +stdoutHandle _ = error "expected stdoutHandle" +stderrHandle :: HandleExtractor +stderrHandle (_, _, Just h, _) = h +stderrHandle _ = error "expected stderrHandle" +ioHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) +ioHandles (Just hin, Just hout, _, _) = (hin, hout) +ioHandles _ = error "expected ioHandles" +oeHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) +oeHandles (_, Just hout, Just herr, _) = (hout, herr) +oeHandles _ = error "expected oeHandles" + +processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle +processHandle (_, _, _, pid) = pid + +-- | Shows the command that a CreateProcess will run. +showCmd :: CreateProcess -> String +showCmd = go . cmdspec + where + go (ShellCommand s) = s + go (RawCommand c ps) = c ++ " " ++ show ps + +-- | Starts an interactive process. Unlike runInteractiveProcess in +-- System.Process, stderr is inherited. +startInteractiveProcess + :: FilePath + -> [String] + -> Maybe [(String, String)] + -> IO (ProcessHandle, Handle, Handle) +startInteractiveProcess cmd args environ = do + let p = (proc cmd args) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = Inherit + , env = environ + } + (Just from, Just to, _, pid) <- createProcess p + return (pid, to, from) + +-- | Wrapper around 'System.Process.createProcess' that does debug logging. +createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProcess p = do + debugProcess p + Utility.Process.Shim.createProcess p + +-- | Debugging trace for a CreateProcess. +debugProcess :: CreateProcess -> IO () +debugProcess p = debugM "Utility.Process" $ unwords + [ action ++ ":" + , showCmd p + ] + where + action + | piped (std_in p) && piped (std_out p) = "chat" + | piped (std_in p) = "feed" + | piped (std_out p) = "read" + | otherwise = "call" + piped Inherit = False + piped _ = True + +-- | Wrapper around 'System.Process.waitForProcess' that does debug logging. +waitForProcess :: ProcessHandle -> IO ExitCode +waitForProcess h = do + r <- Utility.Process.Shim.waitForProcess h + debugM "Utility.Process" ("process done " ++ show r) + return r diff --git a/Utility/Process/Shim.hs b/Utility/Process/Shim.hs new file mode 100644 index 0000000..09312c7 --- /dev/null +++ b/Utility/Process/Shim.hs @@ -0,0 +1,3 @@ +module Utility.Process.Shim (module X) where + +import System.Process as X diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs new file mode 100644 index 0000000..cd408dd --- /dev/null +++ b/Utility/QuickCheck.hs @@ -0,0 +1,53 @@ +{- QuickCheck with additional instances + - + - Copyright 2012-2014 Joey Hess + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Utility.QuickCheck + ( module X + , module Utility.QuickCheck + ) where + +import Test.QuickCheck as X +import Data.Time.Clock.POSIX +import System.Posix.Types +import qualified Data.Map as M +import qualified Data.Set as S +import Control.Applicative +import Prelude + +instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where + arbitrary = M.fromList <$> arbitrary + +instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where + arbitrary = S.fromList <$> arbitrary + +{- Times before the epoch are excluded. -} +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) + +{- Inodes are never negative. -} +instance Arbitrary FileID where + arbitrary = nonNegative arbitrarySizedIntegral + +{- File sizes are never negative. -} +instance Arbitrary FileOffset where + arbitrary = nonNegative arbitrarySizedIntegral + +nonNegative :: (Num a, Ord a) => Gen a -> Gen a +nonNegative g = g `suchThat` (>= 0) + +positive :: (Num a, Ord a) => Gen a -> Gen a +positive g = g `suchThat` (> 0) diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs new file mode 100644 index 0000000..3aaf928 --- /dev/null +++ b/Utility/Rsync.hs @@ -0,0 +1,141 @@ +{- various rsync stuff + - + - Copyright 2010-2013 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.Rsync where + +import Common +import Utility.Metered + +import Data.Char +import System.Console.GetOpt +import Data.Tuple.Utils + +{- Generates parameters to make rsync use a specified command as its remote + - shell. -} +rsyncShell :: [CommandParam] -> [CommandParam] +rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand command)] + where + {- 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) ++ "'" + +{- Runs rsync in server mode to send a file. -} +rsyncServerSend :: [CommandParam] -> FilePath -> IO Bool +rsyncServerSend options file = rsync $ + rsyncServerParams ++ Param "--sender" : options ++ [File file] + +{- Runs rsync in server mode to receive a file. -} +rsyncServerReceive :: [CommandParam] -> FilePath -> IO Bool +rsyncServerReceive options file = rsync $ + rsyncServerParams ++ options ++ [File file] + +rsyncServerParams :: [CommandParam] +rsyncServerParams = + [ Param "--server" + -- preserve timestamps + , Param "-t" + -- allow resuming of transfers of big files + , Param "--inplace" + -- other options rsync normally uses in server mode + , Param "-e.Lsf" + , Param "." + ] + +rsyncUseDestinationPermissions :: CommandParam +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 + - 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 (Param s) + | rsyncUrlIsPath s = Param (toCygPath s) + fixup p = p +#else +rsyncParamsFixup = id +#endif + +{- Checks if an rsync url involves the remote shell (ssh or rsh). + - Use of such urls with rsync requires additional shell + - escaping. -} +rsyncUrlIsShell :: String -> Bool +rsyncUrlIsShell s + | "rsync://" `isPrefixOf` s = False + | otherwise = go s + where + -- host::dir is rsync protocol, while host:dir is ssh/rsh + go [] = False + go (c:cs) + | c == '/' = False -- got to directory with no colon + | c == ':' = not $ ":" `isPrefixOf` cs + | otherwise = go cs + +{- Checks if a rsync url is really just a local path. -} +rsyncUrlIsPath :: String -> Bool +rsyncUrlIsPath s +#ifdef mingw32_HOST_OS + | not (null (takeDrive s)) = True +#endif + | rsyncUrlIsShell s = False + | otherwise = ':' `notElem` s + +{- Runs rsync, but intercepts its progress output and updates a progress + - meter. + - + - 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 + +{- Strategy: Look for chunks prefixed with \r (rsync writes a \r before + - the first progress output, and each thereafter). The first number + - after the \r is the number of bytes processed. After the number, + - there must appear some whitespace, or we didn't get the whole number, + - and return the \r and part we did get, for later processing. + - + - In some locales, the number will have one or more commas in the middle + - of it. + -} +parseRsyncProgress :: ProgressParser +parseRsyncProgress = go [] . reverse . progresschunks + where + go remainder [] = (Nothing, remainder) + go remainder (x:xs) = case parsebytes (findbytesstart x) of + Nothing -> go (delim:x++remainder) xs + Just b -> (Just (toBytesProcessed b), remainder) + + delim = '\r' + + {- 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] + findbytesstart s = dropWhile isSpace s + + parsebytes :: String -> Maybe Integer + parsebytes s = case break isSpace s of + ([], _) -> Nothing + (_, []) -> Nothing + (b, _) -> readish $ filter (/= ',') b + +{- Filters options to those that are safe to pass to rsync in server mode, + - without causing it to eg, expose files. -} +filterRsyncSafeOptions :: [String] -> [String] +filterRsyncSafeOptions = fst3 . getOpt Permute + [ Option [] ["bwlimit"] (reqArgLong "bwlimit") "" ] + where + reqArgLong x = ReqArg (\v -> "--" ++ x ++ "=" ++ v) "" diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs new file mode 100644 index 0000000..5ce17a8 --- /dev/null +++ b/Utility/SafeCommand.hs @@ -0,0 +1,136 @@ +{- safely running shell commands + - + - Copyright 2010-2015 Joey Hess + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.SafeCommand where + +import System.Exit +import Utility.Process +import Data.String.Utils +import System.FilePath +import Data.Char +import Data.List +import Control.Applicative +import Prelude + +-- | Parameters that can be passed to a shell command. +data CommandParam + = Param String -- ^ A parameter + | File FilePath -- ^ The name of a file + deriving (Eq, Show, Ord) + +-- | Used to pass a list of CommandParams to a function that runs +-- a command and expects Strings. -} +toCommand :: [CommandParam] -> [String] +toCommand = map unwrap + 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:"./" + +-- | Run a system command, and returns True or False if it succeeded or failed. +-- +-- This and other command running functions in this module log the commands +-- run at debug level, using System.Log.Logger. +boolSystem :: FilePath -> [CommandParam] -> IO Bool +boolSystem command params = boolSystem' command params id + +boolSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO Bool +boolSystem' command params mkprocess = dispatch <$> safeSystem' command params mkprocess + where + dispatch ExitSuccess = True + dispatch _ = False + +boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool +boolSystemEnv command params environ = boolSystem' command params $ + \p -> p { env = environ } + +-- | Runs a system command, returning the exit status. +safeSystem :: FilePath -> [CommandParam] -> IO ExitCode +safeSystem command params = safeSystem' command params id + +safeSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO ExitCode +safeSystem' command params mkprocess = do + (_, _, _, pid) <- createProcess p + waitForProcess pid + where + p = mkprocess $ proc command (toCommand params) + +safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode +safeSystemEnv command params environ = safeSystem' command params $ + \p -> p { env = environ } + +-- | Wraps a shell command line inside sh -c, allowing it to be run in a +-- login shell that may not support POSIX shell, eg csh. +shellWrap :: String -> String +shellWrap cmdline = "sh -c " ++ shellEscape cmdline + +-- | Escapes a filename or other parameter to be safely able to be exposed to +-- the shell. +-- +-- This method works for POSIX shells, as well as other shells like csh. +shellEscape :: String -> String +shellEscape f = "'" ++ escaped ++ "'" + where + -- replace ' with '"'"' + escaped = intercalate "'\"'\"'" $ split "'" f + +-- | Unescapes a set of shellEscaped words or filenames. +shellUnEscape :: String -> [String] +shellUnEscape [] = [] +shellUnEscape s = word : shellUnEscape rest + where + (word, rest) = findword "" s + findword w [] = (w, "") + findword w (c:cs) + | c == ' ' = (w, cs) + | c == '\'' = inquote c w cs + | c == '"' = inquote c w cs + | otherwise = findword (w++[c]) cs + inquote _ w [] = (w, "") + inquote q w (c:cs) + | c == q = findword w cs + | otherwise = inquote q (w++[c]) cs + +-- | For quickcheck. +prop_isomorphic_shellEscape :: String -> Bool +prop_isomorphic_shellEscape s = [s] == (shellUnEscape . shellEscape) s +prop_isomorphic_shellEscape_multiword :: [String] -> Bool +prop_isomorphic_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s + +-- | Segments a list of filenames into groups that are all below the maximum +-- command-line length limit. +segmentXargsOrdered :: [FilePath] -> [[FilePath]] +segmentXargsOrdered = reverse . map reverse . segmentXargsUnordered + +-- | Not preserving order is a little faster, and streams better when +-- there are a great many filenames. +segmentXargsUnordered :: [FilePath] -> [[FilePath]] +segmentXargsUnordered l = go l [] 0 [] + where + go [] c _ r = (c:r) + go (f:fs) c accumlen r + | newlen > maxlen && len < maxlen = go (f:fs) [] 0 (c:r) + | otherwise = go fs (f:c) newlen r + where + len = length f + newlen = accumlen + len + + {- 10k of filenames per command, well under 100k limit + - of Linux (and OSX has a similar limit); + - allows room for other parameters etc. Also allows for + - eg, multibyte characters. -} + maxlen = 10240 diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs new file mode 100644 index 0000000..da05e99 --- /dev/null +++ b/Utility/ThreadScheduler.hs @@ -0,0 +1,74 @@ +{- thread scheduling + - + - Copyright 2012, 2013 Joey Hess + - Copyright 2011 Bas van Dijk & Roel van Dijk + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.ThreadScheduler where + +import Control.Monad +import Control.Concurrent +#ifndef mingw32_HOST_OS +import Control.Monad.IfElse +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) + +type Microseconds = Integer + +{- Runs an action repeatedly forever, sleeping at least the specified number + - of seconds in between. -} +runEvery :: Seconds -> IO a -> IO a +runEvery n a = forever $ do + threadDelaySeconds n + a + +threadDelaySeconds :: Seconds -> IO () +threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond) + +{- Like threadDelay, but not bounded by an Int. + - + - There is no guarantee that the thread will be rescheduled promptly when the + - delay has expired, but the thread will never continue to run earlier than + - specified. + - + - Taken from the unbounded-delay package to avoid a dependency for 4 lines + - of code. + -} +unboundDelay :: Microseconds -> IO () +unboundDelay time = do + let maxWait = min time $ toInteger (maxBound :: Int) + threadDelay $ fromInteger maxWait + when (maxWait /= time) $ unboundDelay (time - maxWait) + +{- Pauses the main thread, letting children run until program termination. -} +waitForTermination :: IO () +waitForTermination = do +#ifdef mingw32_HOST_OS + forever $ threadDelaySeconds (Seconds 6000) +#else + lock <- newEmptyMVar + let check sig = void $ + installHandler sig (CatchOnce $ putMVar lock ()) Nothing + check softwareTermination +#ifndef __ANDROID__ + whenM (queryTerminal stdInput) $ + check keyboardSignal +#endif + takeMVar lock +#endif + +oneSecond :: Microseconds +oneSecond = 1000000 diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs new file mode 100644 index 0000000..7610f6c --- /dev/null +++ b/Utility/Tmp.hs @@ -0,0 +1,124 @@ +{- Temporary files and directories. + - + - Copyright 2010-2013 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Tmp where + +import System.IO +import System.Directory +import Control.Monad.IfElse +import System.FilePath +import Control.Monad.IO.Class +#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 a file content = bracketIO setup cleanup use + where + (dir, base) = splitFileName file + template = base ++ ".tmp" + setup = do + createDirectoryIfMissing True dir + openTempFile dir template + cleanup (tmpfile, h) = do + _ <- tryIO $ hClose h + tryIO $ removeFile tmpfile + use (tmpfile, h) = do + liftIO $ hClose h + a tmpfile content + liftIO $ rename tmpfile file + +{- Runs an action with a tmp file located in the system's tmp directory + - (or in "." if there is none) then removes the file. -} +withTmpFile :: (MonadIO m, MonadMask m) => Template -> (FilePath -> Handle -> m a) -> m a +withTmpFile template a = do + tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory + withTmpFileIn tmpdir template a + +{- Runs an action with a tmp file located in the specified directory, + - then removes the file. -} +withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a +withTmpFileIn tmpdir template a = bracket create remove use + where + create = liftIO $ openTempFile tmpdir template + remove (name, h) = liftIO $ do + hClose h + 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. + - + - This generates a template that is never too long. + - (Well, it allocates 20 characters for use in making a unique temp file, + - anyway, which is enough for the current implementation and any + - likely implementation.) + -} +relatedTemplate :: FilePath -> FilePath +relatedTemplate f + | len > 20 = truncateFilePath (len - 20) f + | otherwise = f + where + len = length f diff --git a/Utility/URI.hs b/Utility/URI.hs new file mode 100644 index 0000000..e68fda5 --- /dev/null +++ b/Utility/URI.hs @@ -0,0 +1,18 @@ +{- 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 new file mode 100644 index 0000000..7e94caf --- /dev/null +++ b/Utility/UserInfo.hs @@ -0,0 +1,63 @@ +{- user info + - + - Copyright 2012 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.UserInfo ( + myHomeDir, + myUserName, + myUserGecos, +) where + +import Utility.Env + +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 + where +#ifndef mingw32_HOST_OS + env = ["HOME"] +#else + env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin +#endif + +{- Current user's user name. -} +myUserName :: IO String +myUserName = myVal env userName + where +#ifndef mingw32_HOST_OS + env = ["USER", "LOGNAME"] +#else + env = ["USERNAME", "USER", "LOGNAME"] +#endif + +myUserGecos :: IO (Maybe String) +-- userGecos crashes on Android and is not available on Windows. +#if defined(__ANDROID__) || defined(mingw32_HOST_OS) +myUserGecos = return Nothing +#else +myUserGecos = Just <$> myVal [] userGecos +#endif + +myVal :: [String] -> (UserEntry -> String) -> IO String +myVal envvars extract = go envvars + where +#ifndef mingw32_HOST_OS + go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID) +#else + go [] = error $ "environment not set: " ++ show envvars +#endif + go (v:vs) = maybe (go vs) return =<< getEnv v diff --git a/configure.hs b/configure.hs new file mode 100644 index 0000000..15833e6 --- /dev/null +++ b/configure.hs @@ -0,0 +1,6 @@ +{- configure program -} + +import Build.Configure + +main :: IO () +main = run tests diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..efbd0a8 --- /dev/null +++ b/debian/changelog @@ -0,0 +1,105 @@ +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/compat b/debian/compat new file mode 100644 index 0000000..ec63514 --- /dev/null +++ b/debian/compat @@ -0,0 +1 @@ +9 diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..cdbef1c --- /dev/null +++ b/debian/control @@ -0,0 +1,36 @@ +Source: git-repair +Section: utils +Priority: optional +Build-Depends: + debhelper (>= 9), + ghc, + git, + libghc-missingh-dev, + libghc-hslogger-dev, + libghc-network-dev, + libghc-exceptions-dev (>= 0.6), + libghc-transformers-dev, + libghc-unix-compat-dev, + libghc-ifelse-dev, + libghc-text-dev, + libghc-quickcheck2-dev, + libghc-utf8-string-dev, + libghc-async-dev, + libghc-optparse-applicative-dev (>= 0.10.0) +Maintainer: Richard Hartmann +Standards-Version: 3.9.5 +Vcs-Git: git://git-repair.branchable.com/ +Homepage: http://git-repair.branchable.com/ + +Package: git-repair +Architecture: any +Section: utils +Depends: ${misc:Depends}, ${shlibs:Depends}, git, rsync +Description: repair various forms of damage to git repositories + git-repair can repair various forms of damage to git repositories. + . + It is a complement to git fsck, which finds problems, but does not fix them. + . + 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. diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..33f85b4 --- /dev/null +++ b/debian/copyright @@ -0,0 +1,35 @@ +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/git-repair.lintian-overrides b/debian/git-repair.lintian-overrides new file mode 100644 index 0000000..25d3d4c --- /dev/null +++ b/debian/git-repair.lintian-overrides @@ -0,0 +1 @@ +binary-or-shlib-defines-rpath diff --git a/debian/manpages b/debian/manpages new file mode 100644 index 0000000..4cad191 --- /dev/null +++ b/debian/manpages @@ -0,0 +1 @@ +git-repair.1 diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..4d8fa21 --- /dev/null +++ b/debian/rules @@ -0,0 +1,10 @@ +#!/usr/bin/make -f + +# Avoid using cabal, as it writes to $HOME +export CABAL=./Setup + +# Do use the changelog's version number, rather than making one up. +export RELEASE_BUILD=1 + +%: + dh $@ diff --git a/doc/index.mdwn b/doc/index.mdwn new file mode 100644 index 0000000..503c2c2 --- /dev/null +++ b/doc/index.mdwn @@ -0,0 +1,55 @@ +`git-repair` can repair various forms of damage to git repositories. + +It is a complement to `git fsck`, which finds problems, but does not fix +them. + +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. + +## download + +* `git clone git://git-repair.branchable.com/ git-repair` +* from [Hackage](http://hackage.haskell.org/package/git-repair) + +## install + +This is a Haskell program, developed as a spinoff of +[git-annex](http://git-annex.branchable.com/). + +To build it, you will need to install the +[Haskell Platform](http://www.haskell.org/platform/). + +Then to install it: + + cabal update; cabal install git-repair --bindir=$HOME/bin + +## how it works + +`git-repair` starts by deleting all corrupt objects, and +retreiving all missing objects that it can from the remotes of the +repository. + +If that is not sufficient to fully recover the repository, it can also +reset branches back to commits before the corruption happened, delete +branches that are no longer available due to the lost data, and remove any +missing files from the index. It will only do this if run with the +`--force` option, since that rewrites history and throws out missing data. + +After running this command, you will probably want to run `git fsck` to +verify it fixed the repository. + +Note that fsck may still complain about objects referenced by the reflog, +or the stash, if they were unable to be recovered. This command does not +try to clean up either the reflog or the stash. + +Also note that the `--force` option never touches tags, even if they are no +longer usable due to missing data, so fsck may also find problems with +tags. + +Since this command unpacks all packs in the repository, you may want to +run `git gc` afterwards. + +## news + +[[!inline pages="news/* and !*/Discussion" show="4" archive=yes]] diff --git a/doc/news/version_1.20141027.mdwn b/doc/news/version_1.20141027.mdwn new file mode 100644 index 0000000..b65c652 --- /dev/null +++ b/doc/news/version_1.20141027.mdwn @@ -0,0 +1 @@ +git-repair 1.20140613 released diff --git a/git-repair.1 b/git-repair.1 new file mode 100644 index 0000000..7780095 --- /dev/null +++ b/git-repair.1 @@ -0,0 +1,49 @@ +.TH +.SH NAME +git\-repair \- Fix a broken git repository +.PP +.SH SYNOPSIS +git\-repair [\-\-force] +.PP +.SH DESCRIPTION +This can fix a corrupt or broken git repository, which git fsck would +only complain has problems. +.PP +It does by deleting all corrupt objects, and retreiving all missing +objects that it can from the remotes of the repository. +.PP +If that is not sufficient to fully recover the repository, it can also +reset branches back to commits before the corruption happened, delete +branches that are no longer available due to the lost data, and remove any +missing files from the index. It will only do this if run with the +\fB\-\-force\fP option, since that rewrites history and throws out missing data. +Note that the \fB\-\-force\fP option never touches tags, even if they are no +longer usable due to missing data. +.PP +After running this command, you will probably want to run \fBgit fsck\fP to +verify it fixed the repository. Note that fsck may still complain about +objects referenced by the reflog, or the stash, if they were unable to be +recovered. This command does not try to clean up either the reflog or the +stash. +.PP +Since this command unpacks all packs in the repository, you may want to +run \fBgit gc\fP afterwards. +.SH TESTING +git-repair is able to test itself, by making a temporary copy +of the git reposiory it's run in, damaging it in random ways, and checking +that it can repair it so that git fsck reports no problems. +.PP +This is done using the --test parameter and associated --numtests and +--retry parameters. +.PP +Note that the testing will sometimes find repositories that can only be +repaired when --force is used; this is expected. On the other hand, +if it fails to recover a repository with --force, then the testing has +found a bug! +.PP +.SH AUTHOR +Joey Hess +.PP + +.PP +.PP diff --git a/git-repair.cabal b/git-repair.cabal new file mode 100644 index 0000000..d4583ea --- /dev/null +++ b/git-repair.cabal @@ -0,0 +1,49 @@ +Name: git-repair +Version: 1.20151215 +Cabal-Version: >= 1.8 +License: GPL +Maintainer: Joey Hess +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 +Synopsis: repairs a damanged git repisitory +Description: + git-repair can repair various forms of damage to git repositories. + . + It is a complement to git fsck, which finds problems, but does not fix + them. + . + 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. + +Flag network-uri + Description: Get Network.URI from the network-uri package + Default: True + +Executable git-repair + Main-Is: git-repair.hs + GHC-Options: -threaded -Wall -fno-warn-tabs + 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) + + if flag(network-uri) + Build-Depends: network-uri (>= 2.6), network (>= 2.6) + else + Build-Depends: network (< 2.6), network (>= 2.0) + + if (os(windows)) + Build-Depends: setenv + else + Build-Depends: unix + +source-repository head + type: git + location: git://git-repair.branchable.com/ diff --git a/git-repair.hs b/git-repair.hs new file mode 100644 index 0000000..a82d5d6 --- /dev/null +++ b/git-repair.hs @@ -0,0 +1,119 @@ +{- git-repair program + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +import Options.Applicative + +import Common +import qualified Git.CurrentRepo +import qualified Git.Repair +import qualified Git.Config +import qualified Git.Construct +import qualified Git.Destroyer +import qualified Git.Fsck +import Utility.Tmp + +data Settings = Settings + { forced :: Bool + , testMode :: Bool + , retryTestMode :: Bool + , numTests :: Int + } + +parseSettings :: Parser Settings +parseSettings = Settings + <$> switch + ( long "force" + <> help "Force repair, even if data is lost" + ) + <*> switch + ( long "test" + <> help "Clone local repo, damage the clone, and test repair" + ) + <*> switch + ( long "retry" + <> help "Retry tests in git-repair-test.log" + ) + <*> option auto + ( long "numtests" + <> short 'n' + <> metavar "N" + <> help "Run N tests" + <> value 1 + ) + +main :: IO () +main = execParser opts >>= go + where + opts = info (helper <*> parseSettings) desc + desc = fullDesc + <> header "git-repair - repair a damanged git repository" + go settings + | retryTestMode settings = retryTest settings + | testMode settings = test settings + | otherwise = repair settings + +repair :: Settings -> IO () +repair settings = do + g <- Git.Config.read =<< Git.CurrentRepo.get + ifM (Git.Repair.successfulRepair <$> Git.Repair.runRepair Git.Repair.isTrackingBranch (forced settings) g) + ( exitSuccess + , exitFailure + ) + +test :: Settings -> IO () +test settings = do + forM_ [1 .. numTests settings] $ \n -> do + putStrLn $ "** Test " ++ show n ++ "/" ++ show (numTests settings) + damage <- Git.Destroyer.generateDamage + logDamage damage + runTest settings damage + allOk + +retryTest :: Settings -> IO () +retryTest settings = do + l <- map Prelude.read . lines <$> readFile logFile + forM_ l $ \damage -> + runTest settings damage + allOk + +runTest :: Settings -> [Git.Destroyer.Damage] -> IO () +runTest settings damage = withTmpDir "tmprepo" $ \tmpdir -> do + let cloneloc = tmpdir "clone" + cloned <- boolSystem "git" + [ Param "clone" + , Param "--no-hardlinks" + , File "." + , File cloneloc + ] + unless cloned $ + error $ "failed to clone this repo" + g <- Git.Config.read =<< Git.Construct.fromPath cloneloc + Git.Destroyer.applyDamage damage g + repairstatus <- catchMaybeIO $ Git.Repair.successfulRepair + <$> Git.Repair.runRepair Git.Repair.isTrackingBranch (forced settings) g + case repairstatus of + Just True -> testResult repairstatus + . Just . not . Git.Fsck.foundBroken + =<< Git.Fsck.findBroken False g + _ -> testResult repairstatus Nothing + +-- Pass test result and fsck result +testResult :: (Maybe Bool) -> (Maybe Bool) -> IO () +testResult (Just True) (Just True) = putStrLn "** repair succeeded" +testResult (Just True) (Just False) = error "** repair succeeded, but final fsck failed" +testResult _ _ = error "** repair failed" + +allOk :: IO () +allOk = do + putStrLn "" + putStrLn "All tests ok!" + +logDamage :: [Git.Destroyer.Damage] -> IO () +logDamage damage = appendFile logFile $ show damage ++ "\n" + +logFile :: FilePath +logFile = "git-repair-test.log" -- cgit v1.2.3