From 5ca81d114d7ccf0ee984cb03f56ad6ec1d9499f0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 14 Dec 2017 12:55:53 -0400 Subject: Merge from git-annex. --- .gitignore | 2 +- Build/Configure.hs | 4 ++-- Build/TestConfig.hs | 17 ++--------------- BuildInfo.hs | 12 ++++++++++++ CHANGELOG | 6 ++++++ Git/BuildVersion.hs | 4 ++-- Git/Ref.hs | 31 +++++++++++++++++++++++++++---- Utility/Directory.hs | 2 +- Utility/FileMode.hs | 2 +- Utility/Misc.hs | 2 +- Utility/Path.hs | 9 +++++++-- Utility/Tmp.hs | 4 ++-- Utility/UserInfo.hs | 9 ++++++--- git-repair.cabal | 1 + 14 files changed, 71 insertions(+), 34 deletions(-) create mode 100644 BuildInfo.hs diff --git a/.gitignore b/.gitignore index 55a966c..1ed2e9b 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,3 @@ -Build/SysConfig.hs +Build/SysConfig tags git-repair diff --git a/Build/Configure.hs b/Build/Configure.hs index d48d580..dc15141 100644 --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -1,4 +1,4 @@ -{- Checks system configuration and generates SysConfig.hs. -} +{- Checks system configuration and generates SysConfig. -} {-# OPTIONS_GHC -fno-warn-tabs #-} @@ -15,7 +15,7 @@ import Git.Version tests :: [TestCase] tests = [ TestCase "version" (Config "packageversion" . StringConfig <$> getVersion) - , TestCase "git" $ requireCmd "git" "git --version >/dev/null" + , TestCase "git" $ testCmd "git" "git --version >/dev/null" , TestCase "git version" getGitVersion ] diff --git a/Build/TestConfig.hs b/Build/TestConfig.hs index 79979c5..2f7213f 100644 --- a/Build/TestConfig.hs +++ b/Build/TestConfig.hs @@ -1,4 +1,4 @@ -{- Tests the system and generates Build.SysConfig.hs. -} +{- Tests the system and generates SysConfig. -} {-# OPTIONS_GHC -fno-warn-tabs #-} @@ -42,12 +42,11 @@ instance Show Config where valuetype (MaybeBoolConfig _) = "Maybe Bool" writeSysConfig :: [Config] -> IO () -writeSysConfig config = writeFile "Build/SysConfig.hs" body +writeSysConfig config = writeFile "Build/SysConfig" body where body = unlines $ header ++ map show config ++ footer header = [ "{- Automatically generated. -}" - , "module Build.SysConfig where" , "" ] footer = [] @@ -61,18 +60,6 @@ runTests (TestCase tname t : ts) = do rest <- runTests ts return $ c:rest -{- Tests that a command is available, aborting if not. -} -requireCmd :: ConfigKey -> String -> Test -requireCmd k cmdline = do - ret <- testCmd k cmdline - handle ret - where - handle r@(Config _ (BoolConfig True)) = return r - handle r = do - testEnd r - error $ "** the " ++ c ++ " command is required" - c = head $ words cmdline - {- Checks if a command is available by running a command line. -} testCmd :: ConfigKey -> String -> Test testCmd k cmdline = do diff --git a/BuildInfo.hs b/BuildInfo.hs new file mode 100644 index 0000000..812402c --- /dev/null +++ b/BuildInfo.hs @@ -0,0 +1,12 @@ +{- build info + - + - Copyright 2017 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module BuildInfo where + +#include "Build/SysConfig" diff --git a/CHANGELOG b/CHANGELOG index f3f31de..9c8889d 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,9 @@ +git-repair (1.20170627) UNRELEASED; urgency=medium + + * Merge from git-annex. + + -- Joey Hess Thu, 14 Dec 2017 12:55:44 -0400 + git-repair (1.20170626) unstable; urgency=medium * Merge from git-annex. diff --git a/Git/BuildVersion.hs b/Git/BuildVersion.hs index 50e4a3a..7d1c53a 100644 --- a/Git/BuildVersion.hs +++ b/Git/BuildVersion.hs @@ -8,14 +8,14 @@ module Git.BuildVersion where import Git.Version -import qualified Build.SysConfig +import qualified BuildInfo {- Using the version it was configured for avoids running git to check its - version, at the cost that upgrading git won't be noticed. - This is only acceptable because it's rare that git's version influences - code's behavior. -} buildVersion :: GitVersion -buildVersion = normalize Build.SysConfig.gitversion +buildVersion = normalize BuildInfo.gitversion older :: String -> Bool older n = buildVersion < normalize n diff --git a/Git/Ref.hs b/Git/Ref.hs index 2d80137..1986db6 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -45,6 +45,10 @@ base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef underBase :: String -> Ref -> Ref underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r) +{- Convert a branch such as "master" into a fully qualified ref. -} +branchRef :: Branch -> Ref +branchRef = underBase "refs/heads" + {- A Ref that can be used to refer to a file in the repository, as staged - in the index. - @@ -101,7 +105,7 @@ matching refs repo = matching' (map fromRef refs) repo matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)] matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo -{- List of (shas, branches) matching a given ref or refs. -} +{- List of (shas, branches) matching a given ref spec. -} matching' :: [String] -> Repo -> IO [(Sha, Branch)] matching' ps repo = map gen . lines <$> pipeReadStrict (Param "show-ref" : map Param ps) repo @@ -109,17 +113,36 @@ matching' ps repo = map gen . lines <$> gen l = let (r, b) = separate (== ' ') l in (Ref r, Ref b) -{- List of (shas, branches) matching a given ref spec. +{- List of (shas, branches) matching a given ref. - Duplicate shas are filtered out. -} matchingUniq :: [Ref] -> Repo -> IO [(Sha, Branch)] matchingUniq refs repo = nubBy uniqref <$> matching refs repo where uniqref (a, _) (b, _) = a == b +{- List of all refs. -} +list :: Repo -> IO [(Sha, Ref)] +list = matching' [] + +{- Deletes a ref. This can delete refs that are not branches, + - which git branch --delete refuses to delete. -} +delete :: Sha -> Ref -> Repo -> IO () +delete oldvalue ref = run + [ Param "update-ref" + , Param "-d" + , Param $ fromRef ref + , Param $ fromRef oldvalue + ] + {- Gets the sha of the tree a ref uses. -} tree :: Ref -> Repo -> IO (Maybe Sha) -tree ref = extractSha <$$> pipeReadStrict - [ Param "rev-parse", Param (fromRef ref ++ ":") ] +tree (Ref ref) = extractSha <$$> pipeReadStrict + [ Param "rev-parse", Param ref' ] + where + ref' = if ":" `isInfixOf` ref + then ref + -- de-reference commit objects to the tree + else ref ++ ":" {- Checks if a String is a legal git ref name. - diff --git a/Utility/Directory.hs b/Utility/Directory.hs index c24f36d..895581d 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -16,6 +16,7 @@ module Utility.Directory ( import System.IO.Error import Control.Monad import System.FilePath +import System.PosixCompat.Files import Control.Applicative import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO) @@ -31,7 +32,6 @@ import Control.Monad.IfElse #endif import Utility.SystemDirectory -import Utility.PosixFiles import Utility.Tmp import Utility.Exception import Utility.Monad diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index d9a2694..370bcf6 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -15,7 +15,7 @@ module Utility.FileMode ( import System.IO import Control.Monad import System.PosixCompat.Types -import Utility.PosixFiles +import System.PosixCompat.Files #ifndef mingw32_HOST_OS import System.Posix.Files import Control.Monad.IO.Class (liftIO) diff --git a/Utility/Misc.hs b/Utility/Misc.hs index 4498c0a..2ae9928 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -112,7 +112,7 @@ hGetSomeString h sz = do peekbytes :: Int -> Ptr Word8 -> IO [Word8] peekbytes len buf = mapM (peekElemOff buf) [0..pred len] -{- Reaps any zombie git processes. +{- Reaps any zombie processes that may be hanging around. - - Warning: Not thread safe. Anything that was expecting to wait - on a process and get back an exit status is going to be confused diff --git a/Utility/Path.hs b/Utility/Path.hs index 0779d16..dc91ce5 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -136,17 +136,22 @@ relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to -} relPathDirToFileAbs :: FilePath -> FilePath -> FilePath relPathDirToFileAbs from to - | takeDrive from /= takeDrive to = to +#ifdef mingw32_HOST_OS + | normdrive from /= normdrive to = to +#endif | otherwise = joinPath $ dotdots ++ uncommon where pfrom = sp from pto = sp to - sp = map dropTrailingPathSeparator . splitPath + sp = map dropTrailingPathSeparator . splitPath . dropDrive common = map fst $ takeWhile same $ zip pfrom pto same (c,d) = c == d uncommon = drop numcommon pto dotdots = replicate (length pfrom - numcommon) ".." numcommon = length common +#ifdef mingw32_HOST_OS + normdrive = map toLower . takeWhile (/= ':') . takeDrive +#endif prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool prop_relPathDirToFile_basics from to diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index 6a541cf..7255c14 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -15,20 +15,20 @@ import Control.Monad.IfElse import System.FilePath import System.Directory import Control.Monad.IO.Class +import System.PosixCompat.Files #ifndef mingw32_HOST_OS import System.Posix.Temp (mkdtemp) #endif import Utility.Exception import Utility.FileSystemEncoding -import Utility.PosixFiles type Template = String {- Runs an action like writeFile, writing to a temp file first and - then moving it into place. The temp file is stored in the same - directory as the final file to avoid cross-device renames. -} -viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> String -> m ()) -> FilePath -> String -> m () +viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> v -> m ()) -> FilePath -> v -> m () viaTmp a file content = bracketIO setup cleanup use where (dir, base) = splitFileName file diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index dd66c33..d504fa5 100644 --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -15,11 +15,13 @@ module Utility.UserInfo ( ) where import Utility.Env -import Utility.Data import Utility.Exception +#ifndef mingw32_HOST_OS +import Utility.Data +import Control.Applicative +#endif import System.PosixCompat -import Control.Applicative import Prelude {- Current user's home directory. @@ -58,6 +60,7 @@ myVal envvars extract = go envvars #ifndef mingw32_HOST_OS go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID) #else - go [] = return $ Left ("environment not set: " ++ show envvars) + go [] = return $ either Left (Right . extract) $ + Left ("environment not set: " ++ show envvars) #endif go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v diff --git a/git-repair.cabal b/git-repair.cabal index 08b98b7..cff316f 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -58,6 +58,7 @@ Executable git-repair Build-Depends: unix Other-Modules: + BuildInfo Build.Configure Build.TestConfig Build.Version -- cgit v1.2.3