diff options
Diffstat (limited to 'Git')
-rw-r--r-- | Git/Branch.hs | 4 | ||||
-rw-r--r-- | Git/BuildVersion.hs | 2 | ||||
-rw-r--r-- | Git/CatFile.hs | 4 | ||||
-rw-r--r-- | Git/Command.hs | 4 | ||||
-rw-r--r-- | Git/Config.hs | 24 | ||||
-rw-r--r-- | Git/Construct.hs | 42 | ||||
-rw-r--r-- | Git/CurrentRepo.hs | 6 | ||||
-rw-r--r-- | Git/Destroyer.hs | 1 | ||||
-rw-r--r-- | Git/DiffTreeItem.hs | 24 | ||||
-rw-r--r-- | Git/FilePath.hs | 5 | ||||
-rw-r--r-- | Git/Filename.hs | 6 | ||||
-rw-r--r-- | Git/Fsck.hs | 2 | ||||
-rw-r--r-- | Git/Index.hs | 23 | ||||
-rw-r--r-- | Git/LsFiles.hs | 85 | ||||
-rw-r--r-- | Git/LsTree.hs | 31 | ||||
-rw-r--r-- | Git/Objects.hs | 2 | ||||
-rw-r--r-- | Git/Ref.hs | 5 | ||||
-rw-r--r-- | Git/RefLog.hs | 22 | ||||
-rw-r--r-- | Git/Remote.hs | 15 | ||||
-rw-r--r-- | Git/Repair.hs | 21 | ||||
-rw-r--r-- | Git/Sha.hs | 2 | ||||
-rw-r--r-- | Git/Types.hs | 2 | ||||
-rw-r--r-- | Git/UpdateIndex.hs | 17 | ||||
-rw-r--r-- | Git/Url.hs | 2 | ||||
-rw-r--r-- | Git/Version.hs | 41 |
25 files changed, 255 insertions, 137 deletions
diff --git a/Git/Branch.hs b/Git/Branch.hs index 0b7d888..a2225dc 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -1,6 +1,6 @@ {- git branch stuff - - - Copyright 2011 Joey Hess <joey@kitenet.net> + - Copyright 2011 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -37,7 +37,7 @@ current r = do {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Git.Ref) currentUnsafe r = parse . firstLine - <$> pipeReadStrict [Param "symbolic-ref", Param $ fromRef Git.Ref.headRef] r + <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r where parse l | null l = Nothing diff --git a/Git/BuildVersion.hs b/Git/BuildVersion.hs index 832ee8a..50e4a3a 100644 --- a/Git/BuildVersion.hs +++ b/Git/BuildVersion.hs @@ -1,6 +1,6 @@ {- git build version - - - Copyright 2011 Joey Hess <joey@kitenet.net> + - Copyright 2011 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Git/CatFile.hs b/Git/CatFile.hs index d0bcef4..c63a064 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -1,6 +1,6 @@ {- git cat-file interface - - - Copyright 2011, 2013 Joey Hess <joey@kitenet.net> + - Copyright 2011, 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -110,4 +110,4 @@ catTree h treeref = go <$> catObjectDetails h treeref parsemodefile b = let (modestr, file) = separate (== ' ') (decodeBS b) in (file, readmode modestr) - readmode = fst . fromMaybe (0, undefined) . headMaybe . readOct + readmode = fromMaybe 0 . fmap fst . headMaybe . readOct diff --git a/Git/Command.hs b/Git/Command.hs index c61cc9f..02e3e5a 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -1,6 +1,6 @@ {- running git commands - - - Copyright 2010-2013 Joey Hess <joey@kitenet.net> + - Copyright 2010-2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -16,7 +16,7 @@ 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 _ _ ) }) = +gitCommandLine params r@(Repo { location = l@(Local { } ) }) = setdir : settree ++ gitGlobalOpts r ++ params where setdir = Param $ "--git-dir=" ++ gitdir l diff --git a/Git/Config.hs b/Git/Config.hs index 32c0dd1..3d62395 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -1,6 +1,6 @@ {- git repository configuration handling - - - Copyright 2010-2012 Joey Hess <joey@kitenet.net> + - Copyright 2010-2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -14,6 +14,7 @@ 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. -} @@ -66,10 +67,9 @@ global = do home <- myHomeDir ifM (doesFileExist $ home </> ".gitconfig") ( do - repo <- Git.Construct.fromUnknown - repo' <- withHandle StdoutHandle createProcessSuccess p $ - hRead repo - return $ Just repo' + repo <- withHandle StdoutHandle createProcessSuccess p $ + hRead (Git.Construct.fromUnknown) + return $ Just repo , return Nothing ) where @@ -194,3 +194,17 @@ changeFile f k v = boolSystem "git" , 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 index eed2b99..03dd29f 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -1,6 +1,6 @@ {- Construction of Git Repo objects - - - Copyright 2010-2012 Joey Hess <joey@kitenet.net> + - Copyright 2010-2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -19,8 +19,8 @@ module Git.Construct ( fromRemotes, fromRemoteLocation, repoAbsPath, - newFrom, checkForRepo, + newFrom, ) where #ifndef mingw32_HOST_OS @@ -45,10 +45,10 @@ fromCwd = getCurrentDirectory >>= seekUp seekUp dir = do r <- checkForRepo dir case r of - Nothing -> case parentDir dir of - "" -> return Nothing - d -> seekUp d - Just loc -> Just <$> newFrom loc + 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 @@ -58,24 +58,29 @@ fromPath dir = fromAbsPath =<< absPath dir - specified. -} fromAbsPath :: FilePath -> IO Repo fromAbsPath dir - | absoluteGitPath dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt ) + | absoluteGitPath dir = hunt | otherwise = error $ "internal error, " ++ dir ++ " is not absolute" where - ret = newFrom . LocalUnknown - {- Git always looks for "dir.git" in preference to - - to "dir", even if dir ends in a "/". -} + ret = pure . newFrom . LocalUnknown canondir = dropTrailingPathSeparator dir - dir' = canondir ++ ".git" {- 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 + , ret (takeDirectory canondir) ) - | otherwise = ret dir + | 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. - @@ -90,13 +95,13 @@ fromUrl url fromUrlStrict :: String -> IO Repo fromUrlStrict url | startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u - | otherwise = newFrom $ Url 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 :: IO Repo +fromUnknown :: Repo fromUnknown = newFrom Unknown {- Converts a local Repo into a remote repo, using the reference repo @@ -153,7 +158,7 @@ fromRemoteLocation s repo = gen $ parseRemoteLocation s repo fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do dir' <- expandTilde dir - fromAbsPath $ repoPath repo </> 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. @@ -223,8 +228,8 @@ checkForRepo dir = gitdirprefix = "gitdir: " gitSignature file = doesFileExist $ dir </> file -newFrom :: RepoLocation -> IO Repo -newFrom l = return Repo +newFrom :: RepoLocation -> Repo +newFrom l = Repo { location = l , config = M.empty , fullconfig = M.empty @@ -234,4 +239,3 @@ newFrom l = return Repo , gitGlobalOpts = [] } - diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs index f611f7a..dab4ad2 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -1,6 +1,6 @@ {- The current git repository. - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -50,8 +50,8 @@ get = do configure (Just d) _ = do absd <- absPath d curr <- getCurrentDirectory - r <- newFrom $ Local { gitdir = absd, worktree = Just curr } - Git.Config.read r + Git.Config.read $ newFrom $ + Local { gitdir = absd, worktree = Just curr } configure Nothing Nothing = error "Not in a git repository." addworktree w r = changelocation r $ diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs index 2ac4dae..e923796 100644 --- a/Git/Destroyer.hs +++ b/Git/Destroyer.hs @@ -21,7 +21,6 @@ import Utility.Tmp import qualified Data.ByteString as B import Data.Word -import System.PosixCompat.Types {- Ways to damange a git repository. -} data Damage 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 <id@joeyh.name> + - + - 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 index 42eb081..edc3c0f 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -5,7 +5,7 @@ - top of the repository even when run in a subdirectory. Adding some - types helps keep that straight. - - - Copyright 2012-2013 Joey Hess <joey@kitenet.net> + - Copyright 2012-2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -39,8 +39,7 @@ 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) <$> absPath file +toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file {- The input FilePath must already be relative to the top of the git - repository -} diff --git a/Git/Filename.hs b/Git/Filename.hs index 5e076d3..ee84d48 100644 --- a/Git/Filename.hs +++ b/Git/Filename.hs @@ -1,7 +1,7 @@ {- Some git commands output encoded filenames, in a rather annoyingly complex - C-style encoding. - - - Copyright 2010, 2011 Joey Hess <joey@kitenet.net> + - Copyright 2010, 2011 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -24,5 +24,5 @@ encode :: FilePath -> String encode s = "\"" ++ encode_c s ++ "\"" {- for quickcheck -} -prop_idempotent_deencode :: String -> Bool -prop_idempotent_deencode s = s == decode (encode s) +prop_isomorphic_deencode :: String -> Bool +prop_isomorphic_deencode s = s == decode (encode s) diff --git a/Git/Fsck.hs b/Git/Fsck.hs index c6002f6..f3e6db9 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -1,6 +1,6 @@ {- git fsck interface - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Git/Index.hs b/Git/Index.hs index c42ac42..551fd98 100644 --- a/Git/Index.hs +++ b/Git/Index.hs @@ -1,6 +1,6 @@ {- git index file stuff - - - Copyright 2011 Joey Hess <joey@kitenet.net> + - Copyright 2011 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -11,6 +11,9 @@ 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 @@ -25,7 +28,7 @@ override index = do return $ reset res where var = "GIT_INDEX_FILE" - reset (Just v) = setEnv var v True + reset (Just v) = setEnv indexEnv v True reset _ = unsetEnv var indexFile :: Repo -> FilePath @@ -34,3 +37,19 @@ 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 index 2aa05ba..f945838 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -1,6 +1,6 @@ {- git ls-files interface - - - Copyright 2010,2012 Joey Hess <joey@kitenet.net> + - Copyright 2010,2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -35,14 +35,23 @@ 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 $ Params "ls-files --cached -z --" : map File l +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 = [Params "ls-files --others"] ++ exclude ++ - [Params "-z --"] ++ map File l + params = concat + [ [ Param "ls-files", Param "--others"] + , exclude + , [ Param "-z", Param "--" ] + , map File l + ] exclude | include_ignored = [] | otherwise = [Param "--exclude-standard"] @@ -50,28 +59,51 @@ notInRepo include_ignored l repo = pipeNullSplit params repo {- Finds all files in the specified locations, whether checked into git or - not. -} allFiles :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -allFiles l = pipeNullSplit $ Params "ls-files --cached --others -z --" : map File l +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 = [Params "ls-files --deleted -z --"] ++ map File l + 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 = [Params "ls-files --modified -z --"] ++ map File l + 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 = [Params "ls-files --modified --others --exclude-standard -z --"] ++ map File l + 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) @@ -85,7 +117,7 @@ stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"] staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix where - prefix = [Params "diff --cached --name-only -z"] + prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] suffix = Param "--" : map File l type StagedDetails = (FilePath, Maybe Sha, Maybe FileMode) @@ -93,7 +125,7 @@ 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' [Params "--others --exclude-standard"] +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) @@ -106,7 +138,7 @@ stagedDetails' ps l repo = do (ls, cleanup) <- pipeNullSplit params repo return (map parse ls, cleanup) where - params = Params "ls-files --stage -z" : ps ++ + params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ Param "--" : map File l parse s | null file = (s, Nothing, Nothing) @@ -131,11 +163,16 @@ 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. - let top = repoPath repo + top <- absPath (repoPath repo) currdir <- getCurrentDirectory - return (map (\f -> relPathDirToFile currdir $ top </> f) fs, cleanup) + return (map (\f -> relPathDirToFileAbs currdir $ top </> f) fs, cleanup) where - prefix = [Params "diff --name-only --diff-filter=T -z"] + 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. @@ -166,7 +203,12 @@ unmerged l repo = do (fs, cleanup) <- pipeNullSplit params repo return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup) where - params = Params "ls-files --unmerged -z --" : map File l + params = + Param "ls-files" : + Param "--unmerged" : + Param "-z" : + Param "--" : + map File l data InternalUnmerged = InternalUnmerged { isus :: Bool @@ -181,12 +223,13 @@ parseUnmerged s | otherwise = case words metadata of (rawblobtype:rawsha:rawstage:_) -> do stage <- readish rawstage :: Maybe Int - unless (stage == 2 || stage == 3) $ - fail undefined -- skip stage 1 - blobtype <- readBlobType rawblobtype - sha <- extractSha rawsha - return $ InternalUnmerged (stage == 2) file - (Just blobtype) (Just sha) + 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 diff --git a/Git/LsTree.hs b/Git/LsTree.hs index ca5e323..1ed6247 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -1,6 +1,6 @@ {- git ls-tree interface - - - Copyright 2011 Joey Hess <joey@kitenet.net> + - Copyright 2011 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -13,10 +13,6 @@ module Git.LsTree ( parseLsTree ) where -import Numeric -import Control.Applicative -import System.Posix.Types - import Common import Git import Git.Command @@ -24,6 +20,9 @@ import Git.Sha import Git.FilePath import qualified Git.Filename +import Numeric +import System.Posix.Types + data TreeItem = TreeItem { mode :: FileMode , typeobj :: String @@ -35,16 +34,30 @@ data TreeItem = TreeItem - with lazy output. -} lsTree :: Ref -> Repo -> IO [TreeItem] lsTree t repo = map parseLsTree - <$> pipeNullSplitZombie (lsTreeParams t) repo + <$> pipeNullSplitZombie (lsTreeParams t []) repo -lsTreeParams :: Ref -> [CommandParam] -lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ fromRef t ] +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 = [Params "ls-tree --full-tree -z --", File $ fromRef t] ++ map File fs + 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.) -} diff --git a/Git/Objects.hs b/Git/Objects.hs index dadd4f5..bda220b 100644 --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -1,6 +1,6 @@ {- .git/objects - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -1,6 +1,6 @@ {- git ref stuff - - - Copyright 2011-2013 Joey Hess <joey@kitenet.net> + - Copyright 2011-2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -88,6 +88,9 @@ sha branch repo = process <$> showref repo 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 diff --git a/Git/RefLog.hs b/Git/RefLog.hs index 98c9d66..57f35e9 100644 --- a/Git/RefLog.hs +++ b/Git/RefLog.hs @@ -1,6 +1,6 @@ {- git reflog interface - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -14,9 +14,17 @@ import Git.Sha {- Gets the reflog for a given branch. -} get :: Branch -> Repo -> IO [Sha] -get b = mapMaybe extractSha . lines <$$> pipeReadStrict - [ Param "log" - , Param "-g" - , Param "--format=%H" - , Param (fromRef b) - ] +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 index 7e8e5f8..717b540 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -1,6 +1,6 @@ {- git remote stuff - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -12,8 +12,6 @@ module Git.Remote where import Common import Git import Git.Types -import qualified Git.Command -import qualified Git.BuildVersion import Data.Char import qualified Data.Map as M @@ -44,17 +42,6 @@ makeLegalName s = case filter legal $ replace "/" "_" s of legal '.' = True legal c = isAlphaNum c -remove :: RemoteName -> Repo -> IO () -remove remotename = Git.Command.run - [ Param "remote" - -- name of this subcommand changed - , Param $ - if Git.BuildVersion.older "1.8.0" - then "rm" - else "remove" - , Param remotename - ] - data RemoteLocation = RemoteUrl String | RemotePath FilePath remoteLocationIsUrl :: RemoteLocation -> Bool diff --git a/Git/Repair.hs b/Git/Repair.hs index 77a592b..b441f13 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -1,6 +1,6 @@ {- git repository recovery - - - Copyright 2013-2014 Joey Hess <joey@kitenet.net> + - Copyright 2013-2014 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -99,7 +99,7 @@ retrieveMissingObjects :: FsckResults -> Maybe FilePath -> Repo -> IO FsckResult retrieveMissingObjects missing referencerepo r | not (foundBroken missing) = return missing | otherwise = withTmpDir "tmprepo" $ \tmpdir -> do - unlessM (boolSystem "git" [Params "init", File tmpdir]) $ + 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 @@ -140,7 +140,9 @@ retrieveMissingObjects missing referencerepo r ps' = [ Param "fetch" , Param fetchurl - , Params "--force --update-head-ok --quiet" + , Param "--force" + , Param "--update-head-ok" + , Param "--quiet" ] ++ ps fetchr' = fetchr { gitGlobalOpts = gitGlobalOpts fetchr ++ nogc } nogc = [ Param "-c", Param "gc.auto=0" ] @@ -225,10 +227,13 @@ badBranches missing r = filterM isbad =<< getAllRefs r - Relies on packed refs being exploded before it's called. -} getAllRefs :: Repo -> IO [Ref] -getAllRefs r = map toref <$> dirContentsRecursive refdir - where - refdir = localGitDir r </> "refs" - toref = Ref . relPathDirToFile (localGitDir r) +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 @@ -336,7 +341,7 @@ 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 + (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 @@ -1,6 +1,6 @@ {- git SHA stuff - - - Copyright 2011 Joey Hess <joey@kitenet.net> + - Copyright 2011 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Git/Types.hs b/Git/Types.hs index 838c9e0..bb91a17 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -1,6 +1,6 @@ {- git data types - - - Copyright 2010-2012 Joey Hess <joey@kitenet.net> + - Copyright 2010-2012 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index ecd154a..55c5b3b 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -1,6 +1,6 @@ {- git-update-index library - - - Copyright 2011-2013 Joey Hess <joey@kitenet.net> + - Copyright 2011-2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -19,7 +19,8 @@ module Git.UpdateIndex ( updateIndexLine, stageFile, unstageFile, - stageSymlink + stageSymlink, + stageDiffTreeItem, ) where import Common @@ -28,6 +29,7 @@ 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. -} @@ -95,7 +97,10 @@ stageFile sha filetype file repo = do unstageFile :: FilePath -> Repo -> IO Streamer unstageFile file repo = do p <- toTopFilePath file repo - return $ pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p + 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 @@ -106,5 +111,11 @@ stageSymlink file sha repo = do <*> 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 @@ -1,6 +1,6 @@ {- git repository urls - - - Copyright 2010, 2011 Joey Hess <joey@kitenet.net> + - Copyright 2010, 2011 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Git/Version.hs b/Git/Version.hs index 5c61f85..19ff945 100644 --- a/Git/Version.hs +++ b/Git/Version.hs @@ -1,22 +1,23 @@ {- git versions - - - Copyright 2011, 2013 Joey Hess <joey@kitenet.net> + - Copyright 2011, 2013 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} -module Git.Version where +{-# OPTIONS_GHC -fno-warn-tabs #-} -import Common - -data GitVersion = GitVersion String Integer - deriving (Eq) +module Git.Version ( + installed, + older, + normalize, + GitVersion, +) where -instance Ord GitVersion where - compare (GitVersion _ x) (GitVersion _ y) = compare x y +import Common +import Utility.DottedVersion -instance Show GitVersion where - show (GitVersion s _) = s +type GitVersion = DottedVersion installed :: IO GitVersion installed = normalize . extract <$> readProcess "git" ["--version"] @@ -25,19 +26,7 @@ installed = normalize . extract <$> readProcess "git" ["--version"] [] -> "" (l:_) -> unwords $ drop 2 $ words l -{- To compare dotted versions like 1.7.7 and 1.8, they are normalized to - - a somewhat arbitrary integer representation. -} -normalize :: String -> GitVersion -normalize v = GitVersion v $ - sum $ mult 1 $ reverse $ extend precision $ take precision $ - map readi $ split "." v - where - extend n l = l ++ replicate (n - length l) 0 - mult _ [] = [] - mult n (x:xs) = (n*x) : mult (n*10^width) xs - readi :: String -> Integer - readi s = case reads s of - ((x,_):_) -> x - _ -> 0 - precision = 10 -- number of segments of the version to compare - width = length "yyyymmddhhmmss" -- maximum width of a segment +older :: String -> IO Bool +older n = do + v <- installed + return $ v < normalize n |