summaryrefslogtreecommitdiff
path: root/Git
diff options
context:
space:
mode:
authorJoey Hess <joeyh@joeyh.name>2020-01-02 12:34:10 -0400
committerJoey Hess <joeyh@joeyh.name>2020-01-02 12:42:57 -0400
commit9df8a6eb9405dde4464d27133c04f5ee539a85de (patch)
tree8a7ac5f52be8679f8a2525515a0b2c1b715c99ad /Git
parent16022a8b98f4bc134542e78a42538364d2f97d92 (diff)
downloadgit-repair-9df8a6eb9405dde4464d27133c04f5ee539a85de.tar.gz
merge from git-annex and relicense accordingly
Merge git library and utility from git-annex. The former is now relicensed AGPL, so git-repair as a whole becomes AGPL. For simplicity, I am relicensing the remainder of the code in git-repair AGPL as well, per the header changes in this commit. While that code is also technically available under the GPL license, as it's been released under that license before, changes going forward will be only released by me under the AGPL.
Diffstat (limited to 'Git')
-rw-r--r--Git/Branch.hs32
-rw-r--r--Git/BuildVersion.hs2
-rw-r--r--Git/CatFile.hs107
-rw-r--r--Git/Command.hs55
-rw-r--r--Git/Config.hs115
-rw-r--r--Git/Construct.hs40
-rw-r--r--Git/CurrentRepo.hs44
-rw-r--r--Git/Destroyer.hs4
-rw-r--r--Git/DiffTreeItem.hs2
-rw-r--r--Git/FilePath.hs55
-rw-r--r--Git/Filename.hs53
-rw-r--r--Git/Fsck.hs61
-rw-r--r--Git/HashObject.hs76
-rw-r--r--Git/Index.hs32
-rw-r--r--Git/LsFiles.hs146
-rw-r--r--Git/LsTree.hs85
-rw-r--r--Git/Objects.hs4
-rw-r--r--Git/Ref.hs64
-rw-r--r--Git/RefLog.hs4
-rw-r--r--Git/Remote.hs33
-rw-r--r--Git/Repair.hs38
-rw-r--r--Git/Sha.hs2
-rw-r--r--Git/Types.hs119
-rw-r--r--Git/UpdateIndex.hs71
-rw-r--r--Git/Url.hs10
-rw-r--r--Git/Version.hs2
26 files changed, 825 insertions, 431 deletions
diff --git a/Git/Branch.hs b/Git/Branch.hs
index 875f20f..699fbf5 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -2,10 +2,11 @@
-
- Copyright 2011 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
module Git.Branch where
@@ -15,13 +16,14 @@ import Git.Sha
import Git.Command
import qualified Git.Config
import qualified Git.Ref
-import qualified Git.BuildVersion
+
+import qualified Data.ByteString as B
{- The currently checked out branch.
-
- In a just initialized git repo before the first commit,
- symbolic-ref will show the master branch, even though that
- - branch is not created yet. So, this also looks at show-ref HEAD
+ - branch is not created yet. So, this also looks at show-ref
- to double-check.
-}
current :: Repo -> IO (Maybe Branch)
@@ -30,19 +32,19 @@ current r = do
case v of
Nothing -> return Nothing
Just branch ->
- ifM (null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r)
+ ifM (B.null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r)
( return Nothing
, return v
)
{- The current branch, which may not really exist yet. -}
currentUnsafe :: Repo -> IO (Maybe Branch)
-currentUnsafe r = parse . firstLine
+currentUnsafe r = parse . firstLine'
<$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r
where
- parse l
- | null l = Nothing
- | otherwise = Just $ Git.Ref l
+ parse b
+ | B.null b = Nothing
+ | otherwise = Just $ Git.Ref $ decodeBS b
{- Checks if the second branch has any commits not present on the first
- branch. -}
@@ -54,7 +56,8 @@ changed origbranch newbranch repo
where
changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String
-changed' origbranch newbranch extraps repo = pipeReadStrict ps repo
+changed' origbranch newbranch extraps repo =
+ decodeBS <$> pipeReadStrict ps repo
where
ps =
[ Param "log"
@@ -73,7 +76,7 @@ changedCommits origbranch newbranch extraps repo =
-
- This requires there to be a path from the old to the new. -}
fastForwardable :: Ref -> Ref -> Repo -> IO Bool
-fastForwardable old new repo = not . null <$>
+fastForwardable old new repo = not . B.null <$>
pipeReadStrict
[ Param "log"
, Param $ fromRef old ++ ".." ++ fromRef new
@@ -125,8 +128,7 @@ data CommitMode = ManualCommit | AutomaticCommit
{- 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
+ | commitmode == AutomaticCommit = Param "--no-gpg-sign" : ps
| otherwise = ps
{- Some versions of git commit-tree honor commit.gpgsign themselves,
@@ -134,8 +136,8 @@ applyCommitMode commitmode ps
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 ->
+ case Git.Config.getMaybe "commit.gpgsign" r of
+ Just s | Git.Config.isTrueFalse' s == Just True ->
Param "-S":ps
_ -> ps'
| otherwise = ps'
@@ -162,7 +164,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" $
- pipeReadStrict [Param "write-tree"] repo
+ decodeBS' <$> pipeReadStrict [Param "write-tree"] repo
ifM (cancommit tree)
( do
sha <- commitTree commitmode message parentrefs tree repo
diff --git a/Git/BuildVersion.hs b/Git/BuildVersion.hs
index 7d1c53a..f94a892 100644
--- a/Git/BuildVersion.hs
+++ b/Git/BuildVersion.hs
@@ -2,7 +2,7 @@
-
- Copyright 2011 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
module Git.BuildVersion where
diff --git a/Git/CatFile.hs b/Git/CatFile.hs
index ba68c4e..6402001 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -1,8 +1,8 @@
{- git cat-file interface
-
- - Copyright 2011-2016 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
module Git.CatFile (
@@ -28,20 +28,23 @@ import Data.String
import Data.Char
import Numeric
import System.Posix.Types
+import Text.Read
import Common
import Git
import Git.Sha
+import qualified Git.Ref
import Git.Command
import Git.Types
import Git.FilePath
+import Git.HashObject
import qualified Utility.CoProcess as CoProcess
-import Utility.FileSystemEncoding
import Utility.Tuple
data CatFileHandle = CatFileHandle
{ catFileProcess :: CoProcess.CoProcessHandle
, checkFileProcess :: CoProcess.CoProcessHandle
+ , gitRepo :: Repo
}
catFileStart :: Repo -> IO CatFileHandle
@@ -51,6 +54,7 @@ catFileStart' :: Bool -> Repo -> IO CatFileHandle
catFileStart' restartable repo = CatFileHandle
<$> startp "--batch"
<*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)"
+ <*> pure repo
where
startp p = gitCoProcessStart restartable
[ Param "cat-file"
@@ -63,13 +67,13 @@ catFileStop h = do
CoProcess.stop (checkFileProcess h)
{- Reads a file from a specified branch. -}
-catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString
+catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString
catFile h branch file = catObject h $ Ref $
- fromRef branch ++ ":" ++ toInternalGitPath file
+ fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file)
-catFileDetails :: CatFileHandle -> Branch -> FilePath -> IO (Maybe (L.ByteString, Sha, ObjectType))
+catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType))
catFileDetails h branch file = catObjectDetails h $ Ref $
- fromRef branch ++ ":" ++ toInternalGitPath file
+ fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file)
{- Uses a running git cat-file read the content of an object.
- Objects that do not exist will have "" returned. -}
@@ -77,7 +81,7 @@ 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 h object = query (catFileProcess h) object $ \from -> do
+catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \from -> do
header <- hGetLine from
case parseResp object header of
Just (ParsedResp sha size objtype) -> do
@@ -91,23 +95,53 @@ catObjectDetails h object = query (catFileProcess h) object $ \from -> do
c <- hGetChar from
when (c /= expected) $
error $ "missing " ++ (show expected) ++ " from git cat-file"
+
+ -- Slow fallback path for filenames containing newlines.
+ newlinefallback = queryObjectType object (gitRepo h) >>= \case
+ Nothing -> return Nothing
+ Just objtype -> queryContent object (gitRepo h) >>= \case
+ Nothing -> return Nothing
+ Just content -> do
+ -- only the --batch interface allows getting
+ -- the sha, so have to re-hash the object
+ sha <- hashObject' objtype
+ (flip L.hPut content)
+ (gitRepo h)
+ return (Just (content, sha, objtype))
{- 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
+catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType))
+catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do
resp <- hGetLine from
case parseResp object resp of
- Just (ParsedResp _ size objtype) ->
- return $ Just (size, objtype)
+ Just (ParsedResp sha size objtype) ->
+ return $ Just (sha, size, objtype)
Just DNE -> return Nothing
Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object)
+ where
+ -- Slow fallback path for filenames containing newlines.
+ newlinefallback = do
+ sha <- Git.Ref.sha object (gitRepo h)
+ sz <- querySize object (gitRepo h)
+ objtype <- queryObjectType object (gitRepo h)
+ return $ (,,) <$> sha <*> sz <*> objtype
-data ParsedResp = ParsedResp Sha Integer ObjectType | DNE
+data ParsedResp = ParsedResp Sha FileSize ObjectType | DNE
-query :: CoProcess.CoProcessHandle -> Ref -> (Handle -> IO a) -> IO a
-query hdl object receive = CoProcess.query hdl send receive
+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
+ -- 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
+ | otherwise = CoProcess.query hdl send receive
where
- send to = hPutStrLn to (fromRef object)
+ send to = hPutStrLn to s
+ s = fromRef object
parseResp :: Ref -> String -> Maybe ParsedResp
parseResp object l
@@ -116,13 +150,50 @@ parseResp object l
| otherwise = case words l of
[sha, objtype, size]
| length sha == shaSize ->
- case (readObjectType objtype, reads size) of
+ case (readObjectType (encodeBS objtype), reads size) of
(Just t, [(bytes, "")]) ->
Just $ ParsedResp (Ref sha) bytes t
_ -> Nothing
| otherwise -> Nothing
_ -> Nothing
+querySingle :: CommandParam -> Ref -> Repo -> (Handle -> IO a) -> IO (Maybe a)
+querySingle o r repo reader = assertLocal repo $
+ -- In non-batch mode, git cat-file warns on stderr when
+ -- asked for an object that does not exist.
+ -- Squelch that warning to behave the same as batch mode.
+ withNullHandle $ \nullh -> do
+ let p = gitCreateProcess
+ [ Param "cat-file"
+ , o
+ , Param (fromRef r)
+ ] repo
+ let p' = p
+ { std_err = UseHandle nullh
+ , std_in = Inherit
+ , std_out = CreatePipe
+ }
+ pid <- createProcess p'
+ let h = stdoutHandle pid
+ output <- reader h
+ hClose h
+ ifM (checkSuccessProcess (processHandle pid))
+ ( return (Just output)
+ , return Nothing
+ )
+
+querySize :: Ref -> Repo -> IO (Maybe FileSize)
+querySize r repo = maybe Nothing (readMaybe . takeWhile (/= '\n'))
+ <$> querySingle (Param "-s") r repo hGetContentsStrict
+
+queryObjectType :: Ref -> Repo -> IO (Maybe ObjectType)
+queryObjectType r repo = maybe Nothing (readObjectType . encodeBS . takeWhile (/= '\n'))
+ <$> querySingle (Param "-t") r repo hGetContentsStrict
+
+queryContent :: Ref -> Repo -> IO (Maybe L.ByteString)
+queryContent r repo = fmap (\b -> L.fromChunks [b])
+ <$> querySingle (Param "-p") r repo S.hGetContents
+
{- 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
@@ -141,7 +212,7 @@ catTree h treeref = go <$> catObjectDetails h treeref
dropsha = L.drop 21
parsemodefile b =
- let (modestr, file) = separate (== ' ') (decodeBS b)
+ let (modestr, file) = separate (== ' ') (decodeBL b)
in (file, readmode modestr)
readmode = fromMaybe 0 . fmap fst . headMaybe . readOct
diff --git a/Git/Command.hs b/Git/Command.hs
index f40dfab..eb20af2 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -2,7 +2,7 @@
-
- Copyright 2010-2013 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
@@ -14,6 +14,9 @@ import Git
import Git.Types
import qualified Utility.CoProcess as CoProcess
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString as S
+
{- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
gitCommandLine params r@(Repo { location = l@(Local { } ) }) =
@@ -21,10 +24,10 @@ gitCommandLine params r@(Repo { location = l@(Local { } ) }) =
where
setdir
| gitEnvOverridesGitDir r = []
- | otherwise = [Param $ "--git-dir=" ++ gitdir l]
+ | otherwise = [Param $ "--git-dir=" ++ fromRawFilePath (gitdir l)]
settree = case worktree l of
Nothing -> []
- Just t -> [Param $ "--work-tree=" ++ t]
+ Just t -> [Param $ "--work-tree=" ++ fromRawFilePath t]
gitCommandLine _ repo = assertLocal repo $ error "internal"
{- Runs git in the specified repo. -}
@@ -47,13 +50,13 @@ runQuiet params repo = withQuietOutput createProcessSuccess $
{- Runs a git command and returns its output, lazily.
-
- Also returns an action that should be used when the output is all
- - read (or no more is needed), that will wait on the command, and
+ - read, that will wait on the command, and
- return True if it succeeded. Failure to wait will result in zombies.
-}
-pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool)
+pipeReadLazy :: [CommandParam] -> Repo -> IO (L.ByteString, IO Bool)
pipeReadLazy params repo = assertLocal repo $ do
(_, Just h, _, pid) <- createProcess p { std_out = CreatePipe }
- c <- hGetContents h
+ c <- L.hGetContents h
return (c, checkSuccessProcess pid)
where
p = gitCreateProcess params repo
@@ -62,10 +65,14 @@ pipeReadLazy params repo = assertLocal repo $ do
-
- Nonzero exit status is ignored.
-}
-pipeReadStrict :: [CommandParam] -> Repo -> IO String
-pipeReadStrict params repo = assertLocal repo $
+pipeReadStrict :: [CommandParam] -> Repo -> IO S.ByteString
+pipeReadStrict = pipeReadStrict' S.hGetContents
+
+{- The reader action must be strict. -}
+pipeReadStrict' :: (Handle -> IO a) -> [CommandParam] -> Repo -> IO a
+pipeReadStrict' reader params repo = assertLocal repo $
withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do
- output <- hGetContentsStrict h
+ output <- reader h
hClose h
return output
where
@@ -83,28 +90,36 @@ pipeWriteRead params writer repo = assertLocal repo $
{- Runs a git command, feeding it input on a handle with an action. -}
pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO ()
-pipeWrite params repo = withHandle StdinHandle createProcessSuccess $
- gitCreateProcess params repo
+pipeWrite params repo = assertLocal repo $
+ withHandle StdinHandle createProcessSuccess $
+ gitCreateProcess params repo
{- Reads null terminated output of a git command (as enabled by the -z
- parameter), and splits it. -}
-pipeNullSplit :: [CommandParam] -> Repo -> IO ([String], IO Bool)
+pipeNullSplit :: [CommandParam] -> Repo -> IO ([L.ByteString], IO Bool)
pipeNullSplit params repo = do
(s, cleanup) <- pipeReadLazy params repo
- return (filter (not . null) $ splitc sep s, cleanup)
- where
- sep = '\0'
+ return (filter (not . L.null) $ L.split 0 s, cleanup)
-pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [String]
+{- Reads lazily, but copies each part to a strict ByteString for
+ - convenience.
+ -}
+pipeNullSplit' :: [CommandParam] -> Repo -> IO ([S.ByteString], IO Bool)
+pipeNullSplit' params repo = do
+ (s, cleanup) <- pipeNullSplit params repo
+ return (map L.toStrict s, cleanup)
+
+pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [S.ByteString]
pipeNullSplitStrict params repo = do
s <- pipeReadStrict params repo
- return $ filter (not . null) $ splitc sep s
- where
- sep = '\0'
+ return $ filter (not . S.null) $ S.split 0 s
-pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String]
+pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [L.ByteString]
pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo
+pipeNullSplitZombie' :: [CommandParam] -> Repo -> IO [S.ByteString]
+pipeNullSplitZombie' params repo = leaveZombie <$> pipeNullSplit' params repo
+
{- Doesn't run the cleanup action. A zombie results. -}
leaveZombie :: (a, IO Bool) -> a
leaveZombie = fst
diff --git a/Git/Config.hs b/Git/Config.hs
index 9b4c342..4b60664 100644
--- a/Git/Config.hs
+++ b/Git/Config.hs
@@ -1,32 +1,37 @@
{- git repository configuration handling
-
- - Copyright 2010-2012 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Git.Config where
import qualified Data.Map as M
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as S8
import Data.Char
+import qualified System.FilePath.ByteString as P
import Common
import Git
import Git.Types
-import qualified Git.Construct
import qualified Git.Command
+import qualified Git.Construct
import Utility.UserInfo
-{- Returns a single git config setting, or a default value if not set. -}
-get :: String -> String -> Repo -> String
-get key defaultValue repo = M.findWithDefault defaultValue key (config repo)
+{- Returns a single git config setting, or a fallback value if not set. -}
+get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue
+get key fallback repo = M.findWithDefault fallback key (config repo)
-{- Returns a list with each line of a multiline config setting. -}
-getList :: String -> Repo -> [String]
+{- Returns a list of values. -}
+getList :: ConfigKey -> Repo -> [ConfigValue]
getList key repo = M.findWithDefault [] key (fullconfig repo)
{- Returns a single git config setting, if set. -}
-getMaybe :: String -> Repo -> Maybe String
+getMaybe :: ConfigKey -> Repo -> Maybe ConfigValue
getMaybe key repo = M.lookup key (config repo)
{- Runs git config and populates a repo with its config.
@@ -57,7 +62,7 @@ read' repo = go repo
where
params = ["config", "--null", "--list"]
p = (proc "git" params)
- { cwd = Just d
+ { cwd = Just (fromRawFilePath d)
, env = gitEnv repo
}
@@ -79,22 +84,28 @@ global = do
{- Reads git config from a handle and populates a repo with it. -}
hRead :: Repo -> Handle -> IO Repo
hRead repo h = do
- val <- hGetContentsStrict h
+ val <- S.hGetContents h
store val repo
{- Stores a git config into a Repo, returning the new version of the Repo.
- The git config may be multiple lines, or a single line.
- Config settings can be updated incrementally.
-}
-store :: String -> Repo -> IO Repo
+store :: S.ByteString -> Repo -> IO Repo
store s repo = do
let c = parse s
- repo' <- updateLocation $ repo
+ updateLocation $ repo
{ config = (M.map Prelude.head c) `M.union` config repo
, fullconfig = M.unionWith (++) c (fullconfig repo)
}
- rs <- Git.Construct.fromRemotes repo'
- return $ repo' { remotes = rs }
+
+{- Stores a single config setting in a Repo, returning the new version of
+ - the Repo. Config settings can be updated incrementally. -}
+store' :: ConfigKey -> ConfigValue -> Repo -> Repo
+store' k v repo = repo
+ { config = M.singleton k v `M.union` config repo
+ , fullconfig = M.unionWith (++) (M.singleton k [v]) (fullconfig repo)
+ }
{- Updates the location of a repo, based on its configuration.
-
@@ -104,13 +115,13 @@ store s repo = do
-}
updateLocation :: Repo -> IO Repo
updateLocation r@(Repo { location = LocalUnknown d })
- | isBare r = ifM (doesDirectoryExist dotgit)
+ | isBare r = ifM (doesDirectoryExist (fromRawFilePath dotgit))
( updateLocation' r $ Local dotgit Nothing
, updateLocation' r $ Local d Nothing
)
| otherwise = updateLocation' r $ Local dotgit (Just d)
where
- dotgit = (d </> ".git")
+ dotgit = d P.</> ".git"
updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l
updateLocation r = return r
@@ -118,52 +129,66 @@ updateLocation' :: Repo -> RepoLocation -> IO Repo
updateLocation' r l = do
l' <- case getMaybe "core.worktree" r of
Nothing -> return l
- Just d -> do
+ Just (ConfigValue d) -> do
{- core.worktree is relative to the gitdir -}
- top <- absPath $ gitdir l
- return $ l { worktree = Just $ absPathFrom top d }
+ top <- absPath $ fromRawFilePath (gitdir l)
+ let p = absPathFrom top (fromRawFilePath d)
+ return $ l { worktree = Just (toRawFilePath p) }
return $ r { location = l' }
{- Parses git config --list or git config --null --list output into a
- config map. -}
-parse :: String -> M.Map String [String]
-parse [] = M.empty
+parse :: S.ByteString -> M.Map ConfigKey [ConfigValue]
parse s
- -- --list output will have an = in the first line
- | all ('=' `elem`) (take 1 ls) = sep '=' ls
+ | 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 '\n' $ splitc '\0' s
+ | otherwise = sep nl $ S.split 0 s
where
- ls = lines s
- sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .
- map (separate (== c))
+ 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 (S.break (== c))
-{- Checks if a string from git config is a true value. -}
-isTrue :: String -> Maybe Bool
-isTrue s
+{- Checks if a string from git config is a true/false value. -}
+isTrueFalse :: String -> Maybe Bool
+isTrueFalse = isTrueFalse' . ConfigValue . encodeBS'
+
+isTrueFalse' :: ConfigValue -> Maybe Bool
+isTrueFalse' (ConfigValue s)
| s' == "true" = Just True
| s' == "false" = Just False
| otherwise = Nothing
where
- s' = map toLower s
+ s' = S8.map toLower s
boolConfig :: Bool -> String
boolConfig True = "true"
boolConfig False = "false"
+boolConfig' :: Bool -> S.ByteString
+boolConfig' True = "true"
+boolConfig' False = "false"
+
isBare :: Repo -> Bool
-isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r
+isBare r = fromMaybe False $ isTrueFalse' =<< getMaybe coreBare r
-coreBare :: String
+coreBare :: ConfigKey
coreBare = "core.bare"
{- Runs a command to get the configuration of a repo,
- and returns a repo populated with the configuration, as well as the raw
- output of the command. -}
-fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String))
+fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, S.ByteString))
fromPipe r cmd params = try $
withHandle StdoutHandle createProcessSuccess p $ \h -> do
- val <- hGetContentsStrict h
+ val <- S.hGetContents h
r' <- store val r
return (r', val)
where
@@ -171,7 +196,7 @@ fromPipe r cmd params = try $
{- Reads git config from a specified file and returns the repo populated
- with the configuration. -}
-fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String))
+fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString))
fromFile r f = fromPipe r "git"
[ Param "config"
, Param "--file"
@@ -181,13 +206,13 @@ fromFile r f = fromPipe r "git"
{- Changes a git config setting in the specified config file.
- (Creates the file if it does not already exist.) -}
-changeFile :: FilePath -> String -> String -> IO Bool
-changeFile f k v = boolSystem "git"
+changeFile :: FilePath -> ConfigKey -> S.ByteString -> IO Bool
+changeFile f (ConfigKey k) v = boolSystem "git"
[ Param "config"
, Param "--file"
, File f
- , Param k
- , Param v
+ , Param (decodeBS' k)
+ , Param (decodeBS' v)
]
{- Unsets a git config setting, in both the git repo,
@@ -196,10 +221,10 @@ changeFile f k v = boolSystem "git"
- If unsetting the config fails, including in a read-only repo, or
- when the config is not set, returns Nothing.
-}
-unset :: String -> Repo -> IO (Maybe Repo)
-unset k r = ifM (Git.Command.runBool ps r)
- ( return $ Just $ r { config = M.delete k (config r) }
+unset :: ConfigKey -> Repo -> IO (Maybe Repo)
+unset ck@(ConfigKey k) r = ifM (Git.Command.runBool ps r)
+ ( return $ Just $ r { config = M.delete ck (config r) }
, return Nothing
)
where
- ps = [Param "config", Param "--unset-all", Param k]
+ ps = [Param "config", Param "--unset-all", Param (decodeBS' k)]
diff --git a/Git/Construct.hs b/Git/Construct.hs
index 4ad74fd..5b656eb 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -2,7 +2,7 @@
-
- Copyright 2010-2012 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
@@ -58,11 +58,11 @@ fromPath dir = fromAbsPath =<< absPath dir
- specified. -}
fromAbsPath :: FilePath -> IO Repo
fromAbsPath dir
- | absoluteGitPath dir = hunt
+ | absoluteGitPath (encodeBS dir) = hunt
| otherwise =
error $ "internal error, " ++ dir ++ " is not absolute"
where
- ret = pure . newFrom . LocalUnknown
+ ret = pure . newFrom . LocalUnknown . toRawFilePath
canondir = dropTrailingPathSeparator dir
{- When dir == "foo/.git", git looks for "foo/.git/.git",
- and failing that, uses "foo" as the repository. -}
@@ -117,7 +117,7 @@ localToUrl reference r
[ Url.scheme reference
, "//"
, auth
- , repoPath r
+ , fromRawFilePath (repoPath r)
]
in r { location = Url $ fromJust $ parseURI absurl }
@@ -127,9 +127,8 @@ fromRemotes repo = mapM construct remotepairs
where
filterconfig f = filter f $ M.toList $ config repo
filterkeys f = filterconfig (\(k,_) -> f k)
- remotepairs = filterkeys isremote
- isremote k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k
- construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo
+ remotepairs = filterkeys isRemoteKey
+ construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (fromConfigValue v) repo)
{- Sets the name of a remote when constructing the Repo to represent it. -}
remoteNamed :: String -> IO Repo -> IO Repo
@@ -139,11 +138,8 @@ remoteNamed n constructor = do
{- Sets the name of a remote based on the git config key, such as
- "remote.foo.url". -}
-remoteNamedFromKey :: String -> IO Repo -> IO Repo
-remoteNamedFromKey k = remoteNamed basename
- where
- basename = intercalate "." $
- reverse $ drop 1 $ reverse $ drop 1 $ splitc '.' k
+remoteNamedFromKey :: ConfigKey -> IO Repo -> IO Repo
+remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName
{- Constructs a new Repo for one of a Repo's remotes using a given
- location (ie, an url). -}
@@ -158,7 +154,7 @@ fromRemoteLocation s repo = gen $ parseRemoteLocation s repo
fromRemotePath :: FilePath -> Repo -> IO Repo
fromRemotePath dir repo = do
dir' <- expandTilde dir
- fromPath $ repoPath repo </> dir'
+ fromPath $ fromRawFilePath (repoPath repo) </> dir'
{- Git remotes can have a directory that is specified relative
- to the user's home directory, or that contains tilde expansions.
@@ -208,20 +204,29 @@ checkForRepo dir =
where
check test cont = maybe cont (return . Just) =<< test
checkdir c = ifM c
- ( return $ Just $ LocalUnknown dir
+ ( return $ Just $ LocalUnknown $ toRawFilePath dir
, return Nothing
)
- isRepo = checkdir $ gitSignature $ ".git" </> "config"
+ isRepo = checkdir $
+ gitSignature (".git" </> "config")
+ <||>
+ -- A git-worktree lacks .git/config, but has .git/commondir.
+ -- (Normally the .git is a file, not a symlink, but it can
+ -- be converted to a symlink and git will still work;
+ -- this handles that case.)
+ gitSignature (".git" </> "gitdir")
isBareRepo = checkdir $ gitSignature "config"
<&&> doesDirectoryExist (dir </> "objects")
gitDirFile = do
+ -- git-submodule, git-worktree, and --separate-git-dir
+ -- make .git be a file pointing to the real git directory.
c <- firstLine <$>
catchDefaultIO "" (readFile $ dir </> ".git")
return $ if gitdirprefix `isPrefixOf` c
then Just $ Local
- { gitdir = absPathFrom dir $
+ { gitdir = toRawFilePath $ absPathFrom dir $
drop (length gitdirprefix) c
- , worktree = Just dir
+ , worktree = Just (toRawFilePath dir)
}
else Nothing
where
@@ -233,7 +238,6 @@ newFrom l = Repo
{ location = l
, config = M.empty
, fullconfig = M.empty
- , remotes = []
, remoteName = Nothing
, gitEnv = Nothing
, gitEnvOverridesGitDir = False
diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs
index 69a679e..054a81e 100644
--- a/Git/CurrentRepo.hs
+++ b/Git/CurrentRepo.hs
@@ -2,7 +2,7 @@
-
- Copyright 2012 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
module Git.CurrentRepo where
@@ -12,6 +12,7 @@ import Git.Types
import Git.Construct
import qualified Git.Config
import Utility.Env
+import Utility.Env.Set
{- Gets the current git repository.
-
@@ -24,12 +25,20 @@ import Utility.Env
- directory if necessary to ensure it is within the repository's work
- tree. While not needed for git commands, this is useful for anything
- else that looks for files in the worktree.
+ -
+ - Also works around a git bug when running some hooks. It
+ - runs the hooks in the top of the repository, but if GIT_WORK_TREE
+ - was relative (but not "."), it then points to the wrong directory.
+ - In this situation GIT_PREFIX contains the directory that
+ - GIT_WORK_TREE is relative to.
-}
get :: IO Repo
get = do
- gd <- pathenv "GIT_DIR"
+ gd <- getpathenv "GIT_DIR"
r <- configure gd =<< fromCwd
- wt <- maybe (worktree $ location r) Just <$> pathenv "GIT_WORK_TREE"
+ prefix <- getpathenv "GIT_PREFIX"
+ wt <- maybe (fromRawFilePath <$> worktree (location r)) Just
+ <$> getpathenvprefix "GIT_WORK_TREE" prefix
case wt of
Nothing -> return r
Just d -> do
@@ -38,22 +47,39 @@ get = do
setCurrentDirectory d
return $ addworktree wt r
where
- pathenv s = do
+ getpathenv s = do
v <- getEnv s
case v of
Just d -> do
unsetEnv s
- Just <$> absPath d
+ return (Just d)
+ Nothing -> return Nothing
+
+ getpathenvprefix s (Just prefix) | not (null prefix) =
+ getpathenv s >>= \case
Nothing -> return Nothing
+ Just d
+ | d == "." -> return (Just d)
+ | otherwise -> Just <$> absPath (prefix </> d)
+ getpathenvprefix s _ = getpathenv s
configure Nothing (Just r) = Git.Config.read r
configure (Just d) _ = do
absd <- absPath d
curr <- getCurrentDirectory
- Git.Config.read $ newFrom $
- Local { gitdir = absd, worktree = Just curr }
+ r <- Git.Config.read $ newFrom $
+ Local
+ { gitdir = toRawFilePath absd
+ , worktree = Just (toRawFilePath curr)
+ }
+ return $ if Git.Config.isBare r
+ then r { location = (location r) { worktree = Nothing } }
+ else r
+
configure Nothing Nothing = giveup "Not in a git repository."
- addworktree w r = changelocation r $
- Local { gitdir = gitdir (location r), worktree = w }
+ addworktree w r = changelocation r $ Local
+ { gitdir = gitdir (location r)
+ , worktree = fmap toRawFilePath w
+ }
changelocation r l = r { location = l }
diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs
index e923796..3dc8529 100644
--- a/Git/Destroyer.hs
+++ b/Git/Destroyer.hs
@@ -4,7 +4,7 @@
-
- Copyright 2013, 2014 Joey Hess <joey@kitenet.net>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
module Git.Destroyer (
@@ -83,7 +83,7 @@ generateDamage = sample' (arbitrary :: Gen Damage)
applyDamage :: [Damage] -> Repo -> IO ()
applyDamage ds r = do
contents <- sort . filter (not . skipped)
- <$> dirContentsRecursive (localGitDir r)
+ <$> dirContentsRecursive (fromRawFilePath (localGitDir r))
forM_ ds $ \d -> do
let withfile s a = do
let f = selectFile contents s
diff --git a/Git/DiffTreeItem.hs b/Git/DiffTreeItem.hs
index 859f590..ffda2e8 100644
--- a/Git/DiffTreeItem.hs
+++ b/Git/DiffTreeItem.hs
@@ -2,7 +2,7 @@
-
- Copyright 2012 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
module Git.DiffTreeItem (
diff --git a/Git/FilePath.hs b/Git/FilePath.hs
index ffa3331..66a0159 100644
--- a/Git/FilePath.hs
+++ b/Git/FilePath.hs
@@ -5,12 +5,14 @@
- top of the repository even when run in a subdirectory. Adding some
- types helps keep that straight.
-
- - Copyright 2012-2013 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2019 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
module Git.FilePath (
TopFilePath,
@@ -29,30 +31,39 @@ module Git.FilePath (
import Common
import Git
-import qualified System.FilePath.Posix
+import qualified System.FilePath.ByteString as P
+import qualified System.FilePath.Posix.ByteString
+import GHC.Generics
+import Control.DeepSeq
+import qualified Data.ByteString as S
-{- A FilePath, relative to the top of the git repository. -}
-newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }
- deriving (Show, Eq, Ord)
+{- A RawFilePath, relative to the top of the git repository. -}
+newtype TopFilePath = TopFilePath { getTopFilePath :: RawFilePath }
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData TopFilePath
{- A file in a branch or other treeish. -}
data BranchFilePath = BranchFilePath Ref TopFilePath
+ deriving (Show, Eq, Ord)
{- Git uses the branch:file form to refer to a BranchFilePath -}
-descBranchFilePath :: BranchFilePath -> String
-descBranchFilePath (BranchFilePath b f) = fromRef b ++ ':' : getTopFilePath f
+descBranchFilePath :: BranchFilePath -> S.ByteString
+descBranchFilePath (BranchFilePath b f) =
+ encodeBS' (fromRef b) <> ":" <> getTopFilePath f
{- Path to a TopFilePath, within the provided git repo. -}
-fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath
-fromTopFilePath p repo = combine (repoPath repo) (getTopFilePath p)
+fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath
+fromTopFilePath p repo = P.combine (repoPath repo) (getTopFilePath p)
{- The input FilePath can be absolute, or relative to the CWD. -}
-toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath
-toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file
+toTopFilePath :: RawFilePath -> Git.Repo -> IO TopFilePath
+toTopFilePath file repo = TopFilePath . toRawFilePath
+ <$> relPathDirToFile (fromRawFilePath (repoPath repo)) (fromRawFilePath file)
-{- The input FilePath must already be relative to the top of the git
+{- The input RawFilePath must already be relative to the top of the git
- repository -}
-asTopFilePath :: FilePath -> TopFilePath
+asTopFilePath :: RawFilePath -> TopFilePath
asTopFilePath file = TopFilePath file
{- Git may use a different representation of a path when storing
@@ -62,25 +73,25 @@ asTopFilePath file = TopFilePath file
- despite Windows using '\'.
-
-}
-type InternalGitPath = String
+type InternalGitPath = RawFilePath
-toInternalGitPath :: FilePath -> InternalGitPath
+toInternalGitPath :: RawFilePath -> InternalGitPath
#ifndef mingw32_HOST_OS
toInternalGitPath = id
#else
-toInternalGitPath = replace "\\" "/"
+toInternalGitPath = encodeBS . replace "\\" "/" . decodeBS
#endif
-fromInternalGitPath :: InternalGitPath -> FilePath
+fromInternalGitPath :: InternalGitPath -> RawFilePath
#ifndef mingw32_HOST_OS
fromInternalGitPath = id
#else
-fromInternalGitPath = replace "/" "\\"
+fromInternalGitPath = encodeBS . replace "/" "\\" . decodeBS
#endif
{- isAbsolute on Windows does not think "/foo" or "\foo" is absolute,
- so try posix paths.
-}
-absoluteGitPath :: FilePath -> Bool
-absoluteGitPath p = isAbsolute p ||
- System.FilePath.Posix.isAbsolute (toInternalGitPath p)
+absoluteGitPath :: RawFilePath -> Bool
+absoluteGitPath p = P.isAbsolute p ||
+ System.FilePath.Posix.ByteString.isAbsolute (toInternalGitPath p)
diff --git a/Git/Filename.hs b/Git/Filename.hs
index 355e75f..010e5ba 100644
--- a/Git/Filename.hs
+++ b/Git/Filename.hs
@@ -3,7 +3,7 @@
-
- Copyright 2010, 2011 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
module Git.Filename where
@@ -12,23 +12,44 @@ import Common
import Utility.Format (decode_c, encode_c)
import Data.Char
+import Data.Word
+import qualified Data.ByteString as S
-decode :: String -> FilePath
-decode [] = []
-decode f@(c:s)
- -- encoded strings will be inside double quotes
- | c == '"' && end s == ['"'] = decode_c $ beginning s
- | otherwise = f
+-- encoded filenames will be inside double quotes
+decode :: S.ByteString -> RawFilePath
+decode b = case S.uncons b of
+ Nothing -> b
+ Just (h, t)
+ | h /= q -> b
+ | otherwise -> case S.unsnoc t of
+ Nothing -> b
+ Just (i, l)
+ | l /= q -> b
+ | otherwise ->
+ encodeBS $ decode_c $ decodeBS i
+ where
+ q :: Word8
+ q = fromIntegral (ord '"')
{- Should not need to use this, except for testing decode. -}
-encode :: FilePath -> String
-encode s = "\"" ++ encode_c s ++ "\""
+encode :: RawFilePath -> S.ByteString
+encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\""
-{- For quickcheck.
- -
- - See comment on Utility.Format.prop_encode_c_decode_c_roundtrip for
- - why this only tests chars < 256 -}
-prop_encode_decode_roundtrip :: String -> Bool
-prop_encode_decode_roundtrip s = s' == decode (encode s')
+prop_encode_decode_roundtrip :: FilePath -> Bool
+prop_encode_decode_roundtrip s = s' ==
+ fromRawFilePath (decode (encode (toRawFilePath s')))
where
- s' = filter (\c -> ord c < 256) s
+ s' = nonul (nohigh s)
+ -- Encoding and then decoding roundtrips only when
+ -- the string does not contain high unicode, because eg,
+ -- both "\12345" and "\227\128\185" are encoded to
+ -- "\343\200\271".
+ --
+ -- This property papers over the problem, by only
+ -- testing ascii
+ nohigh = filter isAscii
+ -- A String can contain a NUL, but toRawFilePath
+ -- truncates on the NUL, which is generally fine
+ -- because unix filenames cannot contain NUL.
+ -- So the encoding only roundtrips when there is no nul.
+ nonul = filter (/= '\NUL')
diff --git a/Git/Fsck.hs b/Git/Fsck.hs
index a716b56..6f33e11 100644
--- a/Git/Fsck.hs
+++ b/Git/Fsck.hs
@@ -2,7 +2,7 @@
-
- Copyright 2013 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns #-}
@@ -22,10 +22,11 @@ import Git
import Git.Command
import Git.Sha
import Utility.Batch
-import qualified Git.Version
import qualified Data.Set as S
import Control.Concurrent.Async
+import qualified Data.Semigroup as Sem
+import Prelude
data FsckResults
= FsckFoundMissing
@@ -44,15 +45,21 @@ type MissingObjects = S.Set Sha
type Truncated = Bool
+appendFsckOutput :: FsckOutput -> FsckOutput -> FsckOutput
+appendFsckOutput (FsckOutput s1 t1) (FsckOutput s2 t2) =
+ FsckOutput (S.union s1 s2) (t1 || t2)
+appendFsckOutput (FsckOutput s t) _ = FsckOutput s t
+appendFsckOutput _ (FsckOutput s t) = FsckOutput s t
+appendFsckOutput NoFsckOutput NoFsckOutput = NoFsckOutput
+appendFsckOutput AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning
+appendFsckOutput AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning
+appendFsckOutput NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning
+
+instance Sem.Semigroup FsckOutput where
+ (<>) = appendFsckOutput
+
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
@@ -65,9 +72,7 @@ instance Monoid FsckOutput where
-}
findBroken :: Bool -> Repo -> IO FsckResults
findBroken batchmode r = do
- supportsNoDangling <- (>= Git.Version.normalize "1.7.10")
- <$> Git.Version.installed
- let (command, params) = ("git", fsckParams supportsNoDangling r)
+ let (command, params) = ("git", fsckParams r)
(command', params') <- if batchmode
then toBatchCommand (command, params)
else return (command, params)
@@ -78,8 +83,8 @@ findBroken batchmode r = do
, std_err = CreatePipe
}
(o1, o2) <- concurrently
- (parseFsckOutput maxobjs r supportsNoDangling (stdoutHandle p))
- (parseFsckOutput maxobjs r supportsNoDangling (stderrHandle p))
+ (parseFsckOutput maxobjs r (stdoutHandle p))
+ (parseFsckOutput maxobjs r (stderrHandle p))
fsckok <- checkSuccessProcess pid
case mappend o1 o2 of
FsckOutput badobjs truncated
@@ -112,15 +117,15 @@ knownMissing (FsckFoundMissing s _) = s
findMissing :: [Sha] -> Repo -> IO MissingObjects
findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs
-parseFsckOutput :: Int -> Repo -> Bool -> Handle -> IO FsckOutput
-parseFsckOutput maxobjs r supportsNoDangling h = do
+parseFsckOutput :: Int -> Repo -> Handle -> IO FsckOutput
+parseFsckOutput maxobjs r 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 shas = findShas ls
let !truncated = length shas > maxobjs
missingobjs <- findMissing (take maxobjs shas) r
return $ FsckOutput missingobjs truncated
@@ -133,18 +138,14 @@ 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
+findShas :: [String] -> [Sha]
+findShas = catMaybes . map extractSha . concat . map words . filter wanted
where
- wanted l
- | supportsNoDangling = True
- | otherwise = not ("dangling " `isPrefixOf` l)
-
-fsckParams :: Bool -> Repo -> [CommandParam]
-fsckParams supportsNoDangling = gitCommandLine $ map Param $ catMaybes
- [ Just "fsck"
- , if supportsNoDangling
- then Just "--no-dangling"
- else Nothing
- , Just "--no-reflogs"
+ wanted l = not ("dangling " `isPrefixOf` l)
+
+fsckParams :: Repo -> [CommandParam]
+fsckParams = gitCommandLine $ map Param
+ [ "fsck"
+ , "--no-dangling"
+ , "--no-reflogs"
]
diff --git a/Git/HashObject.hs b/Git/HashObject.hs
new file mode 100644
index 0000000..3787c9c
--- /dev/null
+++ b/Git/HashObject.hs
@@ -0,0 +1,76 @@
+{- git hash-object interface
+ -
+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Git.HashObject where
+
+import Common
+import Git
+import Git.Sha
+import Git.Command
+import Git.Types
+import qualified Utility.CoProcess as CoProcess
+import Utility.Tmp
+
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as L
+import Data.ByteString.Builder
+
+type HashObjectHandle = CoProcess.CoProcessHandle
+
+hashObjectStart :: Bool -> Repo -> IO HashObjectHandle
+hashObjectStart writeobject = gitCoProcessStart True $ catMaybes
+ [ Just (Param "hash-object")
+ , if writeobject then Just (Param "-w") else Nothing
+ , Just (Param "--stdin-paths")
+ , Just (Param "--no-filters")
+ ]
+
+hashObjectStop :: HashObjectHandle -> IO ()
+hashObjectStop = CoProcess.stop
+
+{- Injects a file into git, returning the Sha of the object. -}
+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
+
+class HashableBlob t where
+ hashableBlobToHandle :: Handle -> t -> IO ()
+
+instance HashableBlob L.ByteString where
+ hashableBlobToHandle = L.hPut
+
+instance HashableBlob S.ByteString where
+ hashableBlobToHandle = S.hPut
+
+instance HashableBlob Builder where
+ hashableBlobToHandle = hPutBuilder
+
+{- Injects a blob into git. Unfortunately, the current git-hash-object
+ - interface does not allow batch hashing without using temp files. -}
+hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha
+hashBlob h b = withTmpFile "hash" $ \tmp tmph -> do
+ hashableBlobToHandle tmph b
+ hClose tmph
+ hashFile h tmp
+
+{- Injects some content into git, returning its Sha.
+ -
+ - Avoids using a tmp file, but runs a new hash-object command each
+ - time called. -}
+hashObject :: ObjectType -> String -> Repo -> IO Sha
+hashObject objtype content = hashObject' objtype (flip hPutStr content)
+
+hashObject' :: ObjectType -> (Handle -> IO ()) -> Repo -> IO Sha
+hashObject' objtype writer repo = getSha subcmd $
+ pipeWriteRead (map Param params) (Just writer) repo
+ where
+ subcmd = "hash-object"
+ params = [subcmd, "-t", decodeBS (fmtObjectType objtype), "-w", "--stdin", "--no-filters"]
diff --git a/Git/Index.hs b/Git/Index.hs
index 85ea480..afd29c2 100644
--- a/Git/Index.hs
+++ b/Git/Index.hs
@@ -1,8 +1,8 @@
{- git index file stuff
-
- - Copyright 2011 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
module Git.Index where
@@ -10,6 +10,7 @@ module Git.Index where
import Common
import Git
import Utility.Env
+import Utility.Env.Set
indexEnv :: String
indexEnv = "GIT_INDEX_FILE"
@@ -46,25 +47,14 @@ override index _r = do
reset (Just v) = setEnv indexEnv v True
reset _ = unsetEnv var
+{- The normal index file. Does not check GIT_INDEX_FILE. -}
indexFile :: Repo -> FilePath
-indexFile r = localGitDir r </> "index"
+indexFile r = fromRawFilePath (localGitDir r) </> "index"
-{- Git locks the index by creating this file. -}
-indexFileLock :: Repo -> FilePath
-indexFileLock r = indexFile r ++ ".lock"
+{- The index file git will currently use, checking GIT_INDEX_FILE. -}
+currentIndexFile :: Repo -> IO FilePath
+currentIndexFile r = fromMaybe (indexFile r) <$> getEnv indexEnv
-{- When the pre-commit hook is run, and git commit has been run with
- - a file or files specified to commit, rather than committing the staged
- - index, git provides the pre-commit hook with a "false index file".
- -
- - Changes made to this index will influence the commit, but won't
- - affect the real index file.
- -
- - This detects when we're in this situation, using a heuristic, which
- - might be broken by changes to git. Any use of this should have a test
- - case to make sure it works.
- -}
-haveFalseIndex :: IO Bool
-haveFalseIndex = maybe (False) check <$> getEnv indexEnv
- where
- check f = "next-index" `isPrefixOf` takeFileName f
+{- Git locks the index by creating this file. -}
+indexFileLock :: FilePath -> FilePath
+indexFileLock f = f ++ ".lock"
diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs
index f945838..5534307 100644
--- a/Git/LsFiles.hs
+++ b/Git/LsFiles.hs
@@ -1,13 +1,15 @@
{- git ls-files interface
-
- - Copyright 2010,2012 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
module Git.LsFiles (
inRepo,
+ inRepoOrBranch,
notInRepo,
+ notInRepoIncludingEmptyDirectories,
allFiles,
deleted,
modified,
@@ -32,69 +34,89 @@ import Git.Sha
import Numeric
import System.Posix.Types
+import qualified Data.ByteString.Lazy as L
-{- Scans for files that are checked into git at the specified locations. -}
-inRepo :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
-inRepo l = pipeNullSplit $
- Param "ls-files" :
- Param "--cached" :
- Param "-z" :
- Param "--" :
- map File l
+{- Scans for files that are checked into git's index at the specified locations. -}
+inRepo :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+inRepo = inRepo' []
+
+inRepo' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+inRepo' ps l repo = pipeNullSplit' params repo
+ where
+ params =
+ Param "ls-files" :
+ Param "--cached" :
+ Param "-z" :
+ ps ++
+ (Param "--" : map (File . fromRawFilePath) l)
+
+{- 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]
{- Scans for files at the specified locations that are not checked into git. -}
-notInRepo :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
-notInRepo include_ignored l repo = pipeNullSplit params repo
+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
where
params = concat
[ [ Param "ls-files", Param "--others"]
+ , ps
, exclude
, [ Param "-z", Param "--" ]
- , map File l
+ , map (File . fromRawFilePath) l
]
exclude
| include_ignored = []
| otherwise = [Param "--exclude-standard"]
+{- Scans for files at the specified locations that are not checked into
+ - git. Empty directories are included in the result. -}
+notInRepoIncludingEmptyDirectories :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"]
+
{- Finds all files in the specified locations, whether checked into git or
- not. -}
-allFiles :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
-allFiles l = pipeNullSplit $
+allFiles :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+allFiles l = pipeNullSplit' $
Param "ls-files" :
Param "--cached" :
Param "--others" :
Param "-z" :
Param "--" :
- map File l
+ map (File . fromRawFilePath) l
{- Returns a list of files in the specified locations that have been
- deleted. -}
-deleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
-deleted l repo = pipeNullSplit params repo
+deleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+deleted l repo = pipeNullSplit' params repo
where
params =
Param "ls-files" :
Param "--deleted" :
Param "-z" :
Param "--" :
- map File l
+ map (File . fromRawFilePath) l
{- Returns a list of files in the specified locations that have been
- modified. -}
-modified :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
-modified l repo = pipeNullSplit params repo
+modified :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+modified l repo = pipeNullSplit' params repo
where
params =
Param "ls-files" :
Param "--modified" :
Param "-z" :
Param "--" :
- map File l
+ map (File . fromRawFilePath) l
{- Files that have been modified or are not checked into git (and are not
- ignored). -}
-modifiedOthers :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
-modifiedOthers l repo = pipeNullSplit params repo
+modifiedOthers :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+modifiedOthers l repo = pipeNullSplit' params repo
where
params =
Param "ls-files" :
@@ -103,69 +125,69 @@ modifiedOthers l repo = pipeNullSplit params repo
Param "--exclude-standard" :
Param "-z" :
Param "--" :
- map File l
+ map (File . fromRawFilePath) l
{- Returns a list of all files that are staged for commit. -}
-staged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
+staged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
staged = staged' []
{- Returns a list of the files, staged for commit, that are being added,
- moved, or changed (but not deleted), from the specified locations. -}
-stagedNotDeleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
+stagedNotDeleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"]
-staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
-staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix
+staged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+staged' ps l repo = pipeNullSplit' (prefix ++ ps ++ suffix) repo
where
prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"]
- suffix = Param "--" : map File l
+ suffix = Param "--" : map (File . fromRawFilePath) l
-type StagedDetails = (FilePath, Maybe Sha, Maybe FileMode)
+type StagedDetails = (RawFilePath, Maybe Sha, Maybe FileMode)
{- Returns details about files that are staged in the index,
- as well as files not yet in git. Skips ignored files. -}
-stagedOthersDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)
+stagedOthersDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)
stagedOthersDetails = stagedDetails' [Param "--others", Param "--exclude-standard"]
{- Returns details about all files that are staged in the index. -}
-stagedDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)
+stagedDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)
stagedDetails = stagedDetails' []
{- Gets details about staged files, including the Sha of their staged
- contents. -}
-stagedDetails' :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)
+stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)
stagedDetails' ps l repo = do
(ls, cleanup) <- pipeNullSplit params repo
return (map parse ls, cleanup)
where
params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++
- Param "--" : map File l
+ Param "--" : map (File . fromRawFilePath) l
parse s
- | null file = (s, Nothing, Nothing)
- | otherwise = (file, extractSha $ take shaSize rest, readmode mode)
+ | null file = (L.toStrict s, Nothing, Nothing)
+ | otherwise = (toRawFilePath file, extractSha $ take shaSize rest, readmode mode)
where
- (metadata, file) = separate (== '\t') s
+ (metadata, file) = separate (== '\t') (decodeBL' s)
(mode, rest) = separate (== ' ') metadata
readmode = fst <$$> headMaybe . readOct
{- Returns a list of the files in the specified locations that are staged
- for commit, and whose type has changed. -}
-typeChangedStaged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
+typeChangedStaged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
typeChangedStaged = typeChanged' [Param "--cached"]
{- Returns a list of the files in the specified locations whose type has
- changed. Files only staged for commit will not be included. -}
-typeChanged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
+typeChanged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
typeChanged = typeChanged' []
-typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
+typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
typeChanged' ps l repo = do
(fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo
-- git diff returns filenames relative to the top of the git repo;
-- convert to filenames relative to the cwd, like git ls-files.
- top <- absPath (repoPath repo)
+ top <- absPath (fromRawFilePath (repoPath repo))
currdir <- getCurrentDirectory
- return (map (\f -> relPathDirToFileAbs currdir $ top </> f) fs, cleanup)
+ return (map (\f -> toRawFilePath (relPathDirToFileAbs currdir $ top </> decodeBL' f)) fs, cleanup)
where
prefix =
[ Param "diff"
@@ -173,7 +195,7 @@ typeChanged' ps l repo = do
, Param "--diff-filter=T"
, Param "-z"
]
- suffix = Param "--" : (if null l then [File "."] else map File l)
+ suffix = Param "--" : (if null l then [File "."] else map (File . fromRawFilePath) l)
{- A item in conflict has two possible values.
- Either can be Nothing, when that side deleted the file. -}
@@ -183,10 +205,10 @@ data Conflicting v = Conflicting
} deriving (Show)
data Unmerged = Unmerged
- { unmergedFile :: FilePath
- , unmergedBlobType :: Conflicting BlobType
+ { unmergedFile :: RawFilePath
+ , unmergedTreeItemType :: Conflicting TreeItemType
, unmergedSha :: Conflicting Sha
- } deriving (Show)
+ }
{- Returns a list of the files in the specified locations that have
- unresolved merge conflicts.
@@ -198,38 +220,38 @@ data Unmerged = Unmerged
- 3 = them
- If a line is omitted, that side removed the file.
-}
-unmerged :: [FilePath] -> Repo -> IO ([Unmerged], IO Bool)
+unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool)
unmerged l repo = do
(fs, cleanup) <- pipeNullSplit params repo
- return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup)
+ return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup)
where
params =
Param "ls-files" :
Param "--unmerged" :
Param "-z" :
Param "--" :
- map File l
+ map (File . fromRawFilePath) l
data InternalUnmerged = InternalUnmerged
{ isus :: Bool
- , ifile :: FilePath
- , iblobtype :: Maybe BlobType
+ , ifile :: RawFilePath
+ , itreeitemtype :: Maybe TreeItemType
, isha :: Maybe Sha
- } deriving (Show)
+ }
parseUnmerged :: String -> Maybe InternalUnmerged
parseUnmerged s
| null file = Nothing
| otherwise = case words metadata of
- (rawblobtype:rawsha:rawstage:_) -> do
+ (rawtreeitemtype:rawsha:rawstage:_) -> do
stage <- readish rawstage :: Maybe Int
if stage /= 2 && stage /= 3
then Nothing
else do
- blobtype <- readBlobType rawblobtype
+ treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype)
sha <- extractSha rawsha
- return $ InternalUnmerged (stage == 2) file
- (Just blobtype) (Just sha)
+ return $ InternalUnmerged (stage == 2) (toRawFilePath file)
+ (Just treeitemtype) (Just sha)
_ -> Nothing
where
(metadata, file) = separate (== '\t') s
@@ -239,12 +261,12 @@ reduceUnmerged c [] = c
reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest
where
(rest, sibi) = findsib i is
- (blobtypeA, blobtypeB, shaA, shaB)
- | isus i = (iblobtype i, iblobtype sibi, isha i, isha sibi)
- | otherwise = (iblobtype sibi, iblobtype i, isha sibi, isha i)
+ (treeitemtypeA, treeitemtypeB, shaA, shaB)
+ | isus i = (itreeitemtype i, itreeitemtype sibi, isha i, isha sibi)
+ | otherwise = (itreeitemtype sibi, itreeitemtype i, isha sibi, isha i)
new = Unmerged
{ unmergedFile = ifile i
- , unmergedBlobType = Conflicting blobtypeA blobtypeB
+ , unmergedTreeItemType = Conflicting treeitemtypeA treeitemtypeB
, unmergedSha = Conflicting shaA shaB
}
findsib templatei [] = ([], removed templatei)
@@ -253,6 +275,6 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest
| otherwise = (l:ls, removed templatei)
removed templatei = templatei
{ isus = not (isus templatei)
- , iblobtype = Nothing
+ , itreeitemtype = Nothing
, isha = Nothing
}
diff --git a/Git/LsTree.hs b/Git/LsTree.hs
index 225f2ce..a3d8383 100644
--- a/Git/LsTree.hs
+++ b/Git/LsTree.hs
@@ -1,19 +1,21 @@
{- git ls-tree interface
-
- - Copyright 2011-2016 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns #-}
module Git.LsTree (
TreeItem(..),
+ LsTreeMode(..),
lsTree,
lsTree',
lsTreeParams,
lsTreeFiles,
parseLsTree,
+ formatLsTree,
) where
import Common
@@ -22,42 +24,52 @@ import Git.Command
import Git.Sha
import Git.FilePath
import qualified Git.Filename
+import Utility.Attoparsec
import Numeric
-import Data.Char
+import Data.Either
import System.Posix.Types
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Attoparsec.ByteString.Lazy as A
+import qualified Data.Attoparsec.ByteString.Char8 as A8
data TreeItem = TreeItem
{ mode :: FileMode
- , typeobj :: String
+ , typeobj :: S.ByteString
, 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], IO Bool)
+data LsTreeMode = LsTreeRecursive | LsTreeNonRecursive
+
+{- Lists the contents of a tree, with lazy output. -}
+lsTree :: LsTreeMode -> 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)
+lsTree' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool)
+lsTree' ps lsmode t repo = do
+ (l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo
+ return (rights (map parseLsTree l), cleanup)
-lsTreeParams :: Ref -> [CommandParam] -> [CommandParam]
-lsTreeParams r ps =
+lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam]
+lsTreeParams lsmode r ps =
[ Param "ls-tree"
, Param "--full-tree"
, Param "-z"
- , Param "-r"
- ] ++ ps ++
+ ] ++ recursiveparams ++ ps ++
[ Param "--"
, File $ fromRef r
]
+ where
+ recursiveparams = case lsmode of
+ LsTreeRecursive -> [ Param "-r" ]
+ LsTreeNonRecursive -> []
{- Lists specified files in a tree. -}
lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem]
-lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo
+lsTreeFiles t fs repo = rights . map (parseLsTree . L.fromStrict)
+ <$> pipeNullSplitStrict ps repo
where
ps =
[ Param "ls-tree"
@@ -67,21 +79,34 @@ lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo
, File $ fromRef t
] ++ map File fs
+parseLsTree :: L.ByteString -> Either String TreeItem
+parseLsTree b = case A.parse parserLsTree b of
+ A.Done _ r -> Right r
+ A.Fail _ _ err -> Left err
+
{- Parses a line of ls-tree output, in format:
- mode SP type SP sha TAB file
-
- (The --long format is not currently supported.) -}
-parseLsTree :: String -> TreeItem
-parseLsTree l = TreeItem
- { mode = smode
- , typeobj = t
- , sha = Ref s
- , file = sfile
- }
- where
- (m, past_m) = splitAt 7 l -- mode is 6 bytes
- (!t, past_t) = separate isSpace past_m
- (!s, past_s) = splitAt shaSize past_t
- !f = drop 1 past_s
- !smode = fst $ Prelude.head $ readOct m
- !sfile = asTopFilePath $ Git.Filename.decode f
+parserLsTree :: A.Parser TreeItem
+parserLsTree = TreeItem
+ -- mode
+ <$> octal
+ <* A8.char ' '
+ -- type
+ <*> A.takeTill (== 32)
+ <* A8.char ' '
+ -- sha
+ <*> (Ref . decodeBS' <$> A.take shaSize)
+ <* A8.char '\t'
+ -- file
+ <*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString)
+
+{- Inverse of parseLsTree -}
+formatLsTree :: TreeItem -> String
+formatLsTree ti = unwords
+ [ showOct (mode ti) ""
+ , decodeBS (typeobj ti)
+ , fromRef (sha ti)
+ , fromRawFilePath (getTopFilePath (file ti))
+ ]
diff --git a/Git/Objects.hs b/Git/Objects.hs
index bda220b..c9ede4d 100644
--- a/Git/Objects.hs
+++ b/Git/Objects.hs
@@ -2,7 +2,7 @@
-
- Copyright 2013 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
module Git.Objects where
@@ -12,7 +12,7 @@ import Git
import Git.Sha
objectsDir :: Repo -> FilePath
-objectsDir r = localGitDir r </> "objects"
+objectsDir r = fromRawFilePath (localGitDir r) </> "objects"
packDir :: Repo -> FilePath
packDir r = objectsDir r </> "pack"
diff --git a/Git/Ref.hs b/Git/Ref.hs
index 1986db6..621e328 100644
--- a/Git/Ref.hs
+++ b/Git/Ref.hs
@@ -1,10 +1,12 @@
{- git ref stuff
-
- - Copyright 2011-2013 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Git.Ref where
import Common
@@ -13,13 +15,14 @@ import Git.Command
import Git.Sha
import Git.Types
-import Data.Char (chr)
+import Data.Char (chr, ord)
+import qualified Data.ByteString as S
headRef :: Ref
headRef = Ref "HEAD"
headFile :: Repo -> FilePath
-headFile r = localGitDir r </> "HEAD"
+headFile r = fromRawFilePath (localGitDir r) </> "HEAD"
setHeadRef :: Ref -> Repo -> IO ()
setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref)
@@ -33,11 +36,18 @@ describe = fromRef . base
- 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
+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
where
- remove prefix s
- | prefix `isPrefixOf` s = drop (length prefix) s
- | otherwise = s
+ prefix = case end dir of
+ ['/'] -> dir
+ _ -> dir ++ "/"
{- 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,
@@ -55,8 +65,8 @@ branchRef = underBase "refs/heads"
- Prefixing the file with ./ makes this work even if in a subdirectory
- of a repo.
-}
-fileRef :: FilePath -> Ref
-fileRef f = Ref $ ":./" ++ f
+fileRef :: RawFilePath -> Ref
+fileRef f = Ref $ ":./" ++ fromRawFilePath f
{- Converts a Ref to refer to the content of the Ref on a given date. -}
dateRef :: Ref -> RefDate -> Ref
@@ -64,7 +74,7 @@ dateRef (Ref r) (RefDate d) = Ref $ r ++ "@" ++ d
{- A Ref that can be used to refer to a file in the repository as it
- appears in a given Ref. -}
-fileFromRef :: Ref -> FilePath -> Ref
+fileFromRef :: Ref -> RawFilePath -> Ref
fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)
{- Checks if a ref exists. -}
@@ -75,24 +85,29 @@ exists ref = runBool
{- The file used to record a ref. (Git also stores some refs in a
- packed-refs file.) -}
file :: Ref -> Repo -> FilePath
-file ref repo = localGitDir repo </> fromRef ref
+file ref repo = fromRawFilePath (localGitDir repo) </> fromRef ref
{- Checks if HEAD exists. It generally will, except for in a repository
- that was just created. -}
headExists :: Repo -> IO Bool
headExists repo = do
- ls <- lines <$> pipeReadStrict [Param "show-ref", Param "--head"] repo
- return $ any (" HEAD" `isSuffixOf`) ls
+ ls <- S.split nl <$> pipeReadStrict [Param "show-ref", Param "--head"] repo
+ return $ any (" HEAD" `S.isSuffixOf`) ls
+ where
+ nl = fromIntegral (ord '\n')
{- Get the sha of a fully qualified git ref, if it exists. -}
sha :: Branch -> Repo -> IO (Maybe Sha)
sha branch repo = process <$> showref repo
where
- showref = pipeReadStrict [Param "show-ref",
- Param "--hash", -- get the hash
- Param $ fromRef branch]
- process [] = Nothing
- process s = Just $ Ref $ firstLine s
+ showref = pipeReadStrict
+ [ Param "show-ref"
+ , Param "--hash" -- get the hash
+ , Param $ fromRef branch
+ ]
+ process s
+ | S.null s = Nothing
+ | otherwise = Just $ Ref $ decodeBS' $ firstLine' s
headSha :: Repo -> IO (Maybe Sha)
headSha = sha headRef
@@ -107,7 +122,7 @@ matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo
{- List of (shas, branches) matching a given ref spec. -}
matching' :: [String] -> Repo -> IO [(Sha, Branch)]
-matching' ps repo = map gen . lines <$>
+matching' ps repo = map gen . lines . decodeBS' <$>
pipeReadStrict (Param "show-ref" : map Param ps) repo
where
gen l = let (r, b) = separate (== ' ') l
@@ -134,10 +149,13 @@ delete oldvalue ref = run
, Param $ fromRef oldvalue
]
-{- Gets the sha of the tree a ref uses. -}
+{- Gets the sha of the tree a ref uses.
+ -
+ - 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 <$$> pipeReadStrict
- [ Param "rev-parse", Param ref' ]
+tree (Ref ref) = extractSha . decodeBS <$$> pipeReadStrict
+ [ Param "rev-parse", Param "--verify", Param "--quiet", Param ref' ]
where
ref' = if ":" `isInfixOf` ref
then ref
diff --git a/Git/RefLog.hs b/Git/RefLog.hs
index 57f35e9..7ba8713 100644
--- a/Git/RefLog.hs
+++ b/Git/RefLog.hs
@@ -2,7 +2,7 @@
-
- Copyright 2013 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
module Git.RefLog where
@@ -21,7 +21,7 @@ getMulti :: [Branch] -> Repo -> IO [Sha]
getMulti bs = get' (map (Param . fromRef) bs)
get' :: [CommandParam] -> Repo -> IO [Sha]
-get' ps = mapMaybe extractSha . lines <$$> pipeReadStrict ps'
+get' ps = mapMaybe extractSha . lines . decodeBS <$$> pipeReadStrict ps'
where
ps' = catMaybes
[ Just $ Param "log"
diff --git a/Git/Remote.hs b/Git/Remote.hs
index f6eaf93..69d6b52 100644
--- a/Git/Remote.hs
+++ b/Git/Remote.hs
@@ -2,10 +2,11 @@
-
- Copyright 2012 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
module Git.Remote where
@@ -15,11 +16,22 @@ import Git.Types
import Data.Char
import qualified Data.Map as M
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as S8
import Network.URI
#ifdef mingw32_HOST_OS
import Git.FilePath
#endif
+{- Is a git config key one that specifies the location of a remote? -}
+isRemoteKey :: ConfigKey -> Bool
+isRemoteKey (ConfigKey k) = "remote." `S.isPrefixOf` k && ".url" `S.isSuffixOf` k
+
+{- Get a remote's name from the config key that specifies its location. -}
+remoteKeyToRemoteName :: ConfigKey -> RemoteName
+remoteKeyToRemoteName (ConfigKey k) = decodeBS' $
+ S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k
+
{- Construct a legal git remote name out of an arbitrary input string.
-
- There seems to be no formal definition of this in the git source,
@@ -43,6 +55,7 @@ makeLegalName s = case filter legal $ replace "/" "_" s of
legal c = isAlphaNum c
data RemoteLocation = RemoteUrl String | RemotePath FilePath
+ deriving (Eq)
remoteLocationIsUrl :: RemoteLocation -> Bool
remoteLocationIsUrl (RemoteUrl _) = True
@@ -67,16 +80,16 @@ parseRemoteLocation s repo = ret $ calcloc s
-- insteadof config can rewrite remote location
calcloc l
| null insteadofs = l
- | otherwise = replacement ++ drop (length bestvalue) l
+ | otherwise = replacement ++ drop (S.length bestvalue) l
where
- replacement = drop (length prefix) $
- take (length bestkey - length suffix) bestkey
- (bestkey, bestvalue) = maximumBy longestvalue insteadofs
+ replacement = decodeBS' $ S.drop (S.length prefix) $
+ S.take (S.length bestkey - S.length suffix) bestkey
+ (ConfigKey bestkey, ConfigValue bestvalue) = maximumBy longestvalue insteadofs
longestvalue (_, a) (_, b) = compare b a
- insteadofs = filterconfig $ \(k, v) ->
- prefix `isPrefixOf` k &&
- suffix `isSuffixOf` k &&
- v `isPrefixOf` l
+ insteadofs = filterconfig $ \(ConfigKey k, ConfigValue v) ->
+ prefix `S.isPrefixOf` k &&
+ suffix `S.isSuffixOf` k &&
+ v `S.isPrefixOf` encodeBS l
filterconfig f = filter f $
concatMap splitconfigs $ M.toList $ fullconfig repo
splitconfigs (k, vs) = map (\v -> (k, v)) vs
@@ -104,5 +117,5 @@ parseRemoteLocation s repo = ret $ calcloc s
-- git on Windows will write a path to .git/config with "drive:",
-- which is not to be confused with a "host:"
dosstyle = hasDrive
- dospath = fromInternalGitPath
+ dospath = fromRawFilePath . fromInternalGitPath . toRawFilePath
#endif
diff --git a/Git/Repair.hs b/Git/Repair.hs
index 8e43248..66e6811 100644
--- a/Git/Repair.hs
+++ b/Git/Repair.hs
@@ -2,7 +2,7 @@
-
- Copyright 2013-2014 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
module Git.Repair (
@@ -11,7 +11,6 @@ module Git.Repair (
removeBadBranches,
successfulRepair,
cleanCorruptObjects,
- retrieveMissingObjects,
resetLocalBranches,
checkIndex,
checkIndexFast,
@@ -36,7 +35,7 @@ import qualified Git.Ref as Ref
import qualified Git.RefLog as RefLog
import qualified Git.UpdateIndex as UpdateIndex
import qualified Git.Branch as Branch
-import Utility.Tmp
+import Utility.Tmp.Dir
import Utility.Rsync
import Utility.FileMode
import Utility.Tuple
@@ -102,10 +101,11 @@ retrieveMissingObjects missing referencerepo r
unlessM (boolSystem "git" [Param "init", File tmpdir]) $
error $ "failed to create temp repository in " ++ tmpdir
tmpr <- Config.read =<< Construct.fromAbsPath tmpdir
- stillmissing <- pullremotes tmpr (remotes r) fetchrefstags missing
+ rs <- Construct.fromRemotes r
+ stillmissing <- pullremotes tmpr rs fetchrefstags missing
if S.null (knownMissing stillmissing)
then return stillmissing
- else pullremotes tmpr (remotes r) fetchallrefs stillmissing
+ else pullremotes tmpr rs fetchallrefs stillmissing
where
pullremotes tmpr [] fetchrefs stillmissing = case referencerepo of
Nothing -> return stillmissing
@@ -227,7 +227,7 @@ badBranches missing r = filterM isbad =<< getAllRefs r
- Relies on packed refs being exploded before it's called.
-}
getAllRefs :: Repo -> IO [Ref]
-getAllRefs r = getAllRefs' (localGitDir r </> "refs")
+getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) </> "refs")
getAllRefs' :: FilePath -> IO [Ref]
getAllRefs' refdir = do
@@ -245,13 +245,13 @@ explodePackedRefsFile r = do
nukeFile f
where
makeref (sha, ref) = do
- let dest = localGitDir r </> fromRef ref
+ let dest = fromRawFilePath (localGitDir r) </> fromRef ref
createDirectoryIfMissing True (parentDir dest)
unlessM (doesFileExist dest) $
writeFile dest (fromRef sha)
packedRefsFile :: Repo -> FilePath
-packedRefsFile r = localGitDir r </> "packed-refs"
+packedRefsFile r = fromRawFilePath (localGitDir r) </> "packed-refs"
parsePacked :: String -> Maybe (Sha, Ref)
parsePacked l = case words l of
@@ -263,7 +263,7 @@ parsePacked l = case words l of
{- git-branch -d cannot be used to remove a branch that is directly
- pointing to a corrupt commit. -}
nukeBranchRef :: Branch -> Repo -> IO ()
-nukeBranchRef b r = nukeFile $ localGitDir r </> fromRef b
+nukeBranchRef b r = nukeFile $ fromRawFilePath (localGitDir r) </> fromRef b
{- Finds the most recent commit to a branch that does not need any
- of the missing objects. If the input branch is good as-is, returns it.
@@ -284,7 +284,7 @@ findUncorruptedCommit missing goodcommits branch r = do
, Param "--format=%H"
, Param (fromRef branch)
] r
- let branchshas = catMaybes $ map extractSha ls
+ let branchshas = catMaybes $ map (extractSha . decodeBL) ls
reflogshas <- RefLog.get branch r
-- XXX Could try a bit harder here, and look
-- for uncorrupted old commits in branches in the
@@ -313,7 +313,7 @@ verifyCommit missing goodcommits commit r
, Param "--format=%H %T"
, Param (fromRef commit)
] r
- let committrees = map parse ls
+ let committrees = map (parse . decodeBL) ls
if any isNothing committrees || null committrees
then do
void cleanup
@@ -341,8 +341,8 @@ verifyTree :: MissingObjects -> Sha -> Repo -> IO Bool
verifyTree missing treesha r
| S.member treesha missing = return False
| otherwise = do
- (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams treesha []) r
- let objshas = map (LsTree.sha . LsTree.parseLsTree) ls
+ (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive treesha []) r
+ let objshas = mapMaybe (LsTree.sha <$$> eitherToMaybe . LsTree.parseLsTree) ls
if any (`S.member` missing) objshas
then do
void cleanup
@@ -370,7 +370,7 @@ checkIndexFast r = do
length indexcontents `seq` cleanup
missingIndex :: Repo -> IO Bool
-missingIndex r = not <$> doesFileExist (localGitDir r </> "index")
+missingIndex r = not <$> doesFileExist (fromRawFilePath (localGitDir r) </> "index")
{- Finds missing and ok files staged in the index. -}
partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool)
@@ -394,12 +394,12 @@ rewriteIndex r
UpdateIndex.streamUpdateIndex r
=<< (catMaybes <$> mapM reinject good)
void cleanup
- return $ map fst3 bad
+ return $ map (fromRawFilePath . fst3) bad
where
- reinject (file, Just sha, Just mode) = case toBlobType mode of
+ reinject (file, Just sha, Just mode) = case toTreeItemType mode of
Nothing -> return Nothing
- Just blobtype -> Just <$>
- UpdateIndex.stageFile sha blobtype file r
+ Just treeitemtype -> Just <$>
+ UpdateIndex.stageFile sha treeitemtype (fromRawFilePath file) r
reinject _ = return Nothing
newtype GoodCommits = GoodCommits (S.Set Sha)
@@ -446,7 +446,7 @@ preRepair g = do
let f = indexFile g
void $ tryIO $ allowWrite f
where
- headfile = localGitDir g </> "HEAD"
+ headfile = fromRawFilePath (localGitDir g) </> "HEAD"
validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s)
{- Put it all together. -}
diff --git a/Git/Sha.hs b/Git/Sha.hs
index b802c85..cc33cac 100644
--- a/Git/Sha.hs
+++ b/Git/Sha.hs
@@ -2,7 +2,7 @@
-
- Copyright 2011 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
module Git.Sha where
diff --git a/Git/Types.hs b/Git/Types.hs
index 327c1d7..9c2754a 100644
--- a/Git/Types.hs
+++ b/Git/Types.hs
@@ -1,16 +1,23 @@
{- git data types
-
- - Copyright 2010-2012 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
module Git.Types where
import Network.URI
+import Data.String
+import Data.Default
import qualified Data.Map as M
+import qualified Data.ByteString as S
import System.Posix.Types
import Utility.SafeCommand
+import Utility.FileSystemEncoding
{- Support repositories on local disk, and repositories accessed via an URL.
-
@@ -23,19 +30,19 @@ import Utility.SafeCommand
- else known about it.
-}
data RepoLocation
- = Local { gitdir :: FilePath, worktree :: Maybe FilePath }
- | LocalUnknown FilePath
+ = Local { gitdir :: RawFilePath, worktree :: Maybe RawFilePath }
+ | LocalUnknown RawFilePath
| Url URI
| Unknown
deriving (Show, Eq, Ord)
data Repo = Repo
{ location :: RepoLocation
- , config :: M.Map String String
+ , config :: M.Map ConfigKey ConfigValue
-- a given git config key can actually have multiple values
- , fullconfig :: M.Map String [String]
- , remotes :: [Repo]
- -- remoteName holds the name used for this repo in remotes
+ , fullconfig :: M.Map ConfigKey [ConfigValue]
+ -- remoteName holds the name used for this repo in some other
+ -- repo's list of remotes, when this repo is such a remote
, remoteName :: Maybe RemoteName
-- alternate environment to use when running git commands
, gitEnv :: Maybe [(String, String)]
@@ -44,6 +51,33 @@ data Repo = Repo
, gitGlobalOpts :: [CommandParam]
} deriving (Show, Eq, Ord)
+newtype ConfigKey = ConfigKey S.ByteString
+ deriving (Ord, Eq)
+
+newtype ConfigValue = ConfigValue S.ByteString
+ deriving (Ord, Eq, Semigroup, Monoid)
+
+instance Default ConfigValue where
+ def = ConfigValue mempty
+
+fromConfigKey :: ConfigKey -> String
+fromConfigKey (ConfigKey s) = decodeBS' s
+
+instance Show ConfigKey where
+ show = fromConfigKey
+
+fromConfigValue :: ConfigValue -> String
+fromConfigValue (ConfigValue s) = decodeBS' s
+
+instance Show ConfigValue where
+ show = fromConfigValue
+
+instance IsString ConfigKey where
+ fromString = ConfigKey . encodeBS'
+
+instance IsString ConfigValue where
+ fromString = ConfigValue . encodeBS'
+
type RemoteName = String
{- A git ref. Can be a sha1, or a branch or tag name. -}
@@ -64,45 +98,48 @@ newtype RefDate = RefDate String
{- Types of objects that can be stored in git. -}
data ObjectType = BlobObject | CommitObject | TreeObject
- deriving (Eq)
-
-instance Show ObjectType where
- show BlobObject = "blob"
- show CommitObject = "commit"
- show TreeObject = "tree"
-readObjectType :: String -> Maybe ObjectType
+readObjectType :: S.ByteString -> Maybe ObjectType
readObjectType "blob" = Just BlobObject
readObjectType "commit" = Just CommitObject
readObjectType "tree" = Just TreeObject
readObjectType _ = Nothing
-{- Types of blobs. -}
-data BlobType = FileBlob | ExecutableBlob | SymlinkBlob
- deriving (Eq)
-
-{- Git uses magic numbers to denote the type of a blob. -}
-instance Show BlobType where
- show FileBlob = "100644"
- show ExecutableBlob = "100755"
- show SymlinkBlob = "120000"
-
-readBlobType :: String -> Maybe BlobType
-readBlobType "100644" = Just FileBlob
-readBlobType "100755" = Just ExecutableBlob
-readBlobType "120000" = Just SymlinkBlob
-readBlobType _ = Nothing
-
-toBlobType :: FileMode -> Maybe BlobType
-toBlobType 0o100644 = Just FileBlob
-toBlobType 0o100755 = Just ExecutableBlob
-toBlobType 0o120000 = Just SymlinkBlob
-toBlobType _ = Nothing
-
-fromBlobType :: BlobType -> FileMode
-fromBlobType FileBlob = 0o100644
-fromBlobType ExecutableBlob = 0o100755
-fromBlobType SymlinkBlob = 0o120000
+fmtObjectType :: ObjectType -> S.ByteString
+fmtObjectType BlobObject = "blob"
+fmtObjectType CommitObject = "commit"
+fmtObjectType TreeObject = "tree"
+
+{- Types of items in a tree. -}
+data TreeItemType = TreeFile | TreeExecutable | TreeSymlink | TreeSubmodule
+ deriving (Eq, Show)
+
+{- Git uses magic numbers to denote the type of a tree item. -}
+readTreeItemType :: S.ByteString -> Maybe TreeItemType
+readTreeItemType "100644" = Just TreeFile
+readTreeItemType "100755" = Just TreeExecutable
+readTreeItemType "120000" = Just TreeSymlink
+readTreeItemType "160000" = Just TreeSubmodule
+readTreeItemType _ = Nothing
+
+fmtTreeItemType :: TreeItemType -> S.ByteString
+fmtTreeItemType TreeFile = "100644"
+fmtTreeItemType TreeExecutable = "100755"
+fmtTreeItemType TreeSymlink = "120000"
+fmtTreeItemType TreeSubmodule = "160000"
+
+toTreeItemType :: FileMode -> Maybe TreeItemType
+toTreeItemType 0o100644 = Just TreeFile
+toTreeItemType 0o100755 = Just TreeExecutable
+toTreeItemType 0o120000 = Just TreeSymlink
+toTreeItemType 0o160000 = Just TreeSubmodule
+toTreeItemType _ = Nothing
+
+fromTreeItemType :: TreeItemType -> FileMode
+fromTreeItemType TreeFile = 0o100644
+fromTreeItemType TreeExecutable = 0o100755
+fromTreeItemType TreeSymlink = 0o120000
+fromTreeItemType TreeSubmodule = 0o160000
data Commit = Commit
{ commitTree :: Sha
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index 7fdc945..9f07cf5 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -1,11 +1,11 @@
{- git-update-index library
-
- - Copyright 2011-2013 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
-{-# LANGUAGE BangPatterns, CPP #-}
+{-# LANGUAGE BangPatterns, OverloadedStrings, CPP #-}
module Git.UpdateIndex (
Streamer,
@@ -21,6 +21,7 @@ module Git.UpdateIndex (
unstageFile,
stageSymlink,
stageDiffTreeItem,
+ refreshIndex,
) where
import Common
@@ -31,12 +32,14 @@ import Git.FilePath
import Git.Sha
import qualified Git.DiffTreeItem as Diff
+import qualified Data.ByteString.Lazy as L
+
{- Streamers are passed a callback and should feed it lines in the form
- read by update-index, and generated by ls-tree. -}
-type Streamer = (String -> IO ()) -> IO ()
+type Streamer = (L.ByteString -> IO ()) -> IO ()
{- A streamer with a precalculated value. -}
-pureStreamer :: String -> Streamer
+pureStreamer :: L.ByteString -> Streamer
pureStreamer !s = \streamer -> streamer s
{- Streams content into update-index from a list of Streamers. -}
@@ -48,8 +51,8 @@ data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle
streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO ()
streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do
- hPutStr h s
- hPutStr h "\0"
+ L.hPutStr h s
+ L.hPutStr h "\0"
startUpdateIndex :: Repo -> IO UpdateIndexHandle
startUpdateIndex repo = do
@@ -83,38 +86,66 @@ lsSubTree (Ref x) p repo streamer = do
{- Generates a line suitable to be fed into update-index, to add
- a given file with a given sha. -}
-updateIndexLine :: Sha -> BlobType -> TopFilePath -> String
-updateIndexLine sha filetype file =
- show filetype ++ " blob " ++ fromRef sha ++ "\t" ++ indexPath file
-
-stageFile :: Sha -> BlobType -> FilePath -> Repo -> IO Streamer
-stageFile sha filetype file repo = do
- p <- toTopFilePath file repo
- return $ pureStreamer $ updateIndexLine sha filetype p
+updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> L.ByteString
+updateIndexLine sha treeitemtype file = L.fromStrict $
+ fmtTreeItemType treeitemtype
+ <> " blob "
+ <> encodeBS (fromRef sha)
+ <> "\t"
+ <> indexPath file
+
+stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer
+stageFile sha treeitemtype file repo = do
+ p <- toTopFilePath (toRawFilePath file) repo
+ return $ pureStreamer $ updateIndexLine sha treeitemtype p
{- A streamer that removes a file from the index. -}
unstageFile :: FilePath -> Repo -> IO Streamer
unstageFile file repo = do
- p <- toTopFilePath file repo
+ p <- toTopFilePath (toRawFilePath file) repo
return $ unstageFile' p
unstageFile' :: TopFilePath -> Streamer
-unstageFile' p = pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p
+unstageFile' p = pureStreamer $ L.fromStrict $
+ "0 "
+ <> encodeBS' (fromRef nullSha)
+ <> "\t"
+ <> indexPath p
{- A streamer that adds a symlink to the index. -}
stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer
stageSymlink file sha repo = do
!line <- updateIndexLine
<$> pure sha
- <*> pure SymlinkBlob
- <*> toTopFilePath file repo
+ <*> pure TreeSymlink
+ <*> toTopFilePath (toRawFilePath file) repo
return $ pureStreamer line
{- A streamer that applies a DiffTreeItem to the index. -}
stageDiffTreeItem :: Diff.DiffTreeItem -> Streamer
-stageDiffTreeItem d = case toBlobType (Diff.dstmode d) of
+stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of
Nothing -> unstageFile' (Diff.file d)
Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d)
indexPath :: TopFilePath -> InternalGitPath
indexPath = toInternalGitPath . getTopFilePath
+
+{- Refreshes the index, by checking file stat information. -}
+refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool
+refreshIndex repo feeder = do
+ (Just h, _, _, p) <- createProcess (gitCreateProcess params repo)
+ { std_in = CreatePipe }
+ feeder $ \f -> do
+ hPutStr h f
+ hPutStr h "\0"
+ hFlush h
+ hClose h
+ checkSuccessProcess p
+ where
+ params =
+ [ Param "update-index"
+ , Param "-q"
+ , Param "--refresh"
+ , Param "-z"
+ , Param "--stdin"
+ ]
diff --git a/Git/Url.hs b/Git/Url.hs
index fa7d200..8430655 100644
--- a/Git/Url.hs
+++ b/Git/Url.hs
@@ -2,7 +2,7 @@
-
- Copyright 2010, 2011 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
module Git.Url (
@@ -11,9 +11,10 @@ module Git.Url (
port,
hostuser,
authority,
+ path,
) where
-import Network.URI hiding (scheme, authority)
+import Network.URI hiding (scheme, authority, path)
import Common
import Git.Types
@@ -66,6 +67,11 @@ authpart :: (URIAuth -> a) -> Repo -> Maybe a
authpart a Repo { location = Url u } = a <$> uriAuthority u
authpart _ repo = notUrl repo
+{- Path part of an URL repo. -}
+path :: Repo -> FilePath
+path Repo { location = Url u } = uriPath u
+path repo = notUrl repo
+
notUrl :: Repo -> a
notUrl repo = error $
"acting on local git repo " ++ repoDescribe repo ++ " not supported"
diff --git a/Git/Version.hs b/Git/Version.hs
index 19ff945..5ecaca0 100644
--- a/Git/Version.hs
+++ b/Git/Version.hs
@@ -2,7 +2,7 @@
-
- Copyright 2011, 2013 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
{-# OPTIONS_GHC -fno-warn-tabs #-}