From 878e7471fa09dcc36b478e1ac1fd305d5a90b7bf Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 24 Feb 2014 19:40:14 -0400 Subject: merge from git-annex --- Git.hs | 1 + Git/Branch.hs | 20 ++++++------ Git/CatFile.hs | 8 ++--- Git/Command.hs | 23 ++++++-------- Git/Construct.hs | 3 +- Git/FilePath.hs | 21 ++++++++----- Git/Fsck.hs | 2 +- Git/LsTree.hs | 4 +-- Git/Objects.hs | 2 +- Git/Ref.hs | 25 +++++++++------ Git/RefLog.hs | 2 +- Git/Repair.hs | 65 ++++++++++++++++++++++----------------- Git/Sha.hs | 4 +++ Git/Types.hs | 10 ++++-- Git/UpdateIndex.hs | 37 +++++++++++++++++------ Utility/Directory.hs | 20 ++++++++++-- Utility/Env.hs | 18 +++++++++++ Utility/FileMode.hs | 4 +-- Utility/Misc.hs | 9 +++++- Utility/Path.hs | 84 +++++++++++++++++++++++++++++++++++++-------------- Utility/PosixFiles.hs | 33 ++++++++++++++++++++ Utility/QuickCheck.hs | 6 +++- Utility/Tmp.hs | 5 +-- debian/changelog | 7 +++++ 24 files changed, 292 insertions(+), 121 deletions(-) create mode 100644 Utility/PosixFiles.hs 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 + - 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 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 + - Copyright 2010-2014 Joey Hess - - 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 + - + - 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 + - Copyright 2012-2014 Joey Hess - - 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 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 -- cgit v1.2.3