From 8c4352a0a544b2e5a4ed717999fc7c6ecb0a328f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 4 May 2020 15:38:39 -0400 Subject: merge from git-annex * Improve fetching from a remote with an url in host:path format. * Merge from git-annex. --- Git/Branch.hs | 22 ++++---- Git/CatFile.hs | 89 +++++++++++++++++--------------- Git/Command.hs | 9 +++- Git/Config.hs | 73 ++++++++++++++++---------- Git/DiffTreeItem.hs | 7 +-- Git/FilePath.hs | 2 +- Git/Fsck.hs | 3 +- Git/HashObject.hs | 3 +- Git/LsFiles.hs | 146 +++++++++++++++++++++++++++++++++++++++++----------- Git/LsTree.hs | 5 +- Git/Objects.hs | 2 +- Git/Ref.hs | 54 +++++++++++-------- Git/RefLog.hs | 5 +- Git/Remote.hs | 15 ++++-- Git/Repair.hs | 54 ++++++++++--------- Git/Sha.hs | 63 +++++++++++++++++------ Git/Types.hs | 30 ++++++++--- Git/UpdateIndex.hs | 8 +-- 18 files changed, 390 insertions(+), 200 deletions(-) (limited to 'Git') diff --git a/Git/Branch.hs b/Git/Branch.hs index 699fbf5..fcae905 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -18,6 +18,7 @@ import qualified Git.Config import qualified Git.Ref import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 {- The currently checked out branch. - @@ -39,25 +40,27 @@ current r = do {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Branch) -currentUnsafe r = parse . firstLine' - <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r +currentUnsafe r = parse . firstLine' <$> pipeReadStrict + [ Param "symbolic-ref" + , Param "-q" + , Param $ fromRef Git.Ref.headRef + ] r where parse b | B.null b = Nothing - | otherwise = Just $ Git.Ref $ decodeBS b + | otherwise = Just $ Git.Ref b {- 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 + | otherwise = not . B.null <$> changed' origbranch newbranch [Param "-n1"] repo where -changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String -changed' origbranch newbranch extraps repo = - decodeBS <$> pipeReadStrict ps repo +changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO B.ByteString +changed' origbranch newbranch extraps repo = pipeReadStrict ps repo where ps = [ Param "log" @@ -68,7 +71,7 @@ changed' origbranch newbranch extraps repo = {- 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 + catMaybes . map extractSha . B8.lines <$> changed' origbranch newbranch extraps repo {- Check if it's possible to fast-forward from the old @@ -163,8 +166,7 @@ commitCommand' runner commitmode ps = runner $ -} commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha) commit commitmode allowempty message branch parentrefs repo = do - tree <- getSha "write-tree" $ - decodeBS' <$> pipeReadStrict [Param "write-tree"] repo + tree <- getSha "write-tree" $ pipeReadStrict [Param "write-tree"] repo ifM (cancommit tree) ( do sha <- commitTree commitmode message parentrefs tree repo diff --git a/Git/CatFile.hs b/Git/CatFile.hs index 6402001..1769e57 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -1,10 +1,12 @@ {- git cat-file interface - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.CatFile ( CatFileHandle, catFileStart, @@ -22,7 +24,9 @@ module Git.CatFile ( 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.ByteString.Char8 as S8 +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 import qualified Data.Map as M import Data.String import Data.Char @@ -69,11 +73,11 @@ catFileStop h = do {- Reads a file from a specified branch. -} catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString catFile h branch file = catObject h $ Ref $ - fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file) + fromRef' branch <> ":" <> toInternalGitPath file catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) catFileDetails h branch file = catObjectDetails h $ Ref $ - fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file) + fromRef' branch <> ":" <> toInternalGitPath file {- Uses a running git cat-file read the content of an object. - Objects that do not exist will have "" returned. -} @@ -82,9 +86,9 @@ catObject h object = maybe L.empty fst3 <$> catObjectDetails h object catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType)) catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \from -> do - header <- hGetLine from + header <- S8.hGetLine from case parseResp object header of - Just (ParsedResp sha size objtype) -> do + Just (ParsedResp sha objtype size) -> do content <- S.hGet from (fromIntegral size) eatchar '\n' from return $ Just (L.fromChunks [content], sha, objtype) @@ -112,9 +116,9 @@ catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \f {- Gets the size and type of an object, without reading its content. -} catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType)) catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do - resp <- hGetLine from + resp <- S8.hGetLine from case parseResp object resp of - Just (ParsedResp sha size objtype) -> + Just (ParsedResp sha objtype size) -> return $ Just (sha, size, objtype) Just DNE -> return Nothing Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object) @@ -126,36 +130,39 @@ catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ objtype <- queryObjectType object (gitRepo h) return $ (,,) <$> sha <*> sz <*> objtype -data ParsedResp = ParsedResp Sha FileSize ObjectType | DNE +data ParsedResp = ParsedResp Sha ObjectType FileSize | DNE + deriving (Show) query :: CoProcess.CoProcessHandle -> Ref -> IO a -> (Handle -> IO a) -> IO a query hdl object newlinefallback receive -- git cat-file --batch uses a line based protocol, so when the -- filename itself contains a newline, have to fall back to another -- method of getting the information. - | '\n' `elem` s = newlinefallback + | '\n' `S8.elem` s = newlinefallback -- git strips carriage return from the end of a line, out of some -- misplaced desire to support windows, so also use the newline -- fallback for those. - | "\r" `isSuffixOf` s = newlinefallback + | "\r" `S8.isSuffixOf` s = newlinefallback | otherwise = CoProcess.query hdl send receive where - send to = hPutStrLn to s - s = fromRef object + send to = S8.hPutStrLn to s + s = fromRef' object + +parseResp :: Ref -> S.ByteString -> Maybe ParsedResp +parseResp object s + | " missing" `S.isSuffixOf` s -- less expensive than full check + && s == fromRef' object <> " missing" = Just DNE + | otherwise = eitherToMaybe $ A.parseOnly respParser s -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 (encodeBS objtype), reads size) of - (Just t, [(bytes, "")]) -> - Just $ ParsedResp (Ref sha) bytes t - _ -> Nothing - | otherwise -> Nothing - _ -> Nothing +respParser :: A.Parser ParsedResp +respParser = ParsedResp + <$> (maybe (fail "bad sha") return . extractSha =<< nextword) + <* A8.char ' ' + <*> (maybe (fail "bad object type") return . readObjectType =<< nextword) + <* A8.char ' ' + <*> A8.decimal + where + nextword = A8.takeTill (== ' ') querySingle :: CommandParam -> Ref -> Repo -> (Handle -> IO a) -> IO (Maybe a) querySingle o r repo reader = assertLocal repo $ @@ -219,39 +226,39 @@ catTree h treeref = go <$> catObjectDetails h treeref catCommit :: CatFileHandle -> Ref -> IO (Maybe Commit) catCommit h commitref = go <$> catObjectDetails h commitref where - go (Just (b, _, CommitObject)) = parseCommit b + go (Just (b, _, CommitObject)) = parseCommit (L.toStrict b) go _ = Nothing -parseCommit :: L.ByteString -> Maybe Commit +parseCommit :: S.ByteString -> Maybe Commit parseCommit b = Commit - <$> (extractSha . L8.unpack =<< field "tree") - <*> Just (maybe [] (mapMaybe (extractSha . L8.unpack)) (fields "parent")) + <$> (extractSha =<< field "tree") + <*> Just (maybe [] (mapMaybe extractSha) (fields "parent")) <*> (parsemetadata <$> field "author") <*> (parsemetadata <$> field "committer") - <*> Just (L8.unpack $ L.intercalate (L.singleton nl) message) + <*> Just (decodeBS $ S.intercalate (S.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 + let (k, sp_v) = S.break (== sp) l + in (k, [S.drop 1 sp_v]) + (header, message) = separate S.null ls + ls = S.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 + { commitName = whenset $ S.init name_sp , commitEmail = whenset email - , commitDate = whenset $ L.drop 2 gt_sp_date + , commitDate = whenset $ S.drop 2 gt_sp_date } where - (name_sp, rest) = L.break (== lt) l - (email, gt_sp_date) = L.break (== gt) (L.drop 1 rest) + (name_sp, rest) = S.break (== lt) l + (email, gt_sp_date) = S.break (== gt) (S.drop 1 rest) whenset v - | L.null v = Nothing - | otherwise = Just (L8.unpack v) + | S.null v = Nothing + | otherwise = Just (decodeBS v) nl = fromIntegral (ord '\n') sp = fromIntegral (ord ' ') diff --git a/Git/Command.hs b/Git/Command.hs index eb20af2..15157a0 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -81,11 +81,16 @@ pipeReadStrict' reader params repo = assertLocal 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 :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO S.ByteString pipeWriteRead params writer repo = assertLocal repo $ writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) - (gitEnv repo) writer (Just adjusthandle) + (gitEnv repo) writer' where + writer' = case writer of + Nothing -> Nothing + Just a -> Just $ \h -> do + adjusthandle h + a h adjusthandle h = hSetNewlineMode h noNewlineTranslation {- Runs a git command, feeding it input on a handle with an action. -} diff --git a/Git/Config.hs b/Git/Config.hs index 4b60664..f50d5eb 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -1,6 +1,6 @@ {- git repository configuration handling - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -14,6 +14,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.Char import qualified System.FilePath.ByteString as P +import Control.Concurrent.Async import Common import Git @@ -58,7 +59,7 @@ read' repo = go repo go Repo { location = LocalUnknown d } = git_config d go _ = assertLocal repo $ error "internal" git_config d = withHandle StdoutHandle createProcessSuccess p $ - hRead repo + hRead repo ConfigNullList where params = ["config", "--null", "--list"] p = (proc "git" params) @@ -73,7 +74,7 @@ global = do ifM (doesFileExist $ home ".gitconfig") ( do repo <- withHandle StdoutHandle createProcessSuccess p $ - hRead (Git.Construct.fromUnknown) + hRead (Git.Construct.fromUnknown) ConfigNullList return $ Just repo , return Nothing ) @@ -82,18 +83,18 @@ global = do 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 +hRead :: Repo -> ConfigStyle -> Handle -> IO Repo +hRead repo st h = do val <- S.hGetContents h - store val repo + store val st 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 :: S.ByteString -> Repo -> IO Repo -store s repo = do - let c = parse s +store :: S.ByteString -> ConfigStyle -> Repo -> IO Repo +store s st repo = do + let c = parse s st updateLocation $ repo { config = (M.map Prelude.head c) `M.union` config repo , fullconfig = M.unionWith (++) c (fullconfig repo) @@ -134,27 +135,30 @@ updateLocation' r l = do top <- absPath $ fromRawFilePath (gitdir l) let p = absPathFrom top (fromRawFilePath d) return $ l { worktree = Just (toRawFilePath p) } + Just NoConfigValue -> return l return $ r { location = l' } +data ConfigStyle = ConfigList | ConfigNullList + {- Parses git config --list or git config --null --list output into a - config map. -} -parse :: S.ByteString -> M.Map ConfigKey [ConfigValue] -parse s +parse :: S.ByteString -> ConfigStyle -> M.Map ConfigKey [ConfigValue] +parse s st | S.null s = M.empty - -- --list output will have a '=' in the first line - -- (The first line of --null --list output is the name of a key, - -- which is assumed to never contain '='.) - | S.elem eq firstline = sep eq $ S.split nl s - -- --null --list output separates keys from values with newlines - | otherwise = sep nl $ S.split 0 s + | otherwise = case st of + ConfigList -> sep eq $ S.split nl s + ConfigNullList -> sep nl $ S.split 0 s where nl = fromIntegral (ord '\n') eq = fromIntegral (ord '=') - firstline = S.takeWhile (/= nl) s sep c = M.fromListWith (++) - . map (\(k,v) -> (ConfigKey k, [ConfigValue (S.drop 1 v)])) + . map (\(k,v) -> (ConfigKey k, [mkval v])) . map (S.break (== c)) + + mkval v + | S.null v = NoConfigValue + | otherwise = ConfigValue (S.drop 1 v) {- Checks if a string from git config is a true/false value. -} isTrueFalse :: String -> Maybe Bool @@ -162,11 +166,21 @@ isTrueFalse = isTrueFalse' . ConfigValue . encodeBS' isTrueFalse' :: ConfigValue -> Maybe Bool isTrueFalse' (ConfigValue s) + | s' == "yes" = Just True + | s' == "on" = Just True | s' == "true" = Just True + | s' == "1" = Just True + + | s' == "no" = Just False + | s' == "off" = Just False | s' == "false" = Just False + | s' == "0" = Just False + | s' == "" = Just False + | otherwise = Nothing where s' = S8.map toLower s +isTrueFalse' NoConfigValue = Just True boolConfig :: Bool -> String boolConfig True = "true" @@ -184,25 +198,28 @@ 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, S.ByteString)) -fromPipe r cmd params = try $ - withHandle StdoutHandle createProcessSuccess p $ \h -> do - val <- S.hGetContents h - r' <- store val r - return (r', val) + - output and any standard output of the command. -} +fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, S.ByteString)) +fromPipe r cmd params st = try $ + withOEHandles createProcessSuccess p $ \(hout, herr) -> do + geterr <- async $ S.hGetContents herr + getval <- async $ S.hGetContents hout + val <- wait getval + err <- wait geterr + r' <- store val st r + return (r', val, err) 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, S.ByteString)) +fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString, S.ByteString)) fromFile r f = fromPipe r "git" [ Param "config" , Param "--file" , File f , Param "--list" - ] + ] ConfigList {- Changes a git config setting in the specified config file. - (Creates the file if it does not already exist.) -} diff --git a/Git/DiffTreeItem.hs b/Git/DiffTreeItem.hs index ffda2e8..090ad3e 100644 --- a/Git/DiffTreeItem.hs +++ b/Git/DiffTreeItem.hs @@ -10,6 +10,7 @@ module Git.DiffTreeItem ( ) where import System.Posix.Types +import qualified Data.ByteString as S import Git.FilePath import Git.Types @@ -17,8 +18,8 @@ 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 + , srcsha :: Sha -- null sha if file was added + , dstsha :: Sha -- null sha if file was deleted + , status :: S.ByteString , file :: TopFilePath } deriving Show diff --git a/Git/FilePath.hs b/Git/FilePath.hs index 66a0159..d31b421 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -50,7 +50,7 @@ data BranchFilePath = BranchFilePath Ref TopFilePath {- Git uses the branch:file form to refer to a BranchFilePath -} descBranchFilePath :: BranchFilePath -> S.ByteString descBranchFilePath (BranchFilePath b f) = - encodeBS' (fromRef b) <> ":" <> getTopFilePath f + fromRef' b <> ":" <> getTopFilePath f {- Path to a TopFilePath, within the provided git repo. -} fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath diff --git a/Git/Fsck.hs b/Git/Fsck.hs index 6f33e11..69a9e9f 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -139,7 +139,8 @@ isMissing s r = either (const True) (const False) <$> tryIO dump ] r findShas :: [String] -> [Sha] -findShas = catMaybes . map extractSha . concat . map words . filter wanted +findShas = catMaybes . map (extractSha . encodeBS') + . concat . map words . filter wanted where wanted l = not ("dangling " `isPrefixOf` l) diff --git a/Git/HashObject.hs b/Git/HashObject.hs index 3787c9c..bcad9a1 100644 --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -18,6 +18,7 @@ import qualified Utility.CoProcess as CoProcess import Utility.Tmp import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.ByteString.Builder @@ -39,7 +40,7 @@ hashFile :: HashObjectHandle -> FilePath -> IO Sha hashFile h file = CoProcess.query h send receive where send to = hPutStrLn to =<< absPath file - receive from = getSha "hash-object" $ hGetLine from + receive from = getSha "hash-object" $ S8.hGetLine from class HashableBlob t where hashableBlobToHandle :: Handle -> t -> IO () diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index 5534307..830b5f5 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -1,6 +1,6 @@ {- git ls-files interface - - - Copyright 2010-2018 Joey Hess + - Copyright 2010-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -24,6 +24,7 @@ module Git.LsFiles ( Unmerged(..), unmerged, StagedDetails, + inodeCaches, ) where import Common @@ -31,17 +32,45 @@ import Git import Git.Command import Git.Types import Git.Sha +import Utility.InodeCache +import Utility.TimeStamp import Numeric +import Data.Char import System.Posix.Types -import qualified Data.ByteString.Lazy as L +import qualified Data.Map as M +import qualified Data.ByteString as S -{- Scans for files that are checked into git's index at the specified locations. -} +{- It's only safe to use git ls-files on the current repo, not on a remote. + - + - Git has some strange behavior when git ls-files is used with repos + - that are not the one that the cwd is in: + - git --git-dir=../foo/.git --worktree=../foo ../foo fails saying + - "../foo is outside repository". + - That does not happen when an absolute path is provided. + - + - Also, the files output by ls-files are relative to the cwd. + - Unless it's run on remote. Then it's relative to the top of the remote + - repo. + - + - So, best to avoid that class of problems. + -} +safeForLsFiles :: Repo -> Bool +safeForLsFiles r = isNothing (remoteName r) + +guardSafeForLsFiles :: Repo -> IO a -> IO a +guardSafeForLsFiles r a + | safeForLsFiles r = a + | otherwise = error $ "git ls-files is unsafe to run on repository " ++ repoDescribe r + +{- Lists files that are checked into git's index at the specified paths. + - With no paths, all files are listed. + -} inRepo :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) inRepo = inRepo' [] inRepo' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -inRepo' ps l repo = pipeNullSplit' params repo +inRepo' ps l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" : @@ -53,14 +82,15 @@ inRepo' ps l repo = pipeNullSplit' params repo {- Files that are checked into the index or have been committed to a - branch. -} inRepoOrBranch :: Branch -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -inRepoOrBranch (Ref b) = inRepo' [Param $ "--with-tree=" ++ b] +inRepoOrBranch b = inRepo' [Param $ "--with-tree=" ++ fromRef b] {- Scans for files at the specified locations that are not checked into git. -} notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) notInRepo = notInRepo' [] notInRepo' :: [CommandParam] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -notInRepo' ps include_ignored l repo = pipeNullSplit' params repo +notInRepo' ps include_ignored l repo = guardSafeForLsFiles repo $ + pipeNullSplit' params repo where params = concat [ [ Param "ls-files", Param "--others"] @@ -81,18 +111,20 @@ notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"] {- Finds all files in the specified locations, whether checked into git or - not. -} allFiles :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -allFiles l = pipeNullSplit' $ - Param "ls-files" : - Param "--cached" : - Param "--others" : - Param "-z" : - Param "--" : - map (File . fromRawFilePath) l +allFiles l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo + where + params = + Param "ls-files" : + Param "--cached" : + Param "--others" : + Param "-z" : + Param "--" : + map (File . fromRawFilePath) l {- Returns a list of files in the specified locations that have been - deleted. -} deleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -deleted l repo = pipeNullSplit' params repo +deleted l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" : @@ -104,7 +136,7 @@ deleted l repo = pipeNullSplit' params repo {- Returns a list of files in the specified locations that have been - modified. -} modified :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -modified l repo = pipeNullSplit' params repo +modified l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" : @@ -116,7 +148,7 @@ modified l repo = pipeNullSplit' params repo {- Files that have been modified or are not checked into git (and are not - ignored). -} modifiedOthers :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -modifiedOthers l repo = pipeNullSplit' params repo +modifiedOthers l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" : @@ -137,7 +169,8 @@ stagedNotDeleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"] staged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -staged' ps l repo = pipeNullSplit' (prefix ++ ps ++ suffix) repo +staged' ps l repo = guardSafeForLsFiles repo $ + pipeNullSplit' (prefix ++ ps ++ suffix) repo where prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] suffix = Param "--" : map (File . fromRawFilePath) l @@ -156,19 +189,22 @@ stagedDetails = stagedDetails' [] {- Gets details about staged files, including the Sha of their staged - contents. -} stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) -stagedDetails' ps l repo = do - (ls, cleanup) <- pipeNullSplit params repo - return (map parse ls, cleanup) +stagedDetails' ps l repo = guardSafeForLsFiles repo $ do + (ls, cleanup) <- pipeNullSplit' params repo + return (map parseStagedDetails ls, cleanup) where params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ Param "--" : map (File . fromRawFilePath) l - parse s - | null file = (L.toStrict s, Nothing, Nothing) - | otherwise = (toRawFilePath file, extractSha $ take shaSize rest, readmode mode) - where - (metadata, file) = separate (== '\t') (decodeBL' s) - (mode, rest) = separate (== ' ') metadata - readmode = fst <$$> headMaybe . readOct + +parseStagedDetails :: S.ByteString -> StagedDetails +parseStagedDetails s + | S.null file = (s, Nothing, Nothing) + | otherwise = (file, extractSha sha, readmode mode) + where + (metadata, file) = separate' (== fromIntegral (ord '\t')) s + (mode, metadata') = separate' (== fromIntegral (ord ' ')) metadata + (sha, _) = separate' (== fromIntegral (ord ' ')) metadata' + readmode = fst <$$> headMaybe . readOct . decodeBS' {- Returns a list of the files in the specified locations that are staged - for commit, and whose type has changed. -} @@ -181,7 +217,7 @@ typeChanged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChanged = typeChanged' [] typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -typeChanged' ps l repo = do +typeChanged' ps l repo = guardSafeForLsFiles 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. @@ -221,7 +257,7 @@ data Unmerged = Unmerged - If a line is omitted, that side removed the file. -} unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool) -unmerged l repo = do +unmerged l repo = guardSafeForLsFiles repo $ do (fs, cleanup) <- pipeNullSplit params repo return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup) where @@ -249,7 +285,7 @@ parseUnmerged s then Nothing else do treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype) - sha <- extractSha rawsha + sha <- extractSha (encodeBS' rawsha) return $ InternalUnmerged (stage == 2) (toRawFilePath file) (Just treeitemtype) (Just sha) _ -> Nothing @@ -278,3 +314,53 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest , itreeitemtype = Nothing , isha = Nothing } + +{- Gets the InodeCache equivilant information stored in the git index. + - + - Note that this uses a --debug option whose output could change at some + - point in the future. If the output is not as expected, will use Nothing. + -} +inodeCaches :: [RawFilePath] -> Repo -> IO ([(FilePath, Maybe InodeCache)], IO Bool) +inodeCaches locs repo = guardSafeForLsFiles repo $ do + (ls, cleanup) <- pipeNullSplit params repo + return (parse Nothing (map decodeBL ls), cleanup) + where + params = + Param "ls-files" : + Param "--cached" : + Param "-z" : + Param "--debug" : + Param "--" : + map (File . fromRawFilePath) locs + + parse Nothing (f:ls) = parse (Just f) ls + parse (Just f) (s:[]) = + let i = parsedebug s + in (f, i) : [] + parse (Just f) (s:ls) = + let (d, f') = splitdebug s + i = parsedebug d + in (f, i) : parse (Just f') ls + parse _ _ = [] + + -- First 5 lines are --debug output, remainder is the next filename. + -- This assumes that --debug does not start outputting more lines. + splitdebug s = case splitc '\n' s of + (d1:d2:d3:d4:d5:rest) -> + ( intercalate "\n" [d1, d2, d3, d4, d5] + , intercalate "\n" rest + ) + _ -> ("", s) + + -- This parser allows for some changes to the --debug output, + -- including reordering, or adding more items. + parsedebug s = do + let l = words s + let iskey v = ":" `isSuffixOf` v + let m = M.fromList $ zip + (filter iskey l) + (filter (not . iskey) l) + mkInodeCache + <$> (readish =<< M.lookup "ino:" m) + <*> (readish =<< M.lookup "size:" m) + <*> (parsePOSIXTime =<< (replace ":" "." <$> M.lookup "mtime:" m)) diff --git a/Git/LsTree.hs b/Git/LsTree.hs index a3d8383..ead501f 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -21,7 +21,6 @@ module Git.LsTree ( import Common import Git import Git.Command -import Git.Sha import Git.FilePath import qualified Git.Filename import Utility.Attoparsec @@ -94,10 +93,10 @@ parserLsTree = TreeItem <$> octal <* A8.char ' ' -- type - <*> A.takeTill (== 32) + <*> A8.takeTill (== ' ') <* A8.char ' ' -- sha - <*> (Ref . decodeBS' <$> A.take shaSize) + <*> (Ref <$> A8.takeTill (== '\t')) <* A8.char '\t' -- file <*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString) diff --git a/Git/Objects.hs b/Git/Objects.hs index c9ede4d..6a24087 100644 --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -26,7 +26,7 @@ listPackFiles r = filter (".pack" `isSuffixOf`) listLooseObjectShas :: Repo -> IO [Sha] listLooseObjectShas r = catchDefaultIO [] $ - mapMaybe (extractSha . concat . reverse . take 2 . reverse . splitDirectories) + mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories) <$> dirContentsRecursiveSkipping (== "pack") True (objectsDir r) looseObjectFile :: Repo -> Sha -> FilePath diff --git a/Git/Ref.hs b/Git/Ref.hs index 621e328..104a1db 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -17,6 +17,7 @@ import Git.Types import Data.Char (chr, ord) import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 headRef :: Ref headRef = Ref "HEAD" @@ -25,7 +26,7 @@ headFile :: Repo -> FilePath headFile r = fromRawFilePath (localGitDir r) "HEAD" setHeadRef :: Ref -> Repo -> IO () -setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref) +setHeadRef ref r = S.writeFile (headFile r) ("ref: " <> fromRef' ref) {- Converts a fully qualified git ref into a user-visible string. -} describe :: Ref -> String @@ -41,10 +42,11 @@ base = removeBase "refs/heads/" . removeBase "refs/remotes/" {- Removes a directory such as "refs/heads/master" from a - fully qualified ref. Any ref not starting with it is left as-is. -} removeBase :: String -> Ref -> Ref -removeBase dir (Ref r) - | prefix `isPrefixOf` r = Ref (drop (length prefix) r) - | otherwise = Ref r +removeBase dir r + | prefix `isPrefixOf` rs = Ref $ encodeBS $ drop (length prefix) rs + | otherwise = r where + rs = fromRef r prefix = case end dir of ['/'] -> dir _ -> dir ++ "/" @@ -53,7 +55,7 @@ removeBase dir (Ref r) - 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) +underBase dir r = Ref $ encodeBS dir <> "/" <> fromRef' (base r) {- Convert a branch such as "master" into a fully qualified ref. -} branchRef :: Branch -> Ref @@ -66,21 +68,25 @@ branchRef = underBase "refs/heads" - of a repo. -} fileRef :: RawFilePath -> Ref -fileRef f = Ref $ ":./" ++ fromRawFilePath f +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 +dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS' d {- A Ref that can be used to refer to a file in the repository as it - appears in a given Ref. -} fileFromRef :: Ref -> RawFilePath -> Ref -fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr) +fileFromRef r f = let (Ref fr) = fileRef f in Ref (fromRef' 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] + [ 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.) -} @@ -107,26 +113,26 @@ sha branch repo = process <$> showref repo ] process s | S.null s = Nothing - | otherwise = Just $ Ref $ decodeBS' $ firstLine' s + | otherwise = 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 +matching = matching' [] {- Includes HEAD in the output, if asked for it. -} matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)] -matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo +matchingWithHEAD = matching' [Param "--head"] -{- List of (shas, branches) matching a given ref spec. -} -matching' :: [String] -> Repo -> IO [(Sha, Branch)] -matching' ps repo = map gen . lines . decodeBS' <$> - pipeReadStrict (Param "show-ref" : map Param ps) repo +matching' :: [CommandParam] -> [Ref] -> Repo -> IO [(Sha, Branch)] +matching' ps rs repo = map gen . S8.lines <$> + pipeReadStrict (Param "show-ref" : ps ++ rps) repo where - gen l = let (r, b) = separate (== ' ') l + gen l = let (r, b) = separate' (== fromIntegral (ord ' ')) l in (Ref r, Ref b) + rps = map (Param . fromRef) rs {- List of (shas, branches) matching a given ref. - Duplicate shas are filtered out. -} @@ -137,7 +143,7 @@ matchingUniq refs repo = nubBy uniqref <$> matching refs repo {- List of all refs. -} list :: Repo -> IO [(Sha, Ref)] -list = matching' [] +list = matching' [] [] {- Deletes a ref. This can delete refs that are not branches, - which git branch --delete refuses to delete. -} @@ -154,13 +160,17 @@ delete oldvalue ref = run - The ref may be something like a branch name, and it could contain - ":subdir" if a subtree is wanted. -} tree :: Ref -> Repo -> IO (Maybe Sha) -tree (Ref ref) = extractSha . decodeBS <$$> pipeReadStrict - [ Param "rev-parse", Param "--verify", Param "--quiet", Param ref' ] +tree (Ref ref) = extractSha <$$> pipeReadStrict + [ Param "rev-parse" + , Param "--verify" + , Param "--quiet" + , Param (decodeBS' ref') + ] where - ref' = if ":" `isInfixOf` ref + ref' = if ":" `S.isInfixOf` ref then ref -- de-reference commit objects to the tree - else ref ++ ":" + else ref <> ":" {- Checks if a String is a legal git ref name. - diff --git a/Git/RefLog.hs b/Git/RefLog.hs index 7ba8713..b98833c 100644 --- a/Git/RefLog.hs +++ b/Git/RefLog.hs @@ -12,6 +12,9 @@ import Git import Git.Command import Git.Sha +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 + {- Gets the reflog for a given branch. -} get :: Branch -> Repo -> IO [Sha] get b = getMulti [b] @@ -21,7 +24,7 @@ getMulti :: [Branch] -> Repo -> IO [Sha] getMulti bs = get' (map (Param . fromRef) bs) get' :: [CommandParam] -> Repo -> IO [Sha] -get' ps = mapMaybe extractSha . lines . decodeBS <$$> pipeReadStrict ps' +get' ps = mapMaybe (extractSha . S.copy) . S8.lines <$$> pipeReadStrict ps' where ps' = catMaybes [ Just $ Param "log" diff --git a/Git/Remote.hs b/Git/Remote.hs index 69d6b52..7c6cfc2 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -84,12 +84,17 @@ parseRemoteLocation s repo = ret $ calcloc s where replacement = decodeBS' $ S.drop (S.length prefix) $ S.take (S.length bestkey - S.length suffix) bestkey - (ConfigKey bestkey, ConfigValue bestvalue) = maximumBy longestvalue insteadofs + (bestkey, bestvalue) = + case maximumBy longestvalue insteadofs of + (ConfigKey k, ConfigValue v) -> (k, v) + (ConfigKey k, NoConfigValue) -> (k, mempty) longestvalue (_, a) (_, b) = compare b a - insteadofs = filterconfig $ \(ConfigKey k, ConfigValue v) -> - prefix `S.isPrefixOf` k && - suffix `S.isSuffixOf` k && - v `S.isPrefixOf` encodeBS l + insteadofs = filterconfig $ \case + (ConfigKey k, ConfigValue v) -> + prefix `S.isPrefixOf` k && + suffix `S.isSuffixOf` k && + v `S.isPrefixOf` encodeBS l + (_, NoConfigValue) -> False filterconfig f = filter f $ concatMap splitconfigs $ M.toList $ fullconfig repo splitconfigs (k, vs) = map (\v -> (k, v)) vs diff --git a/Git/Repair.hs b/Git/Repair.hs index 66e6811..f81aa78 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -122,24 +122,26 @@ retrieveMissingObjects missing referencerepo r ) 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' + | otherwise = case remoteName rmt of + Just n -> do + putStrLn $ "Trying to recover missing objects from remote " ++ n ++ "." + ifM (fetchfrom n 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 + ) + Nothing -> pullremotes tmpr rmts fetchrefs ms + fetchfrom loc ps fetchr = runBool ps' fetchr' where ps' = [ Param "fetch" - , Param fetchurl + , Param loc , Param "--force" , Param "--update-head-ok" , Param "--quiet" @@ -232,7 +234,7 @@ getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) "refs") getAllRefs' :: FilePath -> IO [Ref] getAllRefs' refdir = do let topsegs = length (splitPath refdir) - 1 - let toref = Ref . joinPath . drop topsegs . splitPath + let toref = Ref . encodeBS' . joinPath . drop topsegs . splitPath map toref <$> dirContentsRecursive refdir explodePackedRefsFile :: Repo -> IO () @@ -245,8 +247,9 @@ explodePackedRefsFile r = do nukeFile f where makeref (sha, ref) = do - let dest = fromRawFilePath (localGitDir r) fromRef ref - createDirectoryIfMissing True (parentDir dest) + let gitd = fromRawFilePath (localGitDir r) + let dest = gitd fromRef ref + createDirectoryUnder gitd (parentDir dest) unlessM (doesFileExist dest) $ writeFile dest (fromRef sha) @@ -256,8 +259,8 @@ packedRefsFile r = fromRawFilePath (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) + | isJust (extractSha (encodeBS' sha)) && Ref.legal True ref -> + Just (Ref (encodeBS' sha), Ref (encodeBS' ref)) _ -> Nothing {- git-branch -d cannot be used to remove a branch that is directly @@ -278,13 +281,13 @@ findUncorruptedCommit missing goodcommits branch r = do if ok then return (Just branch, goodcommits') else do - (ls, cleanup) <- pipeNullSplit + (ls, cleanup) <- pipeNullSplit' [ Param "log" , Param "-z" , Param "--format=%H" , Param (fromRef branch) ] r - let branchshas = catMaybes $ map (extractSha . decodeBL) ls + 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 @@ -327,8 +330,8 @@ verifyCommit missing goodcommits commit r where parse l = case words l of (commitsha:treesha:[]) -> (,) - <$> extractSha commitsha - <*> extractSha treesha + <$> extractSha (encodeBS' commitsha) + <*> extractSha (encodeBS' treesha) _ -> Nothing check [] = return True check ((c, t):rest) @@ -447,7 +450,8 @@ preRepair g = do void $ tryIO $ allowWrite f where headfile = fromRawFilePath (localGitDir g) "HEAD" - validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s) + validhead s = "ref: refs/" `isPrefixOf` s + || isJust (extractSha (encodeBS' s)) {- Put it all together. -} runRepair :: (Ref -> Bool) -> Bool -> Repo -> IO (Bool, [Branch]) diff --git a/Git/Sha.hs b/Git/Sha.hs index cc33cac..a66c34e 100644 --- a/Git/Sha.hs +++ b/Git/Sha.hs @@ -1,43 +1,74 @@ {- git SHA stuff - - - Copyright 2011 Joey Hess + - Copyright 2011,2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Sha where import Common import Git.Types +import qualified Data.ByteString as S +import Data.Char + {- 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 :: String -> IO S.ByteString -> 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 +{- Extracts the Sha from a ByteString. + - + - There can be a trailing newline after it, but nothing else. + -} +extractSha :: S.ByteString -> Maybe Sha extractSha s - | len == shaSize = val s - | len == shaSize + 1 && length s' == shaSize = val s' + | len `elem` shaSizes = val s + | len - 1 `elem` shaSizes && S.length s' == len - 1 = val s' | otherwise = Nothing where - len = length s - s' = firstLine s + len = S.length s + s' = firstLine' s val v - | all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v + | S.all validinsha v = Just $ Ref v | otherwise = Nothing + validinsha w = or + [ w >= 48 && w <= 57 -- 0-9 + , w >= 97 && w <= 102 -- a-f + , w >= 65 && w <= 70 -- A-F + ] -{- Size of a git sha. -} -shaSize :: Int -shaSize = 40 +{- Sizes of git shas. -} +shaSizes :: [Int] +shaSizes = + [ 40 -- sha1 (must come first) + , 64 -- sha256 + ] -nullSha :: Ref -nullSha = Ref $ replicate shaSize '0' +{- Git plumbing often uses a all 0 sha to represent things like a + - deleted file. -} +nullShas :: [Sha] +nullShas = map (\n -> Ref (S.replicate n zero)) shaSizes + where + zero = fromIntegral (ord '0') -{- Git's magic empty tree. -} +{- Sha to provide to git plumbing when deleting a file. + - + - It's ok to provide a sha1; git versions that use sha256 will map the + - sha1 to the sha256, or probably just treat all null sha1 specially + - the same as all null sha256. -} +deleteSha :: Sha +deleteSha = Prelude.head nullShas + +{- Git's magic empty tree. + - + - It's ok to provide the sha1 of this to git to refer to an empty tree; + - git versions that use sha256 will map the sha1 to the sha256. + -} emptyTree :: Ref emptyTree = Ref "4b825dc642cb6eb9a060e54bf8d69288fbee4904" diff --git a/Git/Types.hs b/Git/Types.hs index 9c2754a..4bf61e5 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -1,12 +1,11 @@ {- git data types - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Git.Types where @@ -18,6 +17,8 @@ import qualified Data.ByteString as S import System.Posix.Types import Utility.SafeCommand import Utility.FileSystemEncoding +import qualified Data.Semigroup as Sem +import Prelude {- Support repositories on local disk, and repositories accessed via an URL. - @@ -54,8 +55,20 @@ data Repo = Repo newtype ConfigKey = ConfigKey S.ByteString deriving (Ord, Eq) -newtype ConfigValue = ConfigValue S.ByteString - deriving (Ord, Eq, Semigroup, Monoid) +data ConfigValue + = ConfigValue S.ByteString + | NoConfigValue + -- ^ git treats a setting with no value as different than a setting + -- with an empty value + deriving (Ord, Eq) + +instance Sem.Semigroup ConfigValue where + ConfigValue a <> ConfigValue b = ConfigValue (a <> b) + a <> NoConfigValue = a + NoConfigValue <> b = b + +instance Monoid ConfigValue where + mempty = ConfigValue mempty instance Default ConfigValue where def = ConfigValue mempty @@ -68,6 +81,7 @@ instance Show ConfigKey where fromConfigValue :: ConfigValue -> String fromConfigValue (ConfigValue s) = decodeBS' s +fromConfigValue NoConfigValue = mempty instance Show ConfigValue where show = fromConfigValue @@ -81,11 +95,14 @@ instance IsString ConfigValue where type RemoteName = String {- A git ref. Can be a sha1, or a branch or tag name. -} -newtype Ref = Ref String +newtype Ref = Ref S.ByteString deriving (Eq, Ord, Read, Show) fromRef :: Ref -> String -fromRef (Ref s) = s +fromRef = decodeBS' . fromRef' + +fromRef' :: Ref -> S.ByteString +fromRef' (Ref s) = s {- Aliases for Ref. -} type Branch = Ref @@ -98,6 +115,7 @@ newtype RefDate = RefDate String {- Types of objects that can be stored in git. -} data ObjectType = BlobObject | CommitObject | TreeObject + deriving (Show) readObjectType :: S.ByteString -> Maybe ObjectType readObjectType "blob" = Just BlobObject diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 9f07cf5..f0331d5 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -75,14 +75,14 @@ lsTree (Ref x) repo streamer = do mapM_ streamer s void $ cleanup where - params = map Param ["ls-tree", "-z", "-r", "--full-tree", x] + params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS' 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] + params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS' x, p] {- Generates a line suitable to be fed into update-index, to add - a given file with a given sha. -} @@ -90,7 +90,7 @@ updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> L.ByteString updateIndexLine sha treeitemtype file = L.fromStrict $ fmtTreeItemType treeitemtype <> " blob " - <> encodeBS (fromRef sha) + <> fromRef' sha <> "\t" <> indexPath file @@ -108,7 +108,7 @@ unstageFile file repo = do unstageFile' :: TopFilePath -> Streamer unstageFile' p = pureStreamer $ L.fromStrict $ "0 " - <> encodeBS' (fromRef nullSha) + <> fromRef' deleteSha <> "\t" <> indexPath p -- cgit v1.2.3