wip RawFilePath

Goal is to make git-annex faster by using ByteString for all the
worktree traversal. For now, this is focusing on Command.Find,
in order to benchmark how much it helps. (All other commands are
temporarily disabled)

Currently in a very bad unbuildable in-between state.
This commit is contained in:
Joey Hess 2019-11-25 16:18:19 -04:00
parent 1f035c0d66
commit 6a97ff6b3a
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
25 changed files with 258 additions and 200 deletions

View file

@ -201,8 +201,10 @@ gitAnnexLink file key r config = do
| not (coreSymlinks config) && needsSubmoduleFixup r = | not (coreSymlinks config) && needsSubmoduleFixup r =
absNormPathUnix currdir $ Git.repoPath r </> ".git" absNormPathUnix currdir $ Git.repoPath r </> ".git"
| otherwise = Git.localGitDir r | otherwise = Git.localGitDir r
absNormPathUnix d p = toInternalGitPath $ absNormPathUnix d p = fromRawFilePath $ toInternalGitPath $ toRawFilePath $
absPathFrom (toInternalGitPath d) (toInternalGitPath p) absPathFrom
(fromRawFilePath $ toInternalGitPath $ toRawFilePath d)
(fromRawFilePath $ toInternalGitPath $ toRawFilePath p)
{- Calculates a symlink target as would be used in a typical git {- Calculates a symlink target as would be used in a typical git
- repository, with .git in the top of the work tree. -} - repository, with .git in the top of the work tree. -}

View file

