summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess <joeyh@joeyh.name>2017-12-14 12:55:53 -0400
committerJoey Hess <joeyh@joeyh.name>2017-12-14 12:55:53 -0400
commit5ca81d114d7ccf0ee984cb03f56ad6ec1d9499f0 (patch)
tree4b49c7c03e77f356dd3941070509a498d97a3290
parent3a59749f2c0603872109a85c44234dd744d059cc (diff)
downloadgit-repair-5ca81d114d7ccf0ee984cb03f56ad6ec1d9499f0.tar.gz
Merge from git-annex.
-rw-r--r--.gitignore2
-rw-r--r--Build/Configure.hs4
-rw-r--r--Build/TestConfig.hs17
-rw-r--r--BuildInfo.hs12
-rw-r--r--CHANGELOG6
-rw-r--r--Git/BuildVersion.hs4
-rw-r--r--Git/Ref.hs31
-rw-r--r--Utility/Directory.hs2
-rw-r--r--Utility/FileMode.hs2
-rw-r--r--Utility/Misc.hs2
-rw-r--r--Utility/Path.hs9
-rw-r--r--Utility/Tmp.hs4
-rw-r--r--Utility/UserInfo.hs9
-rw-r--r--git-repair.cabal1
14 files changed, 71 insertions, 34 deletions
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 <id@joeyh.name>
+ -
+ - 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 <id@joeyh.name> 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