From 962e279e17c1f3cf3be49ffdfb5e7310711a220c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 11 Nov 2016 15:01:13 -0400 Subject: merge from git-annex --- Git/Branch.hs | 82 +++++++++++++++++++++++++---------- Git/CatFile.hs | 130 +++++++++++++++++++++++++++++++++++++++++++------------ Git/Command.hs | 6 ++- Git/Construct.hs | 1 + Git/FilePath.hs | 17 ++++++-- Git/Fsck.hs | 67 ++++++++++++++++++++-------- Git/Index.hs | 21 +++++++-- Git/LsTree.hs | 33 +++++++++----- Git/Ref.hs | 18 ++++---- Git/Repair.hs | 4 +- Git/Types.hs | 23 +++++++++- 11 files changed, 302 insertions(+), 100 deletions(-) (limited to 'Git') diff --git a/Git/Branch.hs b/Git/Branch.hs index a2225dc..875f20f 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -13,6 +13,7 @@ import Common import Git import Git.Sha import Git.Command +import qualified Git.Config import qualified Git.Ref import qualified Git.BuildVersion @@ -23,7 +24,7 @@ import qualified Git.BuildVersion - branch is not created yet. So, this also looks at show-ref HEAD - to double-check. -} -current :: Repo -> IO (Maybe Git.Ref) +current :: Repo -> IO (Maybe Branch) current r = do v <- currentUnsafe r case v of @@ -35,7 +36,7 @@ current r = do ) {- The current branch, which may not really exist yet. -} -currentUnsafe :: Repo -> IO (Maybe Git.Ref) +currentUnsafe :: Repo -> IO (Maybe Branch) currentUnsafe r = parse . firstLine <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r where @@ -48,15 +49,25 @@ currentUnsafe r = parse . firstLine changed :: Branch -> Branch -> Repo -> IO Bool changed origbranch newbranch repo | origbranch == newbranch = return False - | otherwise = not . null <$> diffs + | otherwise = not . null + <$> changed' origbranch newbranch [Param "-n1"] repo where - diffs = pipeReadStrict + +changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String +changed' origbranch newbranch extraps repo = pipeReadStrict ps repo + where + ps = [ Param "log" , Param (fromRef origbranch ++ ".." ++ fromRef newbranch) - , Param "-n1" , Param "--pretty=%H" - ] repo - + ] ++ extraps + +{- Lists commits that are in the second branch and not in the first branch. -} +changedCommits :: Branch -> Branch -> [CommandParam] -> Repo -> IO [Sha] +changedCommits origbranch newbranch extraps repo = + catMaybes . map extractSha . lines + <$> changed' origbranch newbranch extraps repo + {- Check if it's possible to fast-forward from the old - ref to the new ref. - @@ -90,7 +101,7 @@ fastForward branch (first:rest) repo = where no_ff = return False do_ff to = do - update branch to repo + update' branch to repo return True findbest c [] = return $ Just c findbest c (r:rs) @@ -104,27 +115,37 @@ fastForward branch (first:rest) repo = (False, True) -> findbest c rs -- worse (False, False) -> findbest c rs -- same -{- The user may have set commit.gpgsign, indending all their manual +{- The user may have set commit.gpgsign, intending 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) +{- Prevent signing automatic commits. -} applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam] applyCommitMode commitmode ps | commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") = Param "--no-gpg-sign" : ps | otherwise = ps +{- Some versions of git commit-tree honor commit.gpgsign themselves, + - but others need -S to be passed to enable gpg signing of manual commits. -} +applyCommitModeForCommitTree :: CommitMode -> [CommandParam] -> Repo -> [CommandParam] +applyCommitModeForCommitTree commitmode ps r + | commitmode == ManualCommit = + case (Git.Config.getMaybe "commit.gpgsign" r) of + Just s | Git.Config.isTrue s == Just True -> + Param "-S":ps + _ -> ps' + | otherwise = ps' + where + ps' = applyCommitMode commitmode 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 @@ -144,36 +165,51 @@ commit commitmode allowempty message branch parentrefs repo = do 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 + sha <- commitTree commitmode message parentrefs tree 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 +commitTree :: CommitMode -> String -> [Ref] -> Ref -> Repo -> IO Sha +commitTree commitmode message parentrefs tree repo = + getSha "commit-tree" $ + pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) + sendmsg repo + where + sendmsg = Just $ flip hPutStr message + ps = applyCommitModeForCommitTree commitmode parentparams repo + parentparams = map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs + {- 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 +{- Updates a branch (or other ref) to a new Sha or branch Ref. -} +update :: String -> Branch -> Ref -> Repo -> IO () +update message branch r = run + [ Param "update-ref" + , Param "-m" + , Param message + , Param $ fromRef branch + , Param $ fromRef r + ] + +update' :: Branch -> Ref -> Repo -> IO () +update' branch r = run [ Param "update-ref" , Param $ fromRef branch - , Param $ fromRef sha + , Param $ fromRef r ] {- Checks out a branch, creating it if necessary. -} diff --git a/Git/CatFile.hs b/Git/CatFile.hs index c63a064..061349f 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -1,6 +1,6 @@ {- git cat-file interface - - - Copyright 2011, 2013 Joey Hess + - Copyright 2011-2016 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -13,13 +13,19 @@ module Git.CatFile ( catFile, catFileDetails, catTree, + catCommit, catObject, catObjectDetails, + catObjectMetaData, ) where import System.IO import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.Map as M +import Data.String +import Data.Char import Data.Tuple.Utils import Numeric import System.Posix.Types @@ -32,21 +38,28 @@ import Git.Types import Git.FilePath import qualified Utility.CoProcess as CoProcess -data CatFileHandle = CatFileHandle CoProcess.CoProcessHandle Repo +data CatFileHandle = CatFileHandle + { catFileProcess :: CoProcess.CoProcessHandle + , checkFileProcess :: CoProcess.CoProcessHandle + } catFileStart :: Repo -> IO CatFileHandle catFileStart = catFileStart' True catFileStart' :: Bool -> Repo -> IO CatFileHandle -catFileStart' restartable repo = do - coprocess <- CoProcess.rawMode =<< gitCoProcessStart restartable +catFileStart' restartable repo = CatFileHandle + <$> startp "--batch" + <*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)" + where + startp p = gitCoProcessStart restartable [ Param "cat-file" - , Param "--batch" + , Param p ] repo - return $ CatFileHandle coprocess repo catFileStop :: CatFileHandle -> IO () -catFileStop (CatFileHandle p _) = CoProcess.stop p +catFileStop h = do + CoProcess.stop (catFileProcess h) + CoProcess.stop (checkFileProcess h) {- Reads a file from a specified branch. -} catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString @@ -63,32 +76,52 @@ 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 +catObjectDetails h object = query (catFileProcess h) object $ \from -> do + header <- hGetLine from + case parseResp object header of + Just (ParsedResp sha size objtype) -> do + content <- S.hGet from (fromIntegral size) + eatchar '\n' from + return $ Just (L.fromChunks [content], sha, objtype) + Just DNE -> return Nothing + Nothing -> error $ "unknown response from git cat-file " ++ show (header, object) 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 the size and type of an object, without reading its content. -} +catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Integer, ObjectType)) +catObjectMetaData h object = query (checkFileProcess h) object $ \from -> do + resp <- hGetLine from + case parseResp object resp of + Just (ParsedResp _ size objtype) -> + return $ Just (size, objtype) + Just DNE -> return Nothing + Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object) + +data ParsedResp = ParsedResp Sha Integer ObjectType | DNE + +query :: CoProcess.CoProcessHandle -> Ref -> (Handle -> IO a) -> IO a +query hdl object receive = CoProcess.query hdl send receive + where + send to = hPutStrLn to (fromRef object) + +parseResp :: Ref -> String -> Maybe ParsedResp +parseResp object l + | " missing" `isSuffixOf` l -- less expensive than full check + && l == fromRef object ++ " missing" = Just DNE + | otherwise = case words l of + [sha, objtype, size] + | length sha == shaSize -> + case (readObjectType objtype, reads size) of + (Just t, [(bytes, "")]) -> + Just $ ParsedResp (Ref sha) bytes t + _ -> Nothing + | otherwise -> Nothing + _ -> Nothing + {- 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 @@ -104,10 +137,51 @@ catTree h treeref = go <$> catObjectDetails h treeref (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 + +catCommit :: CatFileHandle -> Ref -> IO (Maybe Commit) +catCommit h commitref = go <$> catObjectDetails h commitref + where + go (Just (b, _, CommitObject)) = parseCommit b + go _ = Nothing + +parseCommit :: L.ByteString -> Maybe Commit +parseCommit b = Commit + <$> (extractSha . L8.unpack =<< field "tree") + <*> Just (maybe [] (mapMaybe (extractSha . L8.unpack)) (fields "parent")) + <*> (parsemetadata <$> field "author") + <*> (parsemetadata <$> field "committer") + <*> Just (L8.unpack $ L.intercalate (L.singleton nl) message) + where + field n = headMaybe =<< fields n + fields n = M.lookup (fromString n) fieldmap + fieldmap = M.fromListWith (++) ((map breakfield) header) + breakfield l = + let (k, sp_v) = L.break (== sp) l + in (k, [L.drop 1 sp_v]) + (header, message) = separate L.null ls + ls = L.split nl b + + -- author and committer lines have the form: "name date" + -- The email is always present, even if empty "<>" + parsemetadata l = CommitMetaData + { commitName = whenset $ L.init name_sp + , commitEmail = whenset email + , commitDate = whenset $ L.drop 2 gt_sp_date + } + where + (name_sp, rest) = L.break (== lt) l + (email, gt_sp_date) = L.break (== gt) (L.drop 1 rest) + whenset v + | L.null v = Nothing + | otherwise = Just (L8.unpack v) + + nl = fromIntegral (ord '\n') + sp = fromIntegral (ord ' ') + lt = fromIntegral (ord '<') + gt = fromIntegral (ord '>') diff --git a/Git/Command.hs b/Git/Command.hs index 02e3e5a..2060563 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -17,9 +17,11 @@ 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 + setdir ++ settree ++ gitGlobalOpts r ++ params where - setdir = Param $ "--git-dir=" ++ gitdir l + setdir + | gitEnvOverridesGitDir r = [] + | otherwise = [Param $ "--git-dir=" ++ gitdir l] settree = case worktree l of Nothing -> [] Just t -> [Param $ "--work-tree=" ++ t] diff --git a/Git/Construct.hs b/Git/Construct.hs index 03dd29f..7655622 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -236,6 +236,7 @@ newFrom l = Repo , remotes = [] , remoteName = Nothing , gitEnv = Nothing + , gitEnvOverridesGitDir = False , gitGlobalOpts = [] } diff --git a/Git/FilePath.hs b/Git/FilePath.hs index edc3c0f..ffa3331 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -14,8 +14,10 @@ module Git.FilePath ( TopFilePath, - fromTopFilePath, + BranchFilePath(..), + descBranchFilePath, getTopFilePath, + fromTopFilePath, toTopFilePath, asTopFilePath, InternalGitPath, @@ -31,11 +33,18 @@ import qualified System.FilePath.Posix {- A FilePath, relative to the top of the git repository. -} newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } - deriving (Show) + deriving (Show, Eq, Ord) + +{- A file in a branch or other treeish. -} +data BranchFilePath = BranchFilePath Ref TopFilePath + +{- Git uses the branch:file form to refer to a BranchFilePath -} +descBranchFilePath :: BranchFilePath -> String +descBranchFilePath (BranchFilePath b f) = fromRef b ++ ':' : getTopFilePath f -{- Returns an absolute FilePath. -} +{- Path to a TopFilePath, within the provided git repo. -} fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath -fromTopFilePath p repo = absPathFrom (repoPath repo) (getTopFilePath p) +fromTopFilePath p repo = combine (repoPath repo) (getTopFilePath p) {- The input FilePath can be absolute, or relative to the CWD. -} toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath diff --git a/Git/Fsck.hs b/Git/Fsck.hs index f3e6db9..a716b56 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE BangPatterns #-} + module Git.Fsck ( FsckResults(..), MissingObjects, @@ -25,8 +27,6 @@ import qualified Git.Version import qualified Data.Set as S import Control.Concurrent.Async -type MissingObjects = S.Set Sha - data FsckResults = FsckFoundMissing { missingObjects :: MissingObjects @@ -35,6 +35,25 @@ data FsckResults | FsckFailed deriving (Show) +data FsckOutput + = FsckOutput MissingObjects Truncated + | NoFsckOutput + | AllDuplicateEntriesWarning + +type MissingObjects = S.Set Sha + +type Truncated = Bool + +instance Monoid FsckOutput where + mempty = NoFsckOutput + mappend (FsckOutput s1 t1) (FsckOutput s2 t2) = FsckOutput (S.union s1 s2) (t1 || t2) + mappend (FsckOutput s t) _ = FsckOutput s t + mappend _ (FsckOutput s t) = FsckOutput s t + mappend NoFsckOutput NoFsckOutput = NoFsckOutput + mappend AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning + mappend AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning + mappend NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning + {- 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. @@ -58,18 +77,24 @@ findBroken batchmode r = do { std_out = CreatePipe , std_err = CreatePipe } - (bad1, bad2) <- concurrently - (readMissingObjs maxobjs r supportsNoDangling (stdoutHandle p)) - (readMissingObjs maxobjs r supportsNoDangling (stderrHandle p)) + (o1, o2) <- concurrently + (parseFsckOutput maxobjs r supportsNoDangling (stdoutHandle p)) + (parseFsckOutput 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 + case mappend o1 o2 of + FsckOutput badobjs truncated + | S.null badobjs && not fsckok -> return FsckFailed + | otherwise -> return $ FsckFoundMissing badobjs truncated + NoFsckOutput + | not fsckok -> return FsckFailed + | otherwise -> return noproblem + -- If all fsck output was duplicateEntries warnings, + -- the repository is not broken, it just has some unusual + -- tree objects in it. So ignore nonzero exit status. + AllDuplicateEntriesWarning -> return noproblem where maxobjs = 10000 + noproblem = FsckFoundMissing S.empty False foundBroken :: FsckResults -> Bool foundBroken FsckFailed = True @@ -87,10 +112,18 @@ knownMissing (FsckFoundMissing s _) = s 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 +parseFsckOutput :: Int -> Repo -> Bool -> Handle -> IO FsckOutput +parseFsckOutput maxobjs r supportsNoDangling h = do + ls <- lines <$> hGetContents h + if null ls + then return NoFsckOutput + else if all ("duplicateEntries" `isInfixOf`) ls + then return AllDuplicateEntriesWarning + else do + let shas = findShas supportsNoDangling ls + let !truncated = length shas > maxobjs + missingobjs <- findMissing (take maxobjs shas) r + return $ FsckOutput missingobjs truncated isMissing :: Sha -> Repo -> IO Bool isMissing s r = either (const True) (const False) <$> tryIO dump @@ -100,8 +133,8 @@ isMissing s r = either (const True) (const False) <$> tryIO dump , Param (fromRef s) ] r -findShas :: Bool -> String -> [Sha] -findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted . lines +findShas :: Bool -> [String] -> [Sha] +findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted where wanted l | supportsNoDangling = True diff --git a/Git/Index.hs b/Git/Index.hs index 551fd98..85ea480 100644 --- a/Git/Index.hs +++ b/Git/Index.hs @@ -14,6 +14,20 @@ import Utility.Env indexEnv :: String indexEnv = "GIT_INDEX_FILE" +{- Gets value to set GIT_INDEX_FILE to. Input should be absolute path, + - or relative to the CWD. + - + - When relative, GIT_INDEX_FILE is interpreted by git as being + - relative to the top of the work tree of the git repository, + - not to the CWD. Worse, other environment variables (GIT_WORK_TREE) + - or git options (--work-tree) or configuration (core.worktree) + - can change what the relative path is interpreted relative to. + - + - So, an absolute path is the only safe option for this to return. + -} +indexEnvVal :: FilePath -> IO String +indexEnvVal = absPath + {- Forces git to use the specified index file. - - Returns an action that will reset back to the default @@ -21,10 +35,11 @@ indexEnv = "GIT_INDEX_FILE" - - Warning: Not thread safe. -} -override :: FilePath -> IO (IO ()) -override index = do +override :: FilePath -> Repo -> IO (IO ()) +override index _r = do res <- getEnv var - setEnv var index True + val <- indexEnvVal index + setEnv var val True return $ reset res where var = "GIT_INDEX_FILE" diff --git a/Git/LsTree.hs b/Git/LsTree.hs index 1ed6247..2060fa7 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -1,16 +1,19 @@ {- git ls-tree interface - - - Copyright 2011 Joey Hess + - Copyright 2011-2016 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE BangPatterns #-} + module Git.LsTree ( TreeItem(..), lsTree, + lsTree', lsTreeParams, lsTreeFiles, - parseLsTree + parseLsTree, ) where import Common @@ -26,15 +29,19 @@ import System.Posix.Types data TreeItem = TreeItem { mode :: FileMode , typeobj :: String - , sha :: String + , sha :: Ref , 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 +lsTree :: Ref -> Repo -> IO ([TreeItem], IO Bool) +lsTree = lsTree' [] + +lsTree' :: [CommandParam] -> Ref -> Repo -> IO ([TreeItem], IO Bool) +lsTree' ps t repo = do + (l, cleanup) <- pipeNullSplit (lsTreeParams t ps) repo + return (map parseLsTree l, cleanup) lsTreeParams :: Ref -> [CommandParam] -> [CommandParam] lsTreeParams r ps = @@ -63,16 +70,18 @@ lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo - (The --long format is not currently supported.) -} parseLsTree :: String -> TreeItem parseLsTree l = TreeItem - { mode = fst $ Prelude.head $ readOct m + { mode = smode , typeobj = t - , sha = s - , file = asTopFilePath $ Git.Filename.decode f + , sha = Ref s + , file = sfile } 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 + (!t, past_t) = splitAt 4 past_m + (!s, past_s) = splitAt shaSize $ Prelude.tail past_t + !f = Prelude.tail past_s + !smode = fst $ Prelude.head $ readOct m + !sfile = asTopFilePath $ Git.Filename.decode f diff --git a/Git/Ref.hs b/Git/Ref.hs index 6bc47d5..5b3b853 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -18,12 +18,20 @@ import Data.Char (chr) headRef :: Ref headRef = Ref "HEAD" +headFile :: Repo -> FilePath +headFile r = localGitDir r "HEAD" + +setHeadRef :: Ref -> Repo -> IO () +setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref) + {- 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). -} +{- Often git refs are fully qualified + - (eg refs/heads/master or refs/remotes/origin/master). + - Converts such a fully qualified ref into a base ref + - (eg: master or origin/master). -} base :: Ref -> Ref base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef where @@ -31,12 +39,6 @@ base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef | 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. -} diff --git a/Git/Repair.hs b/Git/Repair.hs index b441f13..fcfc036 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -342,8 +342,8 @@ 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) + let objshas = map (LsTree.sha . LsTree.parseLsTree) ls + if any (`S.member` missing) objshas then do void cleanup return False diff --git a/Git/Types.hs b/Git/Types.hs index bb91a17..327c1d7 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -11,7 +11,6 @@ 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. - @@ -40,6 +39,7 @@ data Repo = Repo , remoteName :: Maybe RemoteName -- alternate environment to use when running git commands , gitEnv :: Maybe [(String, String)] + , gitEnvOverridesGitDir :: Bool -- global options to pass to git when running git commands , gitGlobalOpts :: [CommandParam] } deriving (Show, Eq, Ord) @@ -98,3 +98,24 @@ toBlobType 0o100644 = Just FileBlob toBlobType 0o100755 = Just ExecutableBlob toBlobType 0o120000 = Just SymlinkBlob toBlobType _ = Nothing + +fromBlobType :: BlobType -> FileMode +fromBlobType FileBlob = 0o100644 +fromBlobType ExecutableBlob = 0o100755 +fromBlobType SymlinkBlob = 0o120000 + +data Commit = Commit + { commitTree :: Sha + , commitParent :: [Sha] + , commitAuthorMetaData :: CommitMetaData + , commitCommitterMetaData :: CommitMetaData + , commitMessage :: String + } + deriving (Show) + +data CommitMetaData = CommitMetaData + { commitName :: Maybe String + , commitEmail :: Maybe String + , commitDate :: Maybe String -- In raw git form, "epoch -tzoffset" + } + deriving (Show) -- cgit v1.2.3