ByteString Ref continued

Several nice speed wins I think.

At 340/633 files converted.
This commit is contained in:
Joey Hess 2020-04-07 13:27:11 -04:00
parent d5d8259937
commit 6c81e0c8f1
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
16 changed files with 124 additions and 99 deletions

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 Annex.AdjustedBranch.Name ( module Annex.AdjustedBranch.Name (
originalToAdjusted, originalToAdjusted,
adjustedToOriginal, adjustedToOriginal,
@ -18,14 +20,15 @@ import qualified Git.Ref
import Utility.Misc import Utility.Misc
import Control.Applicative import Control.Applicative
import Data.List import Data.Char
import qualified Data.ByteString as S
adjustedBranchPrefix :: String adjustedBranchPrefix :: S.ByteString
adjustedBranchPrefix = "refs/heads/adjusted/" adjustedBranchPrefix = "refs/heads/adjusted/"
class SerializeAdjustment t where class SerializeAdjustment t where
serializeAdjustment :: t -> String serializeAdjustment :: t -> S.ByteString
deserializeAdjustment :: String -> Maybe t deserializeAdjustment :: S.ByteString -> Maybe t
instance SerializeAdjustment Adjustment where instance SerializeAdjustment Adjustment where
serializeAdjustment (LinkAdjustment l) = serializeAdjustment (LinkAdjustment l) =
@ -33,7 +36,7 @@ instance SerializeAdjustment Adjustment where
serializeAdjustment (PresenceAdjustment p Nothing) = serializeAdjustment (PresenceAdjustment p Nothing) =
serializeAdjustment p serializeAdjustment p
serializeAdjustment (PresenceAdjustment p (Just l)) = serializeAdjustment (PresenceAdjustment p (Just l)) =
serializeAdjustment p ++ "-" ++ serializeAdjustment l serializeAdjustment p <> "-" <> serializeAdjustment l
deserializeAdjustment s = deserializeAdjustment s =
(LinkAdjustment <$> deserializeAdjustment s) (LinkAdjustment <$> deserializeAdjustment s)
<|> <|>
@ -41,7 +44,7 @@ instance SerializeAdjustment Adjustment where
<|> <|>
(PresenceAdjustment <$> deserializeAdjustment s <*> pure Nothing) (PresenceAdjustment <$> deserializeAdjustment s <*> pure Nothing)
where where
(s1, s2) = separate (== '-') s (s1, s2) = separate' (== (fromIntegral (ord '-'))) s
instance SerializeAdjustment LinkAdjustment where instance SerializeAdjustment LinkAdjustment where
serializeAdjustment UnlockAdjustment = "unlocked" serializeAdjustment UnlockAdjustment = "unlocked"
@ -65,19 +68,21 @@ newtype AdjBranch = AdjBranch { adjBranch :: Branch }
originalToAdjusted :: OrigBranch -> Adjustment -> AdjBranch originalToAdjusted :: OrigBranch -> Adjustment -> AdjBranch
originalToAdjusted orig adj = AdjBranch $ Ref $ originalToAdjusted orig adj = AdjBranch $ Ref $
adjustedBranchPrefix ++ base ++ '(' : serializeAdjustment adj ++ ")" adjustedBranchPrefix <> base <> "(" <> serializeAdjustment adj <> ")"
where where
base = fromRef (Git.Ref.base orig) base = fromRef' (Git.Ref.base orig)
type OrigBranch = Branch type OrigBranch = Branch
adjustedToOriginal :: Branch -> Maybe (Adjustment, OrigBranch) adjustedToOriginal :: Branch -> Maybe (Adjustment, OrigBranch)
adjustedToOriginal b adjustedToOriginal b
| adjustedBranchPrefix `isPrefixOf` bs = do | adjustedBranchPrefix `S.isPrefixOf` bs = do
let (base, as) = separate (== '(') (drop prefixlen bs) let (base, as) = separate' (== openparen) (S.drop prefixlen bs)
adj <- deserializeAdjustment (takeWhile (/= ')') as) adj <- deserializeAdjustment (S.takeWhile (/= closeparen) as)
Just (adj, Git.Ref.branchRef (Ref base)) Just (adj, Git.Ref.branchRef (Ref base))
| otherwise = Nothing | otherwise = Nothing
where where
bs = fromRef b bs = fromRef' b
prefixlen = length adjustedBranchPrefix prefixlen = S.length adjustedBranchPrefix
openparen = fromIntegral (ord '(')
closeparen = fromIntegral (ord ')')

View file

@ -29,7 +29,9 @@ module Annex.Branch (
withIndex, withIndex,
) where ) where
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as B8
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Map as M import qualified Data.Map as M
import Data.Function import Data.Function
@ -643,11 +645,11 @@ getMergedRefs = S.fromList . map fst <$> getMergedRefs'
getMergedRefs' :: Annex [(Git.Sha, Git.Branch)] getMergedRefs' :: Annex [(Git.Sha, Git.Branch)]
getMergedRefs' = do getMergedRefs' = do
f <- fromRepo gitAnnexMergedRefs f <- fromRepo gitAnnexMergedRefs
s <- liftIO $ catchDefaultIO "" $ readFile f s <- liftIO $ catchDefaultIO mempty $ B.readFile f
return $ map parse $ lines s return $ map parse $ B8.lines s
where where
parse l = parse l =
let (s, b) = separate (== '\t') l let (s, b) = separate' (== (fromIntegral (ord '\t'))) l
in (Ref s, Ref b) in (Ref s, Ref b)
{- Grafts a treeish into the branch at the specified location, {- Grafts a treeish into the branch at the specified location,

View file

@ -1,6 +1,6 @@
{- Waiting for changed git refs {- Waiting for changed git refs
- -
- Copyright 2014-216 Joey Hess <id@joeyh.name> - Copyright 2014-2016 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -24,13 +24,14 @@ import qualified Utility.SimpleProtocol as Proto
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.STM.TBMChan import Control.Concurrent.STM.TBMChan
import qualified Data.ByteString as S
newtype ChangedRefs = ChangedRefs [Git.Ref] newtype ChangedRefs = ChangedRefs [Git.Ref]
deriving (Show) deriving (Show)
instance Proto.Serializable ChangedRefs where instance Proto.Serializable ChangedRefs where
serialize (ChangedRefs l) = unwords $ map Git.fromRef l serialize (ChangedRefs l) = unwords $ map Git.fromRef l
deserialize = Just . ChangedRefs . map Git.Ref . words deserialize = Just . ChangedRefs . map (Git.Ref . encodeBS) . words
data ChangedRefsHandle = ChangedRefsHandle DirWatcherHandle (TBMChan Git.Sha) data ChangedRefsHandle = ChangedRefsHandle DirWatcherHandle (TBMChan Git.Sha)
@ -97,7 +98,7 @@ notifyHook chan reffile _
| ".lock" `isSuffixOf` reffile = noop | ".lock" `isSuffixOf` reffile = noop
| otherwise = void $ do | otherwise = void $ do
sha <- catchDefaultIO Nothing $ sha <- catchDefaultIO Nothing $
extractSha <$> readFile reffile extractSha <$> S.readFile reffile
-- When the channel is full, there is probably no reader -- When the channel is full, there is probably no reader
-- running, or ref changes have been occuring very fast, -- running, or ref changes have been occuring very fast,
-- so it's ok to not write the change to it. -- so it's ok to not write the change to it.

View file

@ -6,6 +6,7 @@
-} -}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module Database.Keys ( module Database.Keys (
DbHandle, DbHandle,
@ -44,6 +45,7 @@ import Git.Types
import Git.Index import Git.Index
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified System.FilePath.ByteString as P import qualified System.FilePath.ByteString as P
{- Runs an action that reads from the database. {- Runs an action that reads from the database.
@ -237,8 +239,8 @@ reconcileStaged qh = do
Nothing -> noop Nothing -> noop
where where
go cur indexcache = do go cur indexcache = do
(l, cleanup) <- inRepo $ pipeNullSplit diff (l, cleanup) <- inRepo $ pipeNullSplit' diff
changed <- procdiff (map decodeBL' l) False changed <- procdiff l False
void $ liftIO cleanup void $ liftIO cleanup
-- Flush database changes immediately -- Flush database changes immediately
-- so other processes can see them. -- so other processes can see them.
@ -278,15 +280,16 @@ reconcileStaged qh = do
, Param "--no-ext-diff" , Param "--no-ext-diff"
] ]
procdiff (info:file:rest) changed = case words info of procdiff (info:file:rest) changed
((':':_srcmode):dstmode:_srcsha:dstsha:_change:[]) | ":" `S.isPrefixOf` info = case S8.words info of
-- Only want files, not symlinks (_colonsrcmode:dstmode:_srcsha:dstsha:_change:[])
| dstmode /= decodeBS' (fmtTreeItemType TreeSymlink) -> do -- Only want files, not symlinks
maybe noop (reconcile (asTopFilePath (toRawFilePath file))) | dstmode /= fmtTreeItemType TreeSymlink -> do
=<< catKey (Ref dstsha) maybe noop (reconcile (asTopFilePath file))
procdiff rest True =<< catKey (Ref dstsha)
| otherwise -> procdiff rest changed procdiff rest True
_ -> return changed -- parse failed | otherwise -> procdiff rest changed
_ -> return changed -- parse failed
procdiff _ changed = return changed procdiff _ changed = return changed
-- Note that database writes done in here will not necessarily -- Note that database writes done in here will not necessarily

View file

@ -18,6 +18,7 @@ import qualified Git.Config
import qualified Git.Ref import qualified Git.Ref
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
{- The currently checked out branch. {- The currently checked out branch.
- -
@ -39,25 +40,27 @@ current r = do
{- 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
<$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r [ Param "symbolic-ref"
, Param "-q"
, Param $ fromRef Git.Ref.headRef
] r
where where
parse b parse b
| B.null b = Nothing | B.null b = Nothing
| otherwise = Just $ Git.Ref $ decodeBS b | otherwise = Just $ Git.Ref 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. -}
changed :: Branch -> Branch -> Repo -> IO Bool changed :: Branch -> Branch -> Repo -> IO Bool
changed origbranch newbranch repo changed origbranch newbranch repo
| origbranch == newbranch = return False | origbranch == newbranch = return False
| otherwise = not . null | otherwise = not . B.null
<$> changed' origbranch newbranch [Param "-n1"] repo <$> changed' origbranch newbranch [Param "-n1"] repo
where where
changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO B.ByteString
changed' origbranch newbranch extraps repo = changed' origbranch newbranch extraps repo = pipeReadStrict ps repo
decodeBS <$> pipeReadStrict ps repo
where where
ps = ps =
[ Param "log" [ Param "log"
@ -68,7 +71,7 @@ changed' origbranch newbranch extraps repo =
{- Lists commits that are in the second branch and not in the first branch. -} {- Lists commits that are in the second branch and not in the first branch. -}
changedCommits :: Branch -> Branch -> [CommandParam] -> Repo -> IO [Sha] changedCommits :: Branch -> Branch -> [CommandParam] -> Repo -> IO [Sha]
changedCommits origbranch newbranch extraps repo = changedCommits origbranch newbranch extraps repo =
catMaybes . map extractSha . lines catMaybes . map extractSha . B8.lines
<$> changed' origbranch newbranch extraps repo <$> changed' origbranch newbranch extraps repo
{- Check if it's possible to fast-forward from the old {- Check if it's possible to fast-forward from the old
@ -163,8 +166,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

@ -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.CatFile ( module Git.CatFile (
CatFileHandle, CatFileHandle,
catFileStart, catFileStart,
@ -22,7 +24,6 @@ module Git.CatFile (
import System.IO import System.IO
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.Map as M import qualified Data.Map as M
import Data.String import Data.String
import Data.Char import Data.Char
@ -69,11 +70,11 @@ catFileStop h = do
{- Reads a file from a specified branch. -} {- Reads a file from a specified branch. -}
catFile :: CatFileHandle -> Branch -> RawFilePath -> 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 ++ ":" ++ fromRawFilePath (toInternalGitPath file) fromRef' branch <> ":" <> toInternalGitPath file
catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> 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 ++ ":" ++ fromRawFilePath (toInternalGitPath file) fromRef' branch <> ":" <> 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 +149,7 @@ parseResp object l
| " missing" `isSuffixOf` l -- less expensive than full check | " missing" `isSuffixOf` l -- less expensive than full check
&& l == fromRef object ++ " missing" = Just DNE && l == fromRef object ++ " missing" = Just DNE
| otherwise = case words l of | otherwise = case words l of
[sha, objtype, size] -> case extractSha sha of [sha, objtype, size] -> case extractSha (encodeBS sha) of
Just sha' -> case (readObjectType (encodeBS objtype), reads size) of Just sha' -> case (readObjectType (encodeBS objtype), reads size) of
(Just t, [(bytes, "")]) -> (Just t, [(bytes, "")]) ->
Just $ ParsedResp sha' bytes t Just $ ParsedResp sha' bytes t
@ -218,39 +219,39 @@ catTree h treeref = go <$> catObjectDetails h treeref
catCommit :: CatFileHandle -> Ref -> IO (Maybe Commit) catCommit :: CatFileHandle -> Ref -> IO (Maybe Commit)
catCommit h commitref = go <$> catObjectDetails h commitref catCommit h commitref = go <$> catObjectDetails h commitref
where where
go (Just (b, _, CommitObject)) = parseCommit b go (Just (b, _, CommitObject)) = parseCommit (L.toStrict b)
go _ = Nothing go _ = Nothing
parseCommit :: L.ByteString -> Maybe Commit parseCommit :: S.ByteString -> Maybe Commit
parseCommit b = Commit parseCommit b = Commit
<$> (extractSha . L8.unpack =<< field "tree") <$> (extractSha =<< field "tree")
<*> Just (maybe [] (mapMaybe (extractSha . L8.unpack)) (fields "parent")) <*> Just (maybe [] (mapMaybe extractSha) (fields "parent"))
<*> (parsemetadata <$> field "author") <*> (parsemetadata <$> field "author")
<*> (parsemetadata <$> field "committer") <*> (parsemetadata <$> field "committer")
<*> Just (L8.unpack $ L.intercalate (L.singleton nl) message) <*> Just (decodeBS $ S.intercalate (S.singleton nl) message)
where where
field n = headMaybe =<< fields n field n = headMaybe =<< fields n
fields n = M.lookup (fromString n) fieldmap fields n = M.lookup (fromString n) fieldmap
fieldmap = M.fromListWith (++) ((map breakfield) header) fieldmap = M.fromListWith (++) ((map breakfield) header)
breakfield l = breakfield l =
let (k, sp_v) = L.break (== sp) l let (k, sp_v) = S.break (== sp) l
in (k, [L.drop 1 sp_v]) in (k, [S.drop 1 sp_v])
(header, message) = separate L.null ls (header, message) = separate S.null ls
ls = L.split nl b ls = S.split nl b
-- author and committer lines have the form: "name <email> date" -- author and committer lines have the form: "name <email> date"
-- The email is always present, even if empty "<>" -- The email is always present, even if empty "<>"
parsemetadata l = CommitMetaData parsemetadata l = CommitMetaData
{ commitName = whenset $ L.init name_sp { commitName = whenset $ S.init name_sp
, commitEmail = whenset email , commitEmail = whenset email
, commitDate = whenset $ L.drop 2 gt_sp_date , commitDate = whenset $ S.drop 2 gt_sp_date
} }
where where
(name_sp, rest) = L.break (== lt) l (name_sp, rest) = S.break (== lt) l
(email, gt_sp_date) = L.break (== gt) (L.drop 1 rest) (email, gt_sp_date) = S.break (== gt) (S.drop 1 rest)
whenset v whenset v
| L.null v = Nothing | S.null v = Nothing
| otherwise = Just (L8.unpack v) | otherwise = Just (decodeBS v)
nl = fromIntegral (ord '\n') nl = fromIntegral (ord '\n')
sp = fromIntegral (ord ' ') sp = fromIntegral (ord ' ')

View file

@ -16,8 +16,8 @@ import Git.Sha
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy.Char8 as L8
data History t = History t (S.Set (History t)) data History t = History t (S.Set (History t))
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
@ -56,8 +56,8 @@ getHistoryToDepth n commit r = do
!h <- fmap (truncateHistoryToDepth n) !h <- fmap (truncateHistoryToDepth n)
. build Nothing . build Nothing
. map parsehistorycommit . map parsehistorycommit
. map B.copy . map L.toStrict
. B8.lines . L8.lines
<$> L.hGetContents inh <$> L.hGetContents inh
hClose inh hClose inh
void $ waitForProcess pid void $ waitForProcess pid
@ -97,7 +97,7 @@ getHistoryToDepth n commit r = do
, Param "--format=%T %H %P" , Param "--format=%T %H %P"
] ]
parsehistorycommit l = case map extractSha (S8.split ' ' l) of parsehistorycommit l = case map extractSha (B8.split ' ' l) of
(Just t:Just c:ps) -> Just $ (Just t:Just c:ps) -> Just $
( HistoryCommit ( HistoryCommit
{ historyCommit = c { historyCommit = c

View file

@ -36,9 +36,10 @@ import Utility.InodeCache
import Utility.TimeStamp import Utility.TimeStamp
import Numeric import Numeric
import Data.Char
import System.Posix.Types import System.Posix.Types
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S
{- It's only safe to use git ls-files on the current repo, not on a remote. {- It's only safe to use git ls-files on the current repo, not on a remote.
- -
@ -81,7 +82,7 @@ inRepo' ps l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo
{- 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 -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) inRepoOrBranch :: Branch -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
inRepoOrBranch (Ref b) = inRepo' [Param $ "--with-tree=" ++ b] inRepoOrBranch b = inRepo' [Param $ "--with-tree=" ++ fromRef 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 -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
@ -189,21 +190,21 @@ stagedDetails = stagedDetails' []
- contents. -} - contents. -}
stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)
stagedDetails' ps l repo = guardSafeForLsFiles repo $ do stagedDetails' ps l repo = guardSafeForLsFiles repo $ do
(ls, cleanup) <- pipeNullSplit params repo (ls, cleanup) <- pipeNullSplit' params repo
return (map parseStagedDetails ls, cleanup) return (map parseStagedDetails 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 . fromRawFilePath) l Param "--" : map (File . fromRawFilePath) l
parseStagedDetails :: L.ByteString -> StagedDetails parseStagedDetails :: S.ByteString -> StagedDetails
parseStagedDetails s parseStagedDetails s
| null file = (L.toStrict s, Nothing, Nothing) | S.null file = (s, Nothing, Nothing)
| otherwise = (toRawFilePath file, extractSha sha, readmode mode) | otherwise = (file, extractSha sha, readmode mode)
where where
(metadata, file) = separate (== '\t') (decodeBL' s) (metadata, file) = separate' (== fromIntegral (ord '\t')) s
(mode, metadata') = separate (== ' ') metadata (mode, metadata') = separate' (== fromIntegral (ord ' ')) metadata
(sha, _) = separate (== ' ') metadata' (sha, _) = separate' (== fromIntegral (ord ' ')) metadata'
readmode = fst <$$> headMaybe . readOct readmode = fst <$$> headMaybe . readOct . decodeBS'
{- 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. -}

View file

@ -232,7 +232,7 @@ getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) </> "refs")
getAllRefs' :: FilePath -> IO [Ref] getAllRefs' :: FilePath -> IO [Ref]
getAllRefs' refdir = do getAllRefs' refdir = do
let topsegs = length (splitPath refdir) - 1 let topsegs = length (splitPath refdir) - 1
let toref = Ref . joinPath . drop topsegs . splitPath let toref = Ref . encodeBS' . joinPath . drop topsegs . splitPath
map toref <$> dirContentsRecursive refdir map toref <$> dirContentsRecursive refdir
explodePackedRefsFile :: Repo -> IO () explodePackedRefsFile :: Repo -> IO ()
@ -257,8 +257,8 @@ packedRefsFile r = fromRawFilePath (localGitDir r) </> "packed-refs"
parsePacked :: String -> Maybe (Sha, Ref) parsePacked :: String -> Maybe (Sha, Ref)
parsePacked l = case words l of parsePacked l = case words l of
(sha:ref:[]) (sha:ref:[])
| isJust (extractSha sha) && Ref.legal True ref -> | isJust (extractSha (encodeBS' sha)) && Ref.legal True ref ->
Just (Ref sha, Ref ref) Just (Ref (encodeBS' sha), Ref (encodeBS' ref))
_ -> Nothing _ -> Nothing
{- git-branch -d cannot be used to remove a branch that is directly {- git-branch -d cannot be used to remove a branch that is directly
@ -279,13 +279,13 @@ findUncorruptedCommit missing goodcommits branch r = do
if ok if ok
then return (Just branch, goodcommits') then return (Just branch, goodcommits')
else do else do
(ls, cleanup) <- pipeNullSplit (ls, cleanup) <- pipeNullSplit'
[ Param "log" [ Param "log"
, Param "-z" , Param "-z"
, Param "--format=%H" , Param "--format=%H"
, Param (fromRef branch) , Param (fromRef branch)
] r ] r
let branchshas = catMaybes $ map (extractSha . decodeBL) ls let branchshas = catMaybes $ map extractSha 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
@ -328,8 +328,8 @@ verifyCommit missing goodcommits commit r
where where
parse l = case words l of parse l = case words l of
(commitsha:treesha:[]) -> (,) (commitsha:treesha:[]) -> (,)
<$> extractSha commitsha <$> extractSha (encodeBS' commitsha)
<*> extractSha treesha <*> extractSha (encodeBS' treesha)
_ -> Nothing _ -> Nothing
check [] = return True check [] = return True
check ((c, t):rest) check ((c, t):rest)
@ -448,7 +448,8 @@ preRepair g = do
void $ tryIO $ allowWrite f void $ tryIO $ allowWrite f
where where
headfile = fromRawFilePath (localGitDir g) </> "HEAD" headfile = fromRawFilePath (localGitDir g) </> "HEAD"
validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s) validhead s = "ref: refs/" `isPrefixOf` s
|| isJust (extractSha (encodeBS' s))
{- Put it all together. -} {- Put it all together. -}
runRepair :: (Ref -> Bool) -> Bool -> Repo -> IO (Bool, [Branch]) runRepair :: (Ref -> Bool) -> Bool -> Repo -> IO (Bool, [Branch])

View file

@ -38,6 +38,7 @@ import System.Posix.Types
import Control.Monad.IO.Class import Control.Monad.IO.Class
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.ByteString.Char8 as S8
newtype Tree = Tree [TreeContent] newtype Tree = Tree [TreeContent]
deriving (Show) deriving (Show)
@ -106,7 +107,7 @@ mkTree (MkTreeHandle cp) l = CoProcess.query cp send receive
NewSubTree _ _ -> error "recordSubTree internal error; unexpected NewSubTree" NewSubTree _ _ -> error "recordSubTree internal error; unexpected NewSubTree"
TreeCommit f fm s -> mkTreeOutput fm CommitObject s f TreeCommit f fm s -> mkTreeOutput fm CommitObject s f
hPutStr h "\NUL" -- signal end of tree to --batch hPutStr h "\NUL" -- signal end of tree to --batch
receive h = getSha "mktree" (hGetLine h) receive h = getSha "mktree" (S8.hGetLine h)
treeMode :: FileMode treeMode :: FileMode
treeMode = 0o040000 treeMode = 0o040000

View file

@ -10,8 +10,10 @@ module Git.UnionMerge (
mergeIndex mergeIndex
) where ) where
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L 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.ByteString.Char8 as S8
import qualified Data.Set as S import qualified Data.Set as S
import Common import Common
@ -54,13 +56,13 @@ mergeIndex hashhandle ch repo bs = forM_ bs $ \b ->
{- For merging two trees. -} {- For merging two trees. -}
mergeTrees :: Ref -> Ref -> HashObjectHandle -> CatFileHandle -> Repo -> Streamer mergeTrees :: Ref -> Ref -> HashObjectHandle -> CatFileHandle -> Repo -> Streamer
mergeTrees (Ref x) (Ref y) hashhandle ch = doMerge hashhandle ch mergeTrees x y hashhandle ch = doMerge hashhandle ch
("diff-tree":diffOpts ++ [x, y, "--"]) ("diff-tree":diffOpts ++ [fromRef x, fromRef y, "--"])
{- For merging a single tree into the index. -} {- For merging a single tree into the index. -}
mergeTreeIndex :: Ref -> HashObjectHandle -> CatFileHandle -> Repo -> Streamer mergeTreeIndex :: Ref -> HashObjectHandle -> CatFileHandle -> Repo -> Streamer
mergeTreeIndex (Ref r) hashhandle ch = doMerge hashhandle ch $ mergeTreeIndex r hashhandle ch = doMerge hashhandle ch $
"diff-index" : diffOpts ++ ["--cached", r, "--"] "diff-index" : diffOpts ++ ["--cached", fromRef r, "--"]
diffOpts :: [String] diffOpts :: [String]
diffOpts = ["--raw", "-z", "-r", "--no-renames", "-l0"] diffOpts = ["--raw", "-z", "-r", "--no-renames", "-l0"]
@ -69,19 +71,19 @@ diffOpts = ["--raw", "-z", "-r", "--no-renames", "-l0"]
- using git to get a raw diff. -} - using git to get a raw diff. -}
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 diff
void $ cleanup void $ cleanup
where where
go [] = noop go [] = noop
go (info:file:rest) = mergeFile (decodeBL' info) (L.toStrict file) hashhandle ch >>= go (info:file:rest) = mergeFile info file hashhandle ch >>=
maybe (go rest) (\l -> streamer l >> go rest) maybe (go rest) (\l -> streamer l >> go rest)
go (_:[]) = error $ "parse error " ++ show differ go (_:[]) = error $ "parse error " ++ show differ
{- 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 -> RawFilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString) mergeFile :: S.ByteString -> RawFilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString)
mergeFile info file hashhandle h = case filter (`notElem` nullShas) [Ref asha, Ref bsha] of mergeFile info file hashhandle h = case filter (`notElem` nullShas) [Ref asha, Ref bsha] of
[] -> return Nothing [] -> return Nothing
(sha:[]) -> use sha (sha:[]) -> use sha
@ -89,7 +91,7 @@ mergeFile info file hashhandle h = case filter (`notElem` nullShas) [Ref asha, R
=<< either return (hashBlob hashhandle . L8.unlines) =<< either return (hashBlob hashhandle . L8.unlines)
=<< calcMerge . zip shas <$> mapM getcontents shas =<< calcMerge . zip shas <$> mapM getcontents shas
where where
[_colonmode, _bmode, asha, bsha, _status] = words info [_colonmode, _bmode, asha, bsha, _status] = S8.words info
use sha = return $ Just $ use sha = return $ Just $
updateIndexLine sha TreeFile $ asTopFilePath file updateIndexLine sha TreeFile $ asTopFilePath file
-- Get file and split into lines to union merge. -- Get file and split into lines to union merge.

View file

@ -43,7 +43,7 @@ readFsckResults u = do
deserialize ("truncated":ls) = deserialize' ls True deserialize ("truncated":ls) = deserialize' ls True
deserialize ls = deserialize' ls False deserialize ls = deserialize' ls False
deserialize' ls t = deserialize' ls t =
let s = S.fromList $ map Ref ls let s = S.fromList $ map (Ref . encodeBS') ls
in if S.null s then FsckFailed else FsckFoundMissing s t in if S.null s then FsckFailed else FsckFoundMissing s t
clearFsckResults :: UUID -> Annex () clearFsckResults :: UUID -> Annex ()

View file

@ -9,6 +9,8 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
module Logs.View ( module Logs.View (
currentView, currentView,
setView, setView,
@ -31,6 +33,7 @@ import Logs.File
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Set as S import qualified Data.Set as S
import Data.Char import Data.Char
import qualified Data.ByteString as B
setView :: View -> Annex () setView :: View -> Annex ()
setView v = do setView v = do
@ -54,11 +57,11 @@ recentViews = do
currentView :: Annex (Maybe View) currentView :: Annex (Maybe View)
currentView = go =<< inRepo Git.Branch.current currentView = go =<< inRepo Git.Branch.current
where where
go (Just b) | branchViewPrefix `isPrefixOf` fromRef b = go (Just b) | branchViewPrefix `B.isPrefixOf` fromRef' b =
headMaybe . filter (\v -> branchView v == b) <$> recentViews headMaybe . filter (\v -> branchView v == b) <$> recentViews
go _ = return Nothing go _ = return Nothing
branchViewPrefix :: String branchViewPrefix :: B.ByteString
branchViewPrefix = "refs/heads/views" branchViewPrefix = "refs/heads/views"
{- Generates a git branch name for a View. {- Generates a git branch name for a View.
@ -68,10 +71,11 @@ branchViewPrefix = "refs/heads/views"
-} -}
branchView :: View -> Git.Branch branchView :: View -> Git.Branch
branchView view branchView view
| null name = Git.Ref branchViewPrefix | B.null name = Git.Ref branchViewPrefix
| otherwise = Git.Ref $ branchViewPrefix ++ "/" ++ name | otherwise = Git.Ref $ branchViewPrefix <> "/" <> name
where where
name = intercalate ";" $ map branchcomp (viewComponents view) name = encodeBS' $
intercalate ";" $ map branchcomp (viewComponents view)
branchcomp c branchcomp c
| viewVisible c = branchcomp' c | viewVisible c = branchcomp' c
| otherwise = "(" ++ branchcomp' c ++ ")" | otherwise = "(" ++ branchcomp' c ++ ")"
@ -92,7 +96,7 @@ branchView view
is_branchView :: Git.Branch -> Bool is_branchView :: Git.Branch -> Bool
is_branchView (Ref b) is_branchView (Ref b)
| b == branchViewPrefix = True | b == branchViewPrefix = True
| otherwise = (branchViewPrefix ++ "/") `isPrefixOf` b | otherwise = (branchViewPrefix <> "/") `B.isPrefixOf` b
prop_branchView_legal :: View -> Bool prop_branchView_legal :: View -> Bool
prop_branchView_legal = Git.Ref.legal False . fromRef . branchView prop_branchView_legal = Git.Ref.legal False . fromRef . branchView

View file

@ -343,7 +343,7 @@ extractRemoteGitConfig r remotename = do
, remoteAnnexReadOnly = getbool "readonly" False , remoteAnnexReadOnly = getbool "readonly" False
, remoteAnnexCheckUUID = getbool "checkuuid" True , remoteAnnexCheckUUID = getbool "checkuuid" True
, remoteAnnexVerify = getbool "verify" True , remoteAnnexVerify = getbool "verify" True
, remoteAnnexTrackingBranch = Git.Ref <$> , remoteAnnexTrackingBranch = Git.Ref . encodeBS <$>
( notempty (getmaybe "tracking-branch") ( notempty (getmaybe "tracking-branch")
<|> notempty (getmaybe "export-tracking") -- old name <|> notempty (getmaybe "export-tracking") -- old name
) )

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 Types.View where module Types.View where
import Annex.Common import Annex.Common

View file

@ -59,7 +59,7 @@ setIndirect = do
fromDirectBranch :: Ref -> Ref fromDirectBranch :: Ref -> Ref
fromDirectBranch directhead = case splitc '/' $ fromRef directhead of fromDirectBranch directhead = case splitc '/' $ fromRef directhead of
("refs":"heads":"annex":"direct":rest) -> ("refs":"heads":"annex":"direct":rest) ->
Ref $ "refs/heads/" ++ intercalate "/" rest Ref $ encodeBS' $ "refs/heads/" ++ intercalate "/" rest
_ -> directhead _ -> directhead
switchHEADBack :: Annex () switchHEADBack :: Annex ()