summaryrefslogtreecommitdiff
path: root/Git
diff options
context:
space:
mode:
authorJoey Hess <joeyh@joeyh.name>2021-01-11 21:52:32 -0400
committerJoey Hess <joeyh@joeyh.name>2021-01-11 21:52:32 -0400
commitad48349741384ed0e49fab9cf13ac7f90aba0dd1 (patch)
tree6b8c894ce1057d069f89e7209c266f00ea43ec66 /Git
parentb3e72e94efbce652f25fb99d6c6ace8beb2a52d4 (diff)
downloadgit-repair-ad48349741384ed0e49fab9cf13ac7f90aba0dd1.tar.gz
Merge from git-annex.
Diffstat (limited to 'Git')
-rw-r--r--Git/CatFile.hs181
-rw-r--r--Git/Command.hs53
-rw-r--r--Git/Config.hs62
-rw-r--r--Git/Construct.hs97
-rw-r--r--Git/CurrentRepo.hs37
-rw-r--r--Git/Destroyer.hs7
-rw-r--r--Git/FilePath.hs3
-rw-r--r--Git/Filename.hs28
-rw-r--r--Git/Fsck.hs54
-rw-r--r--Git/HashObject.hs6
-rw-r--r--Git/Index.hs22
-rw-r--r--Git/LsFiles.hs174
-rw-r--r--Git/LsTree.hs23
-rw-r--r--Git/Objects.hs32
-rw-r--r--Git/Ref.hs9
-rw-r--r--Git/Repair.hs66
-rw-r--r--Git/Types.hs25
-rw-r--r--Git/UpdateIndex.hs66
-rw-r--r--Git/Version.hs2
19 files changed, 597 insertions, 350 deletions
diff --git a/Git/CatFile.hs b/Git/CatFile.hs
index 1769e57..6bea8c0 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -6,6 +6,7 @@
-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE BangPatterns #-}
module Git.CatFile (
CatFileHandle,
@@ -19,6 +20,9 @@ module Git.CatFile (
catObject,
catObjectDetails,
catObjectMetaData,
+ catObjectStreamLsTree,
+ catObjectStream,
+ catObjectMetaDataStream,
) where
import System.IO
@@ -27,12 +31,15 @@ import qualified Data.ByteString.Lazy as L
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 qualified Data.Map.Strict as M
import Data.String
import Data.Char
import Numeric
import System.Posix.Types
import Text.Read
+import Control.Concurrent.Async
+import Control.Concurrent.Chan
+import Control.Monad.IO.Class (MonadIO)
import Common
import Git
@@ -40,9 +47,10 @@ import Git.Sha
import qualified Git.Ref
import Git.Command
import Git.Types
-import Git.FilePath
import Git.HashObject
+import qualified Git.LsTree as LsTree
import qualified Utility.CoProcess as CoProcess
+import qualified Git.BuildVersion as BuildVersion
import Utility.Tuple
data CatFileHandle = CatFileHandle
@@ -57,7 +65,7 @@ catFileStart = catFileStart' True
catFileStart' :: Bool -> Repo -> IO CatFileHandle
catFileStart' restartable repo = CatFileHandle
<$> startp "--batch"
- <*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)"
+ <*> startp ("--batch-check=" ++ batchFormat)
<*> pure repo
where
startp p = gitCoProcessStart restartable
@@ -65,6 +73,9 @@ catFileStart' restartable repo = CatFileHandle
, Param p
] repo
+batchFormat :: String
+batchFormat = "%(objectname) %(objecttype) %(objectsize)"
+
catFileStop :: CatFileHandle -> IO ()
catFileStop h = do
CoProcess.stop (catFileProcess h)
@@ -72,12 +83,12 @@ 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 <> ":" <> toInternalGitPath file
+catFile h branch file = catObject h $
+ Git.Ref.branchFileRef branch file
catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType))
-catFileDetails h branch file = catObjectDetails h $ Ref $
- fromRef' branch <> ":" <> toInternalGitPath file
+catFileDetails h branch file = catObjectDetails h $
+ Git.Ref.branchFileRef branch file
{- Uses a running git cat-file read the content of an object.
- Objects that do not exist will have "" returned. -}
@@ -88,18 +99,12 @@ catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, Object
catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \from -> do
header <- S8.hGetLine from
case parseResp object header of
- Just (ParsedResp sha objtype size) -> do
- content <- S.hGet from (fromIntegral size)
- eatchar '\n' from
- return $ Just (L.fromChunks [content], sha, objtype)
+ Just r@(ParsedResp sha objtype _size) -> do
+ content <- readObjectContent from r
+ return $ Just (content, sha, objtype)
Just DNE -> return Nothing
Nothing -> error $ "unknown response from git cat-file " ++ show (header, object)
where
- eatchar expected 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
@@ -113,6 +118,18 @@ catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \f
(gitRepo h)
return (Just (content, sha, objtype))
+readObjectContent :: Handle -> ParsedResp -> IO L.ByteString
+readObjectContent h (ParsedResp _ _ size) = do
+ content <- S.hGet h (fromIntegral size)
+ eatchar '\n'
+ return (L.fromChunks [content])
+ where
+ eatchar expected = do
+ c <- hGetChar h
+ when (c /= expected) $
+ error $ "missing " ++ (show expected) ++ " from git cat-file"
+readObjectContent _ DNE = error "internal"
+
{- 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
@@ -180,14 +197,16 @@ querySingle o r repo reader = assertLocal repo $
, std_in = Inherit
, std_out = CreatePipe
}
- pid <- createProcess p'
- let h = stdoutHandle pid
- output <- reader h
- hClose h
- ifM (checkSuccessProcess (processHandle pid))
+ withCreateProcess p' go
+ where
+ go _ (Just outh) _ pid = do
+ output <- reader outh
+ hClose outh
+ ifM (checkSuccessProcess pid)
( return (Just output)
, return Nothing
)
+ go _ _ _ _ = error "internal"
querySize :: Ref -> Repo -> IO (Maybe FileSize)
querySize r repo = maybe Nothing (readMaybe . takeWhile (/= '\n'))
@@ -264,3 +283,123 @@ parseCommit b = Commit
sp = fromIntegral (ord ' ')
lt = fromIntegral (ord '<')
gt = fromIntegral (ord '>')
+
+{- Uses cat-file to stream the contents of the files as efficiently
+ - as possible. This is much faster than querying it repeatedly per file.
+ -}
+catObjectStreamLsTree
+ :: (MonadMask m, MonadIO m)
+ => [LsTree.TreeItem]
+ -> (LsTree.TreeItem -> Maybe v)
+ -> Repo
+ -> (IO (Maybe (v, Maybe L.ByteString)) -> m a)
+ -> m a
+catObjectStreamLsTree l want repo reader = withCatFileStream False repo $
+ \c hin hout -> bracketIO
+ (async $ feeder c hin)
+ cancel
+ (const (reader (catObjectReader readObjectContent c hout)))
+ where
+ feeder c h = do
+ forM_ l $ \ti -> case want ti of
+ Nothing -> return ()
+ Just v -> do
+ let sha = LsTree.sha ti
+ liftIO $ writeChan c (sha, v)
+ S8.hPutStrLn h (fromRef' sha)
+ hClose h
+
+catObjectStream
+ :: (MonadMask m, MonadIO m)
+ => Repo
+ -> (
+ ((v, Ref) -> IO ()) -- ^ call to feed values in
+ -> IO () -- call once all values are fed in
+ -> IO (Maybe (v, Maybe L.ByteString)) -- call to read results
+ -> m a
+ )
+ -> m a
+catObjectStream repo a = withCatFileStream False repo go
+ where
+ go c hin hout = a
+ (feeder c hin)
+ (hClose hin)
+ (catObjectReader readObjectContent c hout)
+ feeder c h (v, ref) = do
+ liftIO $ writeChan c (ref, v)
+ S8.hPutStrLn h (fromRef' ref)
+
+catObjectMetaDataStream
+ :: (MonadMask m, MonadIO m)
+ => Repo
+ -> (
+ ((v, Ref) -> IO ()) -- ^ call to feed values in
+ -> IO () -- call once all values are fed in
+ -> IO (Maybe (v, Maybe (Sha, FileSize, ObjectType))) -- call to read results
+ -> m a
+ )
+ -> m a
+catObjectMetaDataStream repo a = withCatFileStream True repo go
+ where
+ go c hin hout = a
+ (feeder c hin)
+ (hClose hin)
+ (catObjectReader (\_h r -> pure (conv r)) c hout)
+
+ feeder c h (v, ref) = do
+ liftIO $ writeChan c (ref, v)
+ S8.hPutStrLn h (fromRef' ref)
+
+ conv (ParsedResp sha ty sz) = (sha, sz, ty)
+ conv DNE = error "internal"
+
+catObjectReader
+ :: (Handle -> ParsedResp -> IO t)
+ -> Chan (Ref, a)
+ -> Handle
+ -> IO (Maybe (a, Maybe t))
+catObjectReader getv c h = ifM (hIsEOF h)
+ ( return Nothing
+ , do
+ (ref, f) <- liftIO $ readChan c
+ resp <- S8.hGetLine h
+ case parseResp ref resp of
+ Just r@(ParsedResp {}) -> do
+ v <- getv h r
+ return (Just (f, Just v))
+ Just DNE -> return (Just (f, Nothing))
+ Nothing -> error $ "unknown response from git cat-file " ++ show resp
+ )
+
+withCatFileStream
+ :: (MonadMask m, MonadIO m)
+ => Bool
+ -> Repo
+ -> (Chan v -> Handle -> Handle -> m a)
+ -> m a
+withCatFileStream check repo reader = assertLocal repo $
+ bracketIO start stop $ \(c, hin, hout, _) -> reader c hin hout
+ where
+ params = catMaybes
+ [ Just $ Param "cat-file"
+ , Just $ Param ("--batch" ++ (if check then "-check" else "") ++ "=" ++ batchFormat)
+ -- This option makes it faster, but is not present in
+ -- older versions of git.
+ , if BuildVersion.older "2.4.3"
+ then Nothing
+ else Just $ Param "--buffer"
+ ]
+
+ start = do
+ let p = gitCreateProcess params repo
+ (Just hin, Just hout, _, pid) <- createProcess p
+ { std_in = CreatePipe
+ , std_out = CreatePipe
+ }
+ c <- newChan
+ return (c, hin, hout, pid)
+
+ stop (_, hin, hout, pid) = do
+ hClose hin
+ hClose hout
+ void $ checkSuccessProcess pid
diff --git a/Git/Command.hs b/Git/Command.hs
index 15157a0..fef7eb9 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -1,6 +1,6 @@
{- running git commands
-
- - Copyright 2010-2013 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@@ -43,15 +43,19 @@ run params repo = assertLocal repo $
{- Runs git and forces it to be quiet, throwing an error if it fails. -}
runQuiet :: [CommandParam] -> Repo -> IO ()
-runQuiet params repo = withQuietOutput createProcessSuccess $
- (proc "git" $ toCommand $ gitCommandLine (params) repo)
- { env = gitEnv repo }
+runQuiet params repo = withNullHandle $ \nullh ->
+ let p = (proc "git" $ toCommand $ gitCommandLine (params) repo)
+ { env = gitEnv repo
+ , std_out = UseHandle nullh
+ , std_err = UseHandle nullh
+ }
+ in withCreateProcess p $ \_ _ _ -> forceSuccessProcess p
{- Runs a git command and returns its output, lazily.
-
- Also returns an action that should be used when the output is all
- read, that will wait on the command, and
- - return True if it succeeded. Failure to wait will result in zombies.
+ - return True if it succeeded.
-}
pipeReadLazy :: [CommandParam] -> Repo -> IO (L.ByteString, IO Bool)
pipeReadLazy params repo = assertLocal repo $ do
@@ -70,13 +74,17 @@ 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 <- reader h
- hClose h
- return output
+pipeReadStrict' reader params repo = assertLocal repo $ withCreateProcess p go
where
- p = gitCreateProcess params repo
+ p = (gitCreateProcess params repo)
+ { std_out = CreatePipe }
+
+ go _ (Just outh) _ pid = do
+ output <- reader outh
+ hClose outh
+ void $ waitForProcess pid
+ return output
+ go _ _ _ _ = error "internal"
{- 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
@@ -95,9 +103,16 @@ 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 = assertLocal repo $
- withHandle StdinHandle createProcessSuccess $
- gitCreateProcess params repo
+pipeWrite params repo feeder = assertLocal repo $
+ let p = (gitCreateProcess params repo)
+ { std_in = CreatePipe }
+ in withCreateProcess p (go p)
+ where
+ go p (Just hin) _ _ pid = do
+ feeder hin
+ hClose hin
+ forceSuccessProcess p pid
+ go _ _ _ _ _ = error "internal"
{- Reads null terminated output of a git command (as enabled by the -z
- parameter), and splits it. -}
@@ -119,16 +134,6 @@ pipeNullSplitStrict params repo = do
s <- pipeReadStrict params repo
return $ filter (not . S.null) $ S.split 0 s
-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
-
{- Runs a git command as a coprocess. -}
gitCoProcessStart :: Bool -> [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle
gitCoProcessStart restartable params repo = CoProcess.start numrestarts "git"
diff --git a/Git/Config.hs b/Git/Config.hs
index f50d5eb..20ddf79 100644
--- a/Git/Config.hs
+++ b/Git/Config.hs
@@ -58,29 +58,37 @@ read' repo = go repo
go Repo { location = Local { gitdir = d } } = git_config d
go Repo { location = LocalUnknown d } = git_config d
go _ = assertLocal repo $ error "internal"
- git_config d = withHandle StdoutHandle createProcessSuccess p $
- hRead repo ConfigNullList
+ git_config d = withCreateProcess p (git_config' p)
where
params = ["config", "--null", "--list"]
p = (proc "git" params)
{ cwd = Just (fromRawFilePath d)
, env = gitEnv repo
+ , std_out = CreatePipe
}
+ git_config' p _ (Just hout) _ pid =
+ forceSuccessProcess p pid
+ `after`
+ hRead repo ConfigNullList hout
+ git_config' _ _ _ _ _ = error "internal"
{- Gets the global git config, returning a dummy Repo containing it. -}
global :: IO (Maybe Repo)
global = do
home <- myHomeDir
ifM (doesFileExist $ home </> ".gitconfig")
- ( do
- repo <- withHandle StdoutHandle createProcessSuccess p $
- hRead (Git.Construct.fromUnknown) ConfigNullList
- return $ Just repo
+ ( Just <$> withCreateProcess p go
, return Nothing
)
where
params = ["config", "--null", "--list", "--global"]
p = (proc "git" params)
+ { std_out = CreatePipe }
+ go _ (Just hout) _ pid =
+ forceSuccessProcess p pid
+ `after`
+ hRead (Git.Construct.fromUnknown) ConfigNullList hout
+ go _ _ _ _ = error "internal"
{- Reads git config from a handle and populates a repo with it. -}
hRead :: Repo -> ConfigStyle -> Handle -> IO Repo
@@ -132,9 +140,9 @@ updateLocation' r l = do
Nothing -> return l
Just (ConfigValue d) -> do
{- core.worktree is relative to the gitdir -}
- top <- absPath $ fromRawFilePath (gitdir l)
- let p = absPathFrom top (fromRawFilePath d)
- return $ l { worktree = Just (toRawFilePath p) }
+ top <- absPath (gitdir l)
+ let p = absPathFrom top d
+ return $ l { worktree = Just p }
Just NoConfigValue -> return l
return $ r { location = l' }
@@ -177,6 +185,10 @@ isTrueFalse' (ConfigValue s)
| s' == "0" = Just False
| s' == "" = Just False
+ -- Git treats any number other than 0 as true,
+ -- including negative numbers.
+ | S8.all (\c -> isDigit c || c == '-') s' = Just True
+
| otherwise = Nothing
where
s' = S8.map toLower s
@@ -198,22 +210,30 @@ 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 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)
+ - output and the standard error of the command. -}
+fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, String))
+fromPipe r cmd params st = tryNonAsync $ withCreateProcess p go
where
- p = proc cmd $ toCommand params
+ p = (proc cmd $ toCommand params)
+ { std_out = CreatePipe
+ , std_err = CreatePipe
+ }
+ go _ (Just hout) (Just herr) pid =
+ withAsync (getstderr pid herr []) $ \errreader -> do
+ val <- S.hGetContents hout
+ err <- wait errreader
+ forceSuccessProcess p pid
+ r' <- store val st r
+ return (r', val, err)
+ go _ _ _ _ = error "internal"
+
+ getstderr pid herr c = hGetLineUntilExitOrEOF pid herr >>= \case
+ Just l -> getstderr pid herr (l:c)
+ Nothing -> return (unlines (reverse c))
{- Reads git config from a specified file and returns the repo populated
- with the configuration. -}
-fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString, S.ByteString))
+fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString, String))
fromFile r f = fromPipe r "git"
[ Param "config"
, Param "--file"
diff --git a/Git/Construct.hs b/Git/Construct.hs
index 5b656eb..8b63ac4 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -1,10 +1,11 @@
{- Construction of Git Repo objects
-
- - Copyright 2010-2012 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Git.Construct (
@@ -21,6 +22,7 @@ module Git.Construct (
repoAbsPath,
checkForRepo,
newFrom,
+ adjustGitDirFile,
) where
#ifndef mingw32_HOST_OS
@@ -37,6 +39,9 @@ import Git.FilePath
import qualified Git.Url as Url
import Utility.UserInfo
+import qualified Data.ByteString as B
+import qualified System.FilePath.ByteString as P
+
{- Finds the git repository used for the cwd, which may be in a parent
- directory. -}
fromCwd :: IO (Maybe Repo)
@@ -45,40 +50,40 @@ fromCwd = getCurrentDirectory >>= seekUp
seekUp dir = do
r <- checkForRepo dir
case r of
- Nothing -> case upFrom dir of
+ Nothing -> case upFrom (toRawFilePath dir) of
Nothing -> return Nothing
- Just d -> seekUp d
+ Just d -> seekUp (fromRawFilePath d)
Just loc -> pure $ Just $ newFrom loc
{- Local Repo constructor, accepts a relative or absolute path. -}
-fromPath :: FilePath -> IO Repo
+fromPath :: RawFilePath -> IO Repo
fromPath dir = fromAbsPath =<< absPath dir
{- Local Repo constructor, requires an absolute path to the repo be
- specified. -}
-fromAbsPath :: FilePath -> IO Repo
+fromAbsPath :: RawFilePath -> IO Repo
fromAbsPath dir
- | absoluteGitPath (encodeBS dir) = hunt
+ | absoluteGitPath dir = hunt
| otherwise =
- error $ "internal error, " ++ dir ++ " is not absolute"
+ error $ "internal error, " ++ show dir ++ " is not absolute"
where
- ret = pure . newFrom . LocalUnknown . toRawFilePath
- canondir = dropTrailingPathSeparator dir
+ ret = pure . newFrom . LocalUnknown
+ canondir = P.dropTrailingPathSeparator dir
{- When dir == "foo/.git", git looks for "foo/.git/.git",
- and failing that, uses "foo" as the repository. -}
hunt
- | (pathSeparator:".git") `isSuffixOf` canondir =
- ifM (doesDirectoryExist $ dir </> ".git")
+ | (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir =
+ ifM (doesDirectoryExist $ fromRawFilePath dir </> ".git")
( ret dir
- , ret (takeDirectory canondir)
+ , ret (P.takeDirectory canondir)
)
- | otherwise = ifM (doesDirectoryExist dir)
- ( ret dir
+ | otherwise = ifM (doesDirectoryExist (fromRawFilePath dir))
+ ( checkGitDirFile dir >>= maybe (ret dir) (pure . newFrom)
-- git falls back to dir.git when dir doesn't
-- exist, as long as dir didn't end with a
-- path separator
, if dir == canondir
- then ret (dir ++ ".git")
+ then ret (dir <> ".git")
else ret dir
)
@@ -94,7 +99,8 @@ fromUrl url
fromUrlStrict :: String -> IO Repo
fromUrlStrict url
- | "file://" `isPrefixOf` url = fromAbsPath $ unEscapeString $ uriPath u
+ | "file://" `isPrefixOf` url = fromAbsPath $ toRawFilePath $
+ unEscapeString $ uriPath u
| otherwise = pure $ newFrom $ Url u
where
u = fromMaybe bad $ parseURI url
@@ -128,7 +134,8 @@ fromRemotes repo = mapM construct remotepairs
filterconfig f = filter f $ M.toList $ config repo
filterkeys f = filterconfig (\(k,_) -> f k)
remotepairs = filterkeys isRemoteKey
- construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (fromConfigValue v) repo)
+ 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
@@ -154,18 +161,18 @@ fromRemoteLocation s repo = gen $ parseRemoteLocation s repo
fromRemotePath :: FilePath -> Repo -> IO Repo
fromRemotePath dir repo = do
dir' <- expandTilde dir
- fromPath $ fromRawFilePath (repoPath repo) </> dir'
+ fromPath $ repoPath repo P.</> toRawFilePath dir'
{- Git remotes can have a directory that is specified relative
- to the user's home directory, or that contains tilde expansions.
- This converts such a directory to an absolute path.
- Note that it has to run on the system where the remote is.
-}
-repoAbsPath :: FilePath -> IO FilePath
+repoAbsPath :: RawFilePath -> IO RawFilePath
repoAbsPath d = do
- d' <- expandTilde d
+ d' <- expandTilde (fromRawFilePath d)
h <- myHomeDir
- return $ h </> d'
+ return $ toRawFilePath $ h </> d'
expandTilde :: FilePath -> IO FilePath
#ifdef mingw32_HOST_OS
@@ -198,7 +205,7 @@ expandTilde = expandt True
checkForRepo :: FilePath -> IO (Maybe RepoLocation)
checkForRepo dir =
check isRepo $
- check gitDirFile $
+ check (checkGitDirFile (toRawFilePath dir)) $
check isBareRepo $
return Nothing
where
@@ -217,22 +224,40 @@ checkForRepo dir =
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 = toRawFilePath $ absPathFrom dir $
- drop (length gitdirprefix) c
- , worktree = Just (toRawFilePath dir)
- }
- else Nothing
- where
- gitdirprefix = "gitdir: "
gitSignature file = doesFileExist $ dir </> file
+-- Check for a .git file.
+checkGitDirFile :: RawFilePath -> IO (Maybe RepoLocation)
+checkGitDirFile dir = adjustGitDirFile' $ Local
+ { gitdir = dir P.</> ".git"
+ , worktree = Just dir
+ }
+
+-- git-submodule, git-worktree, and --separate-git-dir
+-- make .git be a file pointing to the real git directory.
+-- Detect that, and return a RepoLocation with gitdir pointing
+-- to the real git directory.
+adjustGitDirFile :: RepoLocation -> IO RepoLocation
+adjustGitDirFile loc = fromMaybe loc <$> adjustGitDirFile' loc
+
+adjustGitDirFile' :: RepoLocation -> IO (Maybe RepoLocation)
+adjustGitDirFile' loc = do
+ let gd = gitdir loc
+ c <- firstLine <$> catchDefaultIO "" (readFile (fromRawFilePath gd))
+ if gitdirprefix `isPrefixOf` c
+ then do
+ top <- fromRawFilePath . P.takeDirectory <$> absPath gd
+ return $ Just $ loc
+ { gitdir = absPathFrom
+ (toRawFilePath top)
+ (toRawFilePath
+ (drop (length gitdirprefix) c))
+ }
+ else return Nothing
+ where
+ gitdirprefix = "gitdir: "
+
+
newFrom :: RepoLocation -> Repo
newFrom l = Repo
{ location = l
diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs
index 054a81e..25bdc5c 100644
--- a/Git/CurrentRepo.hs
+++ b/Git/CurrentRepo.hs
@@ -1,10 +1,12 @@
{- The current git repository.
-
- - Copyright 2012 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Git.CurrentRepo where
import Common
@@ -13,6 +15,10 @@ import Git.Construct
import qualified Git.Config
import Utility.Env
import Utility.Env.Set
+import qualified Utility.RawFilePath as R
+
+import qualified Data.ByteString as B
+import qualified System.FilePath.ByteString as P
{- Gets the current git repository.
-
@@ -37,14 +43,14 @@ get = do
gd <- getpathenv "GIT_DIR"
r <- configure gd =<< fromCwd
prefix <- getpathenv "GIT_PREFIX"
- wt <- maybe (fromRawFilePath <$> worktree (location r)) Just
+ wt <- maybe (worktree (location r)) Just
<$> getpathenvprefix "GIT_WORK_TREE" prefix
case wt of
Nothing -> return r
Just d -> do
- curr <- getCurrentDirectory
+ curr <- R.getCurrentDirectory
unless (d `dirContains` curr) $
- setCurrentDirectory d
+ setCurrentDirectory (fromRawFilePath d)
return $ addworktree wt r
where
getpathenv s = do
@@ -52,34 +58,35 @@ get = do
case v of
Just d -> do
unsetEnv s
- return (Just d)
+ return (Just (toRawFilePath d))
Nothing -> return Nothing
- getpathenvprefix s (Just prefix) | not (null prefix) =
+ getpathenvprefix s (Just prefix) | not (B.null prefix) =
getpathenv s >>= \case
Nothing -> return Nothing
Just d
| d == "." -> return (Just d)
- | otherwise -> Just <$> absPath (prefix </> d)
+ | otherwise -> Just
+ <$> absPath (prefix P.</> d)
getpathenvprefix s _ = getpathenv s
configure Nothing (Just r) = Git.Config.read r
configure (Just d) _ = do
absd <- absPath d
- curr <- getCurrentDirectory
- r <- Git.Config.read $ newFrom $
- Local
- { gitdir = toRawFilePath absd
- , worktree = Just (toRawFilePath curr)
- }
+ curr <- R.getCurrentDirectory
+ loc <- adjustGitDirFile $ Local
+ { gitdir = absd
+ , worktree = Just curr
+ }
+ r <- Git.Config.read $ newFrom loc
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 = fmap toRawFilePath w
+ , worktree = w
}
+
changelocation r l = r { location = l }
diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs
index 3dc8529..4d84eec 100644
--- a/Git/Destroyer.hs
+++ b/Git/Destroyer.hs
@@ -95,12 +95,12 @@ applyDamage ds r = do
case d of
Empty s -> withfile s $ \f ->
withSaneMode f $ do
- nukeFile f
+ removeWhenExistsWith removeLink f
writeFile f ""
Reverse s -> withfile s $ \f ->
withSaneMode f $
B.writeFile f =<< B.reverse <$> B.readFile f
- Delete s -> withfile s $ nukeFile
+ Delete s -> withfile s $ removeWhenExistsWith removeLink
AppendGarbage s garbage ->
withfile s $ \f ->
withSaneMode f $
@@ -145,4 +145,5 @@ applyDamage ds r = do
]
withSaneMode :: FilePath -> IO () -> IO ()
-withSaneMode f = withModifiedFileMode f (addModes [ownerWriteMode, ownerReadMode])
+withSaneMode f = withModifiedFileMode (toRawFilePath f)
+ (addModes [ownerWriteMode, ownerReadMode])
diff --git a/Git/FilePath.hs b/Git/FilePath.hs
index d31b421..feed8f6 100644
--- a/Git/FilePath.hs
+++ b/Git/FilePath.hs
@@ -58,8 +58,7 @@ fromTopFilePath p repo = P.combine (repoPath repo) (getTopFilePath p)
{- The input FilePath can be absolute, or relative to the CWD. -}
toTopFilePath :: RawFilePath -> Git.Repo -> IO TopFilePath
-toTopFilePath file repo = TopFilePath . toRawFilePath
- <$> relPathDirToFile (fromRawFilePath (repoPath repo)) (fromRawFilePath file)
+toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file
{- The input RawFilePath must already be relative to the top of the git
- repository -}
diff --git a/Git/Filename.hs b/Git/Filename.hs
index 010e5ba..2fa4c59 100644
--- a/Git/Filename.hs
+++ b/Git/Filename.hs
@@ -10,6 +10,7 @@ module Git.Filename where
import Common
import Utility.Format (decode_c, encode_c)
+import Utility.QuickCheck
import Data.Char
import Data.Word
@@ -35,21 +36,14 @@ decode b = case S.uncons b of
encode :: RawFilePath -> S.ByteString
encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\""
-prop_encode_decode_roundtrip :: FilePath -> Bool
-prop_encode_decode_roundtrip s = s' ==
- fromRawFilePath (decode (encode (toRawFilePath 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".
+--
+-- That is not a real-world problem, and using TestableFilePath
+-- limits what's tested to ascii, so avoids running into it.
+prop_encode_decode_roundtrip :: TestableFilePath -> Bool
+prop_encode_decode_roundtrip ts =
+ s == fromRawFilePath (decode (encode (toRawFilePath s)))
where
- 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')
+ s = fromTestableFilePath ts
diff --git a/Git/Fsck.hs b/Git/Fsck.hs
index 69a9e9f..7440b92 100644
--- a/Git/Fsck.hs
+++ b/Git/Fsck.hs
@@ -77,27 +77,31 @@ findBroken batchmode r = do
then toBatchCommand (command, params)
else return (command, params)
- p@(_, _, _, pid) <- createProcess $
- (proc command' (toCommand params'))
- { std_out = CreatePipe
- , std_err = CreatePipe
- }
- (o1, o2) <- concurrently
- (parseFsckOutput maxobjs r (stdoutHandle p))
- (parseFsckOutput maxobjs r (stderrHandle p))
- fsckok <- checkSuccessProcess pid
- case mappend o1 o2 of
- FsckOutput badobjs truncated
- | S.null badobjs && not fsckok -> return FsckFailed
- | otherwise -> return $ FsckFoundMissing badobjs truncated
- NoFsckOutput
- | not fsckok -> return FsckFailed
- | otherwise -> return noproblem
- -- If all fsck output was duplicateEntries warnings,
- -- the repository is not broken, it just has some unusual
- -- tree objects in it. So ignore nonzero exit status.
- AllDuplicateEntriesWarning -> return noproblem
+ let p = (proc command' (toCommand params'))
+ { std_out = CreatePipe
+ , std_err = CreatePipe
+ }
+ withCreateProcess p go
where
+ go _ (Just outh) (Just errh) pid = do
+ (o1, o2) <- concurrently
+ (parseFsckOutput maxobjs r outh pid)
+ (parseFsckOutput maxobjs r errh pid)
+ fsckok <- checkSuccessProcess pid
+ case mappend o1 o2 of
+ FsckOutput badobjs truncated
+ | S.null badobjs && not fsckok -> return FsckFailed
+ | otherwise -> return $ FsckFoundMissing badobjs truncated
+ NoFsckOutput
+ | not fsckok -> return FsckFailed
+ | otherwise -> return noproblem
+ -- If all fsck output was duplicateEntries warnings,
+ -- the repository is not broken, it just has some
+ -- unusual tree objects in it. So ignore nonzero
+ -- exit status.
+ AllDuplicateEntriesWarning -> return noproblem
+ go _ _ _ _ = error "internal"
+
maxobjs = 10000
noproblem = FsckFoundMissing S.empty False
@@ -117,9 +121,9 @@ knownMissing (FsckFoundMissing s _) = s
findMissing :: [Sha] -> Repo -> IO MissingObjects
findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs
-parseFsckOutput :: Int -> Repo -> Handle -> IO FsckOutput
-parseFsckOutput maxobjs r h = do
- ls <- lines <$> hGetContents h
+parseFsckOutput :: Int -> Repo -> Handle -> ProcessHandle -> IO FsckOutput
+parseFsckOutput maxobjs r h pid = do
+ ls <- getlines []
if null ls
then return NoFsckOutput
else if all ("duplicateEntries" `isInfixOf`) ls
@@ -129,6 +133,10 @@ parseFsckOutput maxobjs r h = do
let !truncated = length shas > maxobjs
missingobjs <- findMissing (take maxobjs shas) r
return $ FsckOutput missingobjs truncated
+ where
+ getlines c = hGetLineUntilExitOrEOF pid h >>= \case
+ Nothing -> return (reverse c)
+ Just l -> getlines (l:c)
isMissing :: Sha -> Repo -> IO Bool
isMissing s r = either (const True) (const False) <$> tryIO dump
diff --git a/Git/HashObject.hs b/Git/HashObject.hs
index bcad9a1..98bd440 100644
--- a/Git/HashObject.hs
+++ b/Git/HashObject.hs
@@ -36,10 +36,10 @@ hashObjectStop :: HashObjectHandle -> IO ()
hashObjectStop = CoProcess.stop
{- Injects a file into git, returning the Sha of the object. -}
-hashFile :: HashObjectHandle -> FilePath -> IO Sha
+hashFile :: HashObjectHandle -> RawFilePath -> IO Sha
hashFile h file = CoProcess.query h send receive
where
- send to = hPutStrLn to =<< absPath file
+ send to = S8.hPutStrLn to =<< absPath file
receive from = getSha "hash-object" $ S8.hGetLine from
class HashableBlob t where
@@ -60,7 +60,7 @@ hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha
hashBlob h b = withTmpFile "hash" $ \tmp tmph -> do
hashableBlobToHandle tmph b
hClose tmph
- hashFile h tmp
+ hashFile h (toRawFilePath tmp)
{- Injects some content into git, returning its Sha.
-
diff --git a/Git/Index.hs b/Git/Index.hs
index afd29c2..b55fc04 100644
--- a/Git/Index.hs
+++ b/Git/Index.hs
@@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Git.Index where
import Common
@@ -12,6 +14,8 @@ import Git
import Utility.Env
import Utility.Env.Set
+import qualified System.FilePath.ByteString as P
+
indexEnv :: String
indexEnv = "GIT_INDEX_FILE"
@@ -26,8 +30,8 @@ indexEnv = "GIT_INDEX_FILE"
-
- So, an absolute path is the only safe option for this to return.
-}
-indexEnvVal :: FilePath -> IO String
-indexEnvVal = absPath
+indexEnvVal :: RawFilePath -> IO String
+indexEnvVal p = fromRawFilePath <$> absPath p
{- Forces git to use the specified index file.
-
@@ -36,7 +40,7 @@ indexEnvVal = absPath
-
- Warning: Not thread safe.
-}
-override :: FilePath -> Repo -> IO (IO ())
+override :: RawFilePath -> Repo -> IO (IO ())
override index _r = do
res <- getEnv var
val <- indexEnvVal index
@@ -48,13 +52,13 @@ override index _r = do
reset _ = unsetEnv var
{- The normal index file. Does not check GIT_INDEX_FILE. -}
-indexFile :: Repo -> FilePath
-indexFile r = fromRawFilePath (localGitDir r) </> "index"
+indexFile :: Repo -> RawFilePath
+indexFile r = localGitDir r P.</> "index"
{- The index file git will currently use, checking GIT_INDEX_FILE. -}
-currentIndexFile :: Repo -> IO FilePath
-currentIndexFile r = fromMaybe (indexFile r) <$> getEnv indexEnv
+currentIndexFile :: Repo -> IO RawFilePath
+currentIndexFile r = maybe (indexFile r) toRawFilePath <$> getEnv indexEnv
{- Git locks the index by creating this file. -}
-indexFileLock :: FilePath -> FilePath
-indexFileLock f = f ++ ".lock"
+indexFileLock :: RawFilePath -> RawFilePath
+indexFileLock f = f <> ".lock"
diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs
index 830b5f5..297c068 100644
--- a/Git/LsFiles.hs
+++ b/Git/LsFiles.hs
@@ -1,22 +1,24 @@
{- git ls-files interface
-
- - Copyright 2010-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Git.LsFiles (
+ Options(..),
inRepo,
+ inRepoDetails,
inRepoOrBranch,
notInRepo,
notInRepoIncludingEmptyDirectories,
allFiles,
deleted,
modified,
- modifiedOthers,
staged,
stagedNotDeleted,
- stagedOthersDetails,
+ usualStageNum,
+ mergeConflictHeadStageNum,
stagedDetails,
typeChanged,
typeChangedStaged,
@@ -34,12 +36,15 @@ import Git.Types
import Git.Sha
import Utility.InodeCache
import Utility.TimeStamp
+import Utility.Attoparsec
+import qualified Utility.RawFilePath as R
-import Numeric
-import Data.Char
import System.Posix.Types
import qualified Data.Map as M
import qualified Data.ByteString as S
+import qualified Data.Attoparsec.ByteString as A
+import qualified Data.Attoparsec.ByteString.Char8 as A8
+import qualified System.FilePath.ByteString as P
{- It's only safe to use git ls-files on the current repo, not on a remote.
-
@@ -63,101 +68,75 @@ guardSafeForLsFiles r a
| safeForLsFiles r = a
| otherwise = error $ "git ls-files is unsafe to run on repository " ++ repoDescribe r
+data Options = ErrorUnmatch
+
+opParam :: Options -> CommandParam
+opParam ErrorUnmatch = Param "--error-unmatch"
+
{- 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 :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+inRepo = inRepo' [Param "--cached"]
-inRepo' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
-inRepo' ps l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo
+inRepo' :: [CommandParam] -> [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+inRepo' ps os l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo
where
params =
Param "ls-files" :
- Param "--cached" :
Param "-z" :
- ps ++
+ map opParam os ++ ps ++
(Param "--" : map (File . fromRawFilePath) l)
+{- Lists the same files inRepo does, but with sha and mode. -}
+inRepoDetails :: [Options] -> [RawFilePath] -> Repo -> IO ([(RawFilePath, Sha, FileMode)], IO Bool)
+inRepoDetails = stagedDetails' parser . map opParam
+ where
+ parser s = case parseStagedDetails s of
+ Just (file, sha, mode, stagenum)
+ | stagenum == usualStageNum || stagenum == mergeConflictHeadStageNum ->
+ Just (file, sha, mode)
+ _ -> Nothing
+
{- Files that are checked into the index or have been committed to a
- branch. -}
-inRepoOrBranch :: Branch -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
-inRepoOrBranch b = inRepo' [Param $ "--with-tree=" ++ fromRef b]
+inRepoOrBranch :: Branch -> [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+inRepoOrBranch b = inRepo'
+ [ Param "--cached"
+ , 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 :: [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
notInRepo = notInRepo' []
-notInRepo' :: [CommandParam] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
-notInRepo' ps include_ignored l repo = guardSafeForLsFiles repo $
- pipeNullSplit' params repo
+notInRepo' :: [CommandParam] -> [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+notInRepo' ps os include_ignored =
+ inRepo' (Param "--others" : ps ++ exclude) os
where
- params = concat
- [ [ Param "ls-files", Param "--others"]
- , ps
- , exclude
- , [ Param "-z", Param "--" ]
- , 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 :: [Options] -> 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 :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
-allFiles l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo
- where
- params =
- Param "ls-files" :
- Param "--cached" :
- Param "--others" :
- Param "-z" :
- Param "--" :
- map (File . fromRawFilePath) l
+allFiles :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+allFiles = inRepo' [Param "--cached", Param "--others"]
{- Returns a list of files in the specified locations that have been
- deleted. -}
-deleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
-deleted l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo
- where
- params =
- Param "ls-files" :
- Param "--deleted" :
- Param "-z" :
- Param "--" :
- map (File . fromRawFilePath) l
+deleted :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+deleted = inRepo' [Param "--deleted"]
{- Returns a list of files in the specified locations that have been
- modified. -}
-modified :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
-modified l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo
- where
- params =
- Param "ls-files" :
- Param "--modified" :
- Param "-z" :
- Param "--" :
- map (File . fromRawFilePath) l
-
-{- 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 = guardSafeForLsFiles repo $ pipeNullSplit' params repo
- where
- params =
- Param "ls-files" :
- Param "--modified" :
- Param "--others" :
- Param "--exclude-standard" :
- Param "-z" :
- Param "--" :
- map (File . fromRawFilePath) l
+modified :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+modified = inRepo' [Param "--modified"]
{- Returns a list of all files that are staged for commit. -}
staged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
@@ -175,36 +154,49 @@ staged' ps l repo = guardSafeForLsFiles repo $
prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"]
suffix = Param "--" : map (File . fromRawFilePath) l
-type StagedDetails = (RawFilePath, Maybe Sha, Maybe FileMode)
+type StagedDetails = (RawFilePath, Sha, FileMode, StageNum)
+
+type StageNum = Int
-{- Returns details about files that are staged in the index,
- - as well as files not yet in git. Skips ignored files. -}
-stagedOthersDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)
-stagedOthersDetails = stagedDetails' [Param "--others", Param "--exclude-standard"]
+{- Used when not in a merge conflict. -}
+usualStageNum :: Int
+usualStageNum = 0
-{- Returns details about all files that are staged in the index. -}
+{- WHen in a merge conflict, git uses stage number 2 for the local HEAD
+ - side of the merge conflict. -}
+mergeConflictHeadStageNum :: Int
+mergeConflictHeadStageNum = 2
+
+{- Returns details about all files that are staged in the index.
+ -
+ - Note that, during a conflict, a file will appear in the list
+ - more than once with different stage numbers.
+ -}
stagedDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)
-stagedDetails = stagedDetails' []
+stagedDetails = stagedDetails' parseStagedDetails []
-{- Gets details about staged files, including the Sha of their staged
- - contents. -}
-stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)
-stagedDetails' ps l repo = guardSafeForLsFiles repo $ do
+stagedDetails' :: (S.ByteString -> Maybe t) -> [CommandParam] -> [RawFilePath] -> Repo -> IO ([t], IO Bool)
+stagedDetails' parser ps l repo = guardSafeForLsFiles repo $ do
(ls, cleanup) <- pipeNullSplit' params repo
- return (map parseStagedDetails ls, cleanup)
+ return (mapMaybe parser ls, cleanup)
where
params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++
Param "--" : map (File . fromRawFilePath) l
-parseStagedDetails :: S.ByteString -> StagedDetails
-parseStagedDetails s
- | S.null file = (s, Nothing, Nothing)
- | otherwise = (file, extractSha sha, readmode mode)
+parseStagedDetails :: S.ByteString -> Maybe StagedDetails
+parseStagedDetails = eitherToMaybe . A.parseOnly parser
where
- (metadata, file) = separate' (== fromIntegral (ord '\t')) s
- (mode, metadata') = separate' (== fromIntegral (ord ' ')) metadata
- (sha, _) = separate' (== fromIntegral (ord ' ')) metadata'
- readmode = fst <$$> headMaybe . readOct . decodeBS'
+ parser = do
+ mode <- octal
+ void $ A8.char ' '
+ sha <- maybe (fail "bad sha") return . extractSha =<< nextword
+ void $ A8.char ' '
+ stagenum <- A8.decimal
+ void $ A8.char '\t'
+ file <- A.takeByteString
+ return (file, sha, mode, stagenum)
+
+ nextword = A8.takeTill (== ' ')
{- Returns a list of the files in the specified locations that are staged
- for commit, and whose type has changed. -}
@@ -218,12 +210,12 @@ typeChanged = typeChanged' []
typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
typeChanged' ps l repo = guardSafeForLsFiles repo $ do
- (fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo
+ (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 (fromRawFilePath (repoPath repo))
- currdir <- getCurrentDirectory
- return (map (\f -> toRawFilePath (relPathDirToFileAbs currdir $ top </> decodeBL' f)) fs, cleanup)
+ top <- absPath (repoPath repo)
+ currdir <- R.getCurrentDirectory
+ return (map (\f -> relPathDirToFileAbs currdir $ top P.</> f) fs, cleanup)
where
prefix =
[ Param "diff"
diff --git a/Git/LsTree.hs b/Git/LsTree.hs
index ead501f..cd0d406 100644
--- a/Git/LsTree.hs
+++ b/Git/LsTree.hs
@@ -1,17 +1,17 @@
{- git ls-tree interface
-
- - Copyright 2011-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
-{-# LANGUAGE BangPatterns #-}
-
module Git.LsTree (
TreeItem(..),
LsTreeMode(..),
lsTree,
lsTree',
+ lsTreeStrict,
+ lsTreeStrict',
lsTreeParams,
lsTreeFiles,
parseLsTree,
@@ -30,6 +30,7 @@ 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 as AS
import qualified Data.Attoparsec.ByteString.Lazy as A
import qualified Data.Attoparsec.ByteString.Char8 as A8
@@ -38,7 +39,7 @@ data TreeItem = TreeItem
, typeobj :: S.ByteString
, sha :: Ref
, file :: TopFilePath
- } deriving Show
+ } deriving (Show)
data LsTreeMode = LsTreeRecursive | LsTreeNonRecursive
@@ -51,6 +52,13 @@ lsTree' ps lsmode t repo = do
(l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo
return (rights (map parseLsTree l), cleanup)
+lsTreeStrict :: LsTreeMode -> Ref -> Repo -> IO [TreeItem]
+lsTreeStrict = lsTreeStrict' []
+
+lsTreeStrict' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO [TreeItem]
+lsTreeStrict' ps lsmode t repo = rights . map parseLsTreeStrict
+ <$> pipeNullSplitStrict (lsTreeParams lsmode t ps) repo
+
lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam]
lsTreeParams lsmode r ps =
[ Param "ls-tree"
@@ -83,6 +91,13 @@ parseLsTree b = case A.parse parserLsTree b of
A.Done _ r -> Right r
A.Fail _ _ err -> Left err
+parseLsTreeStrict :: S.ByteString -> Either String TreeItem
+parseLsTreeStrict b = go (AS.parse parserLsTree b)
+ where
+ go (AS.Done _ r) = Right r
+ go (AS.Fail _ _ err) = Left err
+ go (AS.Partial c) = go (c mempty)
+
{- Parses a line of ls-tree output, in format:
- mode SP type SP sha TAB file
-
diff --git a/Git/Objects.hs b/Git/Objects.hs
index 6a24087..9b7165c 100644
--- a/Git/Objects.hs
+++ b/Git/Objects.hs
@@ -5,39 +5,45 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Git.Objects where
import Common
import Git
import Git.Sha
-objectsDir :: Repo -> FilePath
-objectsDir r = fromRawFilePath (localGitDir r) </> "objects"
+import qualified Data.ByteString as B
+import qualified System.FilePath.ByteString as P
+
+objectsDir :: Repo -> RawFilePath
+objectsDir r = localGitDir r P.</> "objects"
-packDir :: Repo -> FilePath
-packDir r = objectsDir r </> "pack"
+packDir :: Repo -> RawFilePath
+packDir r = objectsDir r P.</> "pack"
-packIdxFile :: FilePath -> FilePath
-packIdxFile = flip replaceExtension "idx"
+packIdxFile :: RawFilePath -> RawFilePath
+packIdxFile = flip P.replaceExtension "idx"
listPackFiles :: Repo -> IO [FilePath]
listPackFiles r = filter (".pack" `isSuffixOf`)
- <$> catchDefaultIO [] (dirContents $ packDir r)
+ <$> catchDefaultIO [] (dirContents $ fromRawFilePath $ packDir r)
listLooseObjectShas :: Repo -> IO [Sha]
listLooseObjectShas r = catchDefaultIO [] $
mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories)
- <$> dirContentsRecursiveSkipping (== "pack") True (objectsDir r)
+ <$> dirContentsRecursiveSkipping (== "pack") True (fromRawFilePath (objectsDir r))
-looseObjectFile :: Repo -> Sha -> FilePath
-looseObjectFile r sha = objectsDir r </> prefix </> rest
+looseObjectFile :: Repo -> Sha -> RawFilePath
+looseObjectFile r sha = objectsDir r P.</> prefix P.</> rest
where
- (prefix, rest) = splitAt 2 (fromRef sha)
+ (prefix, rest) = B.splitAt 2 (fromRef' sha)
listAlternates :: Repo -> IO [FilePath]
-listAlternates r = catchDefaultIO [] (lines <$> readFile alternatesfile)
+listAlternates r = catchDefaultIO [] $
+ lines <$> readFile (fromRawFilePath alternatesfile)
where
- alternatesfile = objectsDir r </> "info" </> "alternates"
+ alternatesfile = objectsDir r P.</> "info" P.</> "alternates"
{- A repository recently cloned with --shared will have one or more
- alternates listed, and contain no loose objects or packs. -}
diff --git a/Git/Ref.hs b/Git/Ref.hs
index 104a1db..7179a4e 100644
--- a/Git/Ref.hs
+++ b/Git/Ref.hs
@@ -1,6 +1,6 @@
{- git ref stuff
-
- - Copyright 2011-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@@ -14,6 +14,7 @@ import Git
import Git.Command
import Git.Sha
import Git.Types
+import Git.FilePath
import Data.Char (chr, ord)
import qualified Data.ByteString as S
@@ -68,7 +69,11 @@ branchRef = underBase "refs/heads"
- of a repo.
-}
fileRef :: RawFilePath -> Ref
-fileRef f = Ref $ ":./" <> f
+fileRef f = Ref $ ":./" <> toInternalGitPath f
+
+{- A Ref that can be used to refer to a file in a particular branch. -}
+branchFileRef :: Branch -> RawFilePath -> Ref
+branchFileRef branch f = Ref $ fromRef' branch <> ":" <> toInternalGitPath f
{- Converts a Ref to refer to the content of the Ref on a given date. -}
dateRef :: Ref -> RefDate -> Ref
diff --git a/Git/Repair.hs b/Git/Repair.hs
index f81aa78..ea682a2 100644
--- a/Git/Repair.hs
+++ b/Git/Repair.hs
@@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Git.Repair (
runRepair,
runRepairOf,
@@ -35,13 +37,15 @@ 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.Directory.Create
import Utility.Tmp.Dir
import Utility.Rsync
import Utility.FileMode
-import Utility.Tuple
+import qualified Utility.RawFilePath as R
import qualified Data.Set as S
import qualified Data.ByteString.Lazy as L
+import qualified System.FilePath.ByteString as P
{- Given a set of bad objects found by git fsck, which may not
- be complete, finds and removes all corrupt objects. -}
@@ -51,9 +55,9 @@ cleanCorruptObjects fsckresults r = do
mapM_ removeLoose (S.toList $ knownMissing fsckresults)
mapM_ removeBad =<< listLooseObjectShas r
where
- removeLoose s = nukeFile (looseObjectFile r s)
+ removeLoose s = removeWhenExistsWith R.removeLink (looseObjectFile r s)
removeBad s = do
- void $ tryIO $ allowRead $ looseObjectFile r s
+ void $ tryIO $ allowRead $ looseObjectFile r s
whenM (isMissing s r) $
removeLoose s
@@ -77,10 +81,11 @@ explodePacks r = go =<< listPackFiles r
putStrLn "Unpacking all pack files."
forM_ packs $ \packfile -> do
moveFile packfile (tmpdir </> takeFileName packfile)
- nukeFile $ packIdxFile packfile
+ removeWhenExistsWith R.removeLink
+ (packIdxFile (toRawFilePath packfile))
forM_ packs $ \packfile -> do
let tmp = tmpdir </> takeFileName packfile
- allowRead tmp
+ allowRead (toRawFilePath tmp)
-- May fail, if pack file is corrupt.
void $ tryIO $
pipeWrite [Param "unpack-objects", Param "-r"] r $ \h ->
@@ -100,7 +105,7 @@ retrieveMissingObjects missing referencerepo r
| otherwise = withTmpDir "tmprepo" $ \tmpdir -> do
unlessM (boolSystem "git" [Param "init", File tmpdir]) $
error $ "failed to create temp repository in " ++ tmpdir
- tmpr <- Config.read =<< Construct.fromAbsPath tmpdir
+ tmpr <- Config.read =<< Construct.fromAbsPath (toRawFilePath tmpdir)
rs <- Construct.fromRemotes r
stillmissing <- pullremotes tmpr rs fetchrefstags missing
if S.null (knownMissing stillmissing)
@@ -161,8 +166,8 @@ retrieveMissingObjects missing referencerepo r
copyObjects :: Repo -> Repo -> IO Bool
copyObjects srcr destr = rsync
[ Param "-qr"
- , File $ addTrailingPathSeparator $ objectsDir srcr
- , File $ addTrailingPathSeparator $ objectsDir destr
+ , File $ addTrailingPathSeparator $ fromRawFilePath $ objectsDir srcr
+ , File $ addTrailingPathSeparator $ fromRawFilePath $ objectsDir destr
]
{- To deal with missing objects that cannot be recovered, resets any
@@ -240,18 +245,20 @@ getAllRefs' refdir = do
explodePackedRefsFile :: Repo -> IO ()
explodePackedRefsFile r = do
let f = packedRefsFile r
+ let f' = toRawFilePath f
whenM (doesFileExist f) $ do
rs <- mapMaybe parsePacked . lines
- <$> catchDefaultIO "" (safeReadFile f)
+ <$> catchDefaultIO "" (safeReadFile f')
forM_ rs makeref
- nukeFile f
+ removeWhenExistsWith R.removeLink f'
where
makeref (sha, ref) = do
- let gitd = fromRawFilePath (localGitDir r)
- let dest = gitd </> fromRef ref
+ let gitd = localGitDir r
+ let dest = gitd P.</> fromRef' ref
+ let dest' = fromRawFilePath dest
createDirectoryUnder gitd (parentDir dest)
- unlessM (doesFileExist dest) $
- writeFile dest (fromRef sha)
+ unlessM (doesFileExist dest') $
+ writeFile dest' (fromRef sha)
packedRefsFile :: Repo -> FilePath
packedRefsFile r = fromRawFilePath (localGitDir r) </> "packed-refs"
@@ -266,7 +273,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 $ fromRawFilePath (localGitDir r) </> fromRef b
+nukeBranchRef b r = removeWhenExistsWith R.removeLink $ localGitDir r P.</> 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.
@@ -379,9 +386,8 @@ missingIndex r = not <$> doesFileExist (fromRawFilePath (localGitDir r) </> "ind
partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool)
partitionIndex r = do
(indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r
- l <- forM indexcontents $ \i -> case i of
- (_file, Just sha, Just _mode) -> (,) <$> isMissing sha r <*> pure i
- _ -> pure (False, i)
+ l <- forM indexcontents $ \i@(_file, sha, _mode, _stagenum) ->
+ (,) <$> isMissing sha r <*> pure i
let (bad, good) = partition fst l
return (map snd bad, map snd good, cleanup)
@@ -393,17 +399,16 @@ rewriteIndex r
| otherwise = do
(bad, good, cleanup) <- partitionIndex r
unless (null bad) $ do
- nukeFile (indexFile r)
+ removeWhenExistsWith R.removeLink (indexFile r)
UpdateIndex.streamUpdateIndex r
=<< (catMaybes <$> mapM reinject good)
void cleanup
- return $ map (fromRawFilePath . fst3) bad
+ return $ map (\(file,_, _, _) -> fromRawFilePath file) bad
where
- reinject (file, Just sha, Just mode) = case toTreeItemType mode of
+ reinject (file, sha, mode, _) = case toTreeItemType mode of
Nothing -> return Nothing
Just treeitemtype -> Just <$>
UpdateIndex.stageFile sha treeitemtype (fromRawFilePath file) r
- reinject _ = return Nothing
newtype GoodCommits = GoodCommits (S.Set Sha)
@@ -442,14 +447,13 @@ displayList items header
preRepair :: Repo -> IO ()
preRepair g = do
unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do
- nukeFile headfile
- writeFile headfile "ref: refs/heads/master"
+ removeWhenExistsWith R.removeLink headfile
+ writeFile (fromRawFilePath headfile) "ref: refs/heads/master"
explodePackedRefsFile g
- unless (repoIsLocalBare g) $ do
- let f = indexFile g
- void $ tryIO $ allowWrite f
+ unless (repoIsLocalBare g) $
+ void $ tryIO $ allowWrite $ indexFile g
where
- headfile = fromRawFilePath (localGitDir g) </> "HEAD"
+ headfile = localGitDir g P.</> "HEAD"
validhead s = "ref: refs/" `isPrefixOf` s
|| isJust (extractSha (encodeBS' s))
@@ -571,7 +575,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do
else successfulfinish modifiedbranches
corruptedindex = do
- nukeFile (indexFile g)
+ removeWhenExistsWith R.removeLink (indexFile g)
-- The corrupted index can prevent fsck from finding other
-- problems, so re-run repair.
fsckresult' <- findBroken False g
@@ -615,7 +619,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do
successfulRepair :: (Bool, [Branch]) -> Bool
successfulRepair = fst
-safeReadFile :: FilePath -> IO String
+safeReadFile :: RawFilePath -> IO String
safeReadFile f = do
allowRead f
- readFileStrict f
+ readFileStrict (fromRawFilePath f)
diff --git a/Git/Types.hs b/Git/Types.hs
index 4bf61e5..73c4fe6 100644
--- a/Git/Types.hs
+++ b/Git/Types.hs
@@ -5,7 +5,7 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
module Git.Types where
@@ -79,9 +79,15 @@ fromConfigKey (ConfigKey s) = decodeBS' s
instance Show ConfigKey where
show = fromConfigKey
-fromConfigValue :: ConfigValue -> String
-fromConfigValue (ConfigValue s) = decodeBS' s
-fromConfigValue NoConfigValue = mempty
+class FromConfigValue a where
+ fromConfigValue :: ConfigValue -> a
+
+instance FromConfigValue S.ByteString where
+ fromConfigValue (ConfigValue s) = s
+ fromConfigValue NoConfigValue = mempty
+
+instance FromConfigValue String where
+ fromConfigValue = decodeBS' . fromConfigValue
instance Show ConfigValue where
show = fromConfigValue
@@ -129,7 +135,12 @@ fmtObjectType CommitObject = "commit"
fmtObjectType TreeObject = "tree"
{- Types of items in a tree. -}
-data TreeItemType = TreeFile | TreeExecutable | TreeSymlink | TreeSubmodule
+data TreeItemType
+ = TreeFile
+ | TreeExecutable
+ | TreeSymlink
+ | TreeSubmodule
+ | TreeSubtree
deriving (Eq, Show)
{- Git uses magic numbers to denote the type of a tree item. -}
@@ -138,6 +149,7 @@ readTreeItemType "100644" = Just TreeFile
readTreeItemType "100755" = Just TreeExecutable
readTreeItemType "120000" = Just TreeSymlink
readTreeItemType "160000" = Just TreeSubmodule
+readTreeItemType "040000" = Just TreeSubtree
readTreeItemType _ = Nothing
fmtTreeItemType :: TreeItemType -> S.ByteString
@@ -145,12 +157,14 @@ fmtTreeItemType TreeFile = "100644"
fmtTreeItemType TreeExecutable = "100755"
fmtTreeItemType TreeSymlink = "120000"
fmtTreeItemType TreeSubmodule = "160000"
+fmtTreeItemType TreeSubtree = "040000"
toTreeItemType :: FileMode -> Maybe TreeItemType
toTreeItemType 0o100644 = Just TreeFile
toTreeItemType 0o100755 = Just TreeExecutable
toTreeItemType 0o120000 = Just TreeSymlink
toTreeItemType 0o160000 = Just TreeSubmodule
+toTreeItemType 0o040000 = Just TreeSubtree
toTreeItemType _ = Nothing
fromTreeItemType :: TreeItemType -> FileMode
@@ -158,6 +172,7 @@ fromTreeItemType TreeFile = 0o100644
fromTreeItemType TreeExecutable = 0o100755
fromTreeItemType TreeSymlink = 0o120000
fromTreeItemType TreeSubmodule = 0o160000
+fromTreeItemType TreeSubtree = 0o040000
data Commit = Commit
{ commitTree :: Sha
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index f0331d5..8e406b1 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -1,6 +1,6 @@
{- git-update-index library
-
- - Copyright 2011-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@@ -12,8 +12,7 @@ module Git.UpdateIndex (
pureStreamer,
streamUpdateIndex,
streamUpdateIndex',
- startUpdateIndex,
- stopUpdateIndex,
+ withUpdateIndex,
lsTree,
lsSubTree,
updateIndexLine,
@@ -32,7 +31,9 @@ import Git.FilePath
import Git.Sha
import qualified Git.DiffTreeItem as Diff
+import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
+import Control.Monad.IO.Class
{- Streamers are passed a callback and should feed it lines in the form
- read by update-index, and generated by ls-tree. -}
@@ -44,28 +45,32 @@ pureStreamer !s = \streamer -> streamer s
{- Streams content into update-index from a list of Streamers. -}
streamUpdateIndex :: Repo -> [Streamer] -> IO ()
-streamUpdateIndex repo as = bracket (startUpdateIndex repo) stopUpdateIndex $
- (\h -> forM_ as $ streamUpdateIndex' h)
+streamUpdateIndex repo as = withUpdateIndex repo $ \h ->
+ forM_ as $ streamUpdateIndex' h
-data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle
+data UpdateIndexHandle = UpdateIndexHandle Handle
streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO ()
-streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do
+streamUpdateIndex' (UpdateIndexHandle h) a = a $ \s -> do
L.hPutStr h s
L.hPutStr h "\0"
-startUpdateIndex :: Repo -> IO UpdateIndexHandle
-startUpdateIndex repo = do
- (Just h, _, _, p) <- createProcess (gitCreateProcess params repo)
- { std_in = CreatePipe }
- return $ UpdateIndexHandle p h
+withUpdateIndex :: (MonadIO m, MonadMask m) => Repo -> (UpdateIndexHandle -> m a) -> m a
+withUpdateIndex repo a = bracket setup cleanup go
where
params = map Param ["update-index", "-z", "--index-info"]
-
-stopUpdateIndex :: UpdateIndexHandle -> IO Bool
-stopUpdateIndex (UpdateIndexHandle p h) = do
- hClose h
- checkSuccessProcess p
+
+ setup = liftIO $ createProcess $
+ (gitCreateProcess params repo)
+ { std_in = CreatePipe }
+ go p = do
+ r <- a (UpdateIndexHandle (stdinHandle p))
+ liftIO $ do
+ hClose (stdinHandle p)
+ void $ checkSuccessProcess (processHandle p)
+ return r
+
+ cleanup = liftIO . cleanupProcess
{- A streamer that adds the current tree for a ref. Useful for eg, copying
- and modifying branches. -}
@@ -113,12 +118,12 @@ unstageFile' p = pureStreamer $ L.fromStrict $
<> indexPath p
{- A streamer that adds a symlink to the index. -}
-stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer
+stageSymlink :: RawFilePath -> Sha -> Repo -> IO Streamer
stageSymlink file sha repo = do
!line <- updateIndexLine
<$> pure sha
<*> pure TreeSymlink
- <*> toTopFilePath (toRawFilePath file) repo
+ <*> toTopFilePath file repo
return $ pureStreamer line
{- A streamer that applies a DiffTreeItem to the index. -}
@@ -131,16 +136,8 @@ 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
+refreshIndex :: Repo -> ((RawFilePath -> IO ()) -> IO ()) -> IO Bool
+refreshIndex repo feeder = withCreateProcess p go
where
params =
[ Param "update-index"
@@ -149,3 +146,14 @@ refreshIndex repo feeder = do
, Param "-z"
, Param "--stdin"
]
+
+ p = (gitCreateProcess params repo)
+ { std_in = CreatePipe }
+
+ go (Just h) _ _ pid = do
+ feeder $ \f ->
+ S.hPut h (S.snoc f 0)
+ hFlush h
+ hClose h
+ checkSuccessProcess pid
+ go _ _ _ _ = error "internal"
diff --git a/Git/Version.hs b/Git/Version.hs
index 5ecaca0..9119f5d 100644
--- a/Git/Version.hs
+++ b/Git/Version.hs
@@ -14,7 +14,7 @@ module Git.Version (
GitVersion,
) where
-import Common
+import Utility.Process
import Utility.DottedVersion
type GitVersion = DottedVersion