@ -18,6 +18,7 @@ import Annex.Multicast
import Types.Test import Types.Test
import Types.Benchmark import Types.Benchmark
{-
import qualified Command.Help import qualified Command.Help
import qualified Command.Add import qualified Command.Add
import qualified Command.Unannex import qualified Command.Unannex
@ -66,7 +67,9 @@ import qualified Command.Unlock
import qualified Command.Lock import qualified Command.Lock
import qualified Command.PreCommit import qualified Command.PreCommit
import qualified Command.PostReceive import qualified Command.PostReceive
-}
import qualified Command.Find import qualified Command.Find
{-
import qualified Command.FindRef import qualified Command.FindRef
import qualified Command.Whereis import qualified Command.Whereis
import qualified Command.List import qualified Command.List
@ -122,10 +125,11 @@ import qualified Command.Test
import qualified Command.FuzzTest import qualified Command.FuzzTest
import qualified Command.TestRemote import qualified Command.TestRemote
import qualified Command.Benchmark import qualified Command.Benchmark
-}
cmds :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [Command] cmds :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [Command]
cmds testoptparser testrunner mkbenchmarkgenerator = cmds testoptparser testrunner mkbenchmarkgenerator =
[ Command.Help.cmd {- [ Command.Help.cmd
, Command.Add.cmd , Command.Add.cmd
, Command.Get.cmd , Command.Get.cmd
, Command.Drop.cmd , Command.Drop.cmd
@ -196,7 +200,9 @@ cmds testoptparser testrunner mkbenchmarkgenerator =
, Command.Unused.cmd , Command.Unused.cmd
, Command.DropUnused.cmd , Command.DropUnused.cmd
, Command.AddUnused.cmd , Command.AddUnused.cmd
, Command.Find.cmd -}
[ Command.Find.cmd
{-
, Command.FindRef.cmd , Command.FindRef.cmd
, Command.Whereis.cmd , Command.Whereis.cmd
, Command.List.cmd , Command.List.cmd
@ -231,6 +237,7 @@ cmds testoptparser testrunner mkbenchmarkgenerator =
, Command.TestRemote.cmd , Command.TestRemote.cmd
, Command.Benchmark.cmd $ , Command.Benchmark.cmd $
mkbenchmarkgenerator $ cmds testoptparser testrunner (\_ _ -> return noop) mkbenchmarkgenerator $ cmds testoptparser testrunner (\_ _ -> return noop)
-}
] ]
run :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [String] -> IO () run :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [String] -> IO ()

View file

@ -34,11 +34,11 @@ import Annex.Content
import Annex.InodeSentinal import Annex.InodeSentinal
import qualified Database.Keys import qualified Database.Keys
withFilesInGit :: (FilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withFilesInGit :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek
withFilesInGit a l = seekActions $ prepFiltered a $ withFilesInGit a l = seekActions $ prepFiltered a $
seekHelper LsFiles.inRepo l seekHelper LsFiles.inRepo l
withFilesInGitNonRecursive :: String -> (FilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withFilesInGitNonRecursive :: String -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek
withFilesInGitNonRecursive needforce a l = ifM (Annex.getState Annex.force) withFilesInGitNonRecursive needforce a l = ifM (Annex.getState Annex.force)
( withFilesInGit a l ( withFilesInGit a l
, if null l , if null l
@ -58,7 +58,7 @@ withFilesInGitNonRecursive needforce a l = ifM (Annex.getState Annex.force)
getfiles c ps getfiles c ps
_ -> giveup needforce _ -> giveup needforce
withFilesNotInGit :: Bool -> (FilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withFilesNotInGit :: Bool -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek
withFilesNotInGit skipdotfiles a l withFilesNotInGit skipdotfiles a l
| skipdotfiles = do | skipdotfiles = do
{- dotfiles are not acted on unless explicitly listed -} {- dotfiles are not acted on unless explicitly listed -}
@ -78,7 +78,7 @@ withFilesNotInGit skipdotfiles a l
go fs = seekActions $ prepFiltered a $ go fs = seekActions $ prepFiltered a $
return $ concat $ segmentPaths (map (\(WorkTreeItem f) -> f) l) fs return $ concat $ segmentPaths (map (\(WorkTreeItem f) -> f) l) fs
withPathContents :: ((FilePath, FilePath) -> CommandSeek) -> CmdParams -> CommandSeek withPathContents :: ((RawFilePath, RawFilePath) -> CommandSeek) -> CmdParams -> CommandSeek
withPathContents a params = do withPathContents a params = do
matcher <- Limit.getMatcher matcher <- Limit.getMatcher
forM_ params $ \p -> do forM_ params $ \p -> do
@ -110,30 +110,30 @@ withPairs a params = seekActions $ return $ map a $ pairs [] params
pairs c (x:y:xs) = pairs ((x,y):c) xs pairs c (x:y:xs) = pairs ((x,y):c) xs
pairs _ _ = giveup "expected pairs" pairs _ _ = giveup "expected pairs"
withFilesToBeCommitted :: (FilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withFilesToBeCommitted :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek
withFilesToBeCommitted a l = seekActions $ prepFiltered a $ withFilesToBeCommitted a l = seekActions $ prepFiltered a $
seekHelper LsFiles.stagedNotDeleted l seekHelper LsFiles.stagedNotDeleted l
isOldUnlocked :: FilePath -> Annex Bool isOldUnlocked :: RawFilePath -> Annex Bool
isOldUnlocked f = liftIO (notSymlink f) <&&> isOldUnlocked f = liftIO (notSymlink f) <&&>
(isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f) (isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f)
{- unlocked pointer files that are staged, and whose content has not been {- unlocked pointer files that are staged, and whose content has not been
- modified-} - modified-}
withUnmodifiedUnlockedPointers :: (FilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withUnmodifiedUnlockedPointers :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek
withUnmodifiedUnlockedPointers a l = seekActions $ withUnmodifiedUnlockedPointers a l = seekActions $
prepFiltered a unlockedfiles prepFiltered a unlockedfiles
where where
unlockedfiles = filterM isUnmodifiedUnlocked unlockedfiles = filterM isUnmodifiedUnlocked
=<< seekHelper LsFiles.typeChangedStaged l =<< seekHelper LsFiles.typeChangedStaged l
isUnmodifiedUnlocked :: FilePath -> Annex Bool isUnmodifiedUnlocked :: RawFilePath -> Annex Bool
isUnmodifiedUnlocked f = catKeyFile f >>= \case isUnmodifiedUnlocked f = catKeyFile f >>= \case
Nothing -> return False Nothing -> return False
Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k
{- Finds files that may be modified. -} {- Finds files that may be modified. -}
withFilesMaybeModified :: (FilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withFilesMaybeModified :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek
withFilesMaybeModified a params = seekActions $ withFilesMaybeModified a params = seekActions $
prepFiltered a $ seekHelper LsFiles.modified params prepFiltered a $ seekHelper LsFiles.modified params
@ -225,7 +225,7 @@ withKeyOptions' ko auto mkkeyaction fallbackaction params = do
forM_ ts $ \(t, i) -> forM_ ts $ \(t, i) ->
keyaction (transferKey t, mkActionItem (t, i)) keyaction (transferKey t, mkActionItem (t, i))
prepFiltered :: (FilePath -> CommandSeek) -> Annex [FilePath] -> Annex [CommandSeek] prepFiltered :: (RawFilePath -> CommandSeek) -> Annex [RawFilePath] -> Annex [CommandSeek]
prepFiltered a fs = do prepFiltered a fs = do
matcher <- Limit.getMatcher matcher <- Limit.getMatcher
map (process matcher) <$> fs map (process matcher) <$> fs
@ -235,7 +235,7 @@ prepFiltered a fs = do
seekActions :: Annex [CommandSeek] -> Annex () seekActions :: Annex [CommandSeek] -> Annex ()
seekActions gen = sequence_ =<< gen seekActions gen = sequence_ =<< gen
seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [WorkTreeItem] -> Annex [FilePath] seekHelper :: ([RawFilePath] -> Git.Repo -> IO ([RawFilePath], IO Bool)) -> [WorkTreeItem] -> Annex [RawFilePath]
seekHelper a l = inRepo $ \g -> seekHelper a l = inRepo $ \g ->
concat . concat <$> forM (segmentXargsOrdered l') concat . concat <$> forM (segmentXargsOrdered l')
(runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g)) (runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g))
@ -243,7 +243,7 @@ seekHelper a l = inRepo $ \g ->
l' = map (\(WorkTreeItem f) -> f) l l' = map (\(WorkTreeItem f) -> f) l
-- An item in the work tree, which may be a file or a directory. -- An item in the work tree, which may be a file or a directory.
newtype WorkTreeItem = WorkTreeItem FilePath newtype WorkTreeItem = WorkTreeItem RawFilePath
-- When in an adjusted branch that hides some files, it may not exist -- When in an adjusted branch that hides some files, it may not exist
-- in the current work tree, but in the original branch. This allows -- in the current work tree, but in the original branch. This allows
@ -273,5 +273,5 @@ workTreeItems' (AllowHidden allowhidden) ps = do
isJust <$> catObjectMetaDataHidden f currbranch isJust <$> catObjectMetaDataHidden f currbranch
| otherwise = return False | otherwise = return False
notSymlink :: FilePath -> IO Bool notSymlink :: RawFilePath -> IO Bool
notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f

View file

@ -16,6 +16,8 @@ import Git.Command
import qualified Git.Config import qualified Git.Config
import qualified Git.Ref import qualified Git.Ref
import qualified Data.ByteString as B
{- The currently checked out branch. {- The currently checked out branch.
- -
- In a just initialized git repo before the first commit, - In a just initialized git repo before the first commit,
@ -29,19 +31,19 @@ current r = do
case v of case v of
Nothing -> return Nothing Nothing -> return Nothing
Just branch -> 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 Nothing
, return v , return v
) )
{- The current branch, which may not really exist yet. -} {- The current branch, which may not really exist yet. -}
currentUnsafe :: Repo -> IO (Maybe Branch) 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 <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r
where where
parse l parse b
| null l = Nothing | B.null b = Nothing
| otherwise = Just $ Git.Ref l | otherwise = Just $ Git.Ref $ decodeBS b
{- Checks if the second branch has any commits not present on the first {- Checks if the second branch has any commits not present on the first
- branch. -} - branch. -}
@ -53,7 +55,8 @@ changed origbranch newbranch repo
where where
changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String 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 where
ps = ps =
[ Param "log" [ Param "log"
@ -72,7 +75,7 @@ changedCommits origbranch newbranch extraps repo =
- -
- This requires there to be a path from the old to the new. -} - This requires there to be a path from the old to the new. -}
fastForwardable :: Ref -> Ref -> Repo -> IO Bool fastForwardable :: Ref -> Ref -> Repo -> IO Bool
fastForwardable old new repo = not . null <$> fastForwardable old new repo = not . B.null <$>
pipeReadStrict pipeReadStrict
[ Param "log" [ Param "log"
, Param $ fromRef old ++ ".." ++ fromRef new , Param $ fromRef old ++ ".." ++ fromRef new
@ -160,7 +163,7 @@ commitCommand' runner commitmode ps = runner $
commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha) commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)
commit commitmode allowempty message branch parentrefs repo = do commit commitmode allowempty message branch parentrefs repo = do
tree <- getSha "write-tree" $ tree <- getSha "write-tree" $
pipeReadStrict [Param "write-tree"] repo decodeBS' <$> pipeReadStrict [Param "write-tree"] repo
ifM (cancommit tree) ifM (cancommit tree)
( do ( do
sha <- commitTree commitmode message parentrefs tree repo sha <- commitTree commitmode message parentrefs tree repo

View file

@ -66,13 +66,13 @@ catFileStop h = do
CoProcess.stop (checkFileProcess h) CoProcess.stop (checkFileProcess h)
{- Reads a file from a specified branch. -} {- 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 $ 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 $ 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. {- Uses a running git cat-file read the content of an object.
- Objects that do not exist will have "" returned. -} - Objects that do not exist will have "" returned. -}
@ -148,7 +148,7 @@ parseResp object l
| otherwise = case words l of | otherwise = case words l of
[sha, objtype, size] [sha, objtype, size]
| length sha == shaSize -> | length sha == shaSize ->
case (readObjectType objtype, reads size) of case (readObjectType (encodeBS objtype), reads size) of
(Just t, [(bytes, "")]) -> (Just t, [(bytes, "")]) ->
Just $ ParsedResp (Ref sha) bytes t Just $ ParsedResp (Ref sha) bytes t
_ -> Nothing _ -> Nothing
@ -185,7 +185,7 @@ querySize r repo = maybe Nothing (readMaybe . takeWhile (/= '\n'))
<$> querySingle (Param "-s") r repo hGetContentsStrict <$> querySingle (Param "-s") r repo hGetContentsStrict
queryObjectType :: Ref -> Repo -> IO (Maybe ObjectType) queryObjectType :: Ref -> Repo -> IO (Maybe ObjectType)
queryObjectType r repo = maybe Nothing (readObjectType . takeWhile (/= '\n')) queryObjectType r repo = maybe Nothing (readObjectType . encodeBS . takeWhile (/= '\n'))
<$> querySingle (Param "-t") r repo hGetContentsStrict <$> querySingle (Param "-t") r repo hGetContentsStrict
queryContent :: Ref -> Repo -> IO (Maybe L.ByteString) queryContent :: Ref -> Repo -> IO (Maybe L.ByteString)

View file

@ -14,6 +14,9 @@ import Git
import Git.Types import Git.Types
import qualified Utility.CoProcess as CoProcess 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. -} {- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
gitCommandLine params r@(Repo { location = l@(Local { } ) }) = gitCommandLine params r@(Repo { location = l@(Local { } ) }) =
@ -50,10 +53,10 @@ runQuiet params repo = withQuietOutput createProcessSuccess $
- read, 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. - 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 pipeReadLazy params repo = assertLocal repo $ do
(_, Just h, _, pid) <- createProcess p { std_out = CreatePipe } (_, Just h, _, pid) <- createProcess p { std_out = CreatePipe }
c <- hGetContents h c <- L.hGetContents h
return (c, checkSuccessProcess pid) return (c, checkSuccessProcess pid)
where where
p = gitCreateProcess params repo p = gitCreateProcess params repo
@ -62,8 +65,8 @@ pipeReadLazy params repo = assertLocal repo $ do
- -
- Nonzero exit status is ignored. - Nonzero exit status is ignored.
-} -}
pipeReadStrict :: [CommandParam] -> Repo -> IO String pipeReadStrict :: [CommandParam] -> Repo -> IO S.ByteString
pipeReadStrict = pipeReadStrict' hGetContentsStrict pipeReadStrict = pipeReadStrict' S.hGetContents
{- The reader action must be strict. -} {- The reader action must be strict. -}
pipeReadStrict' :: (Handle -> IO a) -> [CommandParam] -> Repo -> IO a pipeReadStrict' :: (Handle -> IO a) -> [CommandParam] -> Repo -> IO a
@ -93,21 +96,24 @@ pipeWrite params repo = assertLocal repo $
{- Reads null terminated output of a git command (as enabled by the -z {- Reads null terminated output of a git command (as enabled by the -z
- parameter), and splits it. -} - parameter), and splits it. -}
pipeNullSplit :: [CommandParam] -> Repo -> IO ([String], IO Bool) pipeNullSplit :: [CommandParam] -> Repo -> IO ([L.ByteString], IO Bool)
pipeNullSplit params repo = do pipeNullSplit params repo = do
(s, cleanup) <- pipeReadLazy params repo (s, cleanup) <- pipeReadLazy params repo
return (filter (not . null) $ splitc sep s, cleanup) return (filter (not . L.null) $ L.split 0 s, cleanup)
where
sep = '\0'
pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [String] {- Reads lazily, but converts 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 pipeNullSplitStrict params repo = do
s <- pipeReadStrict params repo s <- pipeReadStrict params repo
return $ filter (not . null) $ splitc sep s return $ filter (not . S.null) $ S.split 0 s
where
sep = '\0'
pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String] pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [L.ByteString]
pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo
{- Doesn't run the cleanup action. A zombie results. -} {- Doesn't run the cleanup action. A zombie results. -}

View file

@ -58,7 +58,7 @@ fromPath dir = fromAbsPath =<< absPath dir
- specified. -} - specified. -}
fromAbsPath :: FilePath -> IO Repo fromAbsPath :: FilePath -> IO Repo
fromAbsPath dir fromAbsPath dir
| absoluteGitPath dir = hunt | absoluteGitPath (encodeBS dir) = hunt
| otherwise = | otherwise =
error $ "internal error, " ++ dir ++ " is not absolute" error $ "internal error, " ++ dir ++ " is not absolute"
where where

View file

@ -89,7 +89,7 @@ commitDiff ref = getdiff (Param "show")
getdiff :: CommandParam -> [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool) getdiff :: CommandParam -> [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool)
getdiff command params repo = do getdiff command params repo = do
(diff, cleanup) <- pipeNullSplit ps repo (diff, cleanup) <- pipeNullSplit ps repo
return (parseDiffRaw diff, cleanup) return (parseDiffRaw (map decodeBL diff), cleanup)
where where
ps = ps =
command : command :
@ -113,7 +113,7 @@ parseDiffRaw l = go l
, srcsha = fromMaybe (error "bad srcsha") $ extractSha ssha , srcsha = fromMaybe (error "bad srcsha") $ extractSha ssha
, dstsha = fromMaybe (error "bad dstsha") $ extractSha dsha , dstsha = fromMaybe (error "bad dstsha") $ extractSha dsha
, status = s , status = s
, file = asTopFilePath $ fromInternalGitPath $ Git.Filename.decode f , file = asTopFilePath $ fromRawFilePath $ fromInternalGitPath $ Git.Filename.decode $ toRawFilePath f
} }
where where
readmode = fst . Prelude.head . readOct readmode = fst . Prelude.head . readOct

View file

@ -34,7 +34,7 @@ import qualified System.FilePath.Posix
import GHC.Generics import GHC.Generics
import Control.DeepSeq import Control.DeepSeq
{- A FilePath, relative to the top of the git repository. -} {- A RawFilePath, relative to the top of the git repository. -}
newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }
deriving (Show, Eq, Ord, Generic) deriving (Show, Eq, Ord, Generic)
@ -46,7 +46,7 @@ data BranchFilePath = BranchFilePath Ref TopFilePath
{- Git uses the branch:file form to refer to a BranchFilePath -} {- Git uses the branch:file form to refer to a BranchFilePath -}
descBranchFilePath :: BranchFilePath -> String descBranchFilePath :: BranchFilePath -> String
descBranchFilePath (BranchFilePath b f) = fromRef b ++ ':' : getTopFilePath f descBranchFilePath (BranchFilePath b f) = fromRef b ++ ':' : (getTopFilePath f)
{- Path to a TopFilePath, within the provided git repo. -} {- Path to a TopFilePath, within the provided git repo. -}
fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath
@ -68,25 +68,25 @@ asTopFilePath file = TopFilePath file
- despite Windows using '\'. - despite Windows using '\'.
- -
-} -}
type InternalGitPath = String type InternalGitPath = RawFilePath
toInternalGitPath :: FilePath -> InternalGitPath toInternalGitPath :: RawFilePath -> InternalGitPath
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
toInternalGitPath = id toInternalGitPath = id
#else #else
toInternalGitPath = replace "\\" "/" toInternalGitPath = encodeBS . replace "\\" "/" . decodeBS
#endif #endif
fromInternalGitPath :: InternalGitPath -> FilePath fromInternalGitPath :: InternalGitPath -> RawFilePath
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
fromInternalGitPath = id fromInternalGitPath = id
#else #else
fromInternalGitPath = replace "/" "\\" fromInternalGitPath = encodeBS . replace "/" "\\" . decodeBS
#endif #endif
{- isAbsolute on Windows does not think "/foo" or "\foo" is absolute, {- isAbsolute on Windows does not think "/foo" or "\foo" is absolute,
- so try posix paths. - so try posix paths.
-} -}
absoluteGitPath :: FilePath -> Bool absoluteGitPath :: RawFilePath -> Bool
absoluteGitPath p = isAbsolute p || absoluteGitPath p = isAbsolute (decodeBS p) ||
System.FilePath.Posix.isAbsolute (toInternalGitPath p) System.FilePath.Posix.isAbsolute (decodeBS (toInternalGitPath p))

