summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess <joey@kitenet.net>2014-02-24 19:40:14 -0400
committerJoey Hess <joey@kitenet.net>2014-02-24 19:40:14 -0400
commit878e7471fa09dcc36b478e1ac1fd305d5a90b7bf (patch)
treed552b8faa43078e3dfe1f8b10063ec566eced4e2
parentd80c547a7d1261f158148ca85e627cc2ecb005f2 (diff)
downloadgit-repair-878e7471fa09dcc36b478e1ac1fd305d5a90b7bf.tar.gz
merge from git-annex
-rw-r--r--Git.hs1
-rw-r--r--Git/Branch.hs20
-rw-r--r--Git/CatFile.hs8
-rw-r--r--Git/Command.hs23
-rw-r--r--Git/Construct.hs3
-rw-r--r--Git/FilePath.hs21
-rw-r--r--Git/Fsck.hs2
-rw-r--r--Git/LsTree.hs4
-rw-r--r--Git/Objects.hs2
-rw-r--r--Git/Ref.hs25
-rw-r--r--Git/RefLog.hs2
-rw-r--r--Git/Repair.hs65
-rw-r--r--Git/Sha.hs4
-rw-r--r--Git/Types.hs10
-rw-r--r--Git/UpdateIndex.hs37
-rw-r--r--Utility/Directory.hs20
-rw-r--r--Utility/Env.hs18
-rw-r--r--Utility/FileMode.hs4
-rw-r--r--Utility/Misc.hs9
-rw-r--r--Utility/Path.hs84
-rw-r--r--Utility/PosixFiles.hs33
-rw-r--r--Utility/QuickCheck.hs6
-rw-r--r--Utility/Tmp.hs5
-rw-r--r--debian/changelog7
24 files changed, 292 insertions, 121 deletions
diff --git a/Git.hs b/Git.hs
index cad4668..55b44a9 100644
--- a/Git.hs
+++ b/Git.hs
@@ -13,6 +13,7 @@
module Git (
Repo(..),
Ref(..),
+ fromRef,
Branch,
Sha,
Tag,
diff --git a/Git/Branch.hs b/Git/Branch.hs
index 405fa10..d182ceb 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -28,7 +28,7 @@ current r = do
case v of
Nothing -> return Nothing
Just branch ->
- ifM (null <$> pipeReadStrict [Param "show-ref", Param $ show branch] r)
+ ifM (null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r)
( return Nothing
, return v
)
@@ -36,7 +36,7 @@ current r = do
{- The current branch, which may not really exist yet. -}
currentUnsafe :: Repo -> IO (Maybe Git.Ref)
currentUnsafe r = parse . firstLine
- <$> pipeReadStrict [Param "symbolic-ref", Param $ show Git.Ref.headRef] r
+ <$> pipeReadStrict [Param "symbolic-ref", Param $ fromRef Git.Ref.headRef] r
where
parse l
| null l = Nothing
@@ -51,7 +51,7 @@ changed origbranch newbranch repo
where
diffs = pipeReadStrict
[ Param "log"
- , Param (show origbranch ++ ".." ++ show newbranch)
+ , Param (fromRef origbranch ++ ".." ++ fromRef newbranch)
, Params "--oneline -n1"
] repo
@@ -74,7 +74,7 @@ fastForward branch (first:rest) repo =
where
no_ff = return False
do_ff to = do
- run [Param "update-ref", Param $ show branch, Param $ show to] repo
+ run [Param "update-ref", Param $ fromRef branch, Param $ fromRef to] repo
return True
findbest c [] = return $ Just c
findbest c (r:rs)
@@ -104,14 +104,14 @@ commit allowempty message branch parentrefs repo = do
ifM (cancommit tree)
( do
sha <- getSha "commit-tree" $ pipeWriteRead
- (map Param $ ["commit-tree", show tree] ++ ps)
+ (map Param $ ["commit-tree", fromRef tree] ++ ps)
(Just $ flip hPutStr message) repo
update branch sha repo
return $ Just sha
, return Nothing
)
where
- ps = concatMap (\r -> ["-p", show r]) parentrefs
+ ps = concatMap (\r -> ["-p", fromRef r]) parentrefs
cancommit tree
| allowempty = return True
| otherwise = case parentrefs of
@@ -130,8 +130,8 @@ forcePush b = "+" ++ b
update :: Branch -> Sha -> Repo -> IO ()
update branch sha = run
[ Param "update-ref"
- , Param $ show branch
- , Param $ show sha
+ , Param $ fromRef branch
+ , Param $ fromRef sha
]
{- Checks out a branch, creating it if necessary. -}
@@ -140,7 +140,7 @@ checkout branch = run
[ Param "checkout"
, Param "-q"
, Param "-B"
- , Param $ show $ Git.Ref.base branch
+ , Param $ fromRef $ Git.Ref.base branch
]
{- Removes a branch. -}
@@ -149,5 +149,5 @@ delete branch = run
[ Param "branch"
, Param "-q"
, Param "-D"
- , Param $ show $ Git.Ref.base branch
+ , Param $ fromRef $ Git.Ref.base branch
]
diff --git a/Git/CatFile.hs b/Git/CatFile.hs
index aee6bd1..c8cb76d 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -50,7 +50,7 @@ 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 $
- show branch ++ ":" ++ toInternalGitPath file
+ fromRef branch ++ ":" ++ toInternalGitPath file
{- Uses a running git cat-file read the content of an object.
- Objects that do not exist will have "" returned. -}
@@ -60,7 +60,7 @@ 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 = show object
+ query = fromRef object
send to = hPutStrLn to query
receive from = do
header <- hGetLine from
@@ -72,8 +72,8 @@ catObjectDetails (CatFileHandle hdl _) object = CoProcess.query hdl send receive
_ -> dne
| otherwise -> dne
_
- | header == show object ++ " missing" -> dne
- | otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)
+ | 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
diff --git a/Git/Command.hs b/Git/Command.hs
index 4c338ba..0fa3d1b 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -18,32 +18,29 @@ import qualified Utility.CoProcess as CoProcess
#ifdef mingw32_HOST_OS
import Git.FilePath
#endif
+import Utility.Batch
{- 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=" ++ gitpath (gitdir l)
+ setdir = Param $ "--git-dir=" ++ gitdir l
settree = case worktree l of
Nothing -> []
- Just t -> [Param $ "--work-tree=" ++ gitpath t]
-#ifdef mingw32_HOST_OS
- -- despite running on windows, msysgit wants a unix-formatted path
- gitpath s
- | isAbsolute s = "/" ++ dropDrive (toInternalGitPath s)
- | otherwise = s
-#else
- gitpath = id
-#endif
+ 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)
+ boolSystemEnv "git" (gitCommandLine params repo) (gitEnv repo)
+
+{- Runs git in batch mode. -}
+runBatch :: BatchCommandMaker -> [CommandParam] -> Repo -> IO Bool
+runBatch batchmaker params repo = assertLocal repo $ do
+ let (cmd, params') = batchmaker ("git", gitCommandLine params repo)
+ boolSystemEnv cmd params' (gitEnv repo)
{- Runs git in the specified repo, throwing an error if it fails. -}
run :: [CommandParam] -> Repo -> IO ()
diff --git a/Git/Construct.hs b/Git/Construct.hs
index 71a13f4..eed2b99 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -33,6 +33,7 @@ import Common
import Git.Types
import Git
import Git.Remote
+import Git.FilePath
import qualified Git.Url as Url
import Utility.UserInfo
@@ -57,7 +58,7 @@ fromPath dir = fromAbsPath =<< absPath dir
- specified. -}
fromAbsPath :: FilePath -> IO Repo
fromAbsPath dir
- | isAbsolute dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt )
+ | absoluteGitPath dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt )
| otherwise =
error $ "internal error, " ++ dir ++ " is not absolute"
where
diff --git a/Git/FilePath.hs b/Git/FilePath.hs
index 4189244..42eb081 100644
--- a/Git/FilePath.hs
+++ b/Git/FilePath.hs
@@ -20,12 +20,15 @@ module Git.FilePath (
asTopFilePath,
InternalGitPath,
toInternalGitPath,
- fromInternalGitPath
+ 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)
@@ -48,8 +51,7 @@ asTopFilePath file = TopFilePath file
- it internally.
-
- On Windows, git uses '/' to separate paths stored in the repository,
- - despite Windows using '\'. Also, git on windows dislikes paths starting
- - with "./" or ".\".
+ - despite Windows using '\'.
-
-}
type InternalGitPath = String
@@ -58,11 +60,7 @@ toInternalGitPath :: FilePath -> InternalGitPath
#ifndef mingw32_HOST_OS
toInternalGitPath = id
#else
-toInternalGitPath p =
- let p' = replace "\\" "/" p
- in if "./" `isPrefixOf` p'
- then dropWhile (== '/') (drop 1 p')
- else p'
+toInternalGitPath = replace "\\" "/"
#endif
fromInternalGitPath :: InternalGitPath -> FilePath
@@ -71,3 +69,10 @@ 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/Fsck.hs b/Git/Fsck.hs
index 23d3a35..e90683b 100644
--- a/Git/Fsck.hs
+++ b/Git/Fsck.hs
@@ -74,7 +74,7 @@ isMissing s r = either (const True) (const False) <$> tryIO dump
where
dump = runQuiet
[ Param "show"
- , Param (show s)
+ , Param (fromRef s)
] r
findShas :: Bool -> String -> [Sha]
diff --git a/Git/LsTree.hs b/Git/LsTree.hs
index 956f9f5..6d3ca48 100644
--- a/Git/LsTree.hs
+++ b/Git/LsTree.hs
@@ -38,13 +38,13 @@ lsTree t repo = map parseLsTree
<$> pipeNullSplitZombie (lsTreeParams t) repo
lsTreeParams :: Ref -> [CommandParam]
-lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ show t ]
+lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ fromRef t ]
{- Lists specified files in a tree. -}
lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem]
lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo
where
- ps = [Params "ls-tree --full-tree -z --", File $ show t] ++ map File fs
+ ps = [Params "ls-tree --full-tree -z --", File $ fromRef t] ++ map File fs
{- Parses a line of ls-tree output.
- (The --long format is not currently supported.) -}
diff --git a/Git/Objects.hs b/Git/Objects.hs
index bb492f5..516aa6d 100644
--- a/Git/Objects.hs
+++ b/Git/Objects.hs
@@ -32,4 +32,4 @@ listLooseObjectShas r = catchDefaultIO [] $
looseObjectFile :: Repo -> Sha -> FilePath
looseObjectFile r sha = objectsDir r </> prefix </> rest
where
- (prefix, rest) = splitAt 2 (show sha)
+ (prefix, rest) = splitAt 2 (fromRef sha)
diff --git a/Git/Ref.hs b/Git/Ref.hs
index 0947293..3d0c68f 100644
--- a/Git/Ref.hs
+++ b/Git/Ref.hs
@@ -11,6 +11,7 @@ import Common
import Git
import Git.Command
import Git.Sha
+import Git.Types
import Data.Char (chr)
@@ -19,12 +20,12 @@ headRef = Ref "HEAD"
{- Converts a fully qualified git ref into a user-visible string. -}
describe :: Ref -> String
-describe = show . base
+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/" . show
+base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef
where
remove prefix s
| prefix `isPrefixOf` s = drop (length prefix) s
@@ -34,13 +35,13 @@ base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show
- it under the directory. -}
under :: String -> Ref -> Ref
under dir r = Ref $ dir ++ "/" ++
- (reverse $ takeWhile (/= '/') $ reverse $ show r)
+ (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 ++ "/" ++ show (base r)
+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.
@@ -51,6 +52,10 @@ underBase dir r = Ref $ dir ++ "/" ++ show (base r)
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
@@ -59,12 +64,12 @@ 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 $ show ref]
+ [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 </> show ref
+file ref repo = localGitDir repo </> fromRef ref
{- Checks if HEAD exists. It generally will, except for in a repository
- that was just created. -}
@@ -79,17 +84,17 @@ sha branch repo = process <$> showref repo
where
showref = pipeReadStrict [Param "show-ref",
Param "--hash", -- get the hash
- Param $ show branch]
+ Param $ fromRef branch]
process [] = Nothing
process s = Just $ Ref $ firstLine s
{- List of (shas, branches) matching a given ref or refs. -}
matching :: [Ref] -> Repo -> IO [(Sha, Branch)]
-matching refs repo = matching' (map show refs) repo
+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 show refs) repo
+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)]
@@ -109,7 +114,7 @@ matchingUniq refs repo = nubBy uniqref <$> matching refs repo
{- Gets the sha of the tree a ref uses. -}
tree :: Ref -> Repo -> IO (Maybe Sha)
tree ref = extractSha <$$> pipeReadStrict
- [ Param "rev-parse", Param (show ref ++ ":") ]
+ [ Param "rev-parse", Param (fromRef ref ++ ":") ]
{- Checks if a String is a legal git ref name.
-
diff --git a/Git/RefLog.hs b/Git/RefLog.hs
index 3f41e8e..98c9d66 100644
--- a/Git/RefLog.hs
+++ b/Git/RefLog.hs
@@ -18,5 +18,5 @@ get b = mapMaybe extractSha . lines <$$> pipeReadStrict
[ Param "log"
, Param "-g"
, Param "--format=%H"
- , Param (show b)
+ , Param (fromRef b)
]
diff --git a/Git/Repair.hs b/Git/Repair.hs
index 2c09836..cdd7032 100644
--- a/Git/Repair.hs
+++ b/Git/Repair.hs
@@ -75,24 +75,35 @@ removeLoose r s = do
return True
else return False
+{- 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 = do
- packs <- listPackFiles r
- if null packs
- then return False
- else do
- putStrLn "Unpacking all pack files."
- mapM_ go packs
- return True
+explodePacks r = go =<< listPackFiles r
where
- go packfile = withTmpFileIn (localGitDir r) "pack" $ \tmp _ -> do
- moveFile packfile tmp
- nukeFile $ packIdxFile packfile
- allowRead tmp
- -- May fail, if pack file is corrupt.
- void $ tryIO $
- pipeWrite [Param "unpack-objects", Param "-r"] r $ \h ->
+ 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.
@@ -168,7 +179,7 @@ resetLocalBranches :: MissingObjects -> GoodCommits -> Repo -> IO ([Branch], [Br
resetLocalBranches missing goodcommits r =
go [] [] goodcommits =<< filter islocalbranch <$> getAllRefs r
where
- islocalbranch b = "refs/heads/" `isPrefixOf` show b
+ 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
@@ -185,12 +196,12 @@ resetLocalBranches missing goodcommits r =
nukeBranchRef b r
void $ runBool
[ Param "branch"
- , Param (show $ Ref.base b)
- , Param (show c)
+ , Param (fromRef $ Ref.base b)
+ , Param (fromRef c)
] r
isTrackingBranch :: Ref -> Bool
-isTrackingBranch b = "refs/remotes/" `isPrefixOf` show b
+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
@@ -231,10 +242,10 @@ explodePackedRefsFile r = do
nukeFile f
where
makeref (sha, ref) = do
- let dest = localGitDir r </> show ref
+ let dest = localGitDir r </> fromRef ref
createDirectoryIfMissing True (parentDir dest)
unlessM (doesFileExist dest) $
- writeFile dest (show sha)
+ writeFile dest (fromRef sha)
packedRefsFile :: Repo -> FilePath
packedRefsFile r = localGitDir r </> "packed-refs"
@@ -249,7 +260,7 @@ parsePacked l = case words l of
{- git-branch -d cannot be used to remove a branch that is directly
- pointing to a corrupt commit. -}
nukeBranchRef :: Branch -> Repo -> IO ()
-nukeBranchRef b r = nukeFile $ localGitDir r </> show b
+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.
@@ -268,7 +279,7 @@ findUncorruptedCommit missing goodcommits branch r = do
[ Param "log"
, Param "-z"
, Param "--format=%H"
- , Param (show branch)
+ , Param (fromRef branch)
] r
let branchshas = catMaybes $ map extractSha ls
reflogshas <- RefLog.get branch r
@@ -297,7 +308,7 @@ verifyCommit missing goodcommits commit r
[ Param "log"
, Param "-z"
, Param "--format=%H %T"
- , Param (show commit)
+ , Param (fromRef commit)
] r
let committrees = map parse ls
if any isNothing committrees || null committrees
@@ -501,9 +512,9 @@ runRepair' removablebranch fsckresult forced referencerepo g = do
, "remote tracking branches that referred to missing objects."
]
(resetbranches, deletedbranches, _) <- resetLocalBranches stillmissing goodcommits g
- displayList (map show resetbranches)
+ displayList (map fromRef resetbranches)
"Reset these local branches to old versions before the missing objects were committed:"
- displayList (map show deletedbranches)
+ displayList (map fromRef deletedbranches)
"Deleted these local branches, which could not be recovered due to missing objects:"
deindexedfiles <- rewriteIndex g
displayList deindexedfiles
@@ -519,7 +530,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do
Just curr -> when (any (== curr) modifiedbranches) $ do
putStrLn $ unwords
[ "You currently have"
- , show curr
+ , 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!"
diff --git a/Git/Sha.hs b/Git/Sha.hs
index ee1b6d6..cbb66ea 100644
--- a/Git/Sha.hs
+++ b/Git/Sha.hs
@@ -37,3 +37,7 @@ 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
index e63e930..8029225 100644
--- a/Git/Types.hs
+++ b/Git/Types.hs
@@ -47,16 +47,20 @@ type RemoteName = String
{- A git ref. Can be a sha1, or a branch or tag name. -}
newtype Ref = Ref String
- deriving (Eq, Ord)
+ deriving (Eq, Ord, Read, Show)
-instance Show Ref where
- show (Ref v) = v
+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)
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index 3b33ac8..6d1ff25 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -11,6 +11,9 @@ module Git.UpdateIndex (
Streamer,
pureStreamer,
streamUpdateIndex,
+ streamUpdateIndex',
+ startUpdateIndex,
+ stopUpdateIndex,
lsTree,
updateIndexLine,
stageFile,
@@ -25,6 +28,9 @@ import Git.Command
import Git.FilePath
import Git.Sha
+import Control.Exception (bracket)
+import System.Process (std_in)
+
{- 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 ()
@@ -35,16 +41,29 @@ pureStreamer !s = \streamer -> streamer s
{- Streams content into update-index from a list of Streamers. -}
streamUpdateIndex :: Repo -> [Streamer] -> IO ()
-streamUpdateIndex repo as = pipeWrite params repo $ \h -> do
+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
- forM_ as (stream h)
- hClose h
+ return $ UpdateIndexHandle p h
where
params = map Param ["update-index", "-z", "--index-info"]
- stream h a = a (streamer h)
- streamer h s = do
- hPutStr h s
- hPutStr h "\0"
+
+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. -}
@@ -60,7 +79,7 @@ lsTree (Ref x) repo streamer = do
- a given file with a given sha. -}
updateIndexLine :: Sha -> BlobType -> TopFilePath -> String
updateIndexLine sha filetype file =
- show filetype ++ " blob " ++ show sha ++ "\t" ++ indexPath file
+ show filetype ++ " blob " ++ fromRef sha ++ "\t" ++ indexPath file
stageFile :: Sha -> BlobType -> FilePath -> Repo -> IO Streamer
stageFile sha filetype file repo = do
@@ -71,7 +90,7 @@ stageFile sha filetype file repo = do
unstageFile :: FilePath -> Repo -> IO Streamer
unstageFile file repo = do
p <- toTopFilePath file repo
- return $ pureStreamer $ "0 " ++ show nullSha ++ "\t" ++ indexPath p
+ return $ pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p
{- A streamer that adds a symlink to the index. -}
stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer
diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index 6caee7e..f1bcfad 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -1,6 +1,6 @@
{- directory manipulation
-
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -10,7 +10,6 @@
module Utility.Directory where
import System.IO.Error
-import System.PosixCompat.Files
import System.Directory
import Control.Exception (throw)
import Control.Monad
@@ -19,10 +18,12 @@ import System.FilePath
import Control.Applicative
import System.IO.Unsafe (unsafeInterleaveIO)
+import Utility.PosixFiles
import Utility.SafeCommand
import Utility.Tmp
import Utility.Exception
import Utility.Monad
+import Utility.Applicative
dirCruft :: FilePath -> Bool
dirCruft "." = True
@@ -73,6 +74,21 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]
)
_ -> 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 ()
diff --git a/Utility/Env.hs b/Utility/Env.hs
index cb73873..90ed58f 100644
--- a/Utility/Env.hs
+++ b/Utility/Env.hs
@@ -61,3 +61,21 @@ unsetEnv var = do
#else
unsetEnv _ = return False
#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/FileMode.hs b/Utility/FileMode.hs
index 46c6a31..b17cadc 100644
--- a/Utility/FileMode.hs
+++ b/Utility/FileMode.hs
@@ -133,10 +133,8 @@ setSticky f = modifyFileMode f $ addModes [stickyMode]
- as writeFile.
-}
writeFileProtected :: FilePath -> String -> IO ()
-writeFileProtected file content = do
- h <- openFile file WriteMode
+writeFileProtected file content = withFile file WriteMode $ \h -> do
void $ tryIO $
modifyFileMode file $
removeModes [groupReadMode, otherReadMode]
hPutStr h content
- hClose h
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 68199c8..20007ad 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -33,13 +33,20 @@ hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s
readFileStrict :: FilePath -> IO String
readFileStrict = readFile >=> \s -> length s `seq` return s
-{- Reads a file strictly, and using the FileSystemEncofing, so it will
+{- Reads a file strictly, and using the FileSystemEncoding, so it will
- never crash on a badly encoded file. -}
readFileStrictAnyEncoding :: FilePath -> IO String
readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do
fileEncoding h
hClose h `after` hGetContentsStrict h
+{- Writes a file, using the FileSystemEncoding so it will never crash
+ - on a badly encoded content string. -}
+writeFileAnyEncoding :: FilePath -> String -> IO ()
+writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do
+ fileEncoding h
+ hPutStr h content
+
{- Like break, but the item matching the condition is not included
- in the second result list.
-
diff --git a/Utility/Path.hs b/Utility/Path.hs
index 44ac72f..e22d0c3 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -1,6 +1,6 @@
{- path manipulation
-
- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -21,28 +21,60 @@ import Control.Applicative
import Data.Char
import qualified System.FilePath.Posix as Posix
#else
-import qualified "MissingH" System.Path as MissingH
import System.Posix.Files
#endif
+import qualified "MissingH" System.Path as MissingH
import Utility.Monad
import Utility.UserInfo
-{- Makes a path absolute if it's not already.
+{- Simplifies a path, removing any ".." or ".", 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' == ".." = 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.
-
- - On Unix, collapses and normalizes ".." etc in the path. May return Nothing
- - if the path cannot be normalized.
- -
- - MissingH's absNormPath does not work on Windows, so on Windows
- - no normalization is done.
+ - Does not attempt to deal with edge cases or ensure security with
+ - untrusted inputs.
-}
-absNormPath :: FilePath -> FilePath -> Maybe FilePath
+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. Resulting path will use / separators. -}
+absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath
#ifndef mingw32_HOST_OS
-absNormPath dir path = MissingH.absNormPath dir path
+absNormPathUnix dir path = MissingH.absNormPath dir path
#else
-absNormPath dir path = Just $ combine dir path
+absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path)
+ where
+ fromdos = replace "\\" "/"
+ todos = replace "/" "\\"
#endif
{- Returns the parent directory of a path.
@@ -72,13 +104,13 @@ prop_parentDir_basics dir
- are all equivilant.
-}
dirContains :: FilePath -> FilePath -> Bool
-dirContains a b = a == b || a' == b' || (a'++[pathSeparator]) `isPrefixOf` b'
+dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b'
where
- norm p = fromMaybe "" $ absNormPath p "."
a' = norm a
b' = norm b
+ norm = normalise . simplifyPath
-{- Converts a filename into a normalized, absolute path.
+{- Converts a filename into an absolute path.
-
- Unlike Directory.canonicalizePath, this does not require the path
- already exists. -}
@@ -87,13 +119,6 @@ absPath file = do
cwd <- getCurrentDirectory
return $ absPathFrom cwd file
-{- Converts a filename into a normalized, absolute path
- - from the specified cwd. -}
-absPathFrom :: FilePath -> FilePath -> FilePath
-absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file
- where
- bad = error $ "unable to normalize " ++ file
-
{- Constructs a relative path from the CWD to a file.
-
- For example, assuming CWD is /tmp/foo/bar:
@@ -105,7 +130,7 @@ relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f
{- Constructs a relative path from a directory to a file.
-
- - Both must be absolute, and normalized (eg with absNormpath).
+ - Both must be absolute, and cannot contain .. etc. (eg use absPath first).
-}
relPathDirToFile :: FilePath -> FilePath -> FilePath
relPathDirToFile from to = join s $ dotdots ++ uncommon
@@ -252,3 +277,18 @@ sanitizeFilePath = map sanitize
| 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..23edc25
--- /dev/null
+++ b/Utility/PosixFiles.hs
@@ -0,0 +1,33 @@
+{- POSIX files (and compatablity wrappers).
+ -
+ - This is like System.PosixCompat.Files, except with a fixed rename.
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+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/QuickCheck.hs b/Utility/QuickCheck.hs
index 82af09f..e2539f3 100644
--- a/Utility/QuickCheck.hs
+++ b/Utility/QuickCheck.hs
@@ -1,6 +1,6 @@
{- QuickCheck with additional instances
-
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -17,11 +17,15 @@ 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
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 = nonNegative arbitrarySizedIntegral
diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs
index 891ce50..f46e1a5 100644
--- a/Utility/Tmp.hs
+++ b/Utility/Tmp.hs
@@ -13,10 +13,11 @@ import Control.Exception (bracket)
import System.IO
import System.Directory
import Control.Monad.IfElse
+import System.FilePath
import Utility.Exception
-import System.FilePath
import Utility.FileSystemEncoding
+import Utility.PosixFiles
type Template = String
@@ -30,7 +31,7 @@ viaTmp a file content = do
(tmpfile, handle) <- openTempFile dir (base ++ ".tmp")
hClose handle
a tmpfile content
- renameFile tmpfile file
+ 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. -}
diff --git a/debian/changelog b/debian/changelog
index 4a9ab76..bcaccce 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,10 @@
+git-repair (1.20140116) UNRELEASED; urgency=medium
+
+ * Optimise unpacking of pack files, and avoid repeated error
+ messages about corrupt pack files.
+
+ -- Joey Hess <joeyh@debian.org> Mon, 24 Feb 2014 19:39:51 -0400
+
git-repair (1.20140115) unstable; urgency=medium
* Support old git versions from before git fsck --no-dangling was