From 7c12f0ac9224246dac308e837bccb5b2157062ee Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 15 Dec 2015 17:47:59 -0700 Subject: Import git-repair_1.20151215.orig.tar.xz [dgit import orig git-repair_1.20151215.orig.tar.xz] --- Git/Branch.hs | 195 +++++++++++++++++ Git/BuildVersion.hs | 21 ++ Git/CatFile.hs | 113 ++++++++++ Git/Command.hs | 128 +++++++++++ Git/Config.hs | 210 ++++++++++++++++++ Git/Construct.hs | 241 ++++++++++++++++++++ Git/CurrentRepo.hs | 59 +++++ Git/Destroyer.hs | 148 +++++++++++++ Git/DiffTreeItem.hs | 24 ++ Git/FilePath.hs | 77 +++++++ Git/Filename.hs | 28 +++ Git/Fsck.hs | 117 ++++++++++ Git/Index.hs | 55 +++++ Git/LsFiles.hs | 258 ++++++++++++++++++++++ Git/LsTree.hs | 78 +++++++ Git/Objects.hs | 49 +++++ Git/Ref.hs | 147 +++++++++++++ Git/RefLog.hs | 30 +++ Git/Remote.hs | 108 +++++++++ Git/Repair.hs | 617 ++++++++++++++++++++++++++++++++++++++++++++++++++++ Git/Sha.hs | 43 ++++ Git/Types.hs | 100 +++++++++ Git/UpdateIndex.hs | 121 +++++++++++ Git/Url.hs | 71 ++++++ Git/Version.hs | 32 +++ 25 files changed, 3070 insertions(+) create mode 100644 Git/Branch.hs create mode 100644 Git/BuildVersion.hs create mode 100644 Git/CatFile.hs create mode 100644 Git/Command.hs create mode 100644 Git/Config.hs create mode 100644 Git/Construct.hs create mode 100644 Git/CurrentRepo.hs create mode 100644 Git/Destroyer.hs create mode 100644 Git/DiffTreeItem.hs create mode 100644 Git/FilePath.hs create mode 100644 Git/Filename.hs create mode 100644 Git/Fsck.hs create mode 100644 Git/Index.hs create mode 100644 Git/LsFiles.hs create mode 100644 Git/LsTree.hs create mode 100644 Git/Objects.hs create mode 100644 Git/Ref.hs create mode 100644 Git/RefLog.hs create mode 100644 Git/Remote.hs create mode 100644 Git/Repair.hs create mode 100644 Git/Sha.hs create mode 100644 Git/Types.hs create mode 100644 Git/UpdateIndex.hs create mode 100644 Git/Url.hs create mode 100644 Git/Version.hs (limited to 'Git') diff --git a/Git/Branch.hs b/Git/Branch.hs new file mode 100644 index 0000000..a2225dc --- /dev/null +++ b/Git/Branch.hs @@ -0,0 +1,195 @@ +{- git branch stuff + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns #-} + +module Git.Branch where + +import Common +import Git +import Git.Sha +import Git.Command +import qualified Git.Ref +import qualified Git.BuildVersion + +{- The currently checked out branch. + - + - In a just initialized git repo before the first commit, + - symbolic-ref will show the master branch, even though that + - branch is not created yet. So, this also looks at show-ref HEAD + - to double-check. + -} +current :: Repo -> IO (Maybe Git.Ref) +current r = do + v <- currentUnsafe r + case v of + Nothing -> return Nothing + Just branch -> + ifM (null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r) + ( return Nothing + , return v + ) + +{- The current branch, which may not really exist yet. -} +currentUnsafe :: Repo -> IO (Maybe Git.Ref) +currentUnsafe r = parse . firstLine + <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r + where + parse l + | null l = Nothing + | otherwise = Just $ Git.Ref l + +{- Checks if the second branch has any commits not present on the first + - branch. -} +changed :: Branch -> Branch -> Repo -> IO Bool +changed origbranch newbranch repo + | origbranch == newbranch = return False + | otherwise = not . null <$> diffs + where + diffs = pipeReadStrict + [ Param "log" + , Param (fromRef origbranch ++ ".." ++ fromRef newbranch) + , Param "-n1" + , Param "--pretty=%H" + ] repo + +{- Check if it's possible to fast-forward from the old + - ref to the new ref. + - + - This requires there to be a path from the old to the new. -} +fastForwardable :: Ref -> Ref -> Repo -> IO Bool +fastForwardable old new repo = not . null <$> + pipeReadStrict + [ Param "log" + , Param $ fromRef old ++ ".." ++ fromRef new + , Param "-n1" + , Param "--pretty=%H" + , Param "--ancestry-path" + ] repo + +{- Given a set of refs that are all known to have commits not + - on the branch, tries to update the branch by a fast-forward. + - + - In order for that to be possible, one of the refs must contain + - every commit present in all the other refs. + -} +fastForward :: Branch -> [Ref] -> Repo -> IO Bool +fastForward _ [] _ = return True +fastForward branch (first:rest) repo = + -- First, check that the branch does not contain any + -- new commits that are not in the first ref. If it does, + -- cannot fast-forward. + ifM (changed first branch repo) + ( no_ff + , maybe no_ff do_ff =<< findbest first rest + ) + where + no_ff = return False + do_ff to = do + update branch to repo + return True + findbest c [] = return $ Just c + findbest c (r:rs) + | c == r = findbest c rs + | otherwise = do + better <- changed c r repo + worse <- changed r c repo + case (better, worse) of + (True, True) -> return Nothing -- divergent fail + (True, False) -> findbest r rs -- better + (False, True) -> findbest c rs -- worse + (False, False) -> findbest c rs -- same + +{- The user may have set commit.gpgsign, indending all their manual + - commits to be signed. But signing automatic/background commits could + - easily lead to unwanted gpg prompts or failures. + -} +data CommitMode = ManualCommit | AutomaticCommit + deriving (Eq) + +applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam] +applyCommitMode commitmode ps + | commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") = + Param "--no-gpg-sign" : ps + | otherwise = ps + +{- Commit via the usual git command. -} +commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool +commitCommand = commitCommand' runBool + +{- Commit will fail when the tree is clean. This suppresses that error. -} +commitQuiet :: CommitMode -> [CommandParam] -> Repo -> IO () +commitQuiet commitmode ps = void . tryIO . commitCommand' runQuiet commitmode ps + +commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> [CommandParam] -> Repo -> IO a +commitCommand' runner commitmode ps = runner $ + Param "commit" : applyCommitMode commitmode ps + +{- Commits the index into the specified branch (or other ref), + - with the specified parent refs, and returns the committed sha. + - + - Without allowempy set, avoids making a commit if there is exactly + - one parent, and it has the same tree that would be committed. + - + - Unlike git-commit, does not run any hooks, or examine the work tree + - in any way. + -} +commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha) +commit commitmode allowempty message branch parentrefs repo = do + tree <- getSha "write-tree" $ + pipeReadStrict [Param "write-tree"] repo + ifM (cancommit tree) + ( do + sha <- getSha "commit-tree" $ + pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) sendmsg repo + update branch sha repo + return $ Just sha + , return Nothing + ) + where + ps = applyCommitMode commitmode $ + map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs + cancommit tree + | allowempty = return True + | otherwise = case parentrefs of + [p] -> maybe False (tree /=) <$> Git.Ref.tree p repo + _ -> return True + sendmsg = Just $ flip hPutStr message + +commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha +commitAlways commitmode message branch parentrefs repo = fromJust + <$> commit commitmode True message branch parentrefs repo + +{- A leading + makes git-push force pushing a branch. -} +forcePush :: String -> String +forcePush b = "+" ++ b + +{- Updates a branch (or other ref) to a new Sha. -} +update :: Branch -> Sha -> Repo -> IO () +update branch sha = run + [ Param "update-ref" + , Param $ fromRef branch + , Param $ fromRef sha + ] + +{- Checks out a branch, creating it if necessary. -} +checkout :: Branch -> Repo -> IO () +checkout branch = run + [ Param "checkout" + , Param "-q" + , Param "-B" + , Param $ fromRef $ Git.Ref.base branch + ] + +{- Removes a branch. -} +delete :: Branch -> Repo -> IO () +delete branch = run + [ Param "branch" + , Param "-q" + , Param "-D" + , Param $ fromRef $ Git.Ref.base branch + ] diff --git a/Git/BuildVersion.hs b/Git/BuildVersion.hs new file mode 100644 index 0000000..50e4a3a --- /dev/null +++ b/Git/BuildVersion.hs @@ -0,0 +1,21 @@ +{- git build version + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.BuildVersion where + +import Git.Version +import qualified Build.SysConfig + +{- Using the version it was configured for avoids running git to check its + - version, at the cost that upgrading git won't be noticed. + - This is only acceptable because it's rare that git's version influences + - code's behavior. -} +buildVersion :: GitVersion +buildVersion = normalize Build.SysConfig.gitversion + +older :: String -> Bool +older n = buildVersion < normalize n diff --git a/Git/CatFile.hs b/Git/CatFile.hs new file mode 100644 index 0000000..c63a064 --- /dev/null +++ b/Git/CatFile.hs @@ -0,0 +1,113 @@ +{- git cat-file interface + - + - Copyright 2011, 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.CatFile ( + CatFileHandle, + catFileStart, + catFileStart', + catFileStop, + catFile, + catFileDetails, + catTree, + catObject, + catObjectDetails, +) where + +import System.IO +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Tuple.Utils +import Numeric +import System.Posix.Types + +import Common +import Git +import Git.Sha +import Git.Command +import Git.Types +import Git.FilePath +import qualified Utility.CoProcess as CoProcess + +data CatFileHandle = CatFileHandle CoProcess.CoProcessHandle Repo + +catFileStart :: Repo -> IO CatFileHandle +catFileStart = catFileStart' True + +catFileStart' :: Bool -> Repo -> IO CatFileHandle +catFileStart' restartable repo = do + coprocess <- CoProcess.rawMode =<< gitCoProcessStart restartable + [ Param "cat-file" + , Param "--batch" + ] repo + return $ CatFileHandle coprocess repo + +catFileStop :: CatFileHandle -> IO () +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 $ + fromRef branch ++ ":" ++ toInternalGitPath file + +catFileDetails :: CatFileHandle -> Branch -> FilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) +catFileDetails h branch file = catObjectDetails h $ Ref $ + fromRef branch ++ ":" ++ toInternalGitPath file + +{- Uses a running git cat-file read the content of an object. + - Objects that do not exist will have "" returned. -} +catObject :: CatFileHandle -> Ref -> IO L.ByteString +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 = fromRef object + send to = hPutStrLn to query + receive from = do + header <- hGetLine from + case words header of + [sha, objtype, size] + | length sha == shaSize -> + case (readObjectType objtype, reads size) of + (Just t, [(bytes, "")]) -> readcontent t bytes from sha + _ -> dne + | otherwise -> dne + _ + | 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 + return $ Just (L.fromChunks [content], Ref sha, objtype) + dne = return Nothing + eatchar expected from = do + c <- hGetChar from + when (c /= expected) $ + error $ "missing " ++ (show expected) ++ " from git cat-file" + +{- Gets a list of files and directories in a tree. (Not recursive.) -} +catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)] +catTree h treeref = go <$> catObjectDetails h treeref + where + go (Just (b, _, TreeObject)) = parsetree [] b + go _ = [] + + parsetree c b = case L.break (== 0) b of + (modefile, rest) + | L.null modefile -> c + | otherwise -> parsetree + (parsemodefile modefile:c) + (dropsha rest) + + -- these 20 bytes after the NUL hold the file's sha + -- TODO: convert from raw form to regular sha + dropsha = L.drop 21 + + parsemodefile b = + let (modestr, file) = separate (== ' ') (decodeBS b) + in (file, readmode modestr) + readmode = fromMaybe 0 . fmap fst . headMaybe . readOct diff --git a/Git/Command.hs b/Git/Command.hs new file mode 100644 index 0000000..02e3e5a --- /dev/null +++ b/Git/Command.hs @@ -0,0 +1,128 @@ +{- running git commands + - + - Copyright 2010-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Git.Command where + +import Common +import Git +import Git.Types +import qualified Utility.CoProcess as CoProcess + +{- 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=" ++ gitdir l + settree = case worktree l of + Nothing -> [] + 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) + +{- Runs git in the specified repo, throwing an error if it fails. -} +run :: [CommandParam] -> Repo -> IO () +run params repo = assertLocal repo $ + unlessM (runBool params repo) $ + error $ "git " ++ show params ++ " failed" + +{- Runs git and forces it to be quiet, throwing an error if it fails. -} +runQuiet :: [CommandParam] -> Repo -> IO () +runQuiet params repo = withQuietOutput createProcessSuccess $ + (proc "git" $ toCommand $ gitCommandLine (params) repo) + { env = gitEnv repo } + +{- Runs a git command and returns its output, lazily. + - + - Also returns an action that should be used when the output is all + - read (or no more is needed), that will wait on the command, and + - return True if it succeeded. Failure to wait will result in zombies. + -} +pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool) +pipeReadLazy params repo = assertLocal repo $ do + (_, Just h, _, pid) <- createProcess p { std_out = CreatePipe } + fileEncoding h + c <- hGetContents h + return (c, checkSuccessProcess pid) + where + p = gitCreateProcess params repo + +{- Runs a git command, and returns its output, strictly. + - + - Nonzero exit status is ignored. + -} +pipeReadStrict :: [CommandParam] -> Repo -> IO String +pipeReadStrict params repo = assertLocal repo $ + withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do + fileEncoding h + output <- hGetContentsStrict h + hClose h + return output + where + p = gitCreateProcess params repo + +{- Runs a git command, feeding it an input, and returning its output, + - which is expected to be fairly small, since it's all read into memory + - strictly. -} +pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO String +pipeWriteRead params writer repo = assertLocal repo $ + writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) + (gitEnv repo) writer (Just adjusthandle) + where + adjusthandle h = do + fileEncoding h + hSetNewlineMode h noNewlineTranslation + +{- Runs a git command, feeding it input on a handle with an action. -} +pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO () +pipeWrite params repo = withHandle StdinHandle createProcessSuccess $ + gitCreateProcess params repo + +{- Reads null terminated output of a git command (as enabled by the -z + - parameter), and splits it. -} +pipeNullSplit :: [CommandParam] -> Repo -> IO ([String], IO Bool) +pipeNullSplit params repo = do + (s, cleanup) <- pipeReadLazy params repo + return (filter (not . null) $ split sep s, cleanup) + where + sep = "\0" + +pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [String] +pipeNullSplitStrict params repo = do + s <- pipeReadStrict params repo + return $ filter (not . null) $ split sep s + where + sep = "\0" + +pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String] +pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo + +{- Doesn't run the cleanup action. A zombie results. -} +leaveZombie :: (a, IO Bool) -> a +leaveZombie = fst + +{- Runs a git command as a coprocess. -} +gitCoProcessStart :: Bool -> [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle +gitCoProcessStart restartable params repo = CoProcess.start numrestarts "git" + (toCommand $ gitCommandLine params repo) + (gitEnv repo) + where + {- If a long-running git command like cat-file --batch + - crashes, it will likely start up again ok. If it keeps crashing + - 10 times, something is badly wrong. -} + numrestarts = if restartable then 10 else 0 + +gitCreateProcess :: [CommandParam] -> Repo -> CreateProcess +gitCreateProcess params repo = + (proc "git" $ toCommand $ gitCommandLine params repo) + { env = gitEnv repo } diff --git a/Git/Config.hs b/Git/Config.hs new file mode 100644 index 0000000..3d62395 --- /dev/null +++ b/Git/Config.hs @@ -0,0 +1,210 @@ +{- git repository configuration handling + - + - Copyright 2010-2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Config where + +import qualified Data.Map as M +import Data.Char + +import Common +import Git +import Git.Types +import qualified Git.Construct +import qualified Git.Command +import Utility.UserInfo + +{- Returns a single git config setting, or a default value if not set. -} +get :: String -> String -> Repo -> String +get key defaultValue repo = M.findWithDefault defaultValue key (config repo) + +{- Returns a list with each line of a multiline config setting. -} +getList :: String -> Repo -> [String] +getList key repo = M.findWithDefault [] key (fullconfig repo) + +{- Returns a single git config setting, if set. -} +getMaybe :: String -> Repo -> Maybe String +getMaybe key repo = M.lookup key (config repo) + +{- Runs git config and populates a repo with its config. + - Avoids re-reading config when run repeatedly. -} +read :: Repo -> IO Repo +read repo@(Repo { config = c }) + | c == M.empty = read' repo + | otherwise = return repo + +{- Reads config even if it was read before. -} +reRead :: Repo -> IO Repo +reRead r = read' $ r + { config = M.empty + , fullconfig = M.empty + } + +{- Cannot use pipeRead because it relies on the config having been already + - read. Instead, chdir to the repo and run git config. + -} +read' :: Repo -> IO Repo +read' repo = go repo + where + go Repo { location = Local { gitdir = d } } = git_config d + go Repo { location = LocalUnknown d } = git_config d + go _ = assertLocal repo $ error "internal" + git_config d = withHandle StdoutHandle createProcessSuccess p $ + hRead repo + where + params = ["config", "--null", "--list"] + p = (proc "git" params) + { cwd = Just d + , env = gitEnv repo + } + +{- Gets the global git config, returning a dummy Repo containing it. -} +global :: IO (Maybe Repo) +global = do + home <- myHomeDir + ifM (doesFileExist $ home ".gitconfig") + ( do + repo <- withHandle StdoutHandle createProcessSuccess p $ + hRead (Git.Construct.fromUnknown) + return $ Just repo + , return Nothing + ) + where + params = ["config", "--null", "--list", "--global"] + p = (proc "git" params) + +{- Reads git config from a handle and populates a repo with it. -} +hRead :: Repo -> Handle -> IO Repo +hRead repo h = do + -- We use the FileSystemEncoding when reading from git-config, + -- because it can contain arbitrary filepaths (and other strings) + -- in any encoding. + fileEncoding h + val <- hGetContentsStrict h + store val repo + +{- Stores a git config into a Repo, returning the new version of the Repo. + - The git config may be multiple lines, or a single line. + - Config settings can be updated incrementally. + -} +store :: String -> Repo -> IO Repo +store s repo = do + let c = parse s + repo' <- updateLocation $ repo + { config = (M.map Prelude.head c) `M.union` config repo + , fullconfig = M.unionWith (++) c (fullconfig repo) + } + rs <- Git.Construct.fromRemotes repo' + return $ repo' { remotes = rs } + +{- Updates the location of a repo, based on its configuration. + - + - Git.Construct makes LocalUknown repos, of which only a directory is + - known. Once the config is read, this can be fixed up to a Local repo, + - based on the core.bare and core.worktree settings. + -} +updateLocation :: Repo -> IO Repo +updateLocation r@(Repo { location = LocalUnknown d }) + | isBare r = ifM (doesDirectoryExist dotgit) + ( updateLocation' r $ Local dotgit Nothing + , updateLocation' r $ Local d Nothing + ) + | otherwise = updateLocation' r $ Local dotgit (Just d) + where + dotgit = (d ".git") +updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l +updateLocation r = return r + +updateLocation' :: Repo -> RepoLocation -> IO Repo +updateLocation' r l = do + l' <- case getMaybe "core.worktree" r of + Nothing -> return l + Just d -> do + {- core.worktree is relative to the gitdir -} + top <- absPath $ gitdir l + return $ l { worktree = Just $ absPathFrom top d } + return $ r { location = l' } + +{- Parses git config --list or git config --null --list output into a + - config map. -} +parse :: String -> M.Map String [String] +parse [] = M.empty +parse s + -- --list output will have an = in the first line + | all ('=' `elem`) (take 1 ls) = sep '=' ls + -- --null --list output separates keys from values with newlines + | otherwise = sep '\n' $ split "\0" s + where + ls = lines s + sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) . + map (separate (== c)) + +{- Checks if a string from git config is a true value. -} +isTrue :: String -> Maybe Bool +isTrue s + | s' == "true" = Just True + | s' == "false" = Just False + | otherwise = Nothing + where + s' = map toLower s + +boolConfig :: Bool -> String +boolConfig True = "true" +boolConfig False = "false" + +isBare :: Repo -> Bool +isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r + +coreBare :: String +coreBare = "core.bare" + +{- Runs a command to get the configuration of a repo, + - and returns a repo populated with the configuration, as well as the raw + - output of the command. -} +fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String)) +fromPipe r cmd params = try $ + withHandle StdoutHandle createProcessSuccess p $ \h -> do + fileEncoding h + val <- hGetContentsStrict h + r' <- store val r + return (r', val) + where + p = proc cmd $ toCommand params + +{- Reads git config from a specified file and returns the repo populated + - with the configuration. -} +fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String)) +fromFile r f = fromPipe r "git" + [ Param "config" + , Param "--file" + , File f + , Param "--list" + ] + +{- Changes a git config setting in the specified config file. + - (Creates the file if it does not already exist.) -} +changeFile :: FilePath -> String -> String -> IO Bool +changeFile f k v = boolSystem "git" + [ Param "config" + , Param "--file" + , File f + , Param k + , Param v + ] + +{- Unsets a git config setting, in both the git repo, + - and the cached config in the Repo. + - + - If unsetting the config fails, including in a read-only repo, or + - when the config is not set, returns Nothing. + -} +unset :: String -> Repo -> IO (Maybe Repo) +unset k r = ifM (Git.Command.runBool ps r) + ( return $ Just $ r { config = M.delete k (config r) } + , return Nothing + ) + where + ps = [Param "config", Param "--unset-all", Param k] diff --git a/Git/Construct.hs b/Git/Construct.hs new file mode 100644 index 0000000..03dd29f --- /dev/null +++ b/Git/Construct.hs @@ -0,0 +1,241 @@ +{- Construction of Git Repo objects + - + - Copyright 2010-2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Git.Construct ( + fromCwd, + fromAbsPath, + fromPath, + fromUrl, + fromUnknown, + localToUrl, + remoteNamed, + remoteNamedFromKey, + fromRemotes, + fromRemoteLocation, + repoAbsPath, + checkForRepo, + newFrom, +) where + +#ifndef mingw32_HOST_OS +import System.Posix.User +#endif +import qualified Data.Map as M hiding (map, split) +import Network.URI + +import Common +import Git.Types +import Git +import Git.Remote +import Git.FilePath +import qualified Git.Url as Url +import Utility.UserInfo + +{- Finds the git repository used for the cwd, which may be in a parent + - directory. -} +fromCwd :: IO (Maybe Repo) +fromCwd = getCurrentDirectory >>= seekUp + where + seekUp dir = do + r <- checkForRepo dir + case r of + Nothing -> case upFrom dir of + Nothing -> return Nothing + Just d -> seekUp d + Just loc -> pure $ Just $ newFrom loc + +{- Local Repo constructor, accepts a relative or absolute path. -} +fromPath :: FilePath -> IO Repo +fromPath dir = fromAbsPath =<< absPath dir + +{- Local Repo constructor, requires an absolute path to the repo be + - specified. -} +fromAbsPath :: FilePath -> IO Repo +fromAbsPath dir + | absoluteGitPath dir = hunt + | otherwise = + error $ "internal error, " ++ dir ++ " is not absolute" + where + ret = pure . newFrom . LocalUnknown + canondir = dropTrailingPathSeparator dir + {- When dir == "foo/.git", git looks for "foo/.git/.git", + - and failing that, uses "foo" as the repository. -} + hunt + | (pathSeparator:".git") `isSuffixOf` canondir = + ifM (doesDirectoryExist $ dir ".git") + ( ret dir + , ret (takeDirectory canondir) + ) + | otherwise = ifM (doesDirectoryExist dir) + ( ret dir + -- git falls back to dir.git when dir doesn't + -- exist, as long as dir didn't end with a + -- path separator + , if dir == canondir + then ret (dir ++ ".git") + else ret dir + ) + +{- Remote Repo constructor. Throws exception on invalid url. + - + - Git is somewhat forgiving about urls to repositories, allowing + - eg spaces that are not normally allowed unescaped in urls. + -} +fromUrl :: String -> IO Repo +fromUrl url + | not (isURI url) = fromUrlStrict $ escapeURIString isUnescapedInURI url + | otherwise = fromUrlStrict url + +fromUrlStrict :: String -> IO Repo +fromUrlStrict url + | startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u + | otherwise = pure $ newFrom $ Url u + where + u = fromMaybe bad $ parseURI url + bad = error $ "bad url " ++ url + +{- Creates a repo that has an unknown location. -} +fromUnknown :: Repo +fromUnknown = newFrom Unknown + +{- Converts a local Repo into a remote repo, using the reference repo + - which is assumed to be on the same host. -} +localToUrl :: Repo -> Repo -> Repo +localToUrl reference r + | not $ repoIsUrl reference = error "internal error; reference repo not url" + | repoIsUrl r = r + | otherwise = case Url.authority reference of + Nothing -> r + Just auth -> + let absurl = concat + [ Url.scheme reference + , "//" + , auth + , repoPath r + ] + in r { location = Url $ fromJust $ parseURI absurl } + +{- Calculates a list of a repo's configured remotes, by parsing its config. -} +fromRemotes :: Repo -> IO [Repo] +fromRemotes repo = mapM construct remotepairs + where + filterconfig f = filter f $ M.toList $ config repo + filterkeys f = filterconfig (\(k,_) -> f k) + remotepairs = filterkeys isremote + isremote k = startswith "remote." k && endswith ".url" k + construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo + +{- Sets the name of a remote when constructing the Repo to represent it. -} +remoteNamed :: String -> IO Repo -> IO Repo +remoteNamed n constructor = do + r <- constructor + return $ r { remoteName = Just n } + +{- Sets the name of a remote based on the git config key, such as + - "remote.foo.url". -} +remoteNamedFromKey :: String -> IO Repo -> IO Repo +remoteNamedFromKey k = remoteNamed basename + where + basename = intercalate "." $ + reverse $ drop 1 $ reverse $ drop 1 $ split "." k + +{- Constructs a new Repo for one of a Repo's remotes using a given + - location (ie, an url). -} +fromRemoteLocation :: String -> Repo -> IO Repo +fromRemoteLocation s repo = gen $ parseRemoteLocation s repo + where + gen (RemotePath p) = fromRemotePath p repo + gen (RemoteUrl u) = fromUrl u + +{- Constructs a Repo from the path specified in the git remotes of + - another Repo. -} +fromRemotePath :: FilePath -> Repo -> IO Repo +fromRemotePath dir repo = do + dir' <- expandTilde dir + fromPath $ repoPath repo dir' + +{- Git remotes can have a directory that is specified relative + - to the user's home directory, or that contains tilde expansions. + - This converts such a directory to an absolute path. + - Note that it has to run on the system where the remote is. + -} +repoAbsPath :: FilePath -> IO FilePath +repoAbsPath d = do + d' <- expandTilde d + h <- myHomeDir + return $ h d' + +expandTilde :: FilePath -> IO FilePath +#ifdef mingw32_HOST_OS +expandTilde = return +#else +expandTilde = expandt True + where + expandt _ [] = return "" + expandt _ ('/':cs) = do + v <- expandt True cs + return ('/':v) + expandt True ('~':'/':cs) = do + h <- myHomeDir + return $ h cs + expandt True ('~':cs) = do + let (name, rest) = findname "" cs + u <- getUserEntryForName name + return $ homeDirectory u rest + expandt _ (c:cs) = do + v <- expandt False cs + return (c:v) + findname n [] = (n, "") + findname n (c:cs) + | c == '/' = (n, cs) + | otherwise = findname (n++[c]) cs +#endif + +{- Checks if a git repository exists in a directory. Does not find + - git repositories in parent directories. -} +checkForRepo :: FilePath -> IO (Maybe RepoLocation) +checkForRepo dir = + check isRepo $ + check gitDirFile $ + check isBareRepo $ + return Nothing + where + check test cont = maybe cont (return . Just) =<< test + checkdir c = ifM c + ( return $ Just $ LocalUnknown dir + , return Nothing + ) + isRepo = checkdir $ gitSignature $ ".git" "config" + isBareRepo = checkdir $ gitSignature "config" + <&&> doesDirectoryExist (dir "objects") + gitDirFile = do + c <- firstLine <$> + catchDefaultIO "" (readFile $ dir ".git") + return $ if gitdirprefix `isPrefixOf` c + then Just $ Local + { gitdir = absPathFrom dir $ + drop (length gitdirprefix) c + , worktree = Just dir + } + else Nothing + where + gitdirprefix = "gitdir: " + gitSignature file = doesFileExist $ dir file + +newFrom :: RepoLocation -> Repo +newFrom l = Repo + { location = l + , config = M.empty + , fullconfig = M.empty + , remotes = [] + , remoteName = Nothing + , gitEnv = Nothing + , gitGlobalOpts = [] + } + diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs new file mode 100644 index 0000000..dab4ad2 --- /dev/null +++ b/Git/CurrentRepo.hs @@ -0,0 +1,59 @@ +{- The current git repository. + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.CurrentRepo where + +import Common +import Git.Types +import Git.Construct +import qualified Git.Config +import Utility.Env + +{- Gets the current git repository. + - + - Honors GIT_DIR and GIT_WORK_TREE. + - Both environment variables are unset, to avoid confusing other git + - commands that also look at them. Instead, the Git module passes + - --work-tree and --git-dir to git commands it runs. + - + - When GIT_WORK_TREE or core.worktree are set, changes the working + - directory if necessary to ensure it is within the repository's work + - tree. While not needed for git commands, this is useful for anything + - else that looks for files in the worktree. + -} +get :: IO Repo +get = do + gd <- pathenv "GIT_DIR" + r <- configure gd =<< fromCwd + wt <- maybe (worktree $ location r) Just <$> pathenv "GIT_WORK_TREE" + case wt of + Nothing -> return r + Just d -> do + curr <- getCurrentDirectory + unless (d `dirContains` curr) $ + setCurrentDirectory d + return $ addworktree wt r + where + pathenv s = do + v <- getEnv s + case v of + Just d -> do + unsetEnv s + Just <$> absPath d + Nothing -> return Nothing + + configure Nothing (Just r) = Git.Config.read r + configure (Just d) _ = do + absd <- absPath d + curr <- getCurrentDirectory + Git.Config.read $ newFrom $ + Local { gitdir = absd, worktree = Just curr } + configure Nothing Nothing = error "Not in a git repository." + + addworktree w r = changelocation r $ + Local { gitdir = gitdir (location r), worktree = w } + changelocation r l = r { location = l } diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs new file mode 100644 index 0000000..e923796 --- /dev/null +++ b/Git/Destroyer.hs @@ -0,0 +1,148 @@ +{- git repository destroyer + - + - Use with caution! + - + - Copyright 2013, 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Destroyer ( + Damage(..), + generateDamage, + applyDamage +) where + +import Common +import Git +import Utility.QuickCheck +import Utility.FileMode +import Utility.Tmp + +import qualified Data.ByteString as B +import Data.Word + +{- Ways to damange a git repository. -} +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 = oneof + [ Empty <$> arbitrary + , Delete <$> arbitrary + , Reverse <$> arbitrary + , AppendGarbage <$> arbitrary <*> garbage + , PrependGarbage <$> arbitrary <*> garbage + , CorruptByte + <$> arbitrary + <*> nonNegative arbitraryBoundedIntegral + <*> arbitrary + , ScrambleFileMode + <$> arbitrary + <*> nonNegative arbitrarySizedIntegral + , SwapFiles + <$> arbitrary + <*> arbitrary + ] + where + garbage = B.pack <$> arbitrary `suchThat` (not . null) + +{- To select a given file in a git repository, all files in the repository + - 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, Eq) + +instance Arbitrary FileSelector where + arbitrary = FileSelector <$> oneof + -- An early file in the git tree, tends to be the most + -- interesting when there are lots of files. + [ nonNegative arbitrarySizedIntegral + -- Totally random choice from any of the files in + -- the git tree, to ensure good coverage. + , nonNegative arbitraryBoundedIntegral + ] + +selectFile :: [FilePath] -> FileSelector -> FilePath +selectFile sortedfs (FileSelector n) = sortedfs !! (n `mod` length sortedfs) + +{- Generates random Damage. -} +generateDamage :: IO [Damage] +generateDamage = sample' (arbitrary :: Gen Damage) + +{- 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 ds r = do + contents <- sort . filter (not . skipped) + <$> dirContentsRecursive (localGitDir r) + 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. + -- 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/DiffTreeItem.hs b/Git/DiffTreeItem.hs new file mode 100644 index 0000000..859f590 --- /dev/null +++ b/Git/DiffTreeItem.hs @@ -0,0 +1,24 @@ +{- git diff-tree item + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.DiffTreeItem ( + DiffTreeItem(..), +) where + +import System.Posix.Types + +import Git.FilePath +import Git.Types + +data DiffTreeItem = DiffTreeItem + { srcmode :: FileMode + , dstmode :: FileMode + , srcsha :: Sha -- nullSha if file was added + , dstsha :: Sha -- nullSha if file was deleted + , status :: String + , file :: TopFilePath + } deriving Show diff --git a/Git/FilePath.hs b/Git/FilePath.hs new file mode 100644 index 0000000..edc3c0f --- /dev/null +++ b/Git/FilePath.hs @@ -0,0 +1,77 @@ +{- git FilePath library + - + - Different git commands use different types of FilePaths to refer to + - files in the repository. Some commands use paths relative to the + - top of the repository even when run in a subdirectory. Adding some + - types helps keep that straight. + - + - Copyright 2012-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Git.FilePath ( + TopFilePath, + fromTopFilePath, + getTopFilePath, + toTopFilePath, + asTopFilePath, + InternalGitPath, + toInternalGitPath, + 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) + +{- Returns an absolute FilePath. -} +fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath +fromTopFilePath p repo = absPathFrom (repoPath repo) (getTopFilePath p) + +{- The input FilePath can be absolute, or relative to the CWD. -} +toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath +toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file + +{- The input FilePath must already be relative to the top of the git + - repository -} +asTopFilePath :: FilePath -> TopFilePath +asTopFilePath file = TopFilePath file + +{- Git may use a different representation of a path when storing + - it internally. + - + - On Windows, git uses '/' to separate paths stored in the repository, + - despite Windows using '\'. + - + -} +type InternalGitPath = String + +toInternalGitPath :: FilePath -> InternalGitPath +#ifndef mingw32_HOST_OS +toInternalGitPath = id +#else +toInternalGitPath = replace "\\" "/" +#endif + +fromInternalGitPath :: InternalGitPath -> FilePath +#ifndef mingw32_HOST_OS +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/Filename.hs b/Git/Filename.hs new file mode 100644 index 0000000..ee84d48 --- /dev/null +++ b/Git/Filename.hs @@ -0,0 +1,28 @@ +{- Some git commands output encoded filenames, in a rather annoyingly complex + - C-style encoding. + - + - Copyright 2010, 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Filename where + +import Utility.Format (decode_c, encode_c) + +import Common + +decode :: String -> FilePath +decode [] = [] +decode f@(c:s) + -- encoded strings will be inside double quotes + | c == '"' && end s == ['"'] = decode_c $ beginning s + | otherwise = f + +{- Should not need to use this, except for testing decode. -} +encode :: FilePath -> String +encode s = "\"" ++ encode_c s ++ "\"" + +{- for quickcheck -} +prop_isomorphic_deencode :: String -> Bool +prop_isomorphic_deencode s = s == decode (encode s) diff --git a/Git/Fsck.hs b/Git/Fsck.hs new file mode 100644 index 0000000..f3e6db9 --- /dev/null +++ b/Git/Fsck.hs @@ -0,0 +1,117 @@ +{- git fsck interface + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Fsck ( + FsckResults(..), + MissingObjects, + findBroken, + foundBroken, + findMissing, + isMissing, + knownMissing, +) where + +import Common +import Git +import Git.Command +import Git.Sha +import Utility.Batch +import qualified Git.Version + +import qualified Data.Set as S +import Control.Concurrent.Async + +type MissingObjects = S.Set Sha + +data FsckResults + = FsckFoundMissing + { missingObjects :: MissingObjects + , missingObjectsTruncated :: Bool + } + | FsckFailed + deriving (Show) + +{- Runs fsck to find some of the broken objects in the repository. + - May not find all broken objects, if fsck fails on bad data in some of + - the broken objects it does find. + - + - Strategy: Rather than parsing fsck's current specific output, + - look for anything in its output (both stdout and stderr) that appears + - to be a git sha. Not all such shas are of broken objects, so ask git + - to try to cat the object, and see if it fails. + -} +findBroken :: Bool -> Repo -> IO FsckResults +findBroken batchmode r = do + 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) + + p@(_, _, _, pid) <- createProcess $ + (proc command' (toCommand params')) + { std_out = CreatePipe + , std_err = CreatePipe + } + (bad1, bad2) <- concurrently + (readMissingObjs maxobjs r supportsNoDangling (stdoutHandle p)) + (readMissingObjs maxobjs r supportsNoDangling (stderrHandle p)) + fsckok <- checkSuccessProcess pid + let truncated = S.size bad1 == maxobjs || S.size bad1 == maxobjs + let badobjs = S.union bad1 bad2 + + if S.null badobjs && not fsckok + then return FsckFailed + else return $ FsckFoundMissing badobjs truncated + where + maxobjs = 10000 + +foundBroken :: FsckResults -> Bool +foundBroken FsckFailed = True +foundBroken (FsckFoundMissing s _) = not (S.null s) + +knownMissing :: FsckResults -> MissingObjects +knownMissing FsckFailed = S.empty +knownMissing (FsckFoundMissing s _) = s + +{- Finds objects that are missing from the git repsitory, or are corrupt. + - + - This does not use git cat-file --batch, because catting a corrupt + - object can cause it to crash, or to report incorrect size information. + -} +findMissing :: [Sha] -> Repo -> IO MissingObjects +findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs + +readMissingObjs :: Int -> Repo -> Bool -> Handle -> IO MissingObjects +readMissingObjs maxobjs r supportsNoDangling h = do + objs <- take maxobjs . findShas supportsNoDangling <$> hGetContents h + findMissing objs r + +isMissing :: Sha -> Repo -> IO Bool +isMissing s r = either (const True) (const False) <$> tryIO dump + where + dump = runQuiet + [ Param "show" + , Param (fromRef s) + ] r + +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 :: Bool -> Repo -> [CommandParam] +fsckParams supportsNoDangling = gitCommandLine $ map Param $ catMaybes + [ Just "fsck" + , if supportsNoDangling + then Just "--no-dangling" + else Nothing + , Just "--no-reflogs" + ] diff --git a/Git/Index.hs b/Git/Index.hs new file mode 100644 index 0000000..551fd98 --- /dev/null +++ b/Git/Index.hs @@ -0,0 +1,55 @@ +{- git index file stuff + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Index where + +import Common +import Git +import Utility.Env + +indexEnv :: String +indexEnv = "GIT_INDEX_FILE" + +{- Forces git to use the specified index file. + - + - Returns an action that will reset back to the default + - index file. + - + - Warning: Not thread safe. + -} +override :: FilePath -> IO (IO ()) +override index = do + res <- getEnv var + setEnv var index True + return $ reset res + where + var = "GIT_INDEX_FILE" + reset (Just v) = setEnv indexEnv v True + reset _ = unsetEnv var + +indexFile :: Repo -> FilePath +indexFile r = localGitDir r "index" + +{- Git locks the index by creating this file. -} +indexFileLock :: Repo -> FilePath +indexFileLock r = indexFile r ++ ".lock" + +{- When the pre-commit hook is run, and git commit has been run with + - a file or files specified to commit, rather than committing the staged + - index, git provides the pre-commit hook with a "false index file". + - + - Changes made to this index will influence the commit, but won't + - affect the real index file. + - + - This detects when we're in this situation, using a heuristic, which + - might be broken by changes to git. Any use of this should have a test + - case to make sure it works. + -} +haveFalseIndex :: IO Bool +haveFalseIndex = maybe (False) check <$> getEnv indexEnv + where + check f = "next-index" `isPrefixOf` takeFileName f diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs new file mode 100644 index 0000000..f945838 --- /dev/null +++ b/Git/LsFiles.hs @@ -0,0 +1,258 @@ +{- git ls-files interface + - + - Copyright 2010,2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.LsFiles ( + inRepo, + notInRepo, + allFiles, + deleted, + modified, + modifiedOthers, + staged, + stagedNotDeleted, + stagedOthersDetails, + stagedDetails, + typeChanged, + typeChangedStaged, + Conflicting(..), + Unmerged(..), + unmerged, + StagedDetails, +) where + +import Common +import Git +import Git.Command +import Git.Types +import Git.Sha + +import Numeric +import System.Posix.Types + +{- Scans for files that are checked into git at the specified locations. -} +inRepo :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +inRepo l = pipeNullSplit $ + Param "ls-files" : + Param "--cached" : + Param "-z" : + Param "--" : + map File l + +{- Scans for files at the specified locations that are not checked into git. -} +notInRepo :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) +notInRepo include_ignored l repo = pipeNullSplit params repo + where + params = concat + [ [ Param "ls-files", Param "--others"] + , exclude + , [ Param "-z", Param "--" ] + , map File l + ] + exclude + | include_ignored = [] + | otherwise = [Param "--exclude-standard"] + +{- Finds all files in the specified locations, whether checked into git or + - not. -} +allFiles :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +allFiles l = pipeNullSplit $ + Param "ls-files" : + Param "--cached" : + Param "--others" : + Param "-z" : + Param "--" : + map File l + +{- Returns a list of files in the specified locations that have been + - deleted. -} +deleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +deleted l repo = pipeNullSplit params repo + where + params = + Param "ls-files" : + Param "--deleted" : + Param "-z" : + Param "--" : + map File l + +{- Returns a list of files in the specified locations that have been + - modified. -} +modified :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +modified l repo = pipeNullSplit params repo + where + params = + Param "ls-files" : + Param "--modified" : + Param "-z" : + Param "--" : + map File l + +{- Files that have been modified or are not checked into git (and are not + - ignored). -} +modifiedOthers :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +modifiedOthers l repo = pipeNullSplit params repo + where + params = + Param "ls-files" : + Param "--modified" : + Param "--others" : + Param "--exclude-standard" : + Param "-z" : + Param "--" : + map File l + +{- Returns a list of all files that are staged for commit. -} +staged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +staged = staged' [] + +{- Returns a list of the files, staged for commit, that are being added, + - moved, or changed (but not deleted), from the specified locations. -} +stagedNotDeleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"] + +staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) +staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix + where + prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] + suffix = Param "--" : map File l + +type StagedDetails = (FilePath, Maybe Sha, Maybe FileMode) + +{- Returns details about files that are staged in the index, + - as well as files not yet in git. Skips ignored files. -} +stagedOthersDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool) +stagedOthersDetails = stagedDetails' [Param "--others", Param "--exclude-standard"] + +{- Returns details about all files that are staged in the index. -} +stagedDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool) +stagedDetails = stagedDetails' [] + +{- Gets details about staged files, including the Sha of their staged + - contents. -} +stagedDetails' :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedDetails], IO Bool) +stagedDetails' ps l repo = do + (ls, cleanup) <- pipeNullSplit params repo + return (map parse ls, cleanup) + where + params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ + Param "--" : map File l + parse s + | null file = (s, Nothing, Nothing) + | otherwise = (file, extractSha $ take shaSize rest, readmode mode) + where + (metadata, file) = separate (== '\t') s + (mode, rest) = separate (== ' ') metadata + readmode = fst <$$> headMaybe . readOct + +{- Returns a list of the files in the specified locations that are staged + - for commit, and whose type has changed. -} +typeChangedStaged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +typeChangedStaged = typeChanged' [Param "--cached"] + +{- Returns a list of the files in the specified locations whose type has + - changed. Files only staged for commit will not be included. -} +typeChanged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +typeChanged = typeChanged' [] + +typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) +typeChanged' ps l repo = do + (fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo + -- git diff returns filenames relative to the top of the git repo; + -- convert to filenames relative to the cwd, like git ls-files. + top <- absPath (repoPath repo) + currdir <- getCurrentDirectory + return (map (\f -> relPathDirToFileAbs currdir $ top f) fs, cleanup) + where + prefix = + [ Param "diff" + , Param "--name-only" + , Param "--diff-filter=T" + , Param "-z" + ] + suffix = Param "--" : (if null l then [File "."] else map File l) + +{- A item in conflict has two possible values. + - Either can be Nothing, when that side deleted the file. -} +data Conflicting v = Conflicting + { valUs :: Maybe v + , valThem :: Maybe v + } deriving (Show) + +data Unmerged = Unmerged + { unmergedFile :: FilePath + , unmergedBlobType :: Conflicting BlobType + , unmergedSha :: Conflicting Sha + } deriving (Show) + +{- Returns a list of the files in the specified locations that have + - unresolved merge conflicts. + - + - ls-files outputs multiple lines per conflicting file, each with its own + - stage number: + - 1 = old version, can be ignored + - 2 = us + - 3 = them + - If a line is omitted, that side removed the file. + -} +unmerged :: [FilePath] -> Repo -> IO ([Unmerged], IO Bool) +unmerged l repo = do + (fs, cleanup) <- pipeNullSplit params repo + return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup) + where + params = + Param "ls-files" : + Param "--unmerged" : + Param "-z" : + Param "--" : + map File l + +data InternalUnmerged = InternalUnmerged + { isus :: Bool + , ifile :: FilePath + , iblobtype :: Maybe BlobType + , isha :: Maybe Sha + } deriving (Show) + +parseUnmerged :: String -> Maybe InternalUnmerged +parseUnmerged s + | null file = Nothing + | otherwise = case words metadata of + (rawblobtype:rawsha:rawstage:_) -> do + stage <- readish rawstage :: Maybe Int + if stage /= 2 && stage /= 3 + then Nothing + else do + blobtype <- readBlobType rawblobtype + sha <- extractSha rawsha + return $ InternalUnmerged (stage == 2) file + (Just blobtype) (Just sha) + _ -> Nothing + where + (metadata, file) = separate (== '\t') s + +reduceUnmerged :: [Unmerged] -> [InternalUnmerged] -> [Unmerged] +reduceUnmerged c [] = c +reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest + where + (rest, sibi) = findsib i is + (blobtypeA, blobtypeB, shaA, shaB) + | isus i = (iblobtype i, iblobtype sibi, isha i, isha sibi) + | otherwise = (iblobtype sibi, iblobtype i, isha sibi, isha i) + new = Unmerged + { unmergedFile = ifile i + , unmergedBlobType = Conflicting blobtypeA blobtypeB + , unmergedSha = Conflicting shaA shaB + } + findsib templatei [] = ([], removed templatei) + findsib templatei (l:ls) + | ifile l == ifile templatei = (ls, l) + | otherwise = (l:ls, removed templatei) + removed templatei = templatei + { isus = not (isus templatei) + , iblobtype = Nothing + , isha = Nothing + } diff --git a/Git/LsTree.hs b/Git/LsTree.hs new file mode 100644 index 0000000..1ed6247 --- /dev/null +++ b/Git/LsTree.hs @@ -0,0 +1,78 @@ +{- git ls-tree interface + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.LsTree ( + TreeItem(..), + lsTree, + lsTreeParams, + lsTreeFiles, + parseLsTree +) where + +import Common +import Git +import Git.Command +import Git.Sha +import Git.FilePath +import qualified Git.Filename + +import Numeric +import System.Posix.Types + +data TreeItem = TreeItem + { mode :: FileMode + , typeobj :: String + , sha :: String + , file :: TopFilePath + } deriving Show + +{- Lists the complete contents of a tree, recursing into sub-trees, + - with lazy output. -} +lsTree :: Ref -> Repo -> IO [TreeItem] +lsTree t repo = map parseLsTree + <$> pipeNullSplitZombie (lsTreeParams t []) repo + +lsTreeParams :: Ref -> [CommandParam] -> [CommandParam] +lsTreeParams r ps = + [ Param "ls-tree" + , Param "--full-tree" + , Param "-z" + , Param "-r" + ] ++ ps ++ + [ Param "--" + , File $ fromRef r + ] + +{- Lists specified files in a tree. -} +lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem] +lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo + where + ps = + [ Param "ls-tree" + , Param "--full-tree" + , Param "-z" + , Param "--" + , File $ fromRef t + ] ++ map File fs + +{- Parses a line of ls-tree output. + - (The --long format is not currently supported.) -} +parseLsTree :: String -> TreeItem +parseLsTree l = TreeItem + { mode = fst $ Prelude.head $ readOct m + , typeobj = t + , sha = s + , file = asTopFilePath $ Git.Filename.decode f + } + where + -- l = SP SP TAB + -- All fields are fixed, so we can pull them out of + -- specific positions in the line. + (m, past_m) = splitAt 7 l + (t, past_t) = splitAt 4 past_m + (s, past_s) = splitAt shaSize $ Prelude.tail past_t + f = Prelude.tail past_s diff --git a/Git/Objects.hs b/Git/Objects.hs new file mode 100644 index 0000000..bda220b --- /dev/null +++ b/Git/Objects.hs @@ -0,0 +1,49 @@ +{- .git/objects + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Objects where + +import Common +import Git +import Git.Sha + +objectsDir :: Repo -> FilePath +objectsDir r = localGitDir r "objects" + +packDir :: Repo -> FilePath +packDir r = objectsDir r "pack" + +packIdxFile :: FilePath -> FilePath +packIdxFile = flip replaceExtension "idx" + +listPackFiles :: Repo -> IO [FilePath] +listPackFiles r = filter (".pack" `isSuffixOf`) + <$> catchDefaultIO [] (dirContents $ packDir r) + +listLooseObjectShas :: Repo -> IO [Sha] +listLooseObjectShas r = catchDefaultIO [] $ + mapMaybe (extractSha . concat . reverse . take 2 . reverse . splitDirectories) + <$> dirContentsRecursiveSkipping (== "pack") True (objectsDir r) + +looseObjectFile :: Repo -> Sha -> FilePath +looseObjectFile r sha = objectsDir r prefix rest + where + (prefix, rest) = splitAt 2 (fromRef sha) + +listAlternates :: Repo -> IO [FilePath] +listAlternates r = catchDefaultIO [] (lines <$> readFile alternatesfile) + where + alternatesfile = objectsDir r "info" "alternates" + +{- A repository recently cloned with --shared will have one or more + - alternates listed, and contain no loose objects or packs. -} +isSharedClone :: Repo -> IO Bool +isSharedClone r = allM id + [ not . null <$> listAlternates r + , null <$> listLooseObjectShas r + , null <$> listPackFiles r + ] diff --git a/Git/Ref.hs b/Git/Ref.hs new file mode 100644 index 0000000..6bc47d5 --- /dev/null +++ b/Git/Ref.hs @@ -0,0 +1,147 @@ +{- git ref stuff + - + - Copyright 2011-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Ref where + +import Common +import Git +import Git.Command +import Git.Sha +import Git.Types + +import Data.Char (chr) + +headRef :: Ref +headRef = Ref "HEAD" + +{- Converts a fully qualified git ref into a user-visible string. -} +describe :: Ref -> String +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/" . fromRef + where + remove prefix s + | prefix `isPrefixOf` s = drop (length prefix) s + | otherwise = s + +{- Given a directory and any ref, takes the basename of the ref and puts + - it under the directory. -} +under :: String -> Ref -> Ref +under dir r = Ref $ dir ++ "/" ++ + (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 ++ "/" ++ fromRef (base r) + +{- A Ref that can be used to refer to a file in the repository, as staged + - in the index. + - + - Prefixing the file with ./ makes this work even if in a subdirectory + - of a repo. + -} +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 +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 $ 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 fromRef ref + +{- Checks if HEAD exists. It generally will, except for in a repository + - that was just created. -} +headExists :: Repo -> IO Bool +headExists repo = do + ls <- lines <$> pipeReadStrict [Param "show-ref", Param "--head"] repo + return $ any (" HEAD" `isSuffixOf`) ls + +{- Get the sha of a fully qualified git ref, if it exists. -} +sha :: Branch -> Repo -> IO (Maybe Sha) +sha branch repo = process <$> showref repo + where + showref = pipeReadStrict [Param "show-ref", + Param "--hash", -- get the hash + Param $ fromRef branch] + process [] = Nothing + process s = Just $ Ref $ firstLine s + +headSha :: Repo -> IO (Maybe Sha) +headSha = sha headRef + +{- List of (shas, branches) matching a given ref or refs. -} +matching :: [Ref] -> Repo -> IO [(Sha, Branch)] +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 fromRef refs) repo + +{- List of (shas, branches) matching a given ref or refs. -} +matching' :: [String] -> Repo -> IO [(Sha, Branch)] +matching' ps repo = map gen . lines <$> + pipeReadStrict (Param "show-ref" : map Param ps) repo + where + gen l = let (r, b) = separate (== ' ') l + in (Ref r, Ref b) + +{- List of (shas, branches) matching a given ref spec. + - Duplicate shas are filtered out. -} +matchingUniq :: [Ref] -> Repo -> IO [(Sha, Branch)] +matchingUniq refs repo = nubBy uniqref <$> matching refs repo + where + uniqref (a, _) (b, _) = a == b + +{- Gets the sha of the tree a ref uses. -} +tree :: Ref -> Repo -> IO (Maybe Sha) +tree ref = extractSha <$$> pipeReadStrict + [ Param "rev-parse", Param (fromRef ref ++ ":") ] + +{- Checks if a String is a legal git ref name. + - + - The rules for this are complex; see git-check-ref-format(1) -} +legal :: Bool -> String -> Bool +legal allowonelevel s = all (== False) illegal + where + illegal = + [ any ("." `isPrefixOf`) pathbits + , any (".lock" `isSuffixOf`) pathbits + , not allowonelevel && length pathbits < 2 + , contains ".." + , any (\c -> contains [c]) illegalchars + , begins "/" + , ends "/" + , contains "//" + , ends "." + , contains "@{" + , null s + ] + contains v = v `isInfixOf` s + ends v = v `isSuffixOf` s + begins v = v `isPrefixOf` s + + pathbits = split "/" s + illegalchars = " ~^:?*[\\" ++ controlchars + controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)] diff --git a/Git/RefLog.hs b/Git/RefLog.hs new file mode 100644 index 0000000..57f35e9 --- /dev/null +++ b/Git/RefLog.hs @@ -0,0 +1,30 @@ +{- git reflog interface + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.RefLog where + +import Common +import Git +import Git.Command +import Git.Sha + +{- Gets the reflog for a given branch. -} +get :: Branch -> Repo -> IO [Sha] +get b = getMulti [b] + +{- Gets reflogs for multiple branches. -} +getMulti :: [Branch] -> Repo -> IO [Sha] +getMulti bs = get' (map (Param . fromRef) bs) + +get' :: [CommandParam] -> Repo -> IO [Sha] +get' ps = mapMaybe extractSha . lines <$$> pipeReadStrict ps' + where + ps' = catMaybes + [ Just $ Param "log" + , Just $ Param "-g" + , Just $ Param "--format=%H" + ] ++ ps diff --git a/Git/Remote.hs b/Git/Remote.hs new file mode 100644 index 0000000..717b540 --- /dev/null +++ b/Git/Remote.hs @@ -0,0 +1,108 @@ +{- git remote stuff + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Git.Remote where + +import Common +import Git +import Git.Types + +import Data.Char +import qualified Data.Map as M +import Network.URI +#ifdef mingw32_HOST_OS +import Git.FilePath +#endif + +{- Construct a legal git remote name out of an arbitrary input string. + - + - There seems to be no formal definition of this in the git source, + - just some ad-hoc checks, and some other things that fail with certian + - types of names (like ones starting with '-'). + -} +makeLegalName :: String -> RemoteName +makeLegalName s = case filter legal $ replace "/" "_" s of + -- it can't be empty + [] -> "unnamed" + -- it can't start with / or - or . + '.':s' -> makeLegalName s' + '/':s' -> makeLegalName s' + '-':s' -> makeLegalName s' + s' -> s' + where + {- Only alphanumerics, and a few common bits of punctuation common + - in hostnames. -} + legal '_' = True + legal '.' = True + legal c = isAlphaNum c + +data RemoteLocation = RemoteUrl String | RemotePath FilePath + +remoteLocationIsUrl :: RemoteLocation -> Bool +remoteLocationIsUrl (RemoteUrl _) = True +remoteLocationIsUrl _ = False + +remoteLocationIsSshUrl :: RemoteLocation -> Bool +remoteLocationIsSshUrl (RemoteUrl u) = "ssh://" `isPrefixOf` u +remoteLocationIsSshUrl _ = False + +{- Determines if a given remote location is an url, or a local + - path. Takes the repository's insteadOf configuration into account. -} +parseRemoteLocation :: String -> Repo -> RemoteLocation +parseRemoteLocation s repo = ret $ calcloc s + where + ret v +#ifdef mingw32_HOST_OS + | dosstyle v = RemotePath (dospath v) +#endif + | scpstyle v = RemoteUrl (scptourl v) + | urlstyle v = RemoteUrl v + | otherwise = RemotePath v + -- insteadof config can rewrite remote location + calcloc l + | null insteadofs = l + | otherwise = replacement ++ drop (length bestvalue) l + where + replacement = drop (length prefix) $ + take (length bestkey - length suffix) bestkey + (bestkey, bestvalue) = maximumBy longestvalue insteadofs + longestvalue (_, a) (_, b) = compare b a + insteadofs = filterconfig $ \(k, v) -> + startswith prefix k && + endswith suffix k && + startswith v l + filterconfig f = filter f $ + concatMap splitconfigs $ M.toList $ fullconfig repo + splitconfigs (k, vs) = map (\v -> (k, v)) vs + (prefix, suffix) = ("url." , ".insteadof") + urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v + -- git remotes can be written scp style -- [user@]host:dir + -- but foo::bar is a git-remote-helper location instead + scpstyle v = ":" `isInfixOf` v + && not ("//" `isInfixOf` v) + && not ("::" `isInfixOf` v) + scptourl v = "ssh://" ++ host ++ slash dir + where + (host, dir) + -- handle ipv6 address inside [] + | "[" `isPrefixOf` v = case break (== ']') v of + (h, ']':':':d) -> (h ++ "]", d) + (h, ']':d) -> (h ++ "]", d) + (h, d) -> (h, d) + | otherwise = separate (== ':') v + slash d | d == "" = "/~/" ++ d + | "/" `isPrefixOf` d = d + | "~" `isPrefixOf` d = '/':d + | otherwise = "/~/" ++ d +#ifdef mingw32_HOST_OS + -- git on Windows will write a path to .git/config with "drive:", + -- which is not to be confused with a "host:" + dosstyle = hasDrive + dospath = fromInternalGitPath +#endif diff --git a/Git/Repair.hs b/Git/Repair.hs new file mode 100644 index 0000000..b441f13 --- /dev/null +++ b/Git/Repair.hs @@ -0,0 +1,617 @@ +{- git repository recovery + - + - Copyright 2013-2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Repair ( + runRepair, + runRepairOf, + removeBadBranches, + successfulRepair, + cleanCorruptObjects, + retrieveMissingObjects, + resetLocalBranches, + checkIndex, + checkIndexFast, + missingIndex, + emptyGoodCommits, + isTrackingBranch, +) where + +import Common +import Git +import Git.Command +import Git.Objects +import Git.Sha +import Git.Types +import Git.Fsck +import Git.Index +import qualified Git.Config as Config +import qualified Git.Construct as Construct +import qualified Git.LsTree as LsTree +import qualified Git.LsFiles as LsFiles +import qualified Git.Ref as Ref +import qualified Git.RefLog as RefLog +import qualified Git.UpdateIndex as UpdateIndex +import qualified Git.Branch as Branch +import Utility.Tmp +import Utility.Rsync +import Utility.FileMode + +import qualified Data.Set as S +import qualified Data.ByteString.Lazy as L +import Data.Tuple.Utils + +{- Given a set of bad objects found by git fsck, which may not + - be complete, finds and removes all corrupt objects. -} +cleanCorruptObjects :: FsckResults -> Repo -> IO () +cleanCorruptObjects fsckresults r = do + void $ explodePacks r + mapM_ removeLoose (S.toList $ knownMissing fsckresults) + mapM_ removeBad =<< listLooseObjectShas r + where + removeLoose s = nukeFile (looseObjectFile r s) + removeBad s = do + void $ tryIO $ allowRead $ looseObjectFile r s + whenM (isMissing s r) $ + removeLoose s + +{- 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 = go =<< listPackFiles r + where + 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. + - + - If another clone of the repository exists locally, which might not be a + - remote of the repo being repaired, its path can be passed as a reference + - repository. + -} +retrieveMissingObjects :: FsckResults -> Maybe FilePath -> Repo -> IO FsckResults +retrieveMissingObjects missing referencerepo r + | not (foundBroken missing) = return missing + | otherwise = withTmpDir "tmprepo" $ \tmpdir -> do + unlessM (boolSystem "git" [Param "init", File tmpdir]) $ + error $ "failed to create temp repository in " ++ tmpdir + tmpr <- Config.read =<< Construct.fromAbsPath tmpdir + stillmissing <- pullremotes tmpr (remotes r) fetchrefstags missing + if S.null (knownMissing stillmissing) + then return stillmissing + else pullremotes tmpr (remotes r) fetchallrefs stillmissing + where + pullremotes tmpr [] fetchrefs stillmissing = case referencerepo of + Nothing -> return stillmissing + Just p -> ifM (fetchfrom p fetchrefs tmpr) + ( do + void $ explodePacks tmpr + void $ copyObjects tmpr r + case stillmissing of + FsckFailed -> return $ FsckFailed + FsckFoundMissing s t -> FsckFoundMissing + <$> findMissing (S.toList s) r + <*> pure t + , return stillmissing + ) + pullremotes tmpr (rmt:rmts) fetchrefs ms + | not (foundBroken ms) = return ms + | otherwise = do + putStrLn $ "Trying to recover missing objects from remote " ++ repoDescribe rmt ++ "." + ifM (fetchfrom (repoLocation rmt) fetchrefs tmpr) + ( do + void $ explodePacks tmpr + void $ copyObjects tmpr r + case ms of + FsckFailed -> pullremotes tmpr rmts fetchrefs ms + FsckFoundMissing s t -> do + stillmissing <- findMissing (S.toList s) r + pullremotes tmpr rmts fetchrefs (FsckFoundMissing stillmissing t) + , pullremotes tmpr rmts fetchrefs ms + ) + fetchfrom fetchurl ps fetchr = runBool ps' fetchr' + where + ps' = + [ Param "fetch" + , Param fetchurl + , Param "--force" + , Param "--update-head-ok" + , Param "--quiet" + ] ++ ps + fetchr' = fetchr { gitGlobalOpts = gitGlobalOpts fetchr ++ nogc } + nogc = [ Param "-c", Param "gc.auto=0" ] + + -- fetch refs and tags + fetchrefstags = [ Param "+refs/heads/*:refs/heads/*", Param "--tags"] + -- Fetch all available refs (more likely to fail, + -- as the remote may have refs it refuses to send). + fetchallrefs = [ Param "+*:*" ] + +{- Copies all objects from the src repository to the dest repository. + - This is done using rsync, so it copies all missing objects, and all + - objects they rely on. -} +copyObjects :: Repo -> Repo -> IO Bool +copyObjects srcr destr = rsync + [ Param "-qr" + , File $ addTrailingPathSeparator $ objectsDir srcr + , File $ addTrailingPathSeparator $ objectsDir destr + ] + +{- To deal with missing objects that cannot be recovered, resets any + - local branches to point to an old commit before the missing + - objects. Returns all branches that were changed, and deleted. + -} +resetLocalBranches :: MissingObjects -> GoodCommits -> Repo -> IO ([Branch], [Branch], GoodCommits) +resetLocalBranches missing goodcommits r = + go [] [] goodcommits =<< filter islocalbranch <$> getAllRefs r + where + 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 + case mc of + Just c + | c == b -> go changed deleted gcs' bs + | otherwise -> do + reset b c + go (b:changed) deleted gcs' bs + Nothing -> do + nukeBranchRef b r + go changed (b:deleted) gcs' bs + reset b c = do + nukeBranchRef b r + void $ runBool + [ Param "branch" + , Param (fromRef $ Ref.base b) + , Param (fromRef c) + ] r + +isTrackingBranch :: Ref -> Bool +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 + - Returns a list of all removed branches. + -} +removeBadBranches :: (Ref -> Bool) -> Repo -> IO [Branch] +removeBadBranches removablebranch r = fst <$> removeBadBranches' removablebranch S.empty emptyGoodCommits r + +removeBadBranches' :: (Ref -> Bool) -> MissingObjects -> GoodCommits -> Repo -> IO ([Branch], GoodCommits) +removeBadBranches' removablebranch missing goodcommits r = + go [] goodcommits =<< filter removablebranch <$> getAllRefs r + where + go removed gcs [] = return (removed, gcs) + go removed gcs (b:bs) = do + (ok, gcs') <- verifyCommit missing gcs b r + if ok + then go removed gcs' bs + else do + nukeBranchRef b r + go (b:removed) gcs' bs + +badBranches :: MissingObjects -> Repo -> IO [Branch] +badBranches missing r = filterM isbad =<< getAllRefs r + where + isbad b = not . fst <$> verifyCommit missing emptyGoodCommits b r + +{- Gets all refs, including ones that are corrupt. + - git show-ref does not output refs to commits that are directly + - corrupted, so it is not used. + - + - Relies on packed refs being exploded before it's called. + -} +getAllRefs :: Repo -> IO [Ref] +getAllRefs r = getAllRefs' (localGitDir r "refs") + +getAllRefs' :: FilePath -> IO [Ref] +getAllRefs' refdir = do + let topsegs = length (splitPath refdir) - 1 + let toref = Ref . joinPath . drop topsegs . splitPath + map toref <$> dirContentsRecursive refdir + +explodePackedRefsFile :: Repo -> IO () +explodePackedRefsFile r = do + let f = packedRefsFile r + whenM (doesFileExist f) $ do + rs <- mapMaybe parsePacked . lines + <$> catchDefaultIO "" (safeReadFile f) + forM_ rs makeref + nukeFile f + where + makeref (sha, ref) = do + let dest = localGitDir r fromRef ref + createDirectoryIfMissing True (parentDir dest) + unlessM (doesFileExist dest) $ + writeFile dest (fromRef sha) + +packedRefsFile :: Repo -> FilePath +packedRefsFile r = localGitDir r "packed-refs" + +parsePacked :: String -> Maybe (Sha, Ref) +parsePacked l = case words l of + (sha:ref:[]) + | isJust (extractSha sha) && Ref.legal True ref -> + Just (Ref sha, Ref ref) + _ -> Nothing + +{- 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 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. + - Otherwise, tries to traverse the commits in the branch to find one + - that is ok. That might fail, if one of them is corrupt, or if an object + - at the root of the branch is missing. Finally, looks for an old version + - of the branch from the reflog. + -} +findUncorruptedCommit :: MissingObjects -> GoodCommits -> Branch -> Repo -> IO (Maybe Sha, GoodCommits) +findUncorruptedCommit missing goodcommits branch r = do + (ok, goodcommits') <- verifyCommit missing goodcommits branch r + if ok + then return (Just branch, goodcommits') + else do + (ls, cleanup) <- pipeNullSplit + [ Param "log" + , Param "-z" + , Param "--format=%H" + , Param (fromRef branch) + ] r + let branchshas = catMaybes $ map extractSha ls + reflogshas <- RefLog.get branch r + -- XXX Could try a bit harder here, and look + -- for uncorrupted old commits in branches in the + -- reflog. + cleanup `after` findfirst goodcommits (branchshas ++ reflogshas) + where + findfirst gcs [] = return (Nothing, gcs) + findfirst gcs (c:cs) = do + (ok, gcs') <- verifyCommit missing gcs c r + if ok + then return (Just c, gcs') + else findfirst gcs' cs + +{- Verifies that none of the missing objects in the set are used by + - the commit. Also adds to a set of commit shas that have been verified to + - be good, which can be passed into subsequent calls to avoid + - redundant work when eg, chasing down branches to find the first + - uncorrupted commit. -} +verifyCommit :: MissingObjects -> GoodCommits -> Sha -> Repo -> IO (Bool, GoodCommits) +verifyCommit missing goodcommits commit r + | checkGoodCommit commit goodcommits = return (True, goodcommits) + | otherwise = do + (ls, cleanup) <- pipeNullSplit + [ Param "log" + , Param "-z" + , Param "--format=%H %T" + , Param (fromRef commit) + ] r + let committrees = map parse ls + if any isNothing committrees || null committrees + then do + void cleanup + return (False, goodcommits) + else do + let cts = catMaybes committrees + ifM (cleanup <&&> check cts) + ( return (True, addGoodCommits (map fst cts) goodcommits) + , return (False, goodcommits) + ) + where + parse l = case words l of + (commitsha:treesha:[]) -> (,) + <$> extractSha commitsha + <*> extractSha treesha + _ -> Nothing + check [] = return True + check ((c, t):rest) + | checkGoodCommit c goodcommits = return True + | otherwise = verifyTree missing t r <&&> check rest + +{- Verifies that a tree is good, including all trees and blobs + - referenced by it. -} +verifyTree :: MissingObjects -> Sha -> Repo -> IO Bool +verifyTree missing treesha r + | S.member treesha missing = return False + | otherwise = do + (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams treesha []) r + let objshas = map (extractSha . LsTree.sha . LsTree.parseLsTree) ls + if any isNothing objshas || any (`S.member` missing) (catMaybes objshas) + then do + void cleanup + return False + -- as long as ls-tree succeeded, we're good + else cleanup + +{- Checks that the index file only refers to objects that are not missing, + - and is not itself corrupt. Note that a missing index file is not + - considered a problem (repo may be new). -} +checkIndex :: Repo -> IO Bool +checkIndex r = do + (bad, _good, cleanup) <- partitionIndex r + if null bad + then cleanup + else do + void cleanup + return False + +{- Does not check every object the index refers to, but only that the index + - itself is not corrupt. -} +checkIndexFast :: Repo -> IO Bool +checkIndexFast r = do + (indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r + length indexcontents `seq` cleanup + +missingIndex :: Repo -> IO Bool +missingIndex r = not <$> doesFileExist (localGitDir r "index") + +{- Finds missing and ok files staged in the index. -} +partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool) +partitionIndex r = do + (indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r + l <- forM indexcontents $ \i -> case i of + (_file, Just sha, Just _mode) -> (,) <$> isMissing sha r <*> pure i + _ -> pure (False, i) + let (bad, good) = partition fst l + return (map snd bad, map snd good, cleanup) + +{- Rewrites the index file, removing from it any files whose blobs are + - missing. Returns the list of affected files. -} +rewriteIndex :: Repo -> IO [FilePath] +rewriteIndex r + | repoIsLocalBare r = return [] + | otherwise = do + (bad, good, cleanup) <- partitionIndex r + unless (null bad) $ do + nukeFile (indexFile r) + UpdateIndex.streamUpdateIndex r + =<< (catMaybes <$> mapM reinject good) + void cleanup + return $ map fst3 bad + where + reinject (file, Just sha, Just mode) = case toBlobType mode of + Nothing -> return Nothing + Just blobtype -> Just <$> + UpdateIndex.stageFile sha blobtype file r + reinject _ = return Nothing + +newtype GoodCommits = GoodCommits (S.Set Sha) + +emptyGoodCommits :: GoodCommits +emptyGoodCommits = GoodCommits S.empty + +checkGoodCommit :: Sha -> GoodCommits -> Bool +checkGoodCommit sha (GoodCommits s) = S.member sha s + +addGoodCommits :: [Sha] -> GoodCommits -> GoodCommits +addGoodCommits shas (GoodCommits s) = GoodCommits $ + S.union s (S.fromList shas) + +displayList :: [String] -> String -> IO () +displayList items header + | null items = return () + | otherwise = do + putStrLn header + putStr $ unlines $ map (\i -> "\t" ++ i) truncateditems + where + numitems = length items + truncateditems + | numitems > 10 = take 10 items ++ ["(and " ++ show (numitems - 10) ++ " more)"] + | otherwise = items + +{- Fix problems that would prevent repair from working at all + - + - A missing or corrupt .git/HEAD makes git not treat the repository as a + - git repo. If there is a git repo in a parent directory, it may move up + - the tree and use that one instead. So, cannot use `git show-ref HEAD` to + - test it. + - + - Explode the packed refs file, to simplify dealing with refs, and because + - fsck can complain about bad refs in it. + -} +preRepair :: Repo -> IO () +preRepair g = do + unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do + nukeFile headfile + writeFile headfile "ref: refs/heads/master" + explodePackedRefsFile g + unless (repoIsLocalBare g) $ do + let f = indexFile g + void $ tryIO $ allowWrite f + where + headfile = localGitDir g "HEAD" + validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s) + +{- Put it all together. -} +runRepair :: (Ref -> Bool) -> Bool -> Repo -> IO (Bool, [Branch]) +runRepair removablebranch forced g = do + preRepair g + putStrLn "Running git fsck ..." + fsckresult <- findBroken False g + if foundBroken fsckresult + then runRepair' removablebranch fsckresult forced Nothing g + else do + bad <- badBranches S.empty g + if null bad + then do + putStrLn "No problems found." + return (True, []) + else runRepair' removablebranch fsckresult forced Nothing g + +runRepairOf :: FsckResults -> (Ref -> Bool) -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch]) +runRepairOf fsckresult removablebranch forced referencerepo g = do + preRepair g + runRepair' removablebranch fsckresult forced referencerepo g + +runRepair' :: (Ref -> Bool) -> FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch]) +runRepair' removablebranch fsckresult forced referencerepo g = do + cleanCorruptObjects fsckresult g + missing <- findBroken False g + stillmissing <- retrieveMissingObjects missing referencerepo g + case stillmissing of + FsckFoundMissing s t + | S.null s -> if repoIsLocalBare g + then checkbadbranches s + else ifM (checkIndex g) + ( checkbadbranches s + , do + putStrLn "No missing objects found, but the index file is corrupt!" + if forced + then corruptedindex + else needforce + ) + | otherwise -> if forced + then ifM (checkIndex g) + ( forcerepair s t + , corruptedindex + ) + else do + putStrLn $ unwords + [ show (S.size s) + , "missing objects could not be recovered!" + ] + unsuccessfulfinish + FsckFailed + | forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex g) + ( do + cleanCorruptObjects FsckFailed g + stillmissing' <- findBroken False g + case stillmissing' of + FsckFailed -> return (False, []) + FsckFoundMissing s t -> forcerepair s t + , corruptedindex + ) + | otherwise -> unsuccessfulfinish + where + repairbranches missing = do + (removedbranches, goodcommits) <- removeBadBranches' removablebranch missing emptyGoodCommits g + let remotebranches = filter isTrackingBranch removedbranches + unless (null remotebranches) $ + putStrLn $ unwords + [ "Removed" + , show (length remotebranches) + , "remote tracking branches that referred to missing objects." + ] + (resetbranches, deletedbranches, _) <- resetLocalBranches missing goodcommits g + displayList (map fromRef resetbranches) + "Reset these local branches to old versions before the missing objects were committed:" + displayList (map fromRef deletedbranches) + "Deleted these local branches, which could not be recovered due to missing objects:" + return (resetbranches ++ deletedbranches) + + checkbadbranches missing = do + bad <- badBranches missing g + case (null bad, forced) of + (True, _) -> successfulfinish [] + (False, False) -> do + displayList (map fromRef bad) + "Some git branches refer to missing objects:" + unsuccessfulfinish + (False, True) -> successfulfinish =<< repairbranches missing + + forcerepair missing fscktruncated = do + modifiedbranches <- repairbranches missing + deindexedfiles <- rewriteIndex g + displayList deindexedfiles + "Removed these missing files from the index. You should look at what files are present in your working tree and git add them back to the index when appropriate." + + -- When the fsck results were truncated, try + -- fscking again, and as long as different + -- missing objects are found, continue + -- the repair process. + if fscktruncated + then do + fsckresult' <- findBroken False g + case fsckresult' of + FsckFailed -> do + putStrLn "git fsck is failing" + return (False, modifiedbranches) + FsckFoundMissing s _ + | S.null s -> successfulfinish modifiedbranches + | S.null (s `S.difference` missing) -> do + putStrLn $ unwords + [ show (S.size s) + , "missing objects could not be recovered!" + ] + return (False, modifiedbranches) + | otherwise -> do + (ok, modifiedbranches') <- runRepairOf fsckresult' removablebranch forced referencerepo g + return (ok, modifiedbranches++modifiedbranches') + else successfulfinish modifiedbranches + + corruptedindex = do + nukeFile (indexFile g) + -- The corrupted index can prevent fsck from finding other + -- problems, so re-run repair. + fsckresult' <- findBroken False g + result <- runRepairOf fsckresult' removablebranch forced referencerepo g + putStrLn "Removed the corrupted index file. You should look at what files are present in your working tree and git add them back to the index when appropriate." + return result + + successfulfinish modifiedbranches + | null modifiedbranches = do + mapM_ putStrLn + [ "Successfully recovered repository!" + , "You should run \"git fsck\" to make sure, but it looks like everything was recovered ok." + ] + return (True, modifiedbranches) + | otherwise = do + unless (repoIsLocalBare g) $ do + mcurr <- Branch.currentUnsafe g + case mcurr of + Nothing -> return () + Just curr -> when (any (== curr) modifiedbranches) $ do + putStrLn $ unwords + [ "You currently have" + , 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!" + putStrLn "Please carefully check that the changes mentioned above are ok.." + return (True, modifiedbranches) + + unsuccessfulfinish = do + if repoIsLocalBare g + then do + putStrLn "If you have a clone of this bare repository, you should add it as a remote of this repository, and retry." + putStrLn "If there are no clones of this repository, you can instead retry with the --force parameter to force recovery to a possibly usable state." + return (False, []) + else needforce + needforce = do + putStrLn "To force a recovery to a usable state, retry with the --force parameter." + return (False, []) + +successfulRepair :: (Bool, [Branch]) -> Bool +successfulRepair = fst + +safeReadFile :: FilePath -> IO String +safeReadFile f = do + allowRead f + readFileStrictAnyEncoding f diff --git a/Git/Sha.hs b/Git/Sha.hs new file mode 100644 index 0000000..b802c85 --- /dev/null +++ b/Git/Sha.hs @@ -0,0 +1,43 @@ +{- git SHA stuff + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Sha where + +import Common +import Git.Types + +{- Runs an action that causes a git subcommand to emit a Sha, and strips + - any trailing newline, returning the sha. -} +getSha :: String -> IO String -> IO Sha +getSha subcommand a = maybe bad return =<< extractSha <$> a + where + bad = error $ "failed to read sha from git " ++ subcommand + +{- Extracts the Sha from a string. There can be a trailing newline after + - it, but nothing else. -} +extractSha :: String -> Maybe Sha +extractSha s + | len == shaSize = val s + | len == shaSize + 1 && length s' == shaSize = val s' + | otherwise = Nothing + where + len = length s + s' = firstLine s + val v + | all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v + | otherwise = Nothing + +{- Size of a git sha. -} +shaSize :: Int +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 new file mode 100644 index 0000000..bb91a17 --- /dev/null +++ b/Git/Types.hs @@ -0,0 +1,100 @@ +{- git data types + - + - Copyright 2010-2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Types where + +import Network.URI +import qualified Data.Map as M +import System.Posix.Types +import Utility.SafeCommand +import Utility.URI () + +{- Support repositories on local disk, and repositories accessed via an URL. + - + - Repos on local disk have a git directory, and unless bare, a worktree. + - + - A local repo may not have had its config read yet, in which case all + - that's known about it is its path. + - + - Finally, an Unknown repository may be known to exist, but nothing + - else known about it. + -} +data RepoLocation + = Local { gitdir :: FilePath, worktree :: Maybe FilePath } + | LocalUnknown FilePath + | Url URI + | Unknown + deriving (Show, Eq, Ord) + +data Repo = Repo + { location :: RepoLocation + , config :: M.Map String String + -- a given git config key can actually have multiple values + , fullconfig :: M.Map String [String] + , remotes :: [Repo] + -- remoteName holds the name used for this repo in remotes + , remoteName :: Maybe RemoteName + -- alternate environment to use when running git commands + , gitEnv :: Maybe [(String, String)] + -- global options to pass to git when running git commands + , gitGlobalOpts :: [CommandParam] + } deriving (Show, Eq, Ord) + +type RemoteName = String + +{- A git ref. Can be a sha1, or a branch or tag name. -} +newtype Ref = Ref String + deriving (Eq, Ord, Read, Show) + +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) + +instance Show ObjectType where + show BlobObject = "blob" + show CommitObject = "commit" + show TreeObject = "tree" + +readObjectType :: String -> Maybe ObjectType +readObjectType "blob" = Just BlobObject +readObjectType "commit" = Just CommitObject +readObjectType "tree" = Just TreeObject +readObjectType _ = Nothing + +{- Types of blobs. -} +data BlobType = FileBlob | ExecutableBlob | SymlinkBlob + deriving (Eq) + +{- Git uses magic numbers to denote the type of a blob. -} +instance Show BlobType where + show FileBlob = "100644" + show ExecutableBlob = "100755" + show SymlinkBlob = "120000" + +readBlobType :: String -> Maybe BlobType +readBlobType "100644" = Just FileBlob +readBlobType "100755" = Just ExecutableBlob +readBlobType "120000" = Just SymlinkBlob +readBlobType _ = Nothing + +toBlobType :: FileMode -> Maybe BlobType +toBlobType 0o100644 = Just FileBlob +toBlobType 0o100755 = Just ExecutableBlob +toBlobType 0o120000 = Just SymlinkBlob +toBlobType _ = Nothing diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs new file mode 100644 index 0000000..55c5b3b --- /dev/null +++ b/Git/UpdateIndex.hs @@ -0,0 +1,121 @@ +{- git-update-index library + - + - Copyright 2011-2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns, CPP #-} + +module Git.UpdateIndex ( + Streamer, + pureStreamer, + streamUpdateIndex, + streamUpdateIndex', + startUpdateIndex, + stopUpdateIndex, + lsTree, + lsSubTree, + updateIndexLine, + stageFile, + unstageFile, + stageSymlink, + stageDiffTreeItem, +) where + +import Common +import Git +import Git.Types +import Git.Command +import Git.FilePath +import Git.Sha +import qualified Git.DiffTreeItem as Diff + +{- 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 () + +{- A streamer with a precalculated value. -} +pureStreamer :: String -> Streamer +pureStreamer !s = \streamer -> streamer s + +{- Streams content into update-index from a list of Streamers. -} +streamUpdateIndex :: Repo -> [Streamer] -> IO () +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 + return $ UpdateIndexHandle p h + where + params = map Param ["update-index", "-z", "--index-info"] + +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 +lsTree (Ref x) repo streamer = do + (s, cleanup) <- pipeNullSplit params repo + mapM_ streamer s + void $ cleanup + where + params = map Param ["ls-tree", "-z", "-r", "--full-tree", x] +lsSubTree :: Ref -> FilePath -> Repo -> Streamer +lsSubTree (Ref x) p repo streamer = do + (s, cleanup) <- pipeNullSplit params repo + mapM_ streamer s + void $ cleanup + where + params = map Param ["ls-tree", "-z", "-r", "--full-tree", x, p] + +{- Generates a line suitable to be fed into update-index, to add + - a given file with a given sha. -} +updateIndexLine :: Sha -> BlobType -> TopFilePath -> String +updateIndexLine sha filetype file = + show filetype ++ " blob " ++ fromRef sha ++ "\t" ++ indexPath file + +stageFile :: Sha -> BlobType -> FilePath -> Repo -> IO Streamer +stageFile sha filetype file repo = do + p <- toTopFilePath file repo + return $ pureStreamer $ updateIndexLine sha filetype p + +{- A streamer that removes a file from the index. -} +unstageFile :: FilePath -> Repo -> IO Streamer +unstageFile file repo = do + p <- toTopFilePath file repo + return $ unstageFile' p + +unstageFile' :: TopFilePath -> Streamer +unstageFile' p = pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p + +{- A streamer that adds a symlink to the index. -} +stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer +stageSymlink file sha repo = do + !line <- updateIndexLine + <$> pure sha + <*> pure SymlinkBlob + <*> toTopFilePath file repo + return $ pureStreamer line + +{- A streamer that applies a DiffTreeItem to the index. -} +stageDiffTreeItem :: Diff.DiffTreeItem -> Streamer +stageDiffTreeItem d = case toBlobType (Diff.dstmode d) of + Nothing -> unstageFile' (Diff.file d) + Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d) + +indexPath :: TopFilePath -> InternalGitPath +indexPath = toInternalGitPath . getTopFilePath diff --git a/Git/Url.hs b/Git/Url.hs new file mode 100644 index 0000000..fa7d200 --- /dev/null +++ b/Git/Url.hs @@ -0,0 +1,71 @@ +{- git repository urls + - + - Copyright 2010, 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Url ( + scheme, + host, + port, + hostuser, + authority, +) where + +import Network.URI hiding (scheme, authority) + +import Common +import Git.Types +import Git + +{- Scheme of an URL repo. -} +scheme :: Repo -> String +scheme Repo { location = Url u } = uriScheme u +scheme repo = notUrl repo + +{- Work around a bug in the real uriRegName + - -} +uriRegName' :: URIAuth -> String +uriRegName' a = fixup $ uriRegName a + where + fixup x@('[':rest) + | rest !! len == ']' = take len rest + | otherwise = x + where + len = length rest - 1 + fixup x = x + +{- Hostname of an URL repo. -} +host :: Repo -> Maybe String +host = authpart uriRegName' + +{- Port of an URL repo, if it has a nonstandard one. -} +port :: Repo -> Maybe Integer +port r = + case authpart uriPort r of + Nothing -> Nothing + Just ":" -> Nothing + Just (':':p) -> readish p + Just _ -> Nothing + +{- Hostname of an URL repo, including any username (ie, "user@host") -} +hostuser :: Repo -> Maybe String +hostuser r = (++) + <$> authpart uriUserInfo r + <*> authpart uriRegName' r + +{- The full authority portion an URL repo. (ie, "user@host:port") -} +authority :: Repo -> Maybe String +authority = authpart assemble + where + assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a + +{- Applies a function to extract part of the uriAuthority of an URL repo. -} +authpart :: (URIAuth -> a) -> Repo -> Maybe a +authpart a Repo { location = Url u } = a <$> uriAuthority u +authpart _ repo = notUrl repo + +notUrl :: Repo -> a +notUrl repo = error $ + "acting on local git repo " ++ repoDescribe repo ++ " not supported" diff --git a/Git/Version.hs b/Git/Version.hs new file mode 100644 index 0000000..19ff945 --- /dev/null +++ b/Git/Version.hs @@ -0,0 +1,32 @@ +{- git versions + - + - Copyright 2011, 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Git.Version ( + installed, + older, + normalize, + GitVersion, +) where + +import Common +import Utility.DottedVersion + +type GitVersion = DottedVersion + +installed :: IO GitVersion +installed = normalize . extract <$> readProcess "git" ["--version"] + where + extract s = case lines s of + [] -> "" + (l:_) -> unwords $ drop 2 $ words l + +older :: String -> IO Bool +older n = do + v <- installed + return $ v < normalize n -- cgit v1.2.3