View file

@ -12,23 +12,29 @@ import Common
import Utility.Format (decode_c, encode_c) import Utility.Format (decode_c, encode_c)
import Data.Char import Data.Char
import Data.Word
import qualified Data.ByteString as S
decode :: String -> FilePath -- encoded filenames will be inside double quotes
decode [] = [] decode :: S.ByteString -> RawFilePath
decode f@(c:s) decode b = case S.uncons b of
-- encoded strings will be inside double quotes Nothing -> b
| c == '"' && end s == ['"'] = decode_c $ beginning s Just (h, t)
| otherwise = f | 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. -} {- Should not need to use this, except for testing decode. -}
encode :: FilePath -> String encode :: RawFilePath -> S.ByteString
encode s = "\"" ++ encode_c s ++ "\"" encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\""
{- For quickcheck. {- For quickcheck. -}
- prop_encode_decode_roundtrip :: RawFilePath -> Bool
- See comment on Utility.Format.prop_encode_c_decode_c_roundtrip for prop_encode_decode_roundtrip s = s == decode (encode s)
- why this only tests chars < 256 -}
prop_encode_decode_roundtrip :: String -> Bool
prop_encode_decode_roundtrip s = s' == decode (encode s')
where
s' = filter (\c -> ord c < 256) s

View file

@ -73,4 +73,4 @@ hashObject' objtype writer repo = getSha subcmd $
pipeWriteRead (map Param params) (Just writer) repo pipeWriteRead (map Param params) (Just writer) repo
where where
subcmd = "hash-object" subcmd = "hash-object"
params = [subcmd, "-t", show objtype, "-w", "--stdin", "--no-filters"] params = [subcmd, "-t", decodeBS (fmtObjectType objtype), "-w", "--stdin", "--no-filters"]

View file

@ -34,37 +34,40 @@ import Git.Sha
import Numeric import Numeric
import System.Posix.Types import System.Posix.Types
import qualified Data.ByteString.Lazy as L
{- Scans for files that are checked into git's index at the specified locations. -} {- Scans for files that are checked into git's index at the specified locations. -}
inRepo :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) inRepo :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
inRepo = inRepo' [] inRepo = inRepo' []
inRepo' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) inRepo' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
inRepo' ps l = pipeNullSplit $ inRepo' ps l repo = pipeNullSplit' params repo
Param "ls-files" : where
Param "--cached" : params =
Param "-z" : Param "ls-files" :
ps ++ Param "--cached" :
(Param "--" : map File l) Param "-z" :
ps ++
(Param "--" : map (File . fromRawFilePath) l)
{- Files that are checked into the index or have been committed to a {- Files that are checked into the index or have been committed to a
- branch. -} - branch. -}
inRepoOrBranch :: Branch -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) inRepoOrBranch :: Branch -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
inRepoOrBranch (Ref b) = inRepo' [Param $ "--with-tree=" ++ b] inRepoOrBranch (Ref b) = inRepo' [Param $ "--with-tree=" ++ b]
{- Scans for files at the specified locations that are not checked into git. -} {- Scans for files at the specified locations that are not checked into git. -}
notInRepo :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
notInRepo = notInRepo' [] notInRepo = notInRepo' []
notInRepo' :: [CommandParam] -> Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) notInRepo' :: [CommandParam] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
notInRepo' ps include_ignored l repo = pipeNullSplit params repo notInRepo' ps include_ignored l repo = pipeNullSplit' params repo
where where
params = concat params = concat
[ [ Param "ls-files", Param "--others"] [ [ Param "ls-files", Param "--others"]
, ps , ps
, exclude , exclude
, [ Param "-z", Param "--" ] , [ Param "-z", Param "--" ]
, map File l , map (File . fromRawFilePath) l
] ]
exclude exclude
| include_ignored = [] | include_ignored = []
@ -72,48 +75,48 @@ notInRepo' ps include_ignored l repo = pipeNullSplit params repo
{- Scans for files at the specified locations that are not checked into {- Scans for files at the specified locations that are not checked into
- git. Empty directories are included in the result. -} - git. Empty directories are included in the result. -}
notInRepoIncludingEmptyDirectories :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) notInRepoIncludingEmptyDirectories :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"] notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"]
{- Finds all files in the specified locations, whether checked into git or {- Finds all files in the specified locations, whether checked into git or
- not. -} - not. -}
allFiles :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) allFiles :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
allFiles l = pipeNullSplit $ allFiles l = pipeNullSplit' $
Param "ls-files" : Param "ls-files" :
Param "--cached" : Param "--cached" :
Param "--others" : Param "--others" :
Param "-z" : Param "-z" :
Param "--" : Param "--" :
map File l map (File . fromRawFilePath) l
{- Returns a list of files in the specified locations that have been {- Returns a list of files in the specified locations that have been
- deleted. -} - deleted. -}
deleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) deleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
deleted l repo = pipeNullSplit params repo deleted l repo = pipeNullSplit' params repo
where where
params = params =
Param "ls-files" : Param "ls-files" :
Param "--deleted" : Param "--deleted" :
Param "-z" : Param "-z" :
Param "--" : Param "--" :
map File l map (File . fromRawFilePath) l
{- Returns a list of files in the specified locations that have been {- Returns a list of files in the specified locations that have been
- modified. -} - modified. -}
modified :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) modified :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
modified l repo = pipeNullSplit params repo modified l repo = pipeNullSplit' params repo
where where
params = params =
Param "ls-files" : Param "ls-files" :
Param "--modified" : Param "--modified" :
Param "-z" : Param "-z" :
Param "--" : Param "--" :
map File l map (File . fromRawFilePath) l
{- Files that have been modified or are not checked into git (and are not {- Files that have been modified or are not checked into git (and are not
- ignored). -} - ignored). -}
modifiedOthers :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) modifiedOthers :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
modifiedOthers l repo = pipeNullSplit params repo modifiedOthers l repo = pipeNullSplit' params repo
where where
params = params =
Param "ls-files" : Param "ls-files" :
@ -122,69 +125,69 @@ modifiedOthers l repo = pipeNullSplit params repo
Param "--exclude-standard" : Param "--exclude-standard" :
Param "-z" : Param "-z" :
Param "--" : Param "--" :
map File l map (File . fromRawFilePath) l
{- Returns a list of all files that are staged for commit. -} {- 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' [] staged = staged' []
{- Returns a list of the files, staged for commit, that are being added, {- Returns a list of the files, staged for commit, that are being added,
- moved, or changed (but not deleted), from the specified locations. -} - 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"] stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"]
staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) staged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix staged' ps l repo = pipeNullSplit' (prefix ++ ps ++ suffix) repo
where where
prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] 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, {- Returns details about files that are staged in the index,
- as well as files not yet in git. Skips ignored files. -} - 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"] stagedOthersDetails = stagedDetails' [Param "--others", Param "--exclude-standard"]
{- Returns details about all files that are staged in the index. -} {- 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' [] stagedDetails = stagedDetails' []
{- Gets details about staged files, including the Sha of their staged {- Gets details about staged files, including the Sha of their staged
- contents. -} - contents. -}
stagedDetails' :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)
stagedDetails' ps l repo = do stagedDetails' ps l repo = do
(ls, cleanup) <- pipeNullSplit params repo (ls, cleanup) <- pipeNullSplit params repo
return (map parse ls, cleanup) return (map parse ls, cleanup)
where where
params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++
Param "--" : map File l Param "--" : map (File . fromRawFilePath) l
parse s parse s
| null file = (s, Nothing, Nothing) | null file = (L.toStrict s, Nothing, Nothing)
| otherwise = (file, extractSha $ take shaSize rest, readmode mode) | otherwise = (toRawFilePath file, extractSha $ take shaSize rest, readmode mode)
where where
(metadata, file) = separate (== '\t') s (metadata, file) = separate (== '\t') (decodeBL' s)
(mode, rest) = separate (== ' ') metadata (mode, rest) = separate (== ' ') metadata
readmode = fst <$$> headMaybe . readOct readmode = fst <$$> headMaybe . readOct
{- Returns a list of the files in the specified locations that are staged {- Returns a list of the files in the specified locations that are staged
- for commit, and whose type has changed. -} - 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"] typeChangedStaged = typeChanged' [Param "--cached"]
{- Returns a list of the files in the specified locations whose type has {- Returns a list of the files in the specified locations whose type has
- changed. Files only staged for commit will not be included. -} - 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 = typeChanged' []
typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
typeChanged' ps l repo = do typeChanged' ps l 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; -- git diff returns filenames relative to the top of the git repo;
-- convert to filenames relative to the cwd, like git ls-files. -- convert to filenames relative to the cwd, like git ls-files.
top <- absPath (repoPath repo) top <- absPath (repoPath repo)
currdir <- getCurrentDirectory currdir <- getCurrentDirectory
return (map (\f -> relPathDirToFileAbs currdir $ top </> f) fs, cleanup) return (map (\f -> toRawFilePath (relPathDirToFileAbs currdir $ top </> decodeBL' f)) fs, cleanup)
where where
prefix = prefix =
[ Param "diff" [ Param "diff"
@ -192,7 +195,7 @@ typeChanged' ps l repo = do
, Param "--diff-filter=T" , Param "--diff-filter=T"
, Param "-z" , 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. {- A item in conflict has two possible values.
- Either can be Nothing, when that side deleted the file. -} - Either can be Nothing, when that side deleted the file. -}
@ -202,7 +205,7 @@ data Conflicting v = Conflicting
} deriving (Show) } deriving (Show)
data Unmerged = Unmerged data Unmerged = Unmerged
{ unmergedFile :: FilePath { unmergedFile :: RawFilePath
, unmergedTreeItemType :: Conflicting TreeItemType , unmergedTreeItemType :: Conflicting TreeItemType
, unmergedSha :: Conflicting Sha , unmergedSha :: Conflicting Sha
} }
@ -217,21 +220,21 @@ data Unmerged = Unmerged
- 3 = them - 3 = them
- If a line is omitted, that side removed the file. - 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 unmerged l repo = do
(fs, cleanup) <- pipeNullSplit params repo (fs, cleanup) <- pipeNullSplit params repo
return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup) return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup)
where where
params = params =
Param "ls-files" : Param "ls-files" :
Param "--unmerged" : Param "--unmerged" :
Param "-z" : Param "-z" :
Param "--" : Param "--" :
map File l map (File . fromRawFilePath) l
data InternalUnmerged = InternalUnmerged data InternalUnmerged = InternalUnmerged
{ isus :: Bool { isus :: Bool
, ifile :: FilePath , ifile :: RawFilePath
, itreeitemtype :: Maybe TreeItemType , itreeitemtype :: Maybe TreeItemType
, isha :: Maybe Sha , isha :: Maybe Sha
} }
@ -245,9 +248,9 @@ parseUnmerged s
if stage /= 2 && stage /= 3 if stage /= 2 && stage /= 3
then Nothing then Nothing
else do else do
treeitemtype <- readTreeItemType rawtreeitemtype treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype)
sha <- extractSha rawsha sha <- extractSha rawsha
return $ InternalUnmerged (stage == 2) file return $ InternalUnmerged (stage == 2) (toRawFilePath file)
(Just treeitemtype) (Just sha) (Just treeitemtype) (Just sha)
_ -> Nothing _ -> Nothing
where where

View file

@ -26,12 +26,16 @@ import Git.FilePath
import qualified Git.Filename import qualified Git.Filename
import Numeric import Numeric
import Data.Char import Data.Either
import System.Posix.Types 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 data TreeItem = TreeItem
{ mode :: FileMode { mode :: FileMode
, typeobj :: String , typeobj :: S.ByteString
, sha :: Ref , sha :: Ref
, file :: TopFilePath , file :: TopFilePath
} deriving Show } deriving Show
@ -45,7 +49,7 @@ lsTree = lsTree' []
lsTree' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool) lsTree' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool)
lsTree' ps lsmode t repo = do lsTree' ps lsmode t repo = do
(l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo (l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo
return (map parseLsTree l, cleanup) return (rights (map parseLsTree l), cleanup)
lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam] lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam]
lsTreeParams lsmode r ps = lsTreeParams lsmode r ps =
@ -63,7 +67,8 @@ lsTreeParams lsmode r ps =
{- Lists specified files in a tree. -} {- Lists specified files in a tree. -}
lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem] 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 where
ps = ps =
[ Param "ls-tree" [ Param "ls-tree"
@ -73,30 +78,34 @@ lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo
, File $ fromRef t , File $ fromRef t
] ++ map File fs ] ++ 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: {- Parses a line of ls-tree output, in format:
- mode SP type SP sha TAB file - mode SP type SP sha TAB file
- -
- (The --long format is not currently supported.) -} - (The --long format is not currently supported.) -}
parseLsTree :: String -> TreeItem parserLsTree :: A.Parser TreeItem
parseLsTree l = TreeItem parserLsTree = TreeItem
{ mode = smode -- mode
, typeobj = t <$> A8.decimal
, sha = Ref s <* A8.char ' '
, file = sfile -- type
} <*> A.takeTill (== 32)
where <* A8.char ' '
(m, past_m) = splitAt 7 l -- mode is 6 bytes -- sha
(!t, past_t) = separate isSpace past_m <*> (Ref . decodeBS' <$> A.take shaSize)
(!s, past_s) = splitAt shaSize past_t <* A8.char '\t'
!f = drop 1 past_s -- file
!smode = fst $ Prelude.head $ readOct m <*> (asTopFilePath . decodeBS' . Git.Filename.decode <$> A.takeByteString)
!sfile = asTopFilePath $ Git.Filename.decode f
{- Inverse of parseLsTree -} {- Inverse of parseLsTree -}
formatLsTree :: TreeItem -> String formatLsTree :: TreeItem -> String
formatLsTree ti = unwords formatLsTree ti = unwords
[ showOct (mode ti) "" [ showOct (mode ti) ""
, typeobj ti , decodeBS (typeobj ti)
, fromRef (sha ti) , fromRef (sha ti)
, getTopFilePath (file ti) , getTopFilePath (file ti)
] ]

View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
module Git.Ref where module Git.Ref where
import Common import Common
@ -13,7 +15,8 @@ import Git.Command
import Git.Sha import Git.Sha
import Git.Types import Git.Types
import Data.Char (chr) import Data.Char (chr, ord)
import qualified Data.ByteString as S
headRef :: Ref headRef :: Ref
headRef = Ref "HEAD" headRef = Ref "HEAD"
@ -88,8 +91,10 @@ file ref repo = localGitDir repo </> fromRef ref
- that was just created. -} - that was just created. -}
headExists :: Repo -> IO Bool headExists :: Repo -> IO Bool
headExists repo = do headExists repo = do
ls <- lines <$> pipeReadStrict [Param "show-ref", Param "--head"] repo ls <- S.split nl <$> pipeReadStrict [Param "show-ref", Param "--head"] repo
return $ any (" HEAD" `isSuffixOf`) ls return $ any (" HEAD" `S.isSuffixOf`) ls
where
nl = fromIntegral (ord '\n')
{- Get the sha of a fully qualified git ref, if it exists. -} {- Get the sha of a fully qualified git ref, if it exists. -}
sha :: Branch -> Repo -> IO (Maybe Sha) sha :: Branch -> Repo -> IO (Maybe Sha)
@ -100,8 +105,9 @@ sha branch repo = process <$> showref repo
, Param "--hash" -- get the hash , Param "--hash" -- get the hash
, Param $ fromRef branch , Param $ fromRef branch
] ]
process [] = Nothing process s
process s = Just $ Ref $ firstLine s | S.null s = Nothing
| otherwise = Just $ Ref $ decodeBS' $ firstLine' s
headSha :: Repo -> IO (Maybe Sha) headSha :: Repo -> IO (Maybe Sha)
headSha = sha headRef headSha = sha headRef
@ -116,7 +122,7 @@ matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo
{- List of (shas, branches) matching a given ref spec. -} {- List of (shas, branches) matching a given ref spec. -}
matching' :: [String] -> Repo -> IO [(Sha, Branch)] 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 pipeReadStrict (Param "show-ref" : map Param ps) repo
where where
gen l = let (r, b) = separate (== ' ') l gen l = let (r, b) = separate (== ' ') l
@ -148,7 +154,7 @@ delete oldvalue ref = run
- The ref may be something like a branch name, and it could contain - The ref may be something like a branch name, and it could contain
- ":subdir" if a subtree is wanted. -} - ":subdir" if a subtree is wanted. -}
tree :: Ref -> Repo -> IO (Maybe Sha) tree :: Ref -> Repo -> IO (Maybe Sha)
tree (Ref ref) = extractSha <$$> pipeReadStrict tree (Ref ref) = extractSha . decodeBS <$$> pipeReadStrict
[ Param "rev-parse", Param "--verify", Param "--quiet", Param ref' ] [ Param "rev-parse", Param "--verify", Param "--quiet", Param ref' ]
where where
ref' = if ":" `isInfixOf` ref ref' = if ":" `isInfixOf` ref

View file

@ -21,7 +21,7 @@ getMulti :: [Branch] -> Repo -> IO [Sha]
getMulti bs = get' (map (Param . fromRef) bs) getMulti bs = get' (map (Param . fromRef) bs)
get' :: [CommandParam] -> Repo -> IO [Sha] get' :: [CommandParam] -> Repo -> IO [Sha]
get' ps = mapMaybe extractSha . lines <$$> pipeReadStrict ps' get' ps = mapMaybe extractSha . lines . decodeBS <$$> pipeReadStrict ps'
where where
ps' = catMaybes ps' = catMaybes
[ Just $ Param "log" [ Just $ Param "log"

View file

@ -284,7 +284,7 @@ findUncorruptedCommit missing goodcommits branch r = do
, Param "--format=%H" , Param "--format=%H"
, Param (fromRef branch) , Param (fromRef branch)
] r ] r
let branchshas = catMaybes $ map extractSha ls let branchshas = catMaybes $ map (extractSha . decodeBS) ls
reflogshas <- RefLog.get branch r reflogshas <- RefLog.get branch r
-- XXX Could try a bit harder here, and look -- XXX Could try a bit harder here, and look
-- for uncorrupted old commits in branches in the -- for uncorrupted old commits in branches in the
@ -313,7 +313,7 @@ verifyCommit missing goodcommits commit r
, Param "--format=%H %T" , Param "--format=%H %T"
, Param (fromRef commit) , Param (fromRef commit)
] r ] r
let committrees = map parse ls let committrees = map (parse . decodeBS) ls
if any isNothing committrees || null committrees if any isNothing committrees || null committrees
then do then do
void cleanup void cleanup

