summaryrefslogtreecommitdiff
path: root/Git
diff options
context:
space:
mode:
Diffstat (limited to 'Git')
-rw-r--r--Git/Branch.hs82
-rw-r--r--Git/CatFile.hs130
-rw-r--r--Git/Command.hs6
-rw-r--r--Git/Construct.hs1
-rw-r--r--Git/FilePath.hs17
-rw-r--r--Git/Fsck.hs67
-rw-r--r--Git/Index.hs21
-rw-r--r--Git/LsTree.hs33
-rw-r--r--Git/Ref.hs18
-rw-r--r--Git/Repair.hs4
-rw-r--r--Git/Types.hs23
11 files changed, 302 insertions, 100 deletions
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 <id@joeyh.name>
+ - Copyright 2011-2016 Joey Hess <id@joeyh.name>
-
- 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 <email> 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 <id@joeyh.name>
+ - Copyright 2011-2016 Joey Hess <id@joeyh.name>
-
- 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 = <mode> SP <type> SP <sha> TAB <file>
-- 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)
generated by cgit v1.2.3 (git 2.39.1) at 2024-04-27 14:18:26 +0000