diff --git a/Git.hs b/Git.hs --- 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 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -28,7 +28,7 @@ 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 @@ {- 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 @@ where diffs = pipeReadStrict [ Param "log" - , Param (show origbranch ++ ".." ++ show newbranch) + , Param (fromRef origbranch ++ ".." ++ fromRef newbranch) , Params "--oneline -n1" ] repo @@ -74,7 +74,7 @@ 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 @@ 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 @@ 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 @@ [ 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 @@ [ 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 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -50,7 +50,7 @@ {- 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 @@ 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 @@ _ -> 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 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -18,32 +18,29 @@ #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 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -33,6 +33,7 @@ import Git.Types import Git import Git.Remote +import Git.FilePath import qualified Git.Url as Url import Utility.UserInfo @@ -57,7 +58,7 @@ - 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/Destroyer.hs b/Git/Destroyer.hs --- a/Git/Destroyer.hs +++ b/Git/Destroyer.hs @@ -2,7 +2,7 @@ - - Use with caution! - - - Copyright 2013 Joey Hess + - Copyright 2013, 2014 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -17,39 +17,41 @@ import Git import Utility.QuickCheck import Utility.FileMode +import Utility.Tmp import qualified Data.ByteString as B import Data.Word import System.PosixCompat.Types {- Ways to damange a git repository. -} -data Damage = Damage DamageAction FileSelector +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 = Damage <$> arbitrary <*> arbitrary - -data DamageAction - = Empty - | Delete - | Reverse - | AppendGarbage B.ByteString - | PrependGarbage B.ByteString - | CorruptByte Int Word8 - | ScrambleFileMode FileMode - deriving (Read, Show) - -instance Arbitrary DamageAction where arbitrary = oneof - [ pure Empty - , pure Delete - , pure Reverse - , AppendGarbage <$> garbage - , PrependGarbage <$> garbage + [ Empty <$> arbitrary + , Delete <$> arbitrary + , Reverse <$> arbitrary + , AppendGarbage <$> arbitrary <*> garbage + , PrependGarbage <$> arbitrary <*> garbage , CorruptByte - <$> nonNegative arbitraryBoundedIntegral + <$> arbitrary + <*> nonNegative arbitraryBoundedIntegral <*> arbitrary - , ScrambleFileMode <$> nonNegative arbitrarySizedIntegral + , ScrambleFileMode + <$> arbitrary + <*> nonNegative arbitrarySizedIntegral + , SwapFiles + <$> arbitrary + <*> arbitrary ] where garbage = B.pack <$> arbitrary `suchThat` (not . null) @@ -58,7 +60,7 @@ - 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) + deriving (Read, Show, Eq) instance Arbitrary FileSelector where arbitrary = FileSelector <$> oneof @@ -80,47 +82,68 @@ {- 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 l r = do - contents <- sort . filter (not . skipped . takeFileName) +applyDamage ds r = do + contents <- sort . filter (not . skipped) <$> dirContentsRecursive (localGitDir r) - forM_ l $ \(Damage action fileselector) -> do - let f = selectFile contents fileselector - -- Symlinks might be dangling, so are skipped. - -- If the file was already removed by a previous Damage, - -- it's skipped. - whenM (doesFileExist f) $ - applyDamageAction action f - `catchIO` \e -> error ("Failed to apply " ++ show action ++ " " ++ show f ++ ": " ++ show e ++ "(total damage: " ++ show l ++ ")") + 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. - skipped f = f `elem` [ "config" ] - -applyDamageAction :: DamageAction -> FilePath -> IO () -applyDamageAction Empty f = withSaneMode f $ do - nukeFile f - writeFile f "" -applyDamageAction Reverse f = withSaneMode f $ - B.writeFile f =<< B.reverse <$> B.readFile f -applyDamageAction Delete f = nukeFile f -applyDamageAction (AppendGarbage garbage) f = withSaneMode f $ - B.appendFile f garbage -applyDamageAction (PrependGarbage garbage) 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. -applyDamageAction (CorruptByte n garbage) 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 - ] -applyDamageAction (ScrambleFileMode mode) f = setFileMode f mode + -- 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/FilePath.hs b/Git/FilePath.hs --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -20,12 +20,15 @@ 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 @@ - 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 @@ #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 @@ #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 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -20,7 +20,7 @@ import Git.Command import Git.Sha import Utility.Batch -import qualified Git.BuildVersion +import qualified Git.Version import qualified Data.Set as S @@ -40,12 +40,14 @@ -} findBroken :: Bool -> Repo -> IO FsckResults findBroken batchmode r = do - let (command, params) = ("git", fsckParams r) + 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) (output, fsckok) <- processTranscript command' (toCommand params') Nothing - let objs = findShas output + let objs = findShas supportsNoDangling output badobjs <- findMissing objs r if S.null badobjs && not fsckok then return FsckFailed @@ -72,24 +74,21 @@ where dump = runQuiet [ Param "show" - , Param (show s) + , Param (fromRef s) ] r -findShas :: String -> [Sha] -findShas = catMaybes . map extractSha . concat . map words . filter wanted . lines +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 :: Repo -> [CommandParam] -fsckParams = gitCommandLine $ map Param $ catMaybes +fsckParams :: Bool -> Repo -> [CommandParam] +fsckParams supportsNoDangling = gitCommandLine $ map Param $ catMaybes [ Just "fsck" , if supportsNoDangling then Just "--no-dangling" else Nothing , Just "--no-reflogs" ] - -supportsNoDangling :: Bool -supportsNoDangling = not $ Git.BuildVersion.older "1.7.10" diff --git a/Git/LsTree.hs b/Git/LsTree.hs --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -38,13 +38,13 @@ <$> 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 --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -32,4 +32,4 @@ 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 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -11,6 +11,7 @@ import Git import Git.Command import Git.Sha +import Git.Types import Data.Char (chr) @@ -19,12 +20,12 @@ {- 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 @@ - 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 @@ 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 @@ {- 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 @@ 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 @@ {- 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 --- a/Git/RefLog.hs +++ b/Git/RefLog.hs @@ -18,5 +18,5 @@ [ Param "log" , Param "-g" , Param "--format=%H" - , Param (show b) + , Param (fromRef b) ] diff --git a/Git/Repair.hs b/Git/Repair.hs --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -75,24 +75,35 @@ 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 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 @@ 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 @@ 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 @@ {- 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 @@ [ 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 @@ [ 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 @@ , "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 @@ 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 --- a/Git/Sha.hs +++ b/Git/Sha.hs @@ -37,3 +37,7 @@ 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 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -47,15 +47,19 @@ {- 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 diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -11,6 +11,9 @@ Streamer, pureStreamer, streamUpdateIndex, + streamUpdateIndex', + startUpdateIndex, + stopUpdateIndex, lsTree, updateIndexLine, stageFile, @@ -25,6 +28,9 @@ 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,17 +41,30 @@ {- 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. -} lsTree :: Ref -> Repo -> Streamer @@ -60,7 +79,7 @@ - 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 @@ 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 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -1,6 +1,6 @@ {- directory manipulation - - - Copyright 2011 Joey Hess + - Copyright 2011-2014 Joey Hess - - 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 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 @@ -72,6 +73,21 @@ , 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. -} diff --git a/Utility/Env.hs b/Utility/Env.hs --- a/Utility/Env.hs +++ b/Utility/Env.hs @@ -61,3 +61,21 @@ #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 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -133,10 +133,8 @@ - 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 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -33,12 +33,19 @@ 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 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -1,6 +1,6 @@ {- path manipulation - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2014 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -21,28 +21,60 @@ 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 @@ - 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 @@ 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 @@ {- 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 @@ | 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 --- /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 + - + - 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 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -1,6 +1,6 @@ {- QuickCheck with additional instances - - - Copyright 2012 Joey Hess + - Copyright 2012-2014 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -17,10 +17,14 @@ 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 diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -13,10 +13,11 @@ 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 @@ (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 --- a/debian/changelog +++ b/debian/changelog @@ -1,9 +1,18 @@ +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 diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -17,7 +17,7 @@ libghc-async-dev, libghc-optparse-applicative-dev Maintainer: Joey Hess -Standards-Version: 3.9.4 +Standards-Version: 3.9.5 Vcs-Git: git://git-repair.branchable.com/ Homepage: http://git-repair.branchable.com/ diff --git a/doc/index.mdwn b/doc/index.mdwn --- a/doc/index.mdwn +++ b/doc/index.mdwn @@ -44,7 +44,7 @@ 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 fack may also find problems with +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 diff --git a/git-repair.1 b/git-repair.1 --- a/git-repair.1 +++ b/git-repair.1 @@ -28,6 +28,18 @@ .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 diff --git a/git-repair.cabal b/git-repair.cabal --- a/git-repair.cabal +++ b/git-repair.cabal @@ -1,5 +1,5 @@ Name: git-repair -Version: 1.20140115 +Version: 1.20140227 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess diff --git a/git-repair.hs b/git-repair.hs --- a/git-repair.hs +++ b/git-repair.hs @@ -52,8 +52,8 @@ desc = fullDesc <> header "git-repair - repair a damanged git repository" go settings - | testMode settings = test settings | retryTestMode settings = retryTest settings + | testMode settings = test settings | otherwise = repair settings repair :: Settings -> IO ()