View file

@ -69,7 +69,7 @@ parseStatusZ = go []
getStatus :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedUnstaged Status], IO Bool) getStatus :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedUnstaged Status], IO Bool)
getStatus ps fs r = do getStatus ps fs r = do
(ls, cleanup) <- pipeNullSplit ps' r (ls, cleanup) <- pipeNullSplit ps' r
return (parseStatusZ ls, cleanup) return (parseStatusZ (map decodeBL ls), cleanup)
where where
ps' = concat ps' = concat
[ [Param "status"] [ [Param "status"]

View file

@ -115,7 +115,7 @@ mkTreeOutput :: FileMode -> ObjectType -> Sha -> TopFilePath -> String
mkTreeOutput fm ot s f = concat mkTreeOutput fm ot s f = concat
[ showOct fm "" [ showOct fm ""
, " " , " "
, show ot , decodeBS (fmtObjectType ot)
, " " , " "
, fromRef s , fromRef s
, "\t" , "\t"
@ -134,7 +134,7 @@ treeItemToTreeContent (TreeItem f m s) = case toTreeItemType m of
treeItemToLsTreeItem :: TreeItem -> LsTree.TreeItem treeItemToLsTreeItem :: TreeItem -> LsTree.TreeItem
treeItemToLsTreeItem (TreeItem f mode sha) = LsTree.TreeItem treeItemToLsTreeItem (TreeItem f mode sha) = LsTree.TreeItem
{ LsTree.mode = mode { LsTree.mode = mode
, LsTree.typeobj = show BlobObject , LsTree.typeobj = fmtObjectType BlobObject
, LsTree.sha = sha , LsTree.sha = sha
, LsTree.file = f , LsTree.file = f
} }
@ -239,7 +239,7 @@ adjustTree adjusttreeitem addtreeitems resolveaddconflict removefiles r repo =
Just CommitObject -> do Just CommitObject -> do
let ti = TreeCommit (LsTree.file i) (LsTree.mode i) (LsTree.sha i) let ti = TreeCommit (LsTree.file i) (LsTree.mode i) (LsTree.sha i)
go h wasmodified (ti:c) depth intree is go h wasmodified (ti:c) depth intree is
_ -> error ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"") _ -> error ("unexpected object type \"" ++ decodeBS (LsTree.typeobj i) ++ "\"")
| otherwise = return (c, wasmodified, i:is) | otherwise = return (c, wasmodified, i:is)
adjustlist h depth ishere underhere l = do adjustlist h depth ishere underhere l = do
@ -328,7 +328,7 @@ graftTree' subtree graftloc basetree repo hdl = go basetree graftdirs
-- For a graftloc of "foo/bar/baz", this generates -- For a graftloc of "foo/bar/baz", this generates
-- ["foo", "foo/bar", "foo/bar/baz"] -- ["foo", "foo/bar", "foo/bar/baz"]
graftdirs = map (asTopFilePath . toInternalGitPath) $ graftdirs = map (asTopFilePath . decodeBS . toInternalGitPath . encodeBS) $
mkpaths [] $ splitDirectories $ gitPath graftloc mkpaths [] $ splitDirectories $ gitPath graftloc
mkpaths _ [] = [] mkpaths _ [] = []
mkpaths base (d:rest) = (joinPath base </> d) : mkpaths (base ++ [d]) rest mkpaths base (d:rest) = (joinPath base </> d) : mkpaths (base ++ [d]) rest
@ -355,7 +355,7 @@ extractTree l = case go [] inTopTree l of
Just CommitObject -> Just CommitObject ->
let c = TreeCommit (LsTree.file i) (LsTree.mode i) (LsTree.sha i) let c = TreeCommit (LsTree.file i) (LsTree.mode i) (LsTree.sha i)
in go (c:t) intree is in go (c:t) intree is
_ -> parseerr ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"") _ -> parseerr ("unexpected object type \"" ++ decodeBS (LsTree.typeobj i) ++ "\"")
| otherwise = Right (t, i:is) | otherwise = Right (t, i:is)
parseerr = Left parseerr = Left

View file

@ -5,13 +5,17 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
module Git.Types where module Git.Types where
import Network.URI import Network.URI
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.ByteString as S
import System.Posix.Types import System.Posix.Types
import Utility.SafeCommand import Utility.SafeCommand
{- Support repositories on local disk, and repositories accessed via an URL. {- Support repositories on local disk, and repositories accessed via an URL.
- -
- Repos on local disk have a git directory, and unless bare, a worktree. - Repos on local disk have a git directory, and unless bare, a worktree.
@ -64,32 +68,31 @@ newtype RefDate = RefDate String
{- Types of objects that can be stored in git. -} {- Types of objects that can be stored in git. -}
data ObjectType = BlobObject | CommitObject | TreeObject data ObjectType = BlobObject | CommitObject | TreeObject
deriving (Eq)
instance Show ObjectType where readObjectType :: S.ByteString -> Maybe ObjectType
show BlobObject = "blob"
show CommitObject = "commit"
show TreeObject = "tree"
readObjectType :: String -> Maybe ObjectType
readObjectType "blob" = Just BlobObject readObjectType "blob" = Just BlobObject
readObjectType "commit" = Just CommitObject readObjectType "commit" = Just CommitObject
readObjectType "tree" = Just TreeObject readObjectType "tree" = Just TreeObject
readObjectType _ = Nothing readObjectType _ = Nothing
fmtObjectType :: ObjectType -> S.ByteString
fmtObjectType BlobObject = "blob"
fmtObjectType CommitObject = "commit"
fmtObjectType TreeObject = "tree"
{- Types of items in a tree. -} {- Types of items in a tree. -}
data TreeItemType = TreeFile | TreeExecutable | TreeSymlink | TreeSubmodule data TreeItemType = TreeFile | TreeExecutable | TreeSymlink | TreeSubmodule
deriving (Eq) deriving (Eq)
{- Git uses magic numbers to denote the type of a tree item. -} {- Git uses magic numbers to denote the type of a tree item. -}
readTreeItemType :: String -> Maybe TreeItemType readTreeItemType :: S.ByteString -> Maybe TreeItemType
readTreeItemType "100644" = Just TreeFile readTreeItemType "100644" = Just TreeFile
readTreeItemType "100755" = Just TreeExecutable readTreeItemType "100755" = Just TreeExecutable
readTreeItemType "120000" = Just TreeSymlink readTreeItemType "120000" = Just TreeSymlink
readTreeItemType "160000" = Just TreeSubmodule readTreeItemType "160000" = Just TreeSubmodule
readTreeItemType _ = Nothing readTreeItemType _ = Nothing
fmtTreeItemType :: TreeItemType -> String fmtTreeItemType :: TreeItemType -> S.ByteString
fmtTreeItemType TreeFile = "100644" fmtTreeItemType TreeFile = "100644"
fmtTreeItemType TreeExecutable = "100755" fmtTreeItemType TreeExecutable = "100755"
fmtTreeItemType TreeSymlink = "120000" fmtTreeItemType TreeSymlink = "120000"

View file

@ -10,6 +10,7 @@ module Git.UnionMerge (
mergeIndex mergeIndex
) where ) where
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.Set as S import qualified Data.Set as S
@ -69,7 +70,7 @@ diffOpts = ["--raw", "-z", "-r", "--no-renames", "-l0"]
doMerge :: HashObjectHandle -> CatFileHandle -> [String] -> Repo -> Streamer doMerge :: HashObjectHandle -> CatFileHandle -> [String] -> Repo -> Streamer
doMerge hashhandle ch differ repo streamer = do doMerge hashhandle ch differ repo streamer = do
(diff, cleanup) <- pipeNullSplit (map Param differ) repo (diff, cleanup) <- pipeNullSplit (map Param differ) repo
go diff go (map decodeBL' diff)
void $ cleanup void $ cleanup
where where
go [] = noop go [] = noop
@ -80,7 +81,7 @@ doMerge hashhandle ch differ repo streamer = do
{- Given an info line from a git raw diff, and the filename, generates {- Given an info line from a git raw diff, and the filename, generates
- a line suitable for update-index that union merges the two sides of the - a line suitable for update-index that union merges the two sides of the
- diff. -} - diff. -}
mergeFile :: String -> FilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe String) mergeFile :: String -> FilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString)
mergeFile info file hashhandle h = case filter (/= nullSha) [Ref asha, Ref bsha] of mergeFile info file hashhandle h = case filter (/= nullSha) [Ref asha, Ref bsha] of
[] -> return Nothing [] -> return Nothing
(sha:[]) -> use sha (sha:[]) -> use sha

View file

@ -1,11 +1,11 @@
{- git-update-index library {- git-update-index library
- -
- Copyright 2011-2018 Joey Hess <id@joeyh.name> - Copyright 2011-2019 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE BangPatterns, CPP #-} {-# LANGUAGE BangPatterns, OverloadedStrings, CPP #-}
module Git.UpdateIndex ( module Git.UpdateIndex (
Streamer, Streamer,
@ -32,12 +32,14 @@ import Git.FilePath
import Git.Sha import Git.Sha
import qualified Git.DiffTreeItem as Diff 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 {- Streamers are passed a callback and should feed it lines in the form
- read by update-index, and generated by ls-tree. -} - 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. -} {- A streamer with a precalculated value. -}
pureStreamer :: String -> Streamer pureStreamer :: L.ByteString -> Streamer
pureStreamer !s = \streamer -> streamer s pureStreamer !s = \streamer -> streamer s
{- Streams content into update-index from a list of Streamers. -} {- Streams content into update-index from a list of Streamers. -}
@ -49,8 +51,8 @@ data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle
streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO () streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO ()
streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do
hPutStr h s L.hPutStr h s
hPutStr h "\0" L.hPutStr h "\0"
startUpdateIndex :: Repo -> IO UpdateIndexHandle startUpdateIndex :: Repo -> IO UpdateIndexHandle
startUpdateIndex repo = do startUpdateIndex repo = do
@ -84,14 +86,13 @@ lsSubTree (Ref x) p repo streamer = do
{- Generates a line suitable to be fed into update-index, to add {- Generates a line suitable to be fed into update-index, to add
- a given file with a given sha. -} - a given file with a given sha. -}
updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> String updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> L.ByteString
updateIndexLine sha treeitemtype file = concat updateIndexLine sha treeitemtype file = L.fromStrict $
[ fmtTreeItemType treeitemtype fmtTreeItemType treeitemtype
, " blob " <> " blob "
, fromRef sha <> encodeBS (fromRef sha)
, "\t" <> "\t"
, indexPath file <> indexPath file
]
stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer
stageFile sha treeitemtype file repo = do stageFile sha treeitemtype file repo = do
@ -105,7 +106,11 @@ unstageFile file repo = do
return $ unstageFile' p return $ unstageFile' p
unstageFile' :: TopFilePath -> Streamer 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. -} {- A streamer that adds a symlink to the index. -}
stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer
@ -123,7 +128,7 @@ stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of
Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d) Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d)
indexPath :: TopFilePath -> InternalGitPath indexPath :: TopFilePath -> InternalGitPath
indexPath = toInternalGitPath . getTopFilePath indexPath = toInternalGitPath . toRawFilePath . getTopFilePath
{- Refreshes the index, by checking file stat information. -} {- Refreshes the index, by checking file stat information. -}
refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool

View file

@ -17,38 +17,39 @@ module Types.Export (
import Git.FilePath import Git.FilePath
import Utility.Split import Utility.Split
import Utility.FileSystemEncoding
import qualified System.FilePath.Posix as Posix import qualified System.FilePath.Posix as Posix
-- A location on a remote that a key can be exported to. -- A location on a remote that a key can be exported to.
-- The FilePath will be relative to the top of the remote, -- The RawFilePath will be relative to the top of the remote,
-- and uses unix-style path separators. -- and uses unix-style path separators.
newtype ExportLocation = ExportLocation FilePath newtype ExportLocation = ExportLocation RawFilePath
deriving (Show, Eq) deriving (Show, Eq)
mkExportLocation :: FilePath -> ExportLocation mkExportLocation :: RawFilePath -> ExportLocation
mkExportLocation = ExportLocation . toInternalGitPath mkExportLocation = ExportLocation . toInternalGitPath
fromExportLocation :: ExportLocation -> FilePath fromExportLocation :: ExportLocation -> RawFilePath
fromExportLocation (ExportLocation f) = f fromExportLocation (ExportLocation f) = f
newtype ExportDirectory = ExportDirectory FilePath newtype ExportDirectory = ExportDirectory RawFilePath
deriving (Show, Eq) deriving (Show, Eq)
mkExportDirectory :: FilePath -> ExportDirectory mkExportDirectory :: RawFilePath -> ExportDirectory
mkExportDirectory = ExportDirectory . toInternalGitPath mkExportDirectory = ExportDirectory . toInternalGitPath
fromExportDirectory :: ExportDirectory -> FilePath fromExportDirectory :: ExportDirectory -> RawFilePath
fromExportDirectory (ExportDirectory f) = f fromExportDirectory (ExportDirectory f) = f
-- | All subdirectories down to the ExportLocation, with the deepest ones -- | All subdirectories down to the ExportLocation, with the deepest ones
-- last. Does not include the top of the export. -- last. Does not include the top of the export.
exportDirectories :: ExportLocation -> [ExportDirectory] exportDirectories :: ExportLocation -> [ExportDirectory]
exportDirectories (ExportLocation f) = exportDirectories (ExportLocation f) =
map (ExportDirectory . Posix.joinPath . reverse) (subs [] dirs) map (ExportDirectory . encodeBS . Posix.joinPath . reverse) (subs [] dirs)
where where
subs _ [] = [] subs _ [] = []
subs ps (d:ds) = (d:ps) : subs (d:ps) ds subs ps (d:ds) = (d:ps) : subs (d:ps) ds
dirs = map Posix.dropTrailingPathSeparator $ dirs = map Posix.dropTrailingPathSeparator $
dropFromEnd 1 $ Posix.splitPath f dropFromEnd 1 $ Posix.splitPath $ decodeBS f

View file

@ -19,10 +19,10 @@ import Utility.FileSystemEncoding
- location on the remote. -} - location on the remote. -}
type ImportLocation = ExportLocation type ImportLocation = ExportLocation
mkImportLocation :: FilePath -> ImportLocation mkImportLocation :: RawFilePath -> ImportLocation
mkImportLocation = mkExportLocation mkImportLocation = mkExportLocation
fromImportLocation :: ImportLocation -> FilePath fromImportLocation :: ImportLocation -> RawFilePath
fromImportLocation = fromExportLocation fromImportLocation = fromExportLocation
{- An identifier for content stored on a remote that has been imported into {- An identifier for content stored on a remote that has been imported into

View file

@ -12,6 +12,7 @@ module Utility.Misc (
readFileStrict, readFileStrict,
separate, separate,
firstLine, firstLine,
firstLine',
segment, segment,
segmentDelim, segmentDelim,
massReplace, massReplace,
@ -28,6 +29,7 @@ import Data.Char
import Data.List import Data.List
import System.Exit import System.Exit
import Control.Applicative import Control.Applicative
import qualified Data.ByteString as S
import Prelude import Prelude
{- A version of hgetContents that is not lazy. Ensures file is {- A version of hgetContents that is not lazy. Ensures file is
@ -56,6 +58,11 @@ separate c l = unbreak $ break c l
firstLine :: String -> String firstLine :: String -> String
firstLine = takeWhile (/= '\n') firstLine = takeWhile (/= '\n')
firstLine' :: S.ByteString -> S.ByteString
firstLine' = S.takeWhile (/= nl)
where
nl = fromIntegral (ord '\n')
{- Splits a list into segments that are delimited by items matching {- Splits a list into segments that are delimited by items matching
- a predicate. (The delimiters are not included in the segments.) - a predicate. (The delimiters are not included in the segments.)
- Segments may be empty. -} - Segments may be empty. -}

View file

@ -602,7 +602,7 @@ Executable git-annex
if flag(DebugLocks) if flag(DebugLocks)
CPP-Options: -DDEBUGLOCKS CPP-Options: -DDEBUGLOCKS
Other-Modules: Other-Modules-Temp-Disabled:
Annex Annex
Annex.Action Annex.Action
Annex.AdjustedBranch Annex.AdjustedBranch
@ -860,7 +860,6 @@ Executable git-annex
Git.RefLog Git.RefLog
Git.Remote Git.Remote
Git.Remote.Remove Git.Remote.Remove
Git.Repair
Git.Sha Git.Sha
Git.Ssh Git.Ssh
Git.Status Git.Status