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:
parent
1f035c0d66
commit
6a97ff6b3a
25 changed files with 258 additions and 200 deletions
|
@ -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. -}
|
||||||
|
|
|
@ -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 ()
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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. -}
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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"]
|
||||||
|
|
105
Git/LsFiles.hs
105
Git/LsFiles.hs
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
]
|
]
|
||||||
|
|
20
Git/Ref.hs
20
Git/Ref.hs
|
@ -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
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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"]
|
||||||
|
|
10
Git/Tree.hs
10
Git/Tree.hs
|
@ -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
|
||||||
|
|
||||||
|
|
21
Git/Types.hs
21
Git/Types.hs
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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. -}
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue