5d8e4a7c74
This makes sync a lot faster in the common case where there's no new backup. There's still room for it to be faster. Currently the old imported tree has to be traversed, to generate the ImportableContents. Which then gets turned around to generate the new imported tree, which is identical. So, it would be possible to just return a "no new imports", or an ImportableContents that has a way to graft in a tree. The latter is probably too far to go to optimise this, unless other things need it. The former might be worth it, but it's already pretty fast, since git ls-tree is pretty fast.
126 lines
3.1 KiB
Haskell
126 lines
3.1 KiB
Haskell
{- git ls-tree interface
|
|
-
|
|
- Copyright 2011-2020 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Git.LsTree (
|
|
TreeItem(..),
|
|
LsTreeMode(..),
|
|
lsTree,
|
|
lsTree',
|
|
lsTreeStrict,
|
|
lsTreeStrict',
|
|
lsTreeParams,
|
|
lsTreeFiles,
|
|
parseLsTree,
|
|
formatLsTree,
|
|
) where
|
|
|
|
import Common
|
|
import Git
|
|
import Git.Command
|
|
import Git.FilePath
|
|
import qualified Git.Filename
|
|
import Utility.Attoparsec
|
|
|
|
import Numeric
|
|
import Data.Either
|
|
import System.Posix.Types
|
|
import qualified Data.ByteString as S
|
|
import qualified Data.ByteString.Lazy as L
|
|
import qualified Data.Attoparsec.ByteString as AS
|
|
import qualified Data.Attoparsec.ByteString.Lazy as A
|
|
import qualified Data.Attoparsec.ByteString.Char8 as A8
|
|
|
|
data TreeItem = TreeItem
|
|
{ mode :: FileMode
|
|
, typeobj :: S.ByteString
|
|
, sha :: Ref
|
|
, file :: TopFilePath
|
|
} deriving (Show)
|
|
|
|
data LsTreeMode = LsTreeRecursive | LsTreeNonRecursive
|
|
|
|
{- Lists the contents of a tree, with lazy output. -}
|
|
lsTree :: LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool)
|
|
lsTree = lsTree' []
|
|
|
|
lsTree' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool)
|
|
lsTree' ps lsmode t repo = do
|
|
(l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo
|
|
return (rights (map parseLsTree l), cleanup)
|
|
|
|
lsTreeStrict :: LsTreeMode -> Ref -> Repo -> IO [TreeItem]
|
|
lsTreeStrict = lsTreeStrict' []
|
|
|
|
lsTreeStrict' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO [TreeItem]
|
|
lsTreeStrict' ps lsmode t repo = rights . map parseLsTreeStrict
|
|
<$> pipeNullSplitStrict (lsTreeParams lsmode t ps) repo
|
|
|
|
lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam]
|
|
lsTreeParams lsmode r ps =
|
|
[ Param "ls-tree"
|
|
, Param "--full-tree"
|
|
, Param "-z"
|
|
] ++ recursiveparams ++ ps ++
|
|
[ Param "--"
|
|
, File $ fromRef r
|
|
]
|
|
where
|
|
recursiveparams = case lsmode of
|
|
LsTreeRecursive -> [ Param "-r" ]
|
|
LsTreeNonRecursive -> []
|
|
|
|
{- Lists specified files in a tree. -}
|
|
lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem]
|
|
lsTreeFiles t fs repo = rights . map (parseLsTree . L.fromStrict)
|
|
<$> pipeNullSplitStrict ps repo
|
|
where
|
|
ps =
|
|
[ Param "ls-tree"
|
|
, Param "--full-tree"
|
|
, Param "-z"
|
|
, Param "--"
|
|
, File $ fromRef t
|
|
] ++ map File fs
|
|
|
|
parseLsTree :: L.ByteString -> Either String TreeItem
|
|
parseLsTree b = case A.parse parserLsTree b of
|
|
A.Done _ r -> Right r
|
|
A.Fail _ _ err -> Left err
|
|
|
|
parseLsTreeStrict :: S.ByteString -> Either String TreeItem
|
|
parseLsTreeStrict b = go (AS.parse parserLsTree b)
|
|
where
|
|
go (AS.Done _ r) = Right r
|
|
go (AS.Fail _ _ err) = Left err
|
|
go (AS.Partial c) = go (c mempty)
|
|
|
|
{- Parses a line of ls-tree output, in format:
|
|
- mode SP type SP sha TAB file
|
|
-
|
|
- (The --long format is not currently supported.) -}
|
|
parserLsTree :: A.Parser TreeItem
|
|
parserLsTree = TreeItem
|
|
-- mode
|
|
<$> octal
|
|
<* A8.char ' '
|
|
-- type
|
|
<*> A8.takeTill (== ' ')
|
|
<* A8.char ' '
|
|
-- sha
|
|
<*> (Ref <$> A8.takeTill (== '\t'))
|
|
<* A8.char '\t'
|
|
-- file
|
|
<*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString)
|
|
|
|
{- Inverse of parseLsTree -}
|
|
formatLsTree :: TreeItem -> String
|
|
formatLsTree ti = unwords
|
|
[ showOct (mode ti) ""
|
|
, decodeBS (typeobj ti)
|
|
, fromRef (sha ti)
|
|
, fromRawFilePath (getTopFilePath (file ti))
|
|
